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

   1 #datadm<-read.table('/home/pierre/.hippasos/corpus_agir_CHDS_16/fileACTtemp.csv', header=TRUE,sep=';', quote='\"',row.names = 1, na.strings = 'NA')
   2 library(cluster)
   3 #dissmat<-daisy(dataact, metric = 'gower', stand = FALSE)
   4 #chd<-diana(dissmat,diss=TRUE,)
   5 #height<-chd$height
   6 #sortheight<-sort(height,decreasing=TRUE)
   7 FindBestCluster<-function (x,Max=15) {
   8     i<-1
   9     j<-1
  10     ListClasseOk<-list()
  11     while (i < Max) {
  12         if (x[i]==1){
  13             while (x[i]==1) {
  14             i<-i+1
  15             }
  16             ListClasseOk[[j]]<-i
  17             j<-j+1
  18         }
  19         if (x[i]==x[i+1]) {
  20             i<-i+1
  21         }
  22         else {
  23             ListClasseOk[[j]]<-i+1
  24             i<-i+1
  25             j<-j+1
  26         }
  27     }
  28         unlist(ListClasseOk)
  29 }
  30 #BestCLusterNb<-FindBestCluster(sortheight)
  31 #classes<-as.data.frame(cutree(as.hclust(chd), k=6))[,1]
  32 #datadm<-cbind(datadm,classes)
  33 #clusplot(datadm,classes,shade=TRUE,color=TRUE,labels=4)
  34
  35 BuildContTable<- function (x) {
  36         afctable<-NULL
  37         for (i in 1:(ncol(x)-1)) {
  38             coltable<-table(x[,i],x$classes)
  39             afctable<-rbind(afctable,coltable)
  40         }
  41         afctable
  42 }
  43
  44 PrintProfile<- function(dataclasse,profileactlist,profileetlist,antiproact,antiproet,clusternb,profileout,antiproout,profilesuplist=NULL,antiprosup=NULL) {
  45     prolist<-list()
  46     profile<-matrix(,0,6)
  47     antipro<-matrix(,0,6)
  48         cltot<-as.data.frame(dataclasse[dataclasse[,ncol(dataclasse)]!=0,])
  49         cltot<-as.data.frame(as.character(cltot[,ncol(cltot)]))
  50         tot<-nrow(cltot)
  51     classes<-as.data.frame(as.character(dataclasse[,ncol(dataclasse)]))
  52     classes.s<-as.data.frame(summary(cltot[,1],maxsum=500))
  53     profile<-rbind(profile,c('***','nb classes',clusternb,'***','',''))
  54     antipro<-rbind(antipro,c('***','nb classes',clusternb,'***','',''))
  55     for(i in 1:clusternb) {
  56         profile<-rbind(profile,c('**','classe',i,'**','',''))
  57         nbind<-classes.s[which(rownames(classes.s)==i),1]
  58         pr<-round((nbind/tot)*100,digits=2)
  59         profile<-rbind(profile,c('****',nbind,tot,pr,'****',''))
  60                 if (length(profileactlist[[1]][[i]])!=0){
  61                 profile<-rbind(profile,as.matrix(profileactlist[[1]][[i]]))
  62                 }
  63                 if (!is.null(profilesuplist)) {
  64                         profile<-rbind(profile,c('*****','*','*','*','*','*'))
  65                         if (length(profilesuplist[[1]][[i]])!=0) {
  66                                 profile<-rbind(profile,as.matrix(profilesuplist[[1]][[i]]))
  67                         }
  68                 }
  69         if (!is.null(profileetlist)) {
  70             profile<-rbind(profile,c('*','*','*','*','*','*'))
  71                     if (length(profileetlist[[1]][[i]])!=0) {
  72                     profile<-rbind(profile,as.matrix(profileetlist[[1]][[i]]))
  73                     }
  74         }
  75         antipro<-rbind(antipro,c('**','classe',i,'**','',''))
  76         antipro<-rbind(antipro,c('****',nbind,tot,pr,'****',''))
  77                 if (length(antiproact[[1]][[i]])!=0) {
  78                 antipro<-rbind(antipro,as.matrix(antiproact[[1]][[i]]))
  79                 }
  80                 if (!is.null(profilesuplist)) {
  81                         antipro<-rbind(antipro,c('*****','*','*','*','*','*'))
  82                         if (length(antiprosup[[1]][[i]])!=0) {
  83                                 antipro<-rbind(antipro,as.matrix(antiprosup[[1]][[i]]))
  84                         }
  85                 }
  86         if (!is.null(profileetlist)) {
  87             antipro<-rbind(antipro,c('*','*','*','*','*','*'))
  88             if (length(antiproet[[1]][[i]])!=0) {
  89                             antipro<-rbind(antipro,as.matrix(antiproet[[1]][[i]]))
  90                     }
  91         }
  92         }
  93     write.csv2(profile,file=profileout,row.names=FALSE)
  94     write.csv2(antipro,file=antiproout,row.names=FALSE)
  95 }
  96
  97 AddCorrelationOk<-function(afc) {
  98         rowcoord<-afc$rowcoord
  99         colcoord<-afc$colcoord
 100         factor <- ncol(rowcoord)
 101         hypo<-function(rowcoord,ligne) {
 102                 somme<-0
 103                 for (i in 1:factor) {
 104                         somme<-somme+(rowcoord[ligne,i])^2
 105                 }
 106         sqrt(somme)
 107         }
 108         cor<-function(d,hypo) {
 109                 d/hypo
 110         }
 111         CompCrl<-function(rowcol) {
 112                 out<-rowcol
 113                 for (i in 1:factor) {
 114                         for(ligne in 1:nrow(rowcol)) {
 115                                 out[ligne,i]<-cor(rowcol[ligne,i],hypo(rowcol,ligne))
 116                         }
 117                 }
 118         out
 119         }
 120         afc$rowcrl<-CompCrl(rowcoord)
 121         afc$colcrl<-CompCrl(colcoord)
 122         afc
 123 }
 124
 125 AsLexico<- function(x) {
 126         x<-as.matrix(x)
 127         sumcol<-colSums(x)
 128     sumrow<-rowSums(x)
 129         tot<-sum(sumrow)
 130         tablesqr<-x
 131         tablep<-x
 132         mod.names<-rownames(x)
 133         #problem exemple aurelia
 134         for (classe in 1:ncol(x)) {
 135                 print(classe)
 136                 for (ligne in 1:nrow(x)) {
 137                         conttable<-matrix(0,2,2)
 138                         conttable[1,1]<-as.numeric(x[ligne,classe])
 139                         conttable[1,2]<-sumrow[ligne]-conttable[1,1]
 140                         conttable[2,1]<-sumcol[classe]-conttable[1,1]
 141                         conttable[2,2]<-tot-sumrow[ligne]-conttable[2,1]
 142                         chiresult<-chisq.test(conttable,correct=TRUE)
 143                         if (is.na(chiresult$p.value)) {
 144                                 chiresult$p.value<-1
 145                                 chiresult$statistic<-0
 146                         }
 147                         obsv<-chiresult$expected
 148                         pval<-as.character(format(chiresult$p.value,scientific=TRUE))
 149                         spval<-strsplit(pval,'e')
 150                         if (is.na(spval)) {
 151                                 print(spval)
 152                         }
 153                         if (conttable[1,1]>obsv[1,1]) {
 154                                 tablep[ligne,classe]<-as.numeric(spval[[1]][2])*(-1)
 155                                 tablesqr[ligne,classe]<-round(chiresult$statistic,digits=3)
 156                         }
 157                         else if (conttable[1,1]<obsv[1,1]){
 158                                 tablep[ligne,classe]<-as.numeric(spval[[1]][2])
 159                                 tablesqr[ligne,classe]<--round(chiresult$statistic,digits=3)
 160                         }
 161                 }
 162         }
 163         output<-list()
 164         eff_relatif<-(x/sumcol)*1000
 165         output[[1]]<-tablep
 166         output[[2]]<-tablesqr
 167         output[[3]]<-eff_relatif
 168         output
 169 }
 170
 171 MyChiSq<-function(x){
 172         sr<-rowSums(x)
 173     sc<-colSums(x)
 174     n <- sum(x)
 175         E <- outer(sr, sc, "*")/n
 176         STAT<-sum((abs(x - E))^2/E)
 177     PVAL <- pchisq(STAT, 1, lower.tail = FALSE)
 178         chi<-list(statistic = STAT, expected = E, p.value = PVAL)
 179     chi
 180 }
 181
 182 AsLexico2<- function(mat, chip = FALSE) {
 183         mat<-as.matrix(mat)
 184         sumcol<-colSums(mat)
 185         sumrow<-rowSums(mat)
 186         tot<-sum(sumrow)
 187         tablesqr<-mat
 188         tablep<-mat
 189     contcs <- mat
 190     for (i in 1:nrow(contcs)) {
 191         contcs[i,] <- sumcol
 192     }
 193     contrs <- mat
 194     contrs[,1:ncol(contrs)] <- sumrow
 195     conttot <- matrix(tot, nrow = nrow(mat), ncol = ncol(mat))
 196     cont12 <- contrs - mat
 197     cont21 <- contcs - mat
 198     cont22 <- conttot - contrs - cont21
 199         mod.names<-rownames(mat)
 200     make_chi_lex <- function(x) {
 201         tb<-matrix(0,2,2)
 202         tb[1,1] <- mat[x]
 203         tb[1,2] <- cont12[x]
 204         tb[2,1] <- cont21[x]
 205         tb[2,2] <- cont22[x]
 206         chiresult<-MyChiSq(tb)
 207         #chiresult$statistic
 208         if (is.na(chiresult$p.value)) {
 209                         chiresult$p.value<-1
 210                         chiresult$statistic<-0
 211                 }
 212                 obsv<-chiresult$expected
 213                 pval<-as.character(format(chiresult$p.value,scientific=TRUE))
 214                 spval<-strsplit(pval,'e')
 215                 if (is.na(spval)) {
 216                         print(spval)
 217                 }
 218                 if (tb[1,1]>obsv[1,1]) {
 219                         as.numeric(spval[[1]][2])*(-1)
 220                 }
 221                 else if (tb[1,1]<obsv[1,1]){
 222                         as.numeric(spval[[1]][2])
 223                 } else {
 224             0
 225         }
 226     }
 227     make_chi_p <- function(x) {
 228         tb<-matrix(0,2,2)
 229         tb[1,1] <- mat[x]
 230         tb[1,2] <- cont12[x]
 231         tb[2,1] <- cont21[x]
 232         tb[2,2] <- cont22[x]
 233         chiresult<-MyChiSq(tb)
 234         #chiresult$statistic
 235         if (is.na(chiresult$p.value)) {
 236                         chiresult$p.value<-1
 237                         chiresult$statistic<-0
 238                 }
 239                 obsv<-chiresult$expected
 240                 if (tb[1,1]>obsv[1,1]) {
 241                         chiresult$p.value
 242                 }
 243                 else if (tb[1,1]<obsv[1,1]){
 244                         1
 245                 } else {
 246             1
 247         }
 248     }
 249     make_chi <- function(x) {
 250         tb<-matrix(0,2,2)
 251         tb[1,1] <- mat[x]
 252         tb[1,2] <- cont12[x]
 253         tb[2,1] <- cont21[x]
 254         tb[2,2] <- cont22[x]
 255         chiresult<-MyChiSq(tb)
 256         #chiresult$statistic
 257         if (is.na(chiresult$p.value)) {
 258                         chiresult$p.value<-1
 259                         chiresult$statistic<-0
 260                 }
 261                 obsv<-chiresult$expected
 262                 if (tb[1,1]>obsv[1,1]) {
 263                         chiresult$statistic
 264                 }
 265                 else if (tb[1,1]<obsv[1,1]){
 266                         0
 267                 } else {
 268             0
 269         }
 270     }
 271
 272     res <- matrix(sapply(1:length(mat), make_chi_lex), ncol = ncol(mat))
 273     rownames(res)<-mod.names
 274     colnames(res) <- colnames(mat)
 275     eff_relatif<-round(t(apply(mat,1,function(x) {(x/t(as.matrix(sumcol))*1000)})),2)
 276     rownames(eff_relatif)<-mod.names
 277     colnames(eff_relatif) <- colnames(mat)
 278     if (chip) {
 279         reschip <- matrix(sapply(1:length(mat), make_chi_p), ncol = ncol(mat))
 280         rownames(reschip)<- mod.names
 281         colnames(reschip) <- colnames(mat)
 282         reschi <- matrix(sapply(1:length(mat), make_chi), ncol = ncol(mat))
 283         rownames(reschip)<- mod.names
 284         colnames(reschip) <- colnames(mat)
 285     }
 286     out <-list()
 287     out[[1]]<-res
 288     out[[3]]<-eff_relatif
 289     if (chip) {
 290         out[[2]] <- reschip
 291         out[[4]] <- reschi
 292     }
 293     out
 294 }
 295
 296 make.spec.hypergeo <- function(mat) {
 297     library(textometry)
 298     spec <- specificities(mat)
 299         sumcol<-colSums(mat)
 300     eff_relatif<-round(t(apply(mat,1,function(x) {(x/t(as.matrix(sumcol))*1000)})),2)
 301     colnames(eff_relatif) <- colnames(mat)
 302     out <-list()
 303     out[[1]]<-spec
 304     out[[3]]<-eff_relatif
 305     out
 306 }
 307
 308 BuildProf01<-function(x,classes) {
 309         #x : donnees en 0/1
 310         #classes : classes de chaque lignes de x
 311         dm<-cbind(x,cl=classes)
 312         clnb=length(summary(as.data.frame(as.character(classes)),max=100))
 313         mat<-matrix(0,ncol(x),clnb)
 314         rownames(mat)<-colnames(x)
 315         for (i in 1:clnb) {
 316                 dtmp<-dm[which(dm$cl==i),]
 317                 for (j in 1:(ncol(dtmp)-1)) {
 318                         mat[j,i]<-sum(dtmp[,j])
 319                 }
 320         }
 321         mat
 322 }
 323
 324 build.prof.tgen <- function(x) {
 325     nbst <- sum(x[nrow(x),])
 326     totcl <- x[nrow(x),]
 327     tottgen <- rowSums(x)
 328     nbtgen <- nrow(x) - 1
 329     chi2 <- x[1:(nrow(x)-1),]
 330     pchi2 <- chi2
 331     for (classe in 1:ncol(x)) {
 332         for (tg in 1:nbtgen) {
 333             cont <- c(x[tg, classe], tottgen[tg] - x[tg, classe], totcl[classe] - x[tg, classe], (nbst - totcl[classe]) - (tottgen[tg] - x[tg, classe]))
 334             cont <- matrix(unlist(cont), nrow=2)
 335             chiresult<-chisq.test(cont,correct=FALSE)
 336             if (is.na(chiresult$p.value)) {
 337                 chiresult$p.value<-1
 338                 chiresult$statistic<-0
 339             }
 340             if (chiresult$expected[1,1] > cont[1,1]) {
 341                 chiresult$statistic <- chiresult$statistic * -1
 342             }
 343             chi2[tg,classe] <- chiresult$statistic
 344             pchi2[tg,classe] <- chiresult$p.value
 345         }
 346     }
 347     res <- list(chi2 = chi2, pchi2 = pchi2)
 348 }
 349
 350 BuildProf<- function(x,dataclasse,clusternb,lim=2) {
 351         ####
 352         #r.names<-rownames(x)
 353         #x<-as.matrix(x)
 354         #rownames(x)<-r.names
 355         ####
 356         #nuce<-nrow(dataclasse)
 357     sumcol<-paste(NULL,1:nrow(x))
 358         colclasse<-dataclasse[,ncol(dataclasse)]
 359         nuce <- length(which(colclasse != 0))
 360 #       for (i in 1:nrow(x)) {
 361 #               sumcol[i]<-sum(x[i,])
 362 #       }
 363 #       afctablesum<-cbind(x,sumcol)
 364     afctablesum <- cbind(x, rowSums(x))
 365     #dataclasse<-as.data.frame(dataclasse[dataclasse[,ncol(dataclasse)]!=0,])
 366         dataclasse<-as.matrix(dataclasse[dataclasse[,ncol(dataclasse)]!=0,])
 367         tablesqr<-x
 368         tablep<-x
 369         x<-afctablesum
 370         listprofile<-list()
 371         listantipro<-list()
 372         mod.names<-rownames(x)
 373         prof<-list()
 374         aprof<-list()
 375         lnbligne<-matrix()
 376         for (classe in 1:clusternb) {
 377                 lnbligne[classe]<-length(colclasse[colclasse==classe])
 378                 prof[[classe]]<-data.frame()
 379                 aprof[[classe]]<-data.frame()
 380         }
 381
 382         for (ligne in 1:nrow(x)) {
 383                 for (classe in 1:clusternb) {
 384                         nbligneclasse<-lnbligne[classe]
 385                         conttable<-data.frame()
 386                         conttable[1,1]<-as.numeric(x[ligne,classe])
 387                         conttable[1,2]<-as.numeric(as.vector(x[ligne,ncol(x)]))-as.numeric(x[ligne,classe])
 388                         conttable[2,1]<-nbligneclasse-as.numeric(x[ligne,classe])
 389                         conttable[2,2]<-nrow(dataclasse)-as.numeric(as.vector(x[ligne,ncol(x)]))-conttable[2,1]
 390                         chiresult<-chisq.test(conttable,correct=FALSE)
 391                         if (is.na(chiresult$p.value)) {
 392                                 chiresult$p.value<-1
 393                                 chiresult$statistic<-0
 394                                 china=TRUE
 395                         }
 396                         obsv<-chiresult$expected
 397                         tablep[ligne,classe]<-round(chiresult$p.value,digits=3)
 398                         #tablep[ligne,classe]<-format(chiresult$p.value, scientific=TRUE)
 399             if (chiresult$statistic>=lim) {
 400                                 if (conttable[1,1]>obsv[1,1]) {
 401                                         tablesqr[ligne,classe]<-round(chiresult$statistic,digits=3)
 402                                         prof[[classe]][nrow(prof[[classe]])+1,1]<-as.numeric(x[ligne,classe])
 403                                         prof[[classe]][nrow(prof[[classe]]),2]<-as.numeric(as.vector(x[ligne,ncol(x)]))
 404                                         prof[[classe]][nrow(prof[[classe]]),3]<-round((as.numeric(as.vector(x[ligne,classe]))/as.numeric(as.vector(x[ligne,ncol(x)])))*100,digits=2)
 405                                         prof[[classe]][nrow(prof[[classe]]),4]<-round(chiresult$statistic,digits=2)
 406                                         prof[[classe]][nrow(prof[[classe]]),5]<-mod.names[ligne]
 407                                         prof[[classe]][nrow(prof[[classe]]),6]<-chiresult$p.value
 408                                 }
 409                                 else if (conttable[1,1]<obsv[1,1]){
 410                                         tablesqr[ligne,classe]<--round(chiresult$statistic,digits=3)
 411                                         aprof[[classe]][nrow(aprof[[classe]])+1,1]<-as.numeric(x[ligne,classe])
 412                                         aprof[[classe]][nrow(aprof[[classe]]),2]<-as.numeric(as.vector(x[ligne,ncol(x)]))
 413                                         aprof[[classe]][nrow(aprof[[classe]]),3]<-round((as.numeric(x[ligne,classe])/as.numeric(as.vector(x[ligne,ncol(x)])))*100,digits=2)
 414                                         aprof[[classe]][nrow(aprof[[classe]]),4]<--round(chiresult$statistic,digits=2)
 415                                         aprof[[classe]][nrow(aprof[[classe]]),5]<-mod.names[ligne]
 416                                         aprof[[classe]][nrow(aprof[[classe]]),6]<-chiresult$p.value
 417                                 }
 418                                 #pour gerer le cas avec une seule v et par exemple
 419                                 else if (conttable[1,1]==obsv[1,1]) {
 420                                         tablesqr[ligne,classe]<-round(chiresult$statistic,digits=3)
 421                                         prof[[classe]][nrow(prof[[classe]])+1,1]<-as.numeric(x[ligne,classe])
 422                                         prof[[classe]][nrow(prof[[classe]]),2]<-as.numeric(as.vector(x[ligne,ncol(x)]))
 423                                         prof[[classe]][nrow(prof[[classe]]),3]<-round((as.numeric(as.vector(x[ligne,classe]))/as.numeric(as.vector(x[ligne,ncol(x)])))*100,digits=2)
 424                                         prof[[classe]][nrow(prof[[classe]]),4]<-round(chiresult$statistic,digits=2)
 425                                         prof[[classe]][nrow(prof[[classe]]),5]<-mod.names[ligne]
 426                                         prof[[classe]][nrow(prof[[classe]]),6]<-chiresult$p.value
 427                                         aprof[[classe]][nrow(aprof[[classe]])+1,1]<-as.numeric(x[ligne,classe])
 428                                         aprof[[classe]][nrow(aprof[[classe]]),2]<-as.numeric(as.vector(x[ligne,ncol(x)]))
 429                                         aprof[[classe]][nrow(aprof[[classe]]),3]<-round((as.numeric(x[ligne,classe])/as.numeric(as.vector(x[ligne,ncol(x)])))*100,digits=2)
 430                                         aprof[[classe]][nrow(aprof[[classe]]),4]<--round(chiresult$statistic,digits=2)
 431                                         aprof[[classe]][nrow(aprof[[classe]]),5]<-mod.names[ligne]
 432                                         aprof[[classe]][nrow(aprof[[classe]]),6]<-chiresult$p.value
 433                                 }
 434                         }else {
 435                                 if (conttable[1,1]>obsv[1,1]) {
 436                                         tablesqr[ligne,classe]<-round(chiresult$statistic,digits=3)
 437                                 } else if (conttable[1,1]<obsv[1,1]){
 438                                         tablesqr[ligne,classe]<--round(chiresult$statistic,digits=3)
 439                                 }
 440                                 #pour gerer le cas avec une seule v et par exemple
 441                                 else if (conttable[1,1]==obsv[1,1]) {
 442                                         tablesqr[ligne,classe]<-round(chiresult$statistic,digits=3)
 443                                 }
 444                         }
 445                         #                               }
 446                 }
 447         }
 448         for (classe in 1:clusternb) {
 449                 if (length(prof[[classe]])!=0) {
 450                         prof[[classe]]<-prof[[classe]][order(prof[[classe]][,4],decreasing=TRUE),]
 451                 }
 452                 if (length(aprof[[classe]])!=0) {
 453                         aprof[[classe]]<-aprof[[classe]][order(aprof[[classe]][,4]),]
 454                 }
 455         }
 456         output<-list()
 457         output[[1]]<-tablep
 458         output[[2]]<-tablesqr
 459         output[[3]]<-afctablesum
 460         output[[4]]<-prof
 461         output[[5]]<-aprof
 462         output
 463 }
 464
 465
 466 build.pond.prof <- function(mat, lim = 2) {
 467         mat<-as.matrix(mat)
 468         mod.names<-rownames(mat)
 469         scol<-colSums(mat)
 470         srow<-rowSums(mat)
 471         tot<-sum(srow)
 472         tablesqr<-mat
 473         tablep<-mat
 474         prof<-list()
 475         aprof<-list()
 476     clusternb <- ncol(mat)
 477     x <- cbind(mat, rowSums(mat))
 478         for (classe in 1:clusternb) {
 479                 prof[[classe]]<-data.frame()
 480                 aprof[[classe]]<-data.frame()
 481         }
 482
 483     for (ligne in 1:nrow(mat)) {
 484         for(classe in 1:ncol(mat)) {
 485             tb <- matrix(0,2,2)
 486             tb[1,1] <- mat[ligne,classe]
 487             tb[1,2] <- srow[ligne] - tb[1,1]
 488             tb[2,1] <- scol[classe] - tb[1,1]
 489             tb[2,2] <- tot - srow[ligne] - tb[2,1]
 490             chiresult <- MyChiSq(tb)
 491             if (is.na(chiresult$p.value)) {
 492                                 chiresult$p.value<-1
 493                                 chiresult$statistic<-0
 494                         }
 495             tablep[ligne,classe]<-round(chiresult$p.value,digits=3)
 496             conttable<-tb
 497             obsv <- chiresult$expected
 498             if (chiresult$statistic>=lim) {
 499                                 if (conttable[1,1]>obsv[1,1]) {
 500                                         tablesqr[ligne,classe]<-round(chiresult$statistic,digits=3)
 501                                         prof[[classe]][nrow(prof[[classe]])+1,1]<-as.numeric(x[ligne,classe])
 502                                         prof[[classe]][nrow(prof[[classe]]),2]<-as.numeric(as.vector(x[ligne,ncol(x)]))
 503                                         prof[[classe]][nrow(prof[[classe]]),3]<-round((as.numeric(as.vector(x[ligne,classe]))/as.numeric(as.vector(x[ligne,ncol(x)])))*100,digits=2)
 504                                         prof[[classe]][nrow(prof[[classe]]),4]<-round(chiresult$statistic,digits=2)
 505                                         prof[[classe]][nrow(prof[[classe]]),5]<-mod.names[ligne]
 506                                         prof[[classe]][nrow(prof[[classe]]),6]<-chiresult$p.value
 507                                 }
 508                                 else if (conttable[1,1]<obsv[1,1]){
 509                                         tablesqr[ligne,classe]<--round(chiresult$statistic,digits=3)
 510                                         aprof[[classe]][nrow(aprof[[classe]])+1,1]<-as.numeric(x[ligne,classe])
 511                                         aprof[[classe]][nrow(aprof[[classe]]),2]<-as.numeric(as.vector(x[ligne,ncol(x)]))
 512                                         aprof[[classe]][nrow(aprof[[classe]]),3]<-round((as.numeric(x[ligne,classe])/as.numeric(as.vector(x[ligne,ncol(x)])))*100,digits=2)
 513                                         aprof[[classe]][nrow(aprof[[classe]]),4]<--round(chiresult$statistic,digits=2)
 514                                         aprof[[classe]][nrow(aprof[[classe]]),5]<-mod.names[ligne]
 515                                         aprof[[classe]][nrow(aprof[[classe]]),6]<-chiresult$p.value
 516                                 }
 517                                 #pour gerer le cas avec une seule v et par exemple
 518                                 else if (conttable[1,1]==obsv[1,1]) {
 519                                         tablesqr[ligne,classe]<-round(chiresult$statistic,digits=3)
 520                                         prof[[classe]][nrow(prof[[classe]])+1,1]<-as.numeric(x[ligne,classe])
 521                                         prof[[classe]][nrow(prof[[classe]]),2]<-as.numeric(as.vector(x[ligne,ncol(x)]))
 522                                         prof[[classe]][nrow(prof[[classe]]),3]<-round((as.numeric(as.vector(x[ligne,classe]))/as.numeric(as.vector(x[ligne,ncol(x)])))*100,digits=2)
 523                                         prof[[classe]][nrow(prof[[classe]]),4]<-round(chiresult$statistic,digits=2)
 524                                         prof[[classe]][nrow(prof[[classe]]),5]<-mod.names[ligne]
 525                                         prof[[classe]][nrow(prof[[classe]]),6]<-chiresult$p.value
 526                                         aprof[[classe]][nrow(aprof[[classe]])+1,1]<-as.numeric(x[ligne,classe])
 527                                         aprof[[classe]][nrow(aprof[[classe]]),2]<-as.numeric(as.vector(x[ligne,ncol(x)]))
 528                                         aprof[[classe]][nrow(aprof[[classe]]),3]<-round((as.numeric(x[ligne,classe])/as.numeric(as.vector(x[ligne,ncol(x)])))*100,digits=2)
 529                                         aprof[[classe]][nrow(aprof[[classe]]),4]<--round(chiresult$statistic,digits=2)
 530                                         aprof[[classe]][nrow(aprof[[classe]]),5]<-mod.names[ligne]
 531                                         aprof[[classe]][nrow(aprof[[classe]]),6]<-chiresult$p.value
 532                                 }
 533                         }else {
 534                                 if (conttable[1,1]>obsv[1,1]) {
 535                                         tablesqr[ligne,classe]<-round(chiresult$statistic,digits=3)
 536                                 } else if (conttable[1,1]<obsv[1,1]){
 537                                         tablesqr[ligne,classe]<--round(chiresult$statistic,digits=3)
 538                                 }
 539                                 #pour gerer le cas avec une seule v et par exemple
 540                                 else if (conttable[1,1]==obsv[1,1]) {
 541                                         tablesqr[ligne,classe]<-round(chiresult$statistic,digits=3)
 542                                 }
 543                         }
 544
 545         }
 546     }
 547         for (classe in 1:clusternb) {
 548                 if (length(prof[[classe]])!=0) {
 549                         prof[[classe]]<-prof[[classe]][order(prof[[classe]][,4],decreasing=TRUE),]
 550                 }
 551                 if (length(aprof[[classe]])!=0) {
 552                         aprof[[classe]]<-aprof[[classe]][order(aprof[[classe]][,4]),]
 553                 }
 554         }
 555         output<-list()
 556         output[[1]]<-tablep
 557         output[[2]]<-tablesqr
 558         output[[3]]<-x
 559         output[[4]]<-prof
 560         output[[5]]<-aprof
 561         output
 562 }
 563
 564
 565