1 #Author: Pierre Ratinaud
2 #Copyright (c) 2008-2009 Pierre Ratinaud
6 #fonction pour la double classification
7 #cette fonction doit etre splitter en 4 ou 5 fonctions
9 AssignClasseToUce <- function(listuce, chd) {
10 print('assigne classe -> uce')
14 fille<-function(classe,classeuce) {
15 listfm<-unique(unlist(classeuce[classeuce[,classe%/%2]==classe,]))
16 listf<-listfm[listfm>=classe]
22 croiseeff <- function(croise, classeuce1, classeuce2) {
25 for (i in 1:ncol(classeuce1)) {
30 for (j in 1:ncol(classeuce2)) {
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))
42 addallfille <- function(lf) {
44 for (i in 1:length(lf)) {
45 if (! is.null(lf[[i]])) {
50 if (f1 > length(lf)) {
51 for (j in (length(lf) + 1):f2) {
62 getfille <- function(nlf, classe, pf) {
63 if (length(nlf[[classe]]) == 1) {
66 pf <- c(pf, nlf[[classe]])
67 c1 <- nlf[[classe]][1]
68 c2 <- nlf[[classe]][2]
69 pf <- getfille(nlf, c1, pf)
70 pf <- getfille(nlf, c2, pf)
75 getmere <- function(list_mere, classe) {
79 pf <- c(pf, list_mere[[i]])
85 getfillemere <- function(list_fille, list_mere, classe) {
86 return(c(getfille(list_fille, classe, NULL), getmere(list_mere, classe)))
89 #nbt nbcl = nbt+1 tcl=((nbt+1) *2) - 2 n1[,ncol(n1)], nchd1[,ncol(nchd1)]
90 Rchdtxt<-function(uceout, chd1, chd2 = NULL, mincl=0, classif_mode=0, nbt = 9) {
91 #FIXME: le nombre de classe peut etre inferieur
93 tcl <- ((nbt+1) * 2) - 2
94 #Assignation des classes
95 classeuce1<-AssignClasseToUce(listuce1,chd1$n1)
96 if (classif_mode==0) {
97 classeuce2<-AssignClasseToUce(listuce2,chd2$n1)
99 classeuce2<-classeuce1
102 #calcul des poids (effectifs)
104 makepoids <- function(classeuce, poids) {
110 poids[cl1 - 1] <- length(which(classeuce[,i] == cl1))
111 poids[cl2 - 1] <- length(which(classeuce[,i] == cl2))
116 # makepoids<-function(classeuce,poids) {
117 # for (classes in 2:(tcl + 1)){
118 # for (i in 1:ncol(classeuce)) {
119 # if (poids[(classes-1)]<length(classeuce[,i][classeuce[,i]==classes])) {
120 # poids[(classes-1)]<-length(classeuce[,i][classeuce[,i]==classes])
127 poids1<-vector(mode='integer',length = tcl)
128 poids1<-makepoids(classeuce1,poids1)
129 if (classif_mode==0) {
130 poids2<-vector(mode='integer',length = tcl)
131 poids2<-makepoids(classeuce2,poids2)
136 print('croisement classif')
138 # croise=matrix(ncol=tcl,nrow=tcl)
140 # docroise <- function(croise, classeuce1, classeuce2) {
141 # #production du tableau de contingence
142 # for (i in 1:ncol(classeuce1)) {
143 # #poids[i]<-length(classeuce1[,i][x==classes])
144 # for (j in 1:ncol(classeuce2)) {
145 # tablecroise<-table(classeuce1[,i],classeuce2[,j])
146 # tabcolnames<-as.numeric(colnames(tablecroise))
147 # #tabcolnames<-c(tabcolnames[(length(tabcolnames)-1)],tabcolnames[length(tabcolnames)])
148 # tabrownames<-as.numeric(rownames(tablecroise))
149 # #tabrownames<-c(tabrownames[(length(tabrownames)-1)],tabrownames[length(tabrownames)])
150 # for (k in (ncol(tablecroise)-1):ncol(tablecroise)) {
151 # for (l in (nrow(tablecroise)-1):nrow(tablecroise)) {
152 # croise[(tabrownames[l]-1),(tabcolnames[k]-1)]<-tablecroise[l,k]
159 croise <- croiseeff( matrix(ncol=tcl,nrow=tcl), classeuce1, classeuce2)
161 if (classif_mode == 0) {ind <- (nbcl * 2)} else {ind <- nbcl}
163 mincl<-round(nrow(classeuce1)/ind)
171 #tableau des chi2 signes
175 # nr <- nrow(classeuce1)
176 # newchicroise <- function(croise, mincl, nr, poids1, poids2) {
177 # chicroise <- croise
178 # chicroise[which(croise < mincl)] <- 0
179 # tocompute <- which(chicroise > 0, arr.ind = TRUE)
180 # for (i in 1:nrow(tocompute)) {
181 # chitable <- matrix(ncol=2,nrow=2)
182 # chitable[1,1] <- croise[tocompute[i,1], tocompute[i,2]]
183 # chitable[1,2] <- poids1[tocompute[i,1]] - chitable[1,1]
184 # chitable[2,1] <- poids2[tocompute[i,2]] - chitable[1,1]
185 # chitable[2,2] <- nr - poids2[tocompute[i,2]] - chitable[1,2]
186 # chitest<-chisq.test(chitable,correct=FALSE)
187 # 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))
194 dochicroise <- function(croise, mincl) {
196 for (i in 1:nrow(croise)) {
197 for (j in 1:ncol(croise)) {
198 if (croise[i,j]==0) {
200 } else if (croise[i,j]<mincl) {
203 chitable<-matrix(ncol=2,nrow=2)
204 chitable[1,1]<-croise[i,j]
205 chitable[1,2]<-poids1[i]-chitable[1,1]
206 chitable[2,1]<-poids2[j]-chitable[1,1]
207 chitable[2,2]<-nrow(classeuce1)-poids2[j]-chitable[1,2]
208 chitest<-chisq.test(chitable,correct=FALSE)
209 if ((chitable[1,1]-chitest$expected[1,1])<0) {
210 chicroise[i,j]<--round(chitest$statistic,digits=7)
212 chicroise[i,j]<-round(chitest$statistic,digits=7)
220 chicroise <- dochicroise(croise, mincl)
223 #determination des chi2 les plus fort
224 chicroiseori<-chicroise
226 doxy <- function(chicroise) {
229 listxy <- which(chicroise > 3.84, arr.ind = TRUE)
231 val <- chicroise[which(chicroise > 3.84)]
232 ord <- order(val, decreasing = TRUE)
233 listxy <- listxy[ord,]
234 #for (i in 1:nrow(listxy)) {
235 # if ((!listxy[,2][i] %in% listx) & (!listxy[,1][i] %in% listy)) {
236 # listx <- c(listx, listxy[,2][i])
237 # listy <- c(listy, listxy[,1][i])
240 xy <- list(x = listxy[,2], y = listxy[,1])
243 xy <- doxy(chicroise)
251 # maxi[i]<-which.max(chicroise)
252 # chimax[i]<-chicroise[maxi[i]]
253 # chicroise[maxi[i]]<-0
255 # testpres<-function(x,listcoord) {
256 # for (i in 1:length(listcoord)) {
257 # if (x==listcoord[i]) {
265 # c.len=nrow(chicroise)
266 # r.len=ncol(chicroise)
271 # #on garde une valeur par ligne / colonne
272 # for (i in 1:length(maxi)) {
273 # #coordonnées de chi2 max
274 # #coord <- arrayInd(maxi[i], dim(chicroise))
275 # #x.co <- coord[1,2]
276 # #y.co <- coord[1,1]
277 # x.co<-ceiling(maxi[i]/c.len)
278 # y.co<-maxi[i]-(x.co-1)*c.len
281 # #print(arrayInd(maxi[i], dim(chicroise)))
282 # a<-testpres(x.co,listx)
283 # b<-testpres(y.co,listy)
295 #pour ecrire les resultats
296 for (i in 1:length(listx)) {
297 txt<-paste(listx[i]+1,listy[i]+1,sep=' ')
298 txt<-paste(txt,croise[listy[i],listx[i]],sep=' ')
299 txt<-paste(txt,chicroiseori[listy[i],listx[i]],sep=' ')
303 #colonne de la classe
304 #trouver les filles et les meres
305 trouvefillemere<-function(classe,chd) {
306 unique(unlist(chd[chd[,classe%/%2]==classe,]))
310 #----------------------------------------------------------------------
311 findbestcoord <- function(classeuce1, classeuce2) {
315 #fillemere1 <- unique(classeuce1)
316 #if (classif_mode == 0) {
317 # fillemere2 <- unique(classeuce2)
319 # fillemere2 <- fillemere1
323 listcoordok <- list()
326 lf1 <- addallfille(chd1$list_fille)
327 if (classif_mode == 0) {
328 lf2 <- addallfille(chd2$list_fille)
332 lme1 <- chd1$list_mere
333 if (classif_mode == 0) {
334 lme2 <- chd2$list_mere
338 for (first in 1:length(listx)) {
345 #listxp<-listx[first:length(listx)]
346 #listxp<-c(listxp,listx[1:(first-1)])
347 #listyp<-listy[first:length(listy)]
348 #listyp<-c(listyp,listy[1:(first-1)])
349 listxp <- listxp[order(listx, decreasing = TRUE)]
350 listyp <- listyp[order(listx, decreasing = TRUE)]
351 #listxp<-c(listxp[first:length(listx)], listx[1:(first-1)])
352 #listyp<-c(listyp[first:length(listy)], listy[1:(first-1)])
353 for (i in 1:length(listx)) {
354 if( (!(listxp[i]+1) %in% f1) & (!(listyp[i]+1) %in% f2) ) {
358 coordok <- rbind(coordok, c(listyp[i] + 1,listxp[i] + 1))
359 #print(c(listyp[i] + 1,listxp[i] + 1))
360 un1 <- getfillemere(lf2, chd2$list_mere, listxp[i] + 1)
362 f1 <- c(f1, listxp[i] + 1)
363 un2 <- getfillemere(lf1, chd1$list_mere, listyp[i] + 1)
365 f2 <- c(f2, listyp[i] + 1)
369 #if (nrow(coordok) > maxcl) {
371 # listcoordok <- list()
372 listcoordok[[nb]] <- coordok
373 # maxcl <- nrow(coordok)
374 #} else if (nrow(coordok) == maxcl) {
376 # listcoordok[[nb]] <- coordok
379 listcoordok <- unique(listcoordok)
382 if (length(listcoordok) > 1) {
384 for (i in 1:length(listcoordok)) {
387 for (j in 1:nrow(listcoordok[[i]])) {
388 chi<-c(chi,chicroiseori[(listcoordok[[i]][j,1]-1),(listcoordok[[i]][j,2]-1)])
389 uce<-c(uce,croise[(listcoordok[[i]][j,1]-1),(listcoordok[[i]][j,2]-1)])
391 if (maxchi < sum(chi)) {
397 print(suce/nrow(classeuce1))
401 #---------------------------------------------------------------------------------
402 #pour trouver une valeur dans une liste
403 #is.element(elem, list)
405 oldfindbestcoord <- function(listx, listy) {
407 trouvecoordok<-function(first) {
412 listxp<-listx[first:length(listx)]
413 listxp<-c(listxp,listx[1:(first-1)])
414 listyp<-listy[first:length(listy)]
415 listyp<-c(listyp,listy[1:(first-1)])
416 for (i in 1:length(listxp)) {
417 if (!(listxp[i]+1)%in%fillemere1) {
418 if (!(listyp[i]+1)%in%fillemere2) {
419 coordok<-rbind(coordok,c(listyp[i]+1,listxp[i]+1))
420 fillemere1<-c(fillemere1,trouvefillemere(listxp[i]+1,chd2$n1))
421 fillemere2<-c(fillemere2,trouvefillemere(listyp[i]+1,chd1$n1))
427 #fonction pour trouver le nombre maximum de classes
428 findmaxclasse<-function(listx,listy) {
432 for (i in 1:length(listy)) {
433 coordok<-trouvecoordok(i)
434 if (maxcl <= nrow(coordok)) {
436 listcoordok[[nb]]<-coordok
440 listcoordok<-unique(listcoordok)
442 #si plusieurs ensemble avec le meme nombre de classe, on conserve
443 #la liste avec le plus fort chi2
444 if (length(listcoordok)>1) {
447 for (i in 1:length(listcoordok)) {
450 if (nrow(listcoordok[[i]])==maxcl) {
451 for (j in 1:nrow(listcoordok[[i]])) {
452 chi<-c(chi,croise[(listcoordok[[i]][j,1]-1),(listcoordok[[i]][j,2]-1)])
453 uce<-c(uce,chicroiseori[(listcoordok[[i]][j,1]-1),(listcoordok[[i]][j,2]-1)])
455 if (maxchi < sum(chi)) {
463 print((maxchi/nrow(classeuce1)*100))
467 coordok<-findmaxclasse(listx,listy)
470 #findmaxclasse(listx,listy)
471 #coordok<-trouvecoordok(1)
472 #coordok <- oldfindbestcoord(listx, listy)
473 coordok <- findbestcoord(listx, listy)
476 lfilletot<-function(classeuce,x) {
478 for (classe in 1:nrow(coordok)) {
479 listfille<-unique(c(listfille,fille(coordok[classe,x],classeuce)))
484 listfille1<-lfilletot(classeuce1,1)
485 listfille2<-lfilletot(classeuce2,2)
487 #utiliser rownames comme coordonnees dans un tableau de 0
488 Assignclasse<-function(classeuce,x) {
489 nchd<-matrix(0,ncol=ncol(classeuce),nrow=nrow(classeuce))
490 for (classe in 1:nrow(coordok)) {
491 clnb<-coordok[classe,x]
493 nchd[which(classeuce[,colnb]==clnb), colnb:ncol(nchd)] <- classe
497 print('commence assigne new classe')
498 nchd1<-Assignclasse(classeuce1,1)
499 if (classif_mode==0) {
500 nchd2<-Assignclasse(classeuce2,2)
504 print('fini assign new classe')
505 #croisep<-matrix(ncol=nrow(coordok),nrow=nrow(coordok))
506 nchd2[which(nchd1[,ncol(nchd1)]==0),] <- 0
507 nchd2[which(nchd1[,ncol(nchd1)]!=nchd2[,ncol(nchd2)]),] <- 0
508 nchd1[which(nchd2[,ncol(nchd2)]==0),] <- 0
511 elim<-which(nchd1[,ncol(nchd1)]==0)
512 keep<-which(nchd1[,ncol(nchd1)]!=0)
513 n1<-nchd1[nchd1[,ncol(nchd1)]!=0,]
514 n2<-nchd2[nchd2[,ncol(nchd2)]!=0,]
517 write.csv2(nchd1[,ncol(nchd1)],uceout)
518 res <- list(n1 = nchd1, coord_ok = coordok, cuce1 = classeuce1, cuce2 = classeuce2)