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 croise=matrix(ncol=tcl,nrow=tcl)
85 #production du tableau de contingence
86 for (i in 1:ncol(classeuce1)) {
87 #poids[i]<-length(classeuce1[,i][x==classes])
88 for (j in 1:ncol(classeuce2)) {
89 tablecroise<-table(classeuce1[,i],classeuce2[,j])
90 tabcolnames<-as.numeric(colnames(tablecroise))
91 #tabcolnames<-c(tabcolnames[(length(tabcolnames)-1)],tabcolnames[length(tabcolnames)])
92 tabrownames<-as.numeric(rownames(tablecroise))
93 #tabrownames<-c(tabrownames[(length(tabrownames)-1)],tabrownames[length(tabrownames)])
94 for (k in (ncol(tablecroise)-1):ncol(tablecroise)) {
95 for (l in (nrow(tablecroise)-1):nrow(tablecroise)) {
96 croise[(tabrownames[l]-1),(tabcolnames[k]-1)]<-tablecroise[l,k]
102 if (classif_mode == 0) {ind <- (nbcl * 2)} else {ind <- nbcl}
104 mincl<-round(nrow(classeuce1)/ind)
105 }#valeur a calculer nbuce/20
112 #tableau des chi2 signes
114 for (i in 1:nrow(croise)) {
115 for (j in 1:ncol(croise)) {
116 if (croise[i,j]==0) {
118 } else if (croise[i,j]<mincl) {
121 chitable<-matrix(ncol=2,nrow=2)
122 chitable[1,1]<-croise[i,j]
123 chitable[1,2]<-poids1[i]-chitable[1,1]
124 chitable[2,1]<-poids2[j]-chitable[1,1]
125 chitable[2,2]<-nrow(classeuce1)-poids2[j]-chitable[1,2]
126 chitest<-chisq.test(chitable,correct=FALSE)
127 if ((chitable[1,1]-chitest$expected)<0) {
128 chicroise[i,j]<--round(chitest$statistic,digits=7)
130 chicroise[i,j]<-round(chitest$statistic,digits=7)
137 #determination des chi2 les plus fort
138 chicroiseori<-chicroise
142 maxi[i]<-which.max(chicroise)
143 chimax[i]<-chicroise[maxi[i]]
144 chicroise[maxi[i]]<-0
146 testpres<-function(x,listcoord) {
147 for (i in 1:length(listcoord)) {
148 if (x==listcoord[i]) {
156 c.len=nrow(chicroise)
157 r.len=ncol(chicroise)
162 #on garde une valeur par ligne / colonne
163 for (i in 1:length(maxi)) {
164 #coordonnées de chi2 max
165 x.co<-ceiling(maxi[i]/c.len)
166 y.co<-maxi[i]-(x.co-1)*c.len
167 a<-testpres(x.co,listx)
168 b<-testpres(y.co,listy)
180 #pour ecrire les resultats
181 for (i in 1:length(listx)) {
182 txt<-paste(listx[i]+1,listy[i]+1,sep=' ')
183 txt<-paste(txt,croise[listy[i],listx[i]],sep=' ')
184 txt<-paste(txt,chicroiseori[listy[i],listx[i]],sep=' ')
188 #colonne de la classe
189 #trouver les filles et les meres
190 trouvefillemere<-function(classe,chd) {
191 unique(unlist(chd[chd[,classe%/%2]==classe,]))
194 #pour trouver une valeur dans une liste
195 #is.element(elem, list)
199 trouvecoordok<-function(first) {
204 listxp<-listx[first:length(listx)]
205 listxp<-c(listxp,listx[1:(first-1)])
206 # listxp<-listxp[-first]
207 listyp<-listy[first:length(listy)]
208 listyp<-c(listyp,listy[1:(first-1)])
209 # listyp<-listyp[-first]
210 for (i in 1:length(listxp)) {
211 if (!(listxp[i]+1)%in%fillemere1) {
212 if (!(listyp[i]+1)%in%fillemere2) {
213 coordok<-rbind(coordok,c(listyp[i]+1,listxp[i]+1))
214 fillemere1<-c(fillemere1,trouvefillemere(listxp[i]+1,chd2$n1))
215 fillemere2<-c(fillemere2,trouvefillemere(listyp[i]+1,chd1$n1))
221 #fonction pour trouver le nombre maximum de classes
222 findmaxclasse<-function(listx,listy) {
226 for (i in 1:length(listy)) {
227 coordok<-trouvecoordok(i)
228 if (maxcl <= nrow(coordok)) {
230 listcoordok[[nb]]<-coordok
234 listcoordok<-unique(listcoordok)
235 #si plusieurs ensemble avec le meme nombre de classe, on conserve
236 #la liste avec le plus fort chi2
237 if (length(listcoordok)>1) {
240 for (i in 1:length(listcoordok)) {
243 if (nrow(listcoordok[[i]])==maxcl) {
244 for (j in 1:nrow(listcoordok[[i]])) {
245 chi<-c(chi,croise[(listcoordok[[i]][j,1]-1),(listcoordok[[i]][j,2]-1)])
246 uce<-c(uce,chicroiseori[(listcoordok[[i]][j,1]-1),(listcoordok[[i]][j,2]-1)])
248 if (maxchi < sum(chi)) {
256 print((suce/nrow(classeuce1)*100))
259 #findmaxclasse(listx,listy)
260 #coordok<-trouvecoordok(1)
261 coordok<-findmaxclasse(listx,listy)
264 lfilletot<-function(classeuce,x) {
266 for (classe in 1:nrow(coordok)) {
267 listfille<-unique(c(listfille,fille(coordok[classe,x],classeuce)))
272 listfille1<-lfilletot(classeuce1,1)
273 listfille2<-lfilletot(classeuce2,2)
275 #utiliser rownames comme coordonnees dans un tableau de 0
276 Assignclasse<-function(classeuce,x) {
277 nchd<-matrix(0,ncol=ncol(classeuce),nrow=nrow(classeuce))
278 for (classe in 1:nrow(coordok)) {
279 clnb<-coordok[classe,x]
281 nchd[which(classeuce[,colnb]==clnb), colnb:ncol(nchd)] <- classe
285 print('commence assigne new classe')
286 nchd1<-Assignclasse(classeuce1,1)
288 nchd2<-Assignclasse(classeuce2,2)
291 print('fini assign new classe')
292 #croisep<-matrix(ncol=nrow(coordok),nrow=nrow(coordok))
293 nchd2[which(nchd1[,ncol(nchd1)]==0),] <- 0
294 nchd2[which(nchd1[,ncol(nchd1)]!=nchd2[,ncol(nchd2)]),] <- 0
295 nchd1[which(nchd2[,ncol(nchd2)]==0),] <- 0
297 # for (i in 1:nrow(nchd1)) {
298 # if (nchd1[i,ncol(nchd1)]==0) {
299 # nchd2[i,]<-nchd2[i,]*0
301 # if (nchd1[i,ncol(nchd1)]!=nchd2[i,ncol(nchd2)]) {
302 # nchd2[i,]<-nchd2[i,]*0
304 # if (nchd2[i,ncol(nchd2)]==0) {
305 # nchd1[i,]<-nchd1[i,]*0
309 elim<-which(nchd1[,ncol(nchd1)]==0)
310 keep<-which(nchd1[,ncol(nchd1)]!=0)
311 n1<-nchd1[nchd1[,ncol(nchd1)]!=0,]
312 n2<-nchd2[nchd2[,ncol(nchd2)]!=0,]
315 write.csv2(nchd1[,ncol(nchd1)],uceout)
316 res <- list(n1 = nchd1, coord_ok = coordok, cuce1 = classeuce1, cuce2 = classeuce2)