+
+
+croiseeff <- function(croise, classeuce1, classeuce2) {
+ cl1 <- 0
+ cl2 <- 1
+ for (i in 1:ncol(classeuce1)) {
+ cl1 <- cl1 + 2
+ cl2 <- cl2 + 2
+ clj1 <- 0
+ clj2 <- 1
+ for (j in 1:ncol(classeuce2)) {
+ clj1 <- clj1 + 2
+ clj2 <- clj2 + 2
+ croise[cl1 - 1, clj1 -1] <- length(which(classeuce1[,i] == cl1 & classeuce2[,j] == clj1))
+ croise[cl1 - 1, clj2 -1] <- length(which(classeuce1[,i] == cl1 & classeuce2[,j] == clj2))
+ croise[cl2 - 1, clj1 -1] <- length(which(classeuce1[,i] == cl2 & classeuce2[,j] == clj1))
+ croise[cl2 - 1, clj2 -1] <- length(which(classeuce1[,i] == cl2 & classeuce2[,j] == clj2))
+ }
+ }
+ croise
+}
+
+addallfille <- function(lf) {
+ nlf <- list()
+ for (i in 1:length(lf)) {
+ if (! is.null(lf[[i]])) {
+ nlf[[i]] <- lf[[i]]
+ filles <- lf[[i]]
+ f1 <- filles[1]
+ f2 <- filles[2]
+ if (f1 > length(lf)) {
+ for (j in (length(lf) + 1):f2) {
+ nlf[[j]] <- 0
+ }
+ }
+ } else {
+ nlf[[i]] <- 0
+ }
+ }
+nlf
+}
+
+getfille <- function(nlf, classe, pf) {
+ if (!length(nlf[[classe]])) {
+ return(pf)
+ } else {
+ for (cl in nlf[[classe]]) {
+ pf <- c(pf, cl)
+ if (cl <= length(nlf)) {
+ pf <- getfille(nlf, cl, pf)
+ }
+ }
+ }
+ return(pf)
+}
+
+getmere <- function(list_mere, classe) {
+ i <- as.numeric(classe)
+ pf <- NULL
+ while (i != 1 ) {
+ pf <- c(pf, list_mere[[i]])
+ i <- list_mere[[i]]
+ }
+ pf
+}
+
+getfillemere <- function(list_fille, list_mere, classe) {
+ return(c(getfille(list_fille, classe, NULL), getmere(list_mere, classe)))
+}
+
+getlength <- function(n1, clnb) {
+ colnb <- (clnb %/%2)
+ tab <- table(n1[,colnb])
+ eff <- tab[which(names(tab) == as.character(clnb))]
+ return(eff)
+}
+
+
+find.terminales <- function(n1, list_mere, list_fille, mincl) {
+ tab <- table(n1[,ncol(n1)])
+ clnames <- rownames(tab)
+ terminales <- clnames[which(tab >= mincl)]
+ tocheck <- setdiff(clnames, terminales)
+ if ("0" %in% terminales) {
+ terminales <- terminales[which(terminales != 0)]
+ }
+ if (length(terminales) == 0) {
+ return('no clusters')
+ }
+ if ("0" %in% tocheck) {
+ tocheck <- tocheck[which(tocheck != "0")]
+ }
+ print(terminales)
+ print(tocheck)
+ while (length(tocheck)!=0) {
+ for (val in tocheck) {
+ print(val)
+ mere <- list_mere[[as.numeric(val)]]
+ print('mere')
+ print(mere)
+ if (mere != 1) {
+ ln.mere <- getlength(n1, mere)
+ print('ln.mere')
+ print(ln.mere)
+ filles.mere <- getfille(list_fille, mere, NULL)
+ print('fille mere')
+ print(filles.mere)
+ filles.mere <- filles.mere[which(filles.mere != val)]
+ print(filles.mere)
+ if ((ln.mere >= mincl) & (length(intersect(filles.mere, tocheck)) == 0) & (length(intersect(filles.mere, terminales)) == 0 )) {
+ print('mere ok')
+ terminales <- c(terminales, mere)
+ for (f in c(filles.mere, val, mere)) {
+ tocheck <- tocheck[which(tocheck != f)]
+ }
+ } else if ((ln.mere >= mincl) & (length(intersect(filles.mere, terminales)) == 0) & (length(intersect(filles.mere, tocheck))!=0)){
+ print('mere a checke cause fille ds tocheck')
+ tocheck <- tocheck[which(tocheck != val)]
+ tocheck <- c(mere, tocheck)
+
+ } else {
+ print('pas ok on vire du check')
+ tocheck <- tocheck[which(tocheck != val)]
+ }
+ } else {
+ print('mere == 1')
+ tocheck <- tocheck[which(tocheck != val)]
+ }
+ print('tocheck')
+ print(tocheck)
+ }
+ print(tocheck)
+ }
+ terminales
+}
+
+make.classes <- function(terminales, n1, tree, lf) {
+ term.n1 <- unique(n1[,ncol(n1)])
+ tree.tip <- tree$tip.label
+ cl.n1 <- n1[,ncol(n1)]
+ classes <- rep(NA, nrow(n1))
+ cl.names <- 1:length(terminales)
+ new.cl <- list()
+ for (i in 1:length(terminales)) {
+ if (terminales[i] %in% term.n1) {
+ classes[which(cl.n1==terminales[i])] <- cl.names[i]
+ new.cl[[terminales[i]]] <- cl.names[i]
+ tree.tip[which(tree.tip==terminales[i])] <- paste('a', cl.names[i], sep='')
+ } else {
+ filles <- getfille(lf, as.numeric(terminales[i]), NULL)
+ tochange <- intersect(filles, term.n1)
+ for (cl in tochange) {
+ classes[which(cl.n1==cl)] <- cl.names[i]
+ new.cl[[cl]] <- cl.names[i]
+ tree.tip[which(tree.tip==cl)] <- paste('a', cl.names[i], sep='')
+ }
+ }
+ }
+ make.tip <- function(x) {
+ if (substring(x,1,1)=='a') {
+ return(substring(x,2))
+ } else {
+ return(0)
+ }
+ }
+ tree$tip.label <- tree.tip
+ ntree <- tree
+ tree$tip.label <- sapply(tree.tip, make.tip)
+ tovire <- sapply(tree.tip, function(x) {substring(x,1,1)!='a'})
+ tovire <- which(tovire)
+ ntree <- drop.tip(ntree, tip=tovire)
+ en.double <- ntree$tip.label[duplicated(ntree$tip.label)]
+ en.double <- unique(en.double)
+ tovire <- sapply(en.double, function(x) {which(ntree$tip.label == x)[1]})
+ ntree <- drop.tip(ntree, tip=tovire)
+ ntree$tip.label <- sapply(ntree$tip.label, function(x) {substring(x,2)})
+ classes[which(is.na(classes))] <- 0
+ res <- list(dendro_tot_cl = tree, tree.cl = ntree, n1=as.matrix(classes))
+ res
+}
+