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(textometrieR)
 298     spec <- specificites(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 BuildProf<- function(x,dataclasse,clusternb,lim=2) {
 325         ####
 326         #r.names<-rownames(x)
 327         #x<-as.matrix(x)
 328         #rownames(x)<-r.names
 329         ####
 330         #nuce<-nrow(dataclasse)
 331     sumcol<-paste(NULL,1:nrow(x))
 332         colclasse<-dataclasse[,ncol(dataclasse)]
 333         nuce <- length(which(colclasse != 0))
 334 #       for (i in 1:nrow(x)) {
 335 #               sumcol[i]<-sum(x[i,])
 336 #       }
 337 #       afctablesum<-cbind(x,sumcol)
 338     afctablesum <- cbind(x, rowSums(x))
 339     #dataclasse<-as.data.frame(dataclasse[dataclasse[,ncol(dataclasse)]!=0,])
 340         dataclasse<-as.matrix(dataclasse[dataclasse[,ncol(dataclasse)]!=0,])
 341         tablesqr<-x
 342         tablep<-x
 343         x<-afctablesum
 344         listprofile<-list()
 345         listantipro<-list()
 346         mod.names<-rownames(x)
 347         prof<-list()
 348         aprof<-list()
 349         lnbligne<-matrix()
 350         for (classe in 1:clusternb) {
 351                 lnbligne[classe]<-length(colclasse[colclasse==classe])
 352                 prof[[classe]]<-data.frame()
 353                 aprof[[classe]]<-data.frame()
 354         }
 355
 356         for (ligne in 1:nrow(x)) {
 357                 for (classe in 1:clusternb) {
 358                         nbligneclasse<-lnbligne[classe]
 359                         conttable<-data.frame()
 360                         conttable[1,1]<-as.numeric(x[ligne,classe])
 361                         conttable[1,2]<-as.numeric(as.vector(x[ligne,ncol(x)]))-as.numeric(x[ligne,classe])
 362                         conttable[2,1]<-nbligneclasse-as.numeric(x[ligne,classe])
 363                         conttable[2,2]<-nrow(dataclasse)-as.numeric(as.vector(x[ligne,ncol(x)]))-conttable[2,1]
 364                         chiresult<-chisq.test(conttable,correct=FALSE)
 365                         if (is.na(chiresult$p.value)) {
 366                                 chiresult$p.value<-1
 367                                 chiresult$statistic<-0
 368                                 china=TRUE
 369                         }
 370                         obsv<-chiresult$expected
 371                         tablep[ligne,classe]<-round(chiresult$p.value,digits=3)
 372                         #tablep[ligne,classe]<-format(chiresult$p.value, scientific=TRUE)
 373             if (chiresult$statistic>=lim) {
 374                                 if (conttable[1,1]>obsv[1,1]) {
 375                                         tablesqr[ligne,classe]<-round(chiresult$statistic,digits=3)
 376                                         prof[[classe]][nrow(prof[[classe]])+1,1]<-as.numeric(x[ligne,classe])
 377                                         prof[[classe]][nrow(prof[[classe]]),2]<-as.numeric(as.vector(x[ligne,ncol(x)]))
 378                                         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)
 379                                         prof[[classe]][nrow(prof[[classe]]),4]<-round(chiresult$statistic,digits=2)
 380                                         prof[[classe]][nrow(prof[[classe]]),5]<-mod.names[ligne]
 381                                         prof[[classe]][nrow(prof[[classe]]),6]<-chiresult$p.value
 382                                 }
 383                                 else if (conttable[1,1]<obsv[1,1]){
 384                                         tablesqr[ligne,classe]<--round(chiresult$statistic,digits=3)
 385                                         aprof[[classe]][nrow(aprof[[classe]])+1,1]<-as.numeric(x[ligne,classe])
 386                                         aprof[[classe]][nrow(aprof[[classe]]),2]<-as.numeric(as.vector(x[ligne,ncol(x)]))
 387                                         aprof[[classe]][nrow(aprof[[classe]]),3]<-round((as.numeric(x[ligne,classe])/as.numeric(as.vector(x[ligne,ncol(x)])))*100,digits=2)
 388                                         aprof[[classe]][nrow(aprof[[classe]]),4]<--round(chiresult$statistic,digits=2)
 389                                         aprof[[classe]][nrow(aprof[[classe]]),5]<-mod.names[ligne]
 390                                         aprof[[classe]][nrow(aprof[[classe]]),6]<-chiresult$p.value
 391                                 }
 392                                 #pour gerer le cas avec une seule v et par exemple
 393                                 else if (conttable[1,1]==obsv[1,1]) {
 394                                         tablesqr[ligne,classe]<-round(chiresult$statistic,digits=3)
 395                                         prof[[classe]][nrow(prof[[classe]])+1,1]<-as.numeric(x[ligne,classe])
 396                                         prof[[classe]][nrow(prof[[classe]]),2]<-as.numeric(as.vector(x[ligne,ncol(x)]))
 397                                         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)
 398                                         prof[[classe]][nrow(prof[[classe]]),4]<-round(chiresult$statistic,digits=2)
 399                                         prof[[classe]][nrow(prof[[classe]]),5]<-mod.names[ligne]
 400                                         prof[[classe]][nrow(prof[[classe]]),6]<-chiresult$p.value
 401                                         aprof[[classe]][nrow(aprof[[classe]])+1,1]<-as.numeric(x[ligne,classe])
 402                                         aprof[[classe]][nrow(aprof[[classe]]),2]<-as.numeric(as.vector(x[ligne,ncol(x)]))
 403                                         aprof[[classe]][nrow(aprof[[classe]]),3]<-round((as.numeric(x[ligne,classe])/as.numeric(as.vector(x[ligne,ncol(x)])))*100,digits=2)
 404                                         aprof[[classe]][nrow(aprof[[classe]]),4]<--round(chiresult$statistic,digits=2)
 405                                         aprof[[classe]][nrow(aprof[[classe]]),5]<-mod.names[ligne]
 406                                         aprof[[classe]][nrow(aprof[[classe]]),6]<-chiresult$p.value
 407                                 }
 408                         }else {
 409                                 if (conttable[1,1]>obsv[1,1]) {
 410                                         tablesqr[ligne,classe]<-round(chiresult$statistic,digits=3)
 411                                 } else if (conttable[1,1]<obsv[1,1]){
 412                                         tablesqr[ligne,classe]<--round(chiresult$statistic,digits=3)
 413                                 }
 414                                 #pour gerer le cas avec une seule v et par exemple
 415                                 else if (conttable[1,1]==obsv[1,1]) {
 416                                         tablesqr[ligne,classe]<-round(chiresult$statistic,digits=3)
 417                                 }
 418                         }
 419                         #                               }
 420                 }
 421         }
 422         for (classe in 1:clusternb) {
 423                 if (length(prof[[classe]])!=0) {
 424                         prof[[classe]]<-prof[[classe]][order(prof[[classe]][,4],decreasing=TRUE),]
 425                 }
 426                 if (length(aprof[[classe]])!=0) {
 427                         aprof[[classe]]<-aprof[[classe]][order(aprof[[classe]][,4]),]
 428                 }
 429         }
 430         output<-list()
 431         output[[1]]<-tablep
 432         output[[2]]<-tablesqr
 433         output[[3]]<-afctablesum
 434         output[[4]]<-prof
 435         output[[5]]<-aprof
 436         output
 437 }
 438
 439
 440 build.pond.prof <- function(mat, lim = 2) {
 441         mat<-as.matrix(mat)
 442         mod.names<-rownames(mat)
 443         scol<-colSums(mat)
 444         srow<-rowSums(mat)
 445         tot<-sum(srow)
 446         tablesqr<-mat
 447         tablep<-mat
 448         prof<-list()
 449         aprof<-list()
 450     clusternb <- ncol(mat)
 451     x <- cbind(mat, rowSums(mat))
 452         for (classe in 1:clusternb) {
 453                 prof[[classe]]<-data.frame()
 454                 aprof[[classe]]<-data.frame()
 455         }
 456
 457     for (ligne in 1:nrow(mat)) {
 458         for(classe in 1:ncol(mat)) {
 459             tb <- matrix(0,2,2)
 460             tb[1,1] <- mat[ligne,classe]
 461             tb[1,2] <- srow[ligne] - tb[1,1]
 462             tb[2,1] <- scol[classe] - tb[1,1]
 463             tb[2,2] <- tot - srow[ligne] - tb[2,1]
 464             chiresult <- MyChiSq(tb)
 465             if (is.na(chiresult$p.value)) {
 466                                 chiresult$p.value<-1
 467                                 chiresult$statistic<-0
 468                         }
 469             tablep[ligne,classe]<-round(chiresult$p.value,digits=3)
 470             conttable<-tb
 471             obsv <- chiresult$expected
 472             if (chiresult$statistic>=lim) {
 473                                 if (conttable[1,1]>obsv[1,1]) {
 474                                         tablesqr[ligne,classe]<-round(chiresult$statistic,digits=3)
 475                                         prof[[classe]][nrow(prof[[classe]])+1,1]<-as.numeric(x[ligne,classe])
 476                                         prof[[classe]][nrow(prof[[classe]]),2]<-as.numeric(as.vector(x[ligne,ncol(x)]))
 477                                         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)
 478                                         prof[[classe]][nrow(prof[[classe]]),4]<-round(chiresult$statistic,digits=2)
 479                                         prof[[classe]][nrow(prof[[classe]]),5]<-mod.names[ligne]
 480                                         prof[[classe]][nrow(prof[[classe]]),6]<-chiresult$p.value
 481                                 }
 482                                 else if (conttable[1,1]<obsv[1,1]){
 483                                         tablesqr[ligne,classe]<--round(chiresult$statistic,digits=3)
 484                                         aprof[[classe]][nrow(aprof[[classe]])+1,1]<-as.numeric(x[ligne,classe])
 485                                         aprof[[classe]][nrow(aprof[[classe]]),2]<-as.numeric(as.vector(x[ligne,ncol(x)]))
 486                                         aprof[[classe]][nrow(aprof[[classe]]),3]<-round((as.numeric(x[ligne,classe])/as.numeric(as.vector(x[ligne,ncol(x)])))*100,digits=2)
 487                                         aprof[[classe]][nrow(aprof[[classe]]),4]<--round(chiresult$statistic,digits=2)
 488                                         aprof[[classe]][nrow(aprof[[classe]]),5]<-mod.names[ligne]
 489                                         aprof[[classe]][nrow(aprof[[classe]]),6]<-chiresult$p.value
 490                                 }
 491                                 #pour gerer le cas avec une seule v et par exemple
 492                                 else if (conttable[1,1]==obsv[1,1]) {
 493                                         tablesqr[ligne,classe]<-round(chiresult$statistic,digits=3)
 494                                         prof[[classe]][nrow(prof[[classe]])+1,1]<-as.numeric(x[ligne,classe])
 495                                         prof[[classe]][nrow(prof[[classe]]),2]<-as.numeric(as.vector(x[ligne,ncol(x)]))
 496                                         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)
 497                                         prof[[classe]][nrow(prof[[classe]]),4]<-round(chiresult$statistic,digits=2)
 498                                         prof[[classe]][nrow(prof[[classe]]),5]<-mod.names[ligne]
 499                                         prof[[classe]][nrow(prof[[classe]]),6]<-chiresult$p.value
 500                                         aprof[[classe]][nrow(aprof[[classe]])+1,1]<-as.numeric(x[ligne,classe])
 501                                         aprof[[classe]][nrow(aprof[[classe]]),2]<-as.numeric(as.vector(x[ligne,ncol(x)]))
 502                                         aprof[[classe]][nrow(aprof[[classe]]),3]<-round((as.numeric(x[ligne,classe])/as.numeric(as.vector(x[ligne,ncol(x)])))*100,digits=2)
 503                                         aprof[[classe]][nrow(aprof[[classe]]),4]<--round(chiresult$statistic,digits=2)
 504                                         aprof[[classe]][nrow(aprof[[classe]]),5]<-mod.names[ligne]
 505                                         aprof[[classe]][nrow(aprof[[classe]]),6]<-chiresult$p.value
 506                                 }
 507                         }else {
 508                                 if (conttable[1,1]>obsv[1,1]) {
 509                                         tablesqr[ligne,classe]<-round(chiresult$statistic,digits=3)
 510                                 } else if (conttable[1,1]<obsv[1,1]){
 511                                         tablesqr[ligne,classe]<--round(chiresult$statistic,digits=3)
 512                                 }
 513                                 #pour gerer le cas avec une seule v et par exemple
 514                                 else if (conttable[1,1]==obsv[1,1]) {
 515                                         tablesqr[ligne,classe]<-round(chiresult$statistic,digits=3)
 516                                 }
 517                         }
 518
 519         }
 520     }
 521         for (classe in 1:clusternb) {
 522                 if (length(prof[[classe]])!=0) {
 523                         prof[[classe]]<-prof[[classe]][order(prof[[classe]][,4],decreasing=TRUE),]
 524                 }
 525                 if (length(aprof[[classe]])!=0) {
 526                         aprof[[classe]]<-aprof[[classe]][order(aprof[[classe]][,4]),]
 527                 }
 528         }
 529         output<-list()
 530         output[[1]]<-tablep
 531         output[[2]]<-tablesqr
 532         output[[3]]<-x
 533         output[[4]]<-prof
 534         output[[5]]<-aprof
 535         output
 536 }
 537
 538
 539