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 #Rchdtxt<-function(tableuc1,tableuc2,listeuce1,listeuce2,arbre1,arbre2,uceout) {
10 #source('/home/pierre/workspace/iramuteq/Rscripts/CHD.R')
13 # data1<-read.csv2(tableuc1)
14 # data2<-read.csv2(tableuc2)
16 #analyse des tableaux avec la fonction CHD qui doit etre sourcee avant
21 # listuce1<-read.csv2(listeuce1)
22 # listuce2<-read.csv2(listeuce2)
24 #Une fonction pour assigner une classe a chaque UCE
25 #AssignClasseToUce<-function(listuce,chd) {
26 # out<-matrix(nrow=nrow(listuce),ncol=ncol(chd))
27 # for (i in 1:nrow(listuce)) {
28 # for (j in 1:ncol(chd)) {
29 # out[i,j]<-chd[(listuce[i,2]+1),j]
35 AssignClasseToUce <- function(listuce, chd) {
36 print('assigne classe -> uce')
37 out<-matrix(nrow=nrow(listuce),ncol=ncol(chd))
38 for (j in 1:ncol(chd)) {
39 out[listuce[,1]+1, j] <- chd[listuce[,2]+1, j]
44 fille<-function(classe,classeuce) {
45 listfm<-unique(unlist(classeuce[classeuce[,classe%/%2]==classe,]))
46 listf<-listfm[listfm>=classe]
50 #nbt nbcl = nbt+1 tcl=((nbt+1) *2) - 2 n1[,ncol(n1)], nchd1[,ncol(nchd1)]
51 Rchdtxt<-function(uceout,mincl=0,classif_mode=0, nbt = 9) {
52 #FIXME: le nombre de classe peut etre inferieur
54 tcl <- ((nbt+1) * 2) - 2
55 #Assignation des classes
56 classeuce1<-AssignClasseToUce(listuce1,chd1$n1)
57 if (classif_mode==0) {
58 classeuce2<-AssignClasseToUce(listuce2,chd2$n1)
60 classeuce2<-classeuce1
63 #calcul des poids (effectifs)
65 makepoids<-function(classeuce,poids) {
66 for (classes in 2:(tcl + 1)){
67 for (i in 1:ncol(classeuce)) {
68 if (poids[(classes-1)]<length(classeuce[,i][classeuce[,i]==classes])) {
69 poids[(classes-1)]<-length(classeuce[,i][classeuce[,i]==classes])
75 poids1<-vector(mode='integer',length = tcl)
76 poids1<-makepoids(classeuce1,poids1)
77 if (classif_mode==0) {
78 poids2<-vector(mode='integer',length = tcl)
79 poids2<-makepoids(classeuce2,poids2)
84 print('croisement classif')
85 croise=matrix(ncol=tcl,nrow=tcl)
86 #production du tableau de contingence
87 for (i in 1:ncol(classeuce1)) {
88 #poids[i]<-length(classeuce1[,i][x==classes])
89 for (j in 1:ncol(classeuce2)) {
90 tablecroise<-table(classeuce1[,i],classeuce2[,j])
91 tabcolnames<-as.numeric(colnames(tablecroise))
92 #tabcolnames<-c(tabcolnames[(length(tabcolnames)-1)],tabcolnames[length(tabcolnames)])
93 tabrownames<-as.numeric(rownames(tablecroise))
94 #tabrownames<-c(tabrownames[(length(tabrownames)-1)],tabrownames[length(tabrownames)])
95 for (k in (ncol(tablecroise)-1):ncol(tablecroise)) {
96 for (l in (nrow(tablecroise)-1):nrow(tablecroise)) {
97 croise[(tabrownames[l]-1),(tabcolnames[k]-1)]<-tablecroise[l,k]
103 if (classif_mode == 0) {ind <- (nbcl * 2)} else {ind <- nbcl}
105 mincl<-round(nrow(classeuce1)/ind)
113 #tableau des chi2 signes
115 for (i in 1:nrow(croise)) {
116 for (j in 1:ncol(croise)) {
117 if (croise[i,j]==0) {
119 } else if (croise[i,j]<mincl) {
122 chitable<-matrix(ncol=2,nrow=2)
123 chitable[1,1]<-croise[i,j]
124 chitable[1,2]<-poids1[i]-chitable[1,1]
125 chitable[2,1]<-poids2[j]-chitable[1,1]
126 chitable[2,2]<-nrow(classeuce1)-poids2[j]-chitable[1,2]
127 chitest<-chisq.test(chitable,correct=FALSE)
128 if ((chitable[1,1]-chitest$expected)<0) {
129 chicroise[i,j]<--round(chitest$statistic,digits=7)
131 chicroise[i,j]<-round(chitest$statistic,digits=7)
138 #determination des chi2 les plus fort
139 chicroiseori<-chicroise
143 maxi[i]<-which.max(chicroise)
144 chimax[i]<-chicroise[maxi[i]]
145 chicroise[maxi[i]]<-0
147 testpres<-function(x,listcoord) {
148 for (i in 1:length(listcoord)) {
149 if (x==listcoord[i]) {
157 c.len=nrow(chicroise)
158 r.len=ncol(chicroise)
163 #on garde une valeur par ligne / colonne
164 for (i in 1:length(maxi)) {
165 #coordonnées de chi2 max
166 x.co<-ceiling(maxi[i]/c.len)
167 y.co<-maxi[i]-(x.co-1)*c.len
168 a<-testpres(x.co,listx)
169 b<-testpres(y.co,listy)
181 #pour ecrire les resultats
182 for (i in 1:length(listx)) {
183 txt<-paste(listx[i]+1,listy[i]+1,sep=' ')
184 txt<-paste(txt,croise[listy[i],listx[i]],sep=' ')
185 txt<-paste(txt,chicroiseori[listy[i],listx[i]],sep=' ')
189 #colonne de la classe
190 #trouver les filles et les meres
191 trouvefillemere<-function(classe,chd) {
192 unique(unlist(chd[chd[,classe%/%2]==classe,]))
195 #pour trouver une valeur dans une liste
196 #is.element(elem, list)
200 trouvecoordok<-function(first) {
205 listxp<-listx[first:length(listx)]
206 listxp<-c(listxp,listx[1:(first-1)])
207 listyp<-listy[first:length(listy)]
208 listyp<-c(listyp,listy[1:(first-1)])
209 for (i in 1:length(listxp)) {
210 if (!(listxp[i]+1)%in%fillemere1) {
211 if (!(listyp[i]+1)%in%fillemere2) {
212 coordok<-rbind(coordok,c(listyp[i]+1,listxp[i]+1))
213 fillemere1<-c(fillemere1,trouvefillemere(listxp[i]+1,chd2$n1))
214 fillemere2<-c(fillemere2,trouvefillemere(listyp[i]+1,chd1$n1))
220 #fonction pour trouver le nombre maximum de classes
221 findmaxclasse<-function(listx,listy) {
225 for (i in 1:length(listy)) {
226 coordok<-trouvecoordok(i)
227 if (maxcl <= nrow(coordok)) {
229 listcoordok[[nb]]<-coordok
233 listcoordok<-unique(listcoordok)
234 #si plusieurs ensemble avec le meme nombre de classe, on conserve
235 #la liste avec le plus fort chi2
236 if (length(listcoordok)>1) {
239 for (i in 1:length(listcoordok)) {
242 if (nrow(listcoordok[[i]])==maxcl) {
243 for (j in 1:nrow(listcoordok[[i]])) {
244 chi<-c(chi,croise[(listcoordok[[i]][j,1]-1),(listcoordok[[i]][j,2]-1)])
245 uce<-c(uce,chicroiseori[(listcoordok[[i]][j,1]-1),(listcoordok[[i]][j,2]-1)])
247 if (maxchi < sum(chi)) {
255 print((suce/nrow(classeuce1)*100))
258 #findmaxclasse(listx,listy)
259 #coordok<-trouvecoordok(1)
260 coordok<-findmaxclasse(listx,listy)
263 lfilletot<-function(classeuce,x) {
265 for (classe in 1:nrow(coordok)) {
266 listfille<-unique(c(listfille,fille(coordok[classe,x],classeuce)))
271 listfille1<-lfilletot(classeuce1,1)
272 listfille2<-lfilletot(classeuce2,2)
274 #utiliser rownames comme coordonnees dans un tableau de 0
275 Assignclasse<-function(classeuce,x) {
276 nchd<-matrix(0,ncol=ncol(classeuce),nrow=nrow(classeuce))
277 for (classe in 1:nrow(coordok)) {
278 clnb<-coordok[classe,x]
280 nchd[which(classeuce[,colnb]==clnb), colnb:ncol(nchd)] <- classe
284 print('commence assigne new classe')
285 nchd1<-Assignclasse(classeuce1,1)
287 nchd2<-Assignclasse(classeuce2,2)
290 print('fini assign new classe')
291 #croisep<-matrix(ncol=nrow(coordok),nrow=nrow(coordok))
292 nchd2[which(nchd1[,ncol(nchd1)]==0),] <- 0
293 nchd2[which(nchd1[,ncol(nchd1)]!=nchd2[,ncol(nchd2)]),] <- 0
294 nchd1[which(nchd2[,ncol(nchd2)]==0),] <- 0
297 elim<-which(nchd1[,ncol(nchd1)]==0)
298 keep<-which(nchd1[,ncol(nchd1)]!=0)
299 n1<-nchd1[nchd1[,ncol(nchd1)]!=0,]
300 n2<-nchd2[nchd2[,ncol(nchd2)]!=0,]
303 write.csv2(nchd1[,ncol(nchd1)],uceout)
304 res <- list(n1 = nchd1, coord_ok = coordok, cuce1 = classeuce1, cuce2 = classeuce2)