iramuteq.org Git - iramuteq/blob - 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         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]
  97                     }
  98                 }
  99             }
 100             tablecroise
 101         }
 102     if (classif_mode == 0) {ind <- (nbcl * 2)} else {ind <- nbcl}
 103         if (mincl==0){
 104                 mincl<-round(nrow(classeuce1)/ind)
 105         }#valeur a calculer nbuce/20
 106         if (mincl<3){
 107                 mincl<-3
 108         }
 109     print(mincl)
 110         #print('table1')
 111         #print(croise)
 112         #tableau des chi2 signes
 113         chicroise<-croise
 114         for (i in 1:nrow(croise)) {
 115             for (j in 1:ncol(croise)) {
 116                 if (croise[i,j]==0) {
 117                     chicroise[i,j]<-0
 118                 } else if (croise[i,j]<mincl) {
 119                     chicroise[i,j]<-0
 120                 } else {
 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)
 129                 } else {
 130                     chicroise[i,j]<-round(chitest$statistic,digits=7)
 131                 #print(chitest)
 132                 }
 133                 }
 134             }
 135         }
 136         #print(chicroise)
 137         #determination des chi2 les plus fort
 138         chicroiseori<-chicroise
 139         maxi<-vector()
 140         chimax<-vector()
 141         for (i in 1:tcl) {
 142             maxi[i]<-which.max(chicroise)
 143             chimax[i]<-chicroise[maxi[i]]
 144             chicroise[maxi[i]]<-0
 145         }
 146         testpres<-function(x,listcoord) {
 147             for (i in 1:length(listcoord)) {
 148                 if (x==listcoord[i]) {
 149                     return(-1)
 150                 } else {
 151                     a<-1
 152                 }
 153             }
 154             a
 155         }
 156         c.len=nrow(chicroise)
 157         r.len=ncol(chicroise)
 158         listx<-c(0)
 159         listy<-c(0)
 160         rang<-0
 161         cons<-list()
 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)
 169
 170             if (a==1) {
 171                         if (b==1) {
 172                             rang<-rang+1
 173                             listx[rang]<-x.co
 174                             listy[rang]<-y.co
 175                         }
 176             }
 177             cons[[1]]<-listx
 178             cons[[2]]<-listy
 179         }
 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=' ')
 185             print(txt)
 186         }
 187
 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,]))
 192         }
 193
 194         #pour trouver une valeur dans une liste
 195         #is.element(elem, list)
 196         #== elem%in%list
 197
 198         coordok<-NULL
 199         trouvecoordok<-function(first) {
 200             fillemere1<-NULL
 201             fillemere2<-NULL
 202             listxp<-listx
 203             listyp<-listy
 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))
 216                   }
 217                }
 218             }
 219             coordok
 220         }
 221 #fonction pour trouver le nombre maximum de classes
 222         findmaxclasse<-function(listx,listy) {
 223             listcoordok<-list()
 224             maxcl<-0
 225             nb<-1
 226             for (i in 1:length(listy)) {
 227                         coordok<-trouvecoordok(i)
 228                         if (maxcl <= nrow(coordok)) {
 229                             maxcl<-nrow(coordok)
 230                             listcoordok[[nb]]<-coordok
 231                             nb<-nb+1
 232                         }
 233             }
 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) {
 238                 maxchi<-0
 239                 best<-NULL
 240                 for (i in 1:length(listcoordok)) {
 241                     chi<-NULL
 242                     uce<-NULL
 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)])
 247                         }
 248                         if (maxchi < sum(chi)) {
 249                             maxchi<-sum(chi)
 250                             suce<-sum(uce)
 251                             best<-i
 252                         }
 253                     }
 254                 }
 255             }
 256             print((suce/nrow(classeuce1)*100))
 257             listcoordok[[best]]
 258         }
 259         #findmaxclasse(listx,listy)
 260         #coordok<-trouvecoordok(1)
 261         coordok<-findmaxclasse(listx,listy)
 262         print(coordok)
 263
 264         lfilletot<-function(classeuce,x) {
 265             listfille<-NULL
 266             for (classe in 1:nrow(coordok)) {
 267                         listfille<-unique(c(listfille,fille(coordok[classe,x],classeuce)))
 268                         listfille
 269             }
 270         }
 271
 272         listfille1<-lfilletot(classeuce1,1)
 273         listfille2<-lfilletot(classeuce2,2)
 274
 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]
 280                         colnb<-clnb%/%2
 281             nchd[which(classeuce[,colnb]==clnb), colnb:ncol(nchd)] <- classe
 282             }
 283             nchd
 284         }
 285         print('commence assigne new classe')
 286         nchd1<-Assignclasse(classeuce1,1)
 287         if (classif_mode==0)
 288                 nchd2<-Assignclasse(classeuce2,2)
 289         else
 290                 nchd2<-nchd1
 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
 296
 297 #       for (i in 1:nrow(nchd1)) {
 298 #           if (nchd1[i,ncol(nchd1)]==0) {
 299 #               nchd2[i,]<-nchd2[i,]*0
 300 #           }
 301 #           if (nchd1[i,ncol(nchd1)]!=nchd2[i,ncol(nchd2)]) {
 302 #               nchd2[i,]<-nchd2[i,]*0
 303 #           }
 304 #           if (nchd2[i,ncol(nchd2)]==0) {
 305 #               nchd1[i,]<-nchd1[i,]*0
 306 #           }
 307 #       }
 308         print('fini croise')
 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,]
 313         #clnb<-nrow(coordok)
 314         print('fini')
 315         write.csv2(nchd1[,ncol(nchd1)],uceout)
 316         res <- list(n1 = nchd1, coord_ok = coordok, cuce1 = classeuce1, cuce2 = classeuce2)
 317         res
 318 }