#Author: Pierre Ratinaud #Copyright (c) 2008-2009 Pierre Ratinaud #Lisense: GNU/GPL #fonction pour la double classification #cette fonction doit etre splitter en 4 ou 5 fonctions #Rchdtxt<-function(tableuc1,tableuc2,listeuce1,listeuce2,arbre1,arbre2,uceout) { #source('/home/pierre/workspace/iramuteq/Rscripts/CHD.R') #lecture des tableaux # data1<-read.csv2(tableuc1) # data2<-read.csv2(tableuc2) #analyse des tableaux avec la fonction CHD qui doit etre sourcee avant # chd1<-CHD(data1) # chd2<-CHD(data2) #lecture des uce # listuce1<-read.csv2(listeuce1) # listuce2<-read.csv2(listeuce2) #Une fonction pour assigner une classe a chaque UCE #AssignClasseToUce<-function(listuce,chd) { # out<-matrix(nrow=nrow(listuce),ncol=ncol(chd)) # for (i in 1:nrow(listuce)) { # for (j in 1:ncol(chd)) { # out[i,j]<-chd[(listuce[i,2]+1),j] # } # } # out #} AssignClasseToUce <- function(listuce, chd) { print('assigne classe -> uce') out<-matrix(nrow=nrow(listuce),ncol=ncol(chd)) for (j in 1:ncol(chd)) { out[listuce[,1]+1, j] <- chd[listuce[,2]+1, j] } out } fille<-function(classe,classeuce) { listfm<-unique(unlist(classeuce[classeuce[,classe%/%2]==classe,])) listf<-listfm[listfm>=classe] listf<-unique(listf) listf } #nbt nbcl = nbt+1 tcl=((nbt+1) *2) - 2 n1[,ncol(n1)], nchd1[,ncol(nchd1)] Rchdtxt<-function(uceout,mincl=0,classif_mode=0, nbt = 9) { #FIXME: le nombre de classe peut etre inferieur nbcl <- nbt + 1 tcl <- ((nbt+1) * 2) - 2 #Assignation des classes classeuce1<-AssignClasseToUce(listuce1,chd1$n1) if (classif_mode==0) { classeuce2<-AssignClasseToUce(listuce2,chd2$n1) } else { classeuce2<-classeuce1 } #calcul des poids (effectifs) makepoids<-function(classeuce,poids) { for (classes in 2:(tcl + 1)){ for (i in 1:ncol(classeuce)) { if (poids[(classes-1)]1) { maxchi<-0 best<-NULL for (i in 1:length(listcoordok)) { chi<-NULL uce<-NULL if (nrow(listcoordok[[i]])==maxcl) { for (j in 1:nrow(listcoordok[[i]])) { chi<-c(chi,croise[(listcoordok[[i]][j,1]-1),(listcoordok[[i]][j,2]-1)]) uce<-c(uce,chicroiseori[(listcoordok[[i]][j,1]-1),(listcoordok[[i]][j,2]-1)]) } if (maxchi < sum(chi)) { maxchi<-sum(chi) suce<-sum(uce) best<-i } } } } print((suce/nrow(classeuce1)*100)) listcoordok[[best]] } #findmaxclasse(listx,listy) #coordok<-trouvecoordok(1) coordok<-findmaxclasse(listx,listy) print(coordok) lfilletot<-function(classeuce,x) { listfille<-NULL for (classe in 1:nrow(coordok)) { listfille<-unique(c(listfille,fille(coordok[classe,x],classeuce))) listfille } } listfille1<-lfilletot(classeuce1,1) listfille2<-lfilletot(classeuce2,2) #utiliser rownames comme coordonnees dans un tableau de 0 Assignclasse<-function(classeuce,x) { nchd<-matrix(0,ncol=ncol(classeuce),nrow=nrow(classeuce)) for (classe in 1:nrow(coordok)) { clnb<-coordok[classe,x] colnb<-clnb%/%2 nchd[which(classeuce[,colnb]==clnb), colnb:ncol(nchd)] <- classe } nchd } print('commence assigne new classe') nchd1<-Assignclasse(classeuce1,1) if (classif_mode==0) nchd2<-Assignclasse(classeuce2,2) else nchd2<-nchd1 print('fini assign new classe') #croisep<-matrix(ncol=nrow(coordok),nrow=nrow(coordok)) nchd2[which(nchd1[,ncol(nchd1)]==0),] <- 0 nchd2[which(nchd1[,ncol(nchd1)]!=nchd2[,ncol(nchd2)]),] <- 0 nchd1[which(nchd2[,ncol(nchd2)]==0),] <- 0 # for (i in 1:nrow(nchd1)) { # if (nchd1[i,ncol(nchd1)]==0) { # nchd2[i,]<-nchd2[i,]*0 # } # if (nchd1[i,ncol(nchd1)]!=nchd2[i,ncol(nchd2)]) { # nchd2[i,]<-nchd2[i,]*0 # } # if (nchd2[i,ncol(nchd2)]==0) { # nchd1[i,]<-nchd1[i,]*0 # } # } print('fini croise') elim<-which(nchd1[,ncol(nchd1)]==0) keep<-which(nchd1[,ncol(nchd1)]!=0) n1<-nchd1[nchd1[,ncol(nchd1)]!=0,] n2<-nchd2[nchd2[,ncol(nchd2)]!=0,] #clnb<-nrow(coordok) print('fini') write.csv2(nchd1[,ncol(nchd1)],uceout) res <- list(n1 = nchd1, coord_ok = coordok, cuce1 = classeuce1, cuce2 = classeuce2) res }