font size...
[iramuteq] / Rscripts / chdtxt.R
1 #Author: Pierre Ratinaud
2 #Copyright (c) 2008-2009 Pierre Ratinaud
3 #License: GNU/GPL
4
5
6 #fonction pour la double classification
7 #cette fonction doit etre splitter en 4 ou 5 fonctions
8
9 AssignClasseToUce <- function(listuce, chd) {
10     print('assigne classe -> uce')
11     chd[listuce[,2]+1,]
12 }
13
14 fille<-function(classe,classeuce) {
15         listfm<-unique(unlist(classeuce[classeuce[,classe%/%2]==classe,]))
16         listf<-listfm[listfm>=classe]
17         listf<-unique(listf)
18         listf
19 }
20
21
22 croiseeff <- function(croise, classeuce1, classeuce2) {
23     cl1 <- 0
24     cl2 <- 1
25     for (i in 1:ncol(classeuce1)) {
26         cl1 <- cl1 + 2
27         cl2 <- cl2 + 2
28         clj1 <- 0
29         clj2 <- 1
30         for (j in 1:ncol(classeuce2)) {
31             clj1 <- clj1 + 2
32             clj2 <- clj2 + 2
33             croise[cl1 - 1, clj1 -1] <- length(which(classeuce1[,i] == cl1 & classeuce2[,j] == clj1))
34             croise[cl1 - 1, clj2 -1] <- length(which(classeuce1[,i] == cl1 & classeuce2[,j] == clj2))
35             croise[cl2 - 1, clj1 -1] <- length(which(classeuce1[,i] == cl2 & classeuce2[,j] == clj1))
36             croise[cl2 - 1, clj2 -1] <- length(which(classeuce1[,i] == cl2 & classeuce2[,j] == clj2))
37         }
38     }
39     croise
40 }
41
42 addallfille <- function(lf) {
43     nlf <- list()
44     for (i in 1:length(lf)) {
45         if (! is.null(lf[[i]])) {
46             nlf[[i]] <- lf[[i]]
47             filles <- lf[[i]]
48             f1 <- filles[1]
49             f2 <- filles[2]
50             if (f1 > length(lf)) {
51                 for (j in (length(lf) + 1):f2) {
52                     nlf[[j]] <- 0
53                 }
54             }
55         } else {
56             nlf[[i]] <- 0
57         }
58     }
59 nlf
60 }
61
62 getfille <- function(nlf, classe, pf) {
63     if (!length(nlf[[classe]])) {
64         return(pf)
65     } else {
66                 for (cl in nlf[[classe]]) {
67                         pf <- c(pf, cl)
68                         if (cl <= length(nlf)) {
69                                 pf <- getfille(nlf, cl, pf)
70                         }
71                 }
72         } 
73     return(pf)
74 }
75
76 getmere <- function(list_mere, classe) {
77     i <- as.numeric(classe)
78     pf <- NULL
79     while (i != 1 ) {
80         pf <- c(pf, list_mere[[i]])
81         i <- list_mere[[i]]
82     }
83     pf
84 }
85
86 getfillemere <- function(list_fille, list_mere, classe) {
87     return(c(getfille(list_fille, classe, NULL), getmere(list_mere, classe)))
88 }
89
90 getlength <- function(n1, clnb) {
91         colnb <- (clnb %/%2)
92         tab <- table(n1[,colnb])
93         eff <- tab[which(names(tab) == as.character(clnb))]
94         return(eff)
95 }
96
97
98 find.terminales <- function(n1, list_mere, list_fille, mincl) {
99         tab <- table(n1[,ncol(n1)])
100         clnames <- rownames(tab)
101         terminales <- clnames[which(tab >= mincl)]
102         tocheck <- setdiff(clnames, terminales)
103         if ("0" %in% terminales) {
104                 terminales <- terminales[which(terminales != 0)]
105         }
106         if (length(terminales) == 0) {
107                 return('no clusters')
108         }
109         if ("0" %in% tocheck) {
110                 tocheck <- tocheck[which(tocheck != "0")]
111         }
112         print(terminales)
113         print(tocheck)
114         while (length(tocheck)!=0) {
115                 for (val in tocheck) {
116                         print(val)
117                         mere <- list_mere[[as.numeric(val)]]
118                         print('mere')
119                         print(mere)
120                         if (mere != 1) {
121                                 ln.mere <- getlength(n1, mere)
122                                 print('ln.mere')
123                                 print(ln.mere)
124                                 filles.mere <- getfille(list_fille, mere, NULL)
125                                 print('fille mere')
126                                 print(filles.mere)
127                                 filles.mere <- filles.mere[which(filles.mere != val)]
128                                 print(filles.mere)
129                                 if ((ln.mere >= mincl) & (length(intersect(filles.mere, tocheck)) == 0) & (length(intersect(filles.mere, terminales)) == 0 )) {
130                                         print('mere ok')
131                                         terminales <- c(terminales, mere)
132                                         for (f in c(filles.mere, val, mere)) {
133                                                 tocheck <- tocheck[which(tocheck != f)]
134                                         }       
135                                 } else if ((ln.mere >= mincl) & (length(intersect(filles.mere, terminales)) == 0) & (length(intersect(filles.mere, tocheck))!=0)){
136                                         print('mere a checke cause fille ds tocheck')
137                                         tocheck <- tocheck[which(tocheck != val)]
138                                         tocheck <- c(mere, tocheck)
139
140                                 } else {
141                                         print('pas ok on vire du check')
142                                         tocheck <- tocheck[which(tocheck != val)]
143                                 }
144                         } else {
145                                 print('mere == 1')
146                                 tocheck <- tocheck[which(tocheck != val)]
147                         }
148                         print('tocheck')
149                         print(tocheck)
150                 }
151                 print(tocheck)
152         }
153         terminales
154 }
155
156 make.classes <- function(terminales, n1, tree, lf) {
157         term.n1 <- unique(n1[,ncol(n1)])
158         tree.tip <- tree$tip.label
159         cl.n1 <- n1[,ncol(n1)]
160         classes <- rep(NA, nrow(n1))
161         cl.names <- 1:length(terminales)
162         new.cl <- list()
163         for (i in 1:length(terminales)) {
164                 if (terminales[i] %in% term.n1) {
165                         classes[which(cl.n1==terminales[i])] <- cl.names[i]
166                         new.cl[[terminales[i]]] <- cl.names[i]
167                         tree.tip[which(tree.tip==terminales[i])] <- paste('a', cl.names[i], sep='')
168                 } else {
169                         filles <- getfille(lf, as.numeric(terminales[i]), NULL)
170                         tochange <- intersect(filles, term.n1)
171                         for (cl in tochange) {
172                                 classes[which(cl.n1==cl)] <- cl.names[i]
173                                 new.cl[[cl]] <- cl.names[i]
174                                 tree.tip[which(tree.tip==cl)] <- paste('a', cl.names[i], sep='')
175                         }
176                 }
177         }
178         make.tip <- function(x) {
179                 if (substring(x,1,1)=='a') {
180                         return(substring(x,2))
181                 } else { 
182                         return(0)
183                 }
184         }
185         tree$tip.label <- tree.tip
186         ntree <- tree
187         tree$tip.label <- sapply(tree.tip, make.tip)
188         tovire <- sapply(tree.tip, function(x) {substring(x,1,1)!='a'})
189         tovire <- which(tovire)
190         ntree <-  drop.tip(ntree, tip=tovire)
191         en.double <- ntree$tip.label[duplicated(ntree$tip.label)]
192         en.double <- unique(en.double)
193         tovire <- sapply(en.double, function(x) {which(ntree$tip.label == x)[1]})
194         ntree <-  drop.tip(ntree, tip=tovire)
195         ntree$tip.label <- sapply(ntree$tip.label, function(x) {substring(x,2)})
196         classes[which(is.na(classes))] <- 0
197         res <- list(dendro_tot_cl = tree, tree.cl = ntree, n1=as.matrix(classes))
198         res
199 }
200
201 #nbt nbcl = nbt+1 tcl=((nbt+1) *2) - 2  n1[,ncol(n1)], nchd1[,ncol(nchd1)]
202 Rchdtxt<-function(uceout, chd1, chd2 = NULL, mincl=0, classif_mode=0, nbt = 9) {
203         #FIXME: le nombre de classe peut etre inferieur
204     nbcl <- nbt + 1
205     tcl <- ((nbt+1) * 2) - 2
206     #Assignation des classes
207         classeuce1<-AssignClasseToUce(listuce1,chd1$n1)
208         if (classif_mode==0) {
209                 classeuce2<-AssignClasseToUce(listuce2,chd2$n1)
210         }
211         #} else {
212         #       classeuce2<-classeuce1
213     #}
214
215         #calcul des poids (effectifs)
216
217     makepoids <- function(classeuce, poids) {
218         cl1 <- 0
219         cl2 <- 1
220         for (i in 1:nbt) {
221             cl1 <- cl1 + 2
222             cl2 <- cl2 + 2
223             poids[cl1 - 1] <- length(which(classeuce[,i] == cl1))
224             poids[cl2 - 1] <- length(which(classeuce[,i] == cl2))
225         }
226         poids
227     }
228
229 #       makepoids<-function(classeuce,poids) {
230 #           for (classes in 2:(tcl + 1)){
231 #                   for (i in 1:ncol(classeuce)) {
232 #                       if (poids[(classes-1)]<length(classeuce[,i][classeuce[,i]==classes])) {
233 #                           poids[(classes-1)]<-length(classeuce[,i][classeuce[,i]==classes])
234 #                       }
235 #                   }
236 #           }
237 #           poids
238 #       }
239     print('make poids')
240         poids1<-vector(mode='integer',length = tcl)
241         poids1<-makepoids(classeuce1,poids1)
242         if (classif_mode==0) {
243                 poids2<-vector(mode='integer',length = tcl)
244                 poids2<-makepoids(classeuce2,poids2)
245         }# else {
246         #       poids2<-poids1
247         #}
248     
249     print('croisement classif')
250
251 #    croise=matrix(ncol=tcl,nrow=tcl)
252 #
253 #    docroise <- function(croise, classeuce1, classeuce2) {
254 #       #production du tableau de contingence
255 #       for (i in 1:ncol(classeuce1)) {
256 #           #poids[i]<-length(classeuce1[,i][x==classes])
257 #           for (j in 1:ncol(classeuce2)) {
258 #                   tablecroise<-table(classeuce1[,i],classeuce2[,j])
259 #                   tabcolnames<-as.numeric(colnames(tablecroise))
260 #                   #tabcolnames<-c(tabcolnames[(length(tabcolnames)-1)],tabcolnames[length(tabcolnames)])
261 #                   tabrownames<-as.numeric(rownames(tablecroise))
262 #                   #tabrownames<-c(tabrownames[(length(tabrownames)-1)],tabrownames[length(tabrownames)])
263 #                   for (k in (ncol(tablecroise)-1):ncol(tablecroise)) {
264 #                       for (l in (nrow(tablecroise)-1):nrow(tablecroise)) {
265 #                           croise[(tabrownames[l]-1),(tabcolnames[k]-1)]<-tablecroise[l,k]
266 #                       }
267 #                   }
268 #           }
269 #       }
270 #        croise
271 #    }
272         if (classif_mode==0) {
273         croise <- croiseeff( matrix(ncol=tcl,nrow=tcl), classeuce1, classeuce2)
274         } else {
275                 croise <- croiseeff( matrix(ncol=tcl,nrow=tcl), classeuce1, classeuce1)
276         }
277     #print(croise)
278     if (classif_mode == 0) {ind <- (nbcl * 2)} else {ind <- nbcl}
279         if (mincl==0){
280                 mincl<-round(nrow(classeuce1)/ind)
281         }
282         #if (mincl<3){
283         #       mincl<-3
284         #}
285     print(mincl)        
286         #print('table1')
287         #print(croise)
288         #tableau des chi2 signes
289     print('croise chi2')
290         #chicroise<-croise
291
292 #    nr <- nrow(classeuce1)
293 #    newchicroise <- function(croise, mincl, nr, poids1, poids2) {
294 #        chicroise <- croise
295 #        chicroise[which(croise < mincl)] <- 0
296 #        tocompute <- which(chicroise > 0, arr.ind = TRUE)
297 #        for (i in 1:nrow(tocompute)) {
298 #            chitable <- matrix(ncol=2,nrow=2)
299 #            chitable[1,1] <- croise[tocompute[i,1],  tocompute[i,2]]
300 #            chitable[1,2] <- poids1[tocompute[i,1]] - chitable[1,1]
301 #            chitable[2,1] <- poids2[tocompute[i,2]] - chitable[1,1]
302 #            chitable[2,2] <- nr - poids2[tocompute[i,2]] - chitable[1,2]
303 #            chitest<-chisq.test(chitable,correct=FALSE)
304 #            chicroise[tocompute[i,1],  tocompute[i,2]] <- ifelse(chitable[1,1] > chitest$expected[1,1], round(chitest$statistic,digits=7), -round(chitest$statistic,digits=7))
305 #        }
306 #        chicroise
307 #    }
308 #
309         
310
311         dochicroise <- function(croise, mincl) {
312         chicroise <- croise
313         for (i in 1:nrow(croise)) {
314                 for (j in 1:ncol(croise)) {
315                     if (croise[i,j]==0) {
316                         chicroise[i,j]<-0
317                     } else if (croise[i,j]<mincl) { 
318                         chicroise[i,j]<-0
319                     } else {
320                         chitable<-matrix(ncol=2,nrow=2)
321                         chitable[1,1]<-croise[i,j]
322                         chitable[1,2]<-poids1[i]-chitable[1,1]
323                         chitable[2,1]<-poids2[j]-chitable[1,1]
324                         chitable[2,2]<-nrow(classeuce1)-poids2[j]-chitable[1,2]
325                         chitest<-chisq.test(chitable,correct=FALSE)
326                         if ((chitable[1,1]-chitest$expected[1,1])<0) {
327                             chicroise[i,j]<--round(chitest$statistic,digits=7)
328                         } else {
329                             chicroise[i,j]<-round(chitest$statistic,digits=7)
330                 #print(chitest)
331                         }
332                     }
333                 }   
334             }
335         chicroise
336     }
337
338         dochicroisesimple <- function(croise, mincl) {
339                 chicroise <- croise
340                 for (i in 1:nrow(croise)) {
341                         for (j in 1:ncol(croise)) {
342                                 if (croise[i,j]==0) {
343                                         chicroise[i,j]<-0
344                                 } else if (croise[i,j]<mincl) { 
345                                         chicroise[i,j]<-0
346                                 } else {
347                                         chitable<-matrix(ncol=2,nrow=2)
348                                         chitable[1,1]<-croise[i,j]
349                                         chitable[1,2]<-poids1[i]-chitable[1,1]
350                                         chitable[2,1]<-poids1[j]-chitable[1,1]
351                                         chitable[2,2]<-nrow(classeuce1)-poids1[j]-chitable[1,2]
352                                         chitest<-chisq.test(chitable,correct=FALSE)
353                                         if ((chitable[1,1]-chitest$expected[1,1])<0) {
354                                                 chicroise[i,j]<--round(chitest$statistic,digits=7)
355                                         } else {
356                                                 chicroise[i,j]<-round(chitest$statistic,digits=7)
357                                                 #print(chitest)
358                                         }
359                                 }
360                         }   
361                 }
362                 chicroise
363         }
364         if (classif_mode == 0) {
365                 chicroise <- dochicroise(croise, mincl)
366         } else {
367                 chicroise <- dochicroisesimple(croise, mincl)
368         }
369     
370     print('fin croise')
371         #print(chicroise)
372         #determination des chi2 les plus fort
373         chicroiseori<-chicroise
374
375     doxy <- function(chicroise) {
376         listx <- NULL
377         listy <- NULL
378         listxy <- which(chicroise > 3.84, arr.ind = TRUE)
379         #print(listxy)
380         val <- chicroise[which(chicroise > 3.84)]
381         ord <- order(val, decreasing = TRUE)
382         listxy <- listxy[ord,]
383         #for (i in 1:nrow(listxy)) {
384         #    if ((!listxy[,2][i] %in% listx) & (!listxy[,1][i] %in% listy)) {
385         #        listx <- c(listx, listxy[,2][i])
386         #        listy <- c(listy, listxy[,1][i])
387         #    }
388         #}
389         xy <- list(x = listxy[,2], y = listxy[,1])
390         xy
391     }
392     xy <- doxy(chicroise)
393     listx <- xy$x
394     listy <- xy$y
395
396 #       maxi<-vector()
397 #       chimax<-vector()
398 #       for (i in 1:tcl) {
399 #           maxi[i]<-which.max(chicroise)
400 #           chimax[i]<-chicroise[maxi[i]]
401 #           chicroise[maxi[i]]<-0
402 #       }
403 #       testpres<-function(x,listcoord) {
404 #           for (i in 1:length(listcoord)) {
405 #                   if (x==listcoord[i]) {
406 #                       return(-1)
407 #                   } else {
408 #                       a<-1
409 #                   }
410 #           }
411 #           a
412 #       }
413 #       c.len=nrow(chicroise)
414 #       r.len=ncol(chicroise)
415 #       listx<-c(0)
416 #       listy<-c(0)
417 #       rang<-0
418 #       cons<-list()
419 #       #on garde une valeur par ligne / colonne
420 #       for (i in 1:length(maxi)) {
421 #       #coordonnées de chi2 max
422 #        #coord <- arrayInd(maxi[i], dim(chicroise))
423 #        #x.co <- coord[1,2]
424 #        #y.co <- coord[1,1]
425 #           x.co<-ceiling(maxi[i]/c.len)
426 #           y.co<-maxi[i]-(x.co-1)*c.len
427 #        #print(x.co)
428 #        #print(y.co)
429 #        #print(arrayInd(maxi[i], dim(chicroise)))
430 #           a<-testpres(x.co,listx)
431 #           b<-testpres(y.co,listy)
432 #           
433 #           if (a==1) {
434 #                       if (b==1) {
435 #                           rang<-rang+1
436 #                           listx[rang]<-x.co
437 #                           listy[rang]<-y.co
438 #                       }
439 #           }
440 #           cons[[1]]<-listx
441 #           cons[[2]]<-listy
442 #       }
443         #pour ecrire les resultats
444         for (i in 1:length(listx)) {
445             txt<-paste(listx[i]+1,listy[i]+1,sep=' ')
446             txt<-paste(txt,croise[listy[i],listx[i]],sep=' ')
447             txt<-paste(txt,chicroiseori[listy[i],listx[i]],sep=' ')
448             #print(txt)
449         }
450         #colonne de la classe
451         #trouver les filles et les meres 
452         trouvefillemere<-function(classe,chd) {
453             unique(unlist(chd[chd[,classe%/%2]==classe,]))
454         }
455
456
457 #----------------------------------------------------------------------
458     findbestcoord <- function(classeuce1, classeuce2, classif_mode, nbt) {
459         #fillemere1 <- NULL
460         #fillemere2 <- NULL
461
462         #fillemere1 <- unique(classeuce1)
463         #if (classif_mode == 0) {
464         #    fillemere2 <- unique(classeuce2)
465         #} else {
466         #    fillemere2 <- fillemere1
467         #}
468
469         #
470         listcoordok <- list()
471         maxcl <- 0
472         nb <- 0
473         lf1 <- addallfille(chd1$list_fille) 
474         if (classif_mode == 0) {
475             lf2 <- addallfille(chd2$list_fille)
476         } else {
477             lf2 <- lf1
478             listx<-listx[1:((nbt+1)*2)]
479             listy<-listy[1:((nbt+1)*2)]
480         }
481         lme1 <- chd1$list_mere
482         if (classif_mode == 0) {
483             lme2 <- chd2$list_mere
484         } else {
485             lme2 <- lme1
486         }
487         print('length listx')
488         print(length(listx))
489         #if (classif_mode == 0) {
490         for (first in 1:length(listx)) {
491             coordok <- NULL
492             f1 <- NULL
493             f2 <- NULL
494             listxp<-listx
495             listyp<-listy
496             
497             #listxp<-listx[first:length(listx)]
498             #listxp<-c(listxp,listx[1:(first-1)])
499             #listyp<-listy[first:length(listy)]
500             #listyp<-c(listyp,listy[1:(first-1)])
501             listxp <- listxp[order(listx, decreasing = TRUE)]
502             listyp <- listyp[order(listx, decreasing = TRUE)]
503             #listxp<-c(listxp[first:length(listx)], listx[1:(first-1)])
504             #listyp<-c(listyp[first:length(listy)], listy[1:(first-1)])
505             for (i in 1:length(listx)) {
506                 if( (!(listxp[i]+1) %in% f1) & (!(listyp[i]+1) %in% f2) ) {
507                     #print(listyp[i]+1)
508                     #print('not in')
509                     #print(f2)
510                     coordok <- rbind(coordok, c(listyp[i] + 1,listxp[i] + 1))
511                     #print(c(listyp[i] + 1,listxp[i] + 1))
512                     un1 <- getfillemere(lf2, chd2$list_mere, listxp[i] + 1)
513                     f1 <- c(f1, un1)
514                     f1 <- c(f1, listxp[i] + 1)
515                     un2 <- getfillemere(lf1, chd1$list_mere, listyp[i] + 1)
516                     f2 <- c(f2, un2)
517                     f2 <- c(f2, listyp[i] + 1)
518                 }
519                 #print(coordok)
520             }
521             #if (nrow(coordok) > maxcl) {
522                 nb <- 1
523             #    listcoordok <- list()
524                 listcoordok[[nb]] <- coordok
525             #    maxcl <- nrow(coordok)
526             #} else if (nrow(coordok) == maxcl) {
527                 nb <- nb + 1
528             #    listcoordok[[nb]] <- coordok
529             #}
530         }
531         #} else {
532 #            stopid <- ((nbt+1) * 2) - 2
533 #            for (first in 1:stopid) {
534 #                coordok <- NULL
535 #                f1 <- NULL
536 #                f2 <- NULL
537 #                listxp<-listx
538 #                listyp<-listy
539 #                
540 #                #listxp<-listx[first:length(listx)]
541 #                #listxp<-c(listxp,listx[1:(first-1)])
542 #                #listyp<-listy[first:length(listy)]
543 #                #listyp<-c(listyp,listy[1:(first-1)])
544 #                listxp <- listxp[order(listx, decreasing = TRUE)]
545 #                listyp <- listyp[order(listx, decreasing = TRUE)]
546 #                #listxp<-c(listxp[first:length(listx)], listx[1:(first-1)])
547 #                #listyp<-c(listyp[first:length(listy)], listy[1:(first-1)])
548 #                for (i in 1:stopid) {
549 #                    if( (!(listxp[i]+1) %in% f1) & (!(listyp[i]+1) %in% f2) ) {
550 #                        #print(listyp[i]+1)
551 #                        #print('not in')
552 #                        #print(f2)
553 #                        coordok <- rbind(coordok, c(listyp[i] + 1,listxp[i] + 1))
554 #                        #print(c(listyp[i] + 1,listxp[i] + 1))
555 #                        un1 <- getfillemere(lf2, chd2$list_mere, listxp[i] + 1)
556 #                        f1 <- c(f1, un1)
557 #                        f1 <- c(f1, listxp[i] + 1)
558 #                        un2 <- getfillemere(lf1, chd1$list_mere, listyp[i] + 1)
559 #                        f2 <- c(f2, un2)
560 #                        f2 <- c(f2, listyp[i] + 1)
561 #                    }
562 #                    #print(coordok)
563 #                }
564 #                #if (nrow(coordok) > maxcl) {
565 #                nb <- 1
566 #                #    listcoordok <- list()
567 #                listcoordok[[nb]] <- coordok
568 #                #    maxcl <- nrow(coordok)
569 #                #} else if (nrow(coordok) == maxcl) {
570 #                nb <- nb + 1
571 #                #    listcoordok[[nb]] <- coordok
572 #                #}
573 #            }            
574 #        }
575         #print(listcoordok)
576         listcoordok <- unique(listcoordok)
577         print(listcoordok)
578         best <- 1
579         if (length(listcoordok) > 1) {
580             maxchi <- 0
581             for (i in 1:length(listcoordok)) {
582                 chi <- NULL
583                 uce <- NULL
584                 for (j in 1:nrow(listcoordok[[i]])) {
585                     chi<-c(chi,chicroiseori[(listcoordok[[i]][j,1]-1),(listcoordok[[i]][j,2]-1)])
586                     uce<-c(uce,croise[(listcoordok[[i]][j,1]-1),(listcoordok[[i]][j,2]-1)])
587                 }
588                 if (maxchi < sum(chi)) {
589                     maxchi <- sum(chi)
590                     suce <- sum(uce)
591                     best <- i
592                 }
593             }
594         print(suce/nrow(classeuce1))
595         }
596         listcoordok[[best]]
597     }
598 #---------------------------------------------------------------------------------   
599         #pour trouver une valeur dans une liste
600         #is.element(elem, list)
601         #== elem%in%list
602     oldfindbestcoord <- function(listx, listy) {
603         coordok<-NULL
604         trouvecoordok<-function(first) {
605             fillemere1<-NULL
606             fillemere2<-NULL
607             listxp<-listx
608             listyp<-listy
609             listxp<-listx[first:length(listx)]
610             listxp<-c(listxp,listx[1:(first-1)])
611             listyp<-listy[first:length(listy)]
612             listyp<-c(listyp,listy[1:(first-1)])
613             for (i in 1:length(listxp)) {
614                 if (!(listxp[i]+1)%in%fillemere1) {
615                         if (!(listyp[i]+1)%in%fillemere2) {
616                             coordok<-rbind(coordok,c(listyp[i]+1,listxp[i]+1))
617                             fillemere1<-c(fillemere1,trouvefillemere(listxp[i]+1,chd2$n1))
618                             fillemere2<-c(fillemere2,trouvefillemere(listyp[i]+1,chd1$n1))
619                         }
620                }
621             }
622             coordok
623         }
624     #fonction pour trouver le nombre maximum de classes
625         findmaxclasse<-function(listx,listy) {
626             listcoordok<-list()
627             maxcl<-0
628             nb<-1
629             for (i in 1:length(listy)) {
630                         coordok<-trouvecoordok(i)
631                         if (maxcl <= nrow(coordok)) {
632                             maxcl<-nrow(coordok)
633                             listcoordok[[nb]]<-coordok
634                             nb<-nb+1
635                         }
636             }
637             listcoordok<-unique(listcoordok)
638             #print(listcoordok)
639                 #si plusieurs ensemble avec le meme nombre de classe, on conserve
640                 #la liste avec le plus fort chi2
641             if (length(listcoordok)>1) {
642                     maxchi<-0
643                     best<-NULL
644                     for (i in 1:length(listcoordok)) {
645                         chi<-NULL
646                         uce<-NULL
647                         if (nrow(listcoordok[[i]])==maxcl) {
648                             for (j in 1:nrow(listcoordok[[i]])) {
649                                 chi<-c(chi,croise[(listcoordok[[i]][j,1]-1),(listcoordok[[i]][j,2]-1)])
650                                 uce<-c(uce,chicroiseori[(listcoordok[[i]][j,1]-1),(listcoordok[[i]][j,2]-1)])
651                             }
652                             if (maxchi < sum(chi)) {
653                                 maxchi <- sum(chi)
654                                 suce <- sum(uce)
655                                 best <- i
656                             } 
657                         }
658                     }
659             }
660             print((maxchi/nrow(classeuce1)*100))
661             listcoordok[[best]]
662         }
663         print('cherche max')
664             coordok<-findmaxclasse(listx,listy)
665             coordok
666     }
667         #findmaxclasse(listx,listy)
668         #coordok<-trouvecoordok(1)
669     #coordok <- oldfindbestcoord(listx, listy)
670     print('begin bestcoord')
671     coordok <- findbestcoord(listx, listy, classif_mode, nbt)
672
673
674         lfilletot<-function(classeuce,x) {
675             listfille<-NULL
676             for (classe in 1:nrow(coordok)) {
677                         listfille<-unique(c(listfille,fille(coordok[classe,x],classeuce)))
678                         listfille
679             }
680         }
681     print('listfille')
682         listfille1<-lfilletot(classeuce1,1)
683         if (classif_mode == 0) {
684                 listfille2<-lfilletot(classeuce2,2)
685         }
686
687         #utiliser rownames comme coordonnees dans un tableau de 0
688         Assignclasse<-function(classeuce,x) {
689             nchd<-matrix(0,ncol=ncol(classeuce),nrow=nrow(classeuce))
690             for (classe in 1:nrow(coordok)) {
691                         clnb<-coordok[classe,x]
692                         colnb<-clnb%/%2
693             nchd[which(classeuce[,colnb]==clnb), colnb:ncol(nchd)] <- classe
694             }
695             nchd
696         }
697         print('commence assigne new classe')
698         nchd1<-Assignclasse(classeuce1,1)
699         if (classif_mode==0) {
700                 nchd2<-Assignclasse(classeuce2,2)
701         }
702         print('fini assign new classe')
703         #croisep<-matrix(ncol=nrow(coordok),nrow=nrow(coordok))
704         if (classif_mode==0) {
705         nchd2[which(nchd1[,ncol(nchd1)]==0),] <- 0
706         nchd2[which(nchd1[,ncol(nchd1)]!=nchd2[,ncol(nchd2)]),] <- 0
707         nchd1[which(nchd2[,ncol(nchd2)]==0),] <- 0
708         }
709
710         print('fini croise')
711         elim<-which(nchd1[,ncol(nchd1)]==0)
712         keep<-which(nchd1[,ncol(nchd1)]!=0)
713         n1<-nchd1[nchd1[,ncol(nchd1)]!=0,]
714         if (classif_mode==0) {
715                 n2<-nchd2[nchd2[,ncol(nchd2)]!=0,]
716         } else {
717                 classeuce2 <- NULL
718         }
719         #clnb<-nrow(coordok)
720         print('fini')
721         write.csv2(nchd1[,ncol(nchd1)],uceout)
722         res <- list(n1 = nchd1, coord_ok = coordok, cuce1 = classeuce1, cuce2 = classeuce2)
723         res
724 }