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     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 }