1 #Author: Pierre Ratinaud
2 #Copyright (c) 2008-2009 Pierre Ratinaud
5 fille<-function(classe,classeuce) {
6 listfm<-unique(unlist(classeuce[classeuce[,classe%/%2]==classe,]))
7 listf<-listfm[listfm>=classe]
12 #fonction pour la double classification
13 #cette fonction doit etre splitter en 4 ou 5 fonctions
15 Rchdquest<-function(tableuc1,listeuce1,uceout ,nbt = 9, mincl = 2) {
16 #source('/home/pierre/workspace/iramuteq/Rscripts/CHD.R')
19 data1<-read.csv2(tableuc1)#,row.names=1)
20 cn.data1 <- colnames(data1)
21 data1 <- as.matrix(data1)
22 colnames(data1) <- cn.data1
23 rownames(data1) <- 1:nrow(data1)
27 data1<-data1[,-which(sc<=4)]
30 #analyse des tableaux avec la fonction CHD qui doit etre sourcee avant
31 chd1<-CHD(data1, x = nbt)
34 #FIXME: le nombre de classe peut etre inferieur
36 tcl <- ((nbt+1) * 2) - 2
39 listuce1<-read.csv2(listeuce1)
42 #Une fonction pour assigner une classe a chaque UCE
43 AssignClasseToUce<-function(listuce,chd) {
44 out<-matrix(nrow=nrow(listuce),ncol=ncol(chd))
45 for (i in 1:nrow(listuce)) {
46 for (j in 1:ncol(chd)) {
47 out[i,j]<-chd[(listuce[i,2]+1),j]
53 #Assignation des classes
54 classeuce1<-AssignClasseToUce(listuce1,chd1$n1)
55 classeuce2<-classeuce1
57 #calcul des poids (effectifs)
58 poids1<-vector(mode='integer',length=tcl)
59 makepoids<-function(classeuce,poids) {
60 for (classes in 2:(tcl + 1)){
61 for (i in 1:ncol(classeuce)) {
62 if (poids[(classes-1)]<length(classeuce[,i][classeuce[,i]==classes])) {
63 poids[(classes-1)]<-length(classeuce[,i][classeuce[,i]==classes])
69 poids1<-makepoids(classeuce1,poids1)
72 croise=matrix(ncol=tcl,nrow=tcl)
73 #production du tableau de contingence
74 for (i in 1:ncol(classeuce1)) {
75 #poids[i]<-length(classeuce1[,i][x==classes])
76 for (j in 1:ncol(classeuce2)) {
77 tablecroise<-table(classeuce1[,i],classeuce2[,j])
78 tabcolnames<-as.numeric(colnames(tablecroise))
79 #tabcolnames<-c(tabcolnames[(length(tabcolnames)-1)],tabcolnames[length(tabcolnames)])
80 tabrownames<-as.numeric(rownames(tablecroise))
81 #tabrownames<-c(tabrownames[(length(tabrownames)-1)],tabrownames[length(tabrownames)])
82 for (k in (ncol(tablecroise)-1):ncol(tablecroise)) {
83 for (l in (nrow(tablecroise)-1):nrow(tablecroise)) {
84 croise[(tabrownames[l]-1),(tabcolnames[k]-1)]<-tablecroise[l,k]
91 mincl<-round(nrow(classeuce1)/(nbt+1)) #valeur a calculer nbuce/nbt
93 #print('ATTENTION MINCL IMPOSE')
100 #print('ATTENTION : ON IMPOSE LA TAILLE DES CLASSES')
104 #tableau des chi2 signes
106 for (i in 1:nrow(croise)) {
107 for (j in 1:ncol(croise)) {
108 if (croise[i,j]==0) {
110 } else if (croise[i,j]<mincl) {
113 chitable<-matrix(ncol=2,nrow=2)
114 chitable[1,1]<-croise[i,j]
115 chitable[1,2]<-poids1[i]-chitable[1,1]
116 chitable[2,1]<-poids2[j]-chitable[1,1]
117 chitable[2,2]<-nrow(classeuce1)-poids2[j]-chitable[1,2]
118 chitest<-chisq.test(chitable,correct=FALSE)
119 if ((chitable[1,1]-chitest$expected)<0) {
120 chicroise[i,j]<--round(chitest$statistic,digits=7)
122 chicroise[i,j]<-round(chitest$statistic,digits=7)
129 #determination des chi2 les plus fort
130 chicroiseori<-chicroise
134 maxi[i]<-which.max(chicroise)
135 chimax[i]<-chicroise[maxi[i]]
136 chicroise[maxi[i]]<-0
138 testpres<-function(x,listcoord) {
139 for (i in 1:length(listcoord)) {
140 if (x==listcoord[i]) {
148 c.len=nrow(chicroise)
149 r.len=ncol(chicroise)
154 #on garde une valeur par ligne / colonne
155 for (i in 1:length(maxi)) {
156 #coordonnées de chi2 max
157 x.co<-ceiling(maxi[i]/c.len)
158 y.co<-maxi[i]-(x.co-1)*c.len
159 a<-testpres(x.co,listx)
160 b<-testpres(y.co,listy)
172 #pour ecrire les resultats
173 for (i in 1:length(listx)) {
174 txt<-paste(listx[i]+1,listy[i]+1,sep=' ')
175 txt<-paste(txt,croise[listy[i],listx[i]],sep=' ')
176 txt<-paste(txt,chicroiseori[listy[i],listx[i]],sep=' ')
180 #colonne de la classe
181 #trouver les filles et les meres
182 trouvefillemere<-function(classe,chd) {
183 unique(unlist(chd[chd[,classe%/%2]==classe,]))
186 #pour trouver une valeur dans une liste
187 #is.element(elem, list)
191 trouvecoordok<-function(first) {
196 listxp<-listx[first:length(listx)]
197 listxp<-c(listxp,listx[1:(first-1)])
198 # listxp<-listxp[-first]
199 listyp<-listy[first:length(listy)]
200 listyp<-c(listyp,listy[1:(first-1)])
201 # listyp<-listyp[-first]
202 for (i in 1:length(listxp)) {
203 if (!(listxp[i]+1)%in%fillemere1) {
204 if (!(listyp[i]+1)%in%fillemere2) {
205 coordok<-rbind(coordok,c(listyp[i]+1,listxp[i]+1))
206 fillemere1<-c(fillemere1,trouvefillemere(listxp[i]+1,chd2$n1))
207 fillemere2<-c(fillemere2,trouvefillemere(listyp[i]+1,chd1$n1))
213 #fonction pour trouver le nombre maximum de classes
214 findmaxclasse<-function(listx,listy) {
218 for (i in 1:length(listy)) {
220 coordok<-trouvecoordok(i)
221 if (maxcl <= nrow(coordok)) {
223 listcoordok[[nb]]<-coordok
227 listcoordok<-unique(listcoordok)
228 print('liste coord ok')
229 # print('FIXME FIXME FIXME FIXME FIXME')
231 #si plusieurs ensemble avec le meme nombre de classe, on conserve
232 #la liste avec le plus fort chi2
233 if (length(listcoordok)>1) {
236 for (i in 1:length(listcoordok)) {
239 if (nrow(listcoordok[[i]])==maxcl) {
240 for (j in 1:nrow(listcoordok[[i]])) {
241 chi<-c(chi,croise[(listcoordok[[i]][j,1]-1),(listcoordok[[i]][j,2]-1)])
242 uce<-c(uce,chicroiseori[(listcoordok[[i]][j,1]-1),(listcoordok[[i]][j,2]-1)])
245 if (maxchi < sum(chi)) {
253 print((suce/nrow(classeuce1)*100))
256 #findmaxclasse(listx,listy)
257 #coordok<-trouvecoordok(1)
258 coordok<-findmaxclasse(listx,listy)
261 fille<-function(classe,classeuce) {
262 listfm<-unique(unlist(classeuce[classeuce[,classe%/%2]==classe,]))
263 listf<-listfm[listfm>=classe]
269 lfilletot<-function(classeuce) {
271 for (classe in 1:nrow(coordok)) {
272 listfille<-unique(c(listfille,fille(coordok[classe,1],classeuce)))
277 listfille1<-lfilletot(classeuce1)
278 listfille2<-lfilletot(classeuce2)
281 #utiliser rownames comme coordonnees dans un tableau de 0
282 Assignclasse<-function(classeuce,x) {
283 nchd<-matrix(0,ncol=ncol(classeuce),nrow=nrow(classeuce))
284 for (classe in 1:nrow(coordok)) {
286 clnb<-coordok[classe,x]
288 tochange<-which(classeuce[,colnb]==clnb)
289 for (row in 1:length(tochange)) {
290 nchd[tochange[row],colnb:ncol(nchd)]<-classe
295 print('commence assigne new classe')
296 nchd1<-Assignclasse(classeuce1,1)
297 #nchd1<-Assignnewclasse(classeuce1,1)
298 nchd2<-Assignclasse(classeuce2,2)
299 print('fini assign new classe')
300 croisep<-matrix(ncol=nrow(coordok),nrow=nrow(coordok))
301 for (i in 1:nrow(nchd1)) {
302 if (nchd1[i,ncol(nchd1)]==0) {
303 nchd2[i,]<-nchd2[i,]*0
305 if (nchd1[i,ncol(nchd1)]!=nchd2[i,ncol(nchd2)]) {
306 nchd2[i,]<-nchd2[i,]*0
308 if (nchd2[i,ncol(nchd2)]==0) {
309 nchd1[i,]<-nchd1[i,]*0
313 elim<-which(nchd1[,ncol(nchd1)]==0)
314 keep<-which(nchd1[,ncol(nchd1)]!=0)
315 n1<-nchd1[nchd1[,ncol(nchd1)]!=0,]
316 n2<-nchd2[nchd2[,ncol(nchd2)]!=0,]
320 write.csv2(nchd1[,ncol(nchd1)],uceout)
321 res <- list(n1 = nchd1, coord_ok = coordok, cuce1 = classeuce1, chd = chd1)
324 #n1<-Rchdtxt('/home/pierre/workspace/iramuteq/corpus/agir2sortie01.csv','/home/pierre/workspace/iramuteq/corpus/testuce.csv','/home/pierre/workspace/iramuteq/corpus/testuceout.csv')