irlba
[iramuteq] / Rscripts / chdtxt.R
1 #Author: Pierre Ratinaud
2 #Copyright (c) 2008-2009 Pierre Ratinaud
3 #Lisense: GNU/GPL
4
5
6 #fonction pour la double classification
7 #cette fonction doit etre splitter en 4 ou 5 fonctions
8
9 #Rchdtxt<-function(tableuc1,tableuc2,listeuce1,listeuce2,arbre1,arbre2,uceout) {
10         #source('/home/pierre/workspace/iramuteq/Rscripts/CHD.R')
11
12         #lecture des tableaux
13 #       data1<-read.csv2(tableuc1)
14 #       data2<-read.csv2(tableuc2)
15
16         #analyse des tableaux avec la fonction CHD qui doit etre sourcee avant
17 #       chd1<-CHD(data1)
18 #       chd2<-CHD(data2)
19
20         #lecture des uce
21 #       listuce1<-read.csv2(listeuce1)
22 #       listuce2<-read.csv2(listeuce2)
23
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]
30 #               }
31 #    }
32 #    out
33 #}
34
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]
40     }
41     out
42 }
43
44 fille<-function(classe,classeuce) {
45         listfm<-unique(unlist(classeuce[classeuce[,classe%/%2]==classe,]))
46         listf<-listfm[listfm>=classe]
47         listf<-unique(listf)
48         listf
49 }
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
53     nbcl <- nbt + 1
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)
59     } else {
60                 classeuce2<-classeuce1
61     }
62
63         #calcul des poids (effectifs)
64
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])
70                     }
71                 }
72             }
73             poids
74         }
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)
80         } else {
81                 poids2<-poids1
82         }
83     
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]
98                         }
99                     }
100             }
101             tablecroise
102         }
103     if (classif_mode == 0) {ind <- (nbcl * 2)} else {ind <- nbcl}
104         if (mincl==0){
105                 mincl<-round(nrow(classeuce1)/ind)
106         }
107         if (mincl<3){
108                 mincl<-3
109         }
110     print(mincl)        
111         #print('table1')
112         #print(croise)
113         #tableau des chi2 signes
114         chicroise<-croise
115         for (i in 1:nrow(croise)) {
116             for (j in 1:ncol(croise)) {
117                     if (croise[i,j]==0) {
118                         chicroise[i,j]<-0
119                     } else if (croise[i,j]<mincl) { 
120                         chicroise[i,j]<-0
121                     } else {
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)
130                         } else {
131                             chicroise[i,j]<-round(chitest$statistic,digits=7)
132                 #print(chitest)
133                         }
134                     }
135             }   
136         }
137         #print(chicroise)
138         #determination des chi2 les plus fort
139         chicroiseori<-chicroise
140         maxi<-vector()
141         chimax<-vector()
142         for (i in 1:tcl) {
143             maxi[i]<-which.max(chicroise)
144             chimax[i]<-chicroise[maxi[i]]
145             chicroise[maxi[i]]<-0
146         }
147         testpres<-function(x,listcoord) {
148             for (i in 1:length(listcoord)) {
149                     if (x==listcoord[i]) {
150                         return(-1)
151                     } else {
152                         a<-1
153                     }
154             }
155             a
156         }
157         c.len=nrow(chicroise)
158         r.len=ncol(chicroise)
159         listx<-c(0)
160         listy<-c(0)
161         rang<-0
162         cons<-list()
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)
170             
171             if (a==1) {
172                         if (b==1) {
173                             rang<-rang+1
174                             listx[rang]<-x.co
175                             listy[rang]<-y.co
176                         }
177             }
178             cons[[1]]<-listx
179             cons[[2]]<-listy
180         }
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=' ')
186             print(txt)
187         }
188
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,]))
193         }
194
195         #pour trouver une valeur dans une liste
196         #is.element(elem, list)
197         #== elem%in%list
198
199         coordok<-NULL
200         trouvecoordok<-function(first) {
201             fillemere1<-NULL
202             fillemere2<-NULL
203             listxp<-listx
204             listyp<-listy
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))
215                         }
216                }
217             }
218             coordok
219         }
220 #fonction pour trouver le nombre maximum de classes
221         findmaxclasse<-function(listx,listy) {
222             listcoordok<-list()
223             maxcl<-0
224             nb<-1
225             for (i in 1:length(listy)) {
226                         coordok<-trouvecoordok(i)
227                         if (maxcl <= nrow(coordok)) {
228                             maxcl<-nrow(coordok)
229                             listcoordok[[nb]]<-coordok
230                             nb<-nb+1
231                         }
232             }
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) {
237                     maxchi<-0
238                     best<-NULL
239                     for (i in 1:length(listcoordok)) {
240                         chi<-NULL
241                         uce<-NULL
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)])
246                             }
247                             if (maxchi < sum(chi)) {
248                                 maxchi <- sum(chi)
249                                 suce <- sum(uce)
250                                 best <- i
251                             } 
252                         }
253                     }
254             }
255             print((suce/nrow(classeuce1)*100))
256             listcoordok[[best]]
257         }
258         #findmaxclasse(listx,listy)
259         #coordok<-trouvecoordok(1)
260         coordok<-findmaxclasse(listx,listy)
261         print(coordok)
262
263         lfilletot<-function(classeuce,x) {
264             listfille<-NULL
265             for (classe in 1:nrow(coordok)) {
266                         listfille<-unique(c(listfille,fille(coordok[classe,x],classeuce)))
267                         listfille
268             }
269         }
270
271         listfille1<-lfilletot(classeuce1,1)
272         listfille2<-lfilletot(classeuce2,2)
273
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]
279                         colnb<-clnb%/%2
280             nchd[which(classeuce[,colnb]==clnb), colnb:ncol(nchd)] <- classe
281             }
282             nchd
283         }
284         print('commence assigne new classe')
285         nchd1<-Assignclasse(classeuce1,1)
286         if (classif_mode==0)
287                 nchd2<-Assignclasse(classeuce2,2)
288         else
289                 nchd2<-nchd1
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
295
296         print('fini croise')
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,]
301         #clnb<-nrow(coordok)
302         print('fini')
303         write.csv2(nchd1[,ncol(nchd1)],uceout)
304         res <- list(n1 = nchd1, coord_ok = coordok, cuce1 = classeuce1, cuce2 = classeuce2)
305         res
306 }