iramuteq.org Git - iramuteq/blob - 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 }