iramuteq.org Git - iramuteq/blob - Rscripts/chdquest.R

   1 #Author: Pierre Ratinaud
   2 #Copyright (c) 2008-2009 Pierre Ratinaud
   3 #Lisense: GNU/GPL
   4
   5 fille<-function(classe,classeuce) {
   6         listfm<-unique(unlist(classeuce[classeuce[,classe%/%2]==classe,]))
   7         listf<-listfm[listfm>=classe]
   8         listf<-unique(listf)
   9         listf
  10 }
  11
  12 #fonction pour la double classification
  13 #cette fonction doit etre splitter en 4 ou 5 fonctions
  14
  15 Rchdquest<-function(tableuc1,listeuce1,uceout ,nbt = 9, mincl = 2) {
  16         #source('/home/pierre/workspace/iramuteq/Rscripts/CHD.R')
  17
  18         #lecture des tableaux
  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)
  24         data2<-data1
  25         sc<-colSums(data2)
  26         if (min(sc)<=4){
  27                 data1<-data1[,-which(sc<=4)]
  28                 sc<-sc[-which(sc<=4)]
  29         }
  30         #analyse des tableaux avec la fonction CHD qui doit etre sourcee avant
  31         chd1<-CHD(data1, x = nbt)
  32         chd2<-chd1
  33
  34         #FIXME: le nombre de classe peut etre inferieur
  35     nbcl <- nbt + 1
  36     tcl <- ((nbt+1) * 2) - 2
  37
  38         #lecture des uce
  39         listuce1<-read.csv2(listeuce1)
  40         listuce2<-listuce1
  41
  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]
  48                         }
  49             }
  50             out
  51         }
  52
  53         #Assignation des classes
  54         classeuce1<-AssignClasseToUce(listuce1,chd1$n1)
  55         classeuce2<-classeuce1
  56
  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])
  64                     }
  65                 }
  66             }
  67             poids
  68         }
  69         poids1<-makepoids(classeuce1,poids1)
  70         poids2<-poids1
  71
  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]
  85                     }
  86                 }
  87             }
  88             tablecroise
  89         }
  90     if (mincl == 2) {
  91             mincl<-round(nrow(classeuce1)/(nbt+1)) #valeur a calculer nbuce/nbt
  92     }
  93     #print('ATTENTION MINCL IMPOSE')
  94         #mincl<-422
  95         print('mincl')
  96         print(mincl)
  97         if (mincl < 3) {
  98             mincl<-3
  99         }
 100     #print('ATTENTION : ON IMPOSE LA TAILLE DES CLASSES')
 101     #mincl <- 15
 102         print('table1')
 103         print(croise)
 104         #tableau des chi2 signes
 105         chicroise<-croise
 106         for (i in 1:nrow(croise)) {
 107             for (j in 1:ncol(croise)) {
 108                 if (croise[i,j]==0) {
 109                     chicroise[i,j]<-0
 110                 } else if (croise[i,j]<mincl) {
 111                     chicroise[i,j]<-0
 112                 } else {
 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)
 121                         } else {
 122                             chicroise[i,j]<-round(chitest$statistic,digits=7)
 123                 #print(chitest)
 124                         }
 125                 }
 126             }
 127         }
 128         print(chicroise)
 129         #determination des chi2 les plus fort
 130         chicroiseori<-chicroise
 131         maxi<-vector()
 132         chimax<-vector()
 133         for (i in 1:tcl) {
 134             maxi[i]<-which.max(chicroise)
 135             chimax[i]<-chicroise[maxi[i]]
 136             chicroise[maxi[i]]<-0
 137         }
 138         testpres<-function(x,listcoord) {
 139             for (i in 1:length(listcoord)) {
 140                 if (x==listcoord[i]) {
 141                     return(-1)
 142                 } else {
 143                     a<-1
 144                 }
 145             }
 146             a
 147         }
 148         c.len=nrow(chicroise)
 149         r.len=ncol(chicroise)
 150         listx<-c(0)
 151         listy<-c(0)
 152         rang<-0
 153         cons<-list()
 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)
 161
 162             if (a==1) {
 163                 if (b==1) {
 164                     rang<-rang+1
 165                     listx[rang]<-x.co
 166                     listy[rang]<-y.co
 167                 }
 168             }
 169             cons[[1]]<-listx
 170             cons[[2]]<-listy
 171         }
 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=' ')
 177             print(txt)
 178         }
 179
 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,]))
 184         }
 185
 186         #pour trouver une valeur dans une liste
 187         #is.element(elem, list)
 188         #== elem%in%list
 189
 190         coordok<-NULL
 191         trouvecoordok<-function(first) {
 192             fillemere1<-NULL
 193             fillemere2<-NULL
 194             listxp<-listx
 195             listyp<-listy
 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))
 208                   }
 209                }
 210             }
 211             coordok
 212         }
 213 #fonction pour trouver le nombre maximum de classes
 214         findmaxclasse<-function(listx,listy) {
 215             listcoordok<-list()
 216             maxcl<-0
 217             nb<-1
 218             for (i in 1:length(listy)) {
 219
 220                 coordok<-trouvecoordok(i)
 221                 if (maxcl <= nrow(coordok)) {
 222                     maxcl<-nrow(coordok)
 223                     listcoordok[[nb]]<-coordok
 224                     nb<-nb+1
 225                 }
 226             }
 227             listcoordok<-unique(listcoordok)
 228                 print('liste coord ok')
 229 #               print('FIXME FIXME FIXME FIXME FIXME')
 230 #               print(listcoordok)
 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) {
 234                 maxchi<-0
 235                 best<-NULL
 236                 for (i in 1:length(listcoordok)) {
 237                     chi<-NULL
 238                     uce<-NULL
 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)])
 243                         }
 244                                 print(sum(uce))
 245                         if (maxchi < sum(chi)) {
 246                             maxchi<-sum(chi)
 247                             suce<-sum(uce)
 248                             best<-i
 249                         }
 250                     }
 251                 }
 252             }
 253             print((suce/nrow(classeuce1)*100))
 254             listcoordok[[best]]
 255         }
 256         #findmaxclasse(listx,listy)
 257         #coordok<-trouvecoordok(1)
 258         coordok<-findmaxclasse(listx,listy)
 259         print(coordok)
 260
 261         fille<-function(classe,classeuce) {
 262             listfm<-unique(unlist(classeuce[classeuce[,classe%/%2]==classe,]))
 263             listf<-listfm[listfm>=classe]
 264             listf<-unique(listf)
 265             listf
 266         }
 267
 268
 269         lfilletot<-function(classeuce) {
 270             listfille<-NULL
 271             for (classe in 1:nrow(coordok)) {
 272                 listfille<-unique(c(listfille,fille(coordok[classe,1],classeuce)))
 273                 listfille
 274             }
 275         }
 276
 277         listfille1<-lfilletot(classeuce1)
 278         listfille2<-lfilletot(classeuce2)
 279
 280
 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)) {
 285
 286                 clnb<-coordok[classe,x]
 287                 colnb<-clnb%/%2
 288                 tochange<-which(classeuce[,colnb]==clnb)
 289             for (row in 1:length(tochange)) {
 290                     nchd[tochange[row],colnb:ncol(nchd)]<-classe
 291                 }
 292             }
 293             nchd
 294         }
 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
 304             }
 305             if (nchd1[i,ncol(nchd1)]!=nchd2[i,ncol(nchd2)]) {
 306                 nchd2[i,]<-nchd2[i,]*0
 307             }
 308             if (nchd2[i,ncol(nchd2)]==0) {
 309                 nchd1[i,]<-nchd1[i,]*0
 310             }
 311         }
 312         print('fini croise')
 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,]
 317         print('debut graph')
 318         clnb<-nrow(coordok)
 319         print('fini')
 320         write.csv2(nchd1[,ncol(nchd1)],uceout)
 321         res <- list(n1 = nchd1, coord_ok = coordok, cuce1 = classeuce1, chd = chd1)
 322         res
 323 }
 324 #n1<-Rchdtxt('/home/pierre/workspace/iramuteq/corpus/agir2sortie01.csv','/home/pierre/workspace/iramuteq/corpus/testuce.csv','/home/pierre/workspace/iramuteq/corpus/testuceout.csv')