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

   1 ############FIXME##################
   2 #PlotDendroComp <- function(chd,filename,reso) {
   3 #   jpeg(filename,res=reso)
   4 #   par(cex=PARCEX)
   5 #   plot(chd,which.plots=2, hang=-1)
   6 #   dev.off()
   7 #}
   8 #
   9 #PlotDendroHori <- function(dendrocutupper,filename,reso) {
  10 #   jpeg(filename,res=reso)
  11 #   par(cex=PARCEX)
  12 #   nP <- list(col=3:2, cex=c(0.5, 0.75), pch= 21:22, bg= c('light blue', 'pink'),lab.cex = 0.75, lab.col = 'tomato')
  13 #   plot(dendrocutupper,nodePar= nP, edgePar = list(col='gray', lwd=2),horiz=TRUE, center=FALSE)
  14 #   dev.off()
  15 #}
  16
  17 PlotDendroCut <- function(chd,filename,reso,clusternb) {
  18    h.chd <- as.hclust(chd)
  19    memb <- cutree(h.chd, k = clusternb)
  20    cent <- NULL
  21    for(k in 1:clusternb){
  22        cent <- rbind(cent, k)
  23    }
  24    h.chd1 <- hclust(dist(cent)^2, method = 'cen', members = table(memb))
  25    h.chd1$labels <- sprintf('CL %02d',1:clusternb)
  26    nP <- list(col=3:2, cex=c(2.0, 0.75), pch= 21:22, bg= c('light blue', 'pink'),lab.cex = 0.75, lab.col = 'tomato')
  27    jpeg(filename,res=reso)
  28    par(cex=PARCEX)
  29    plot(h.chd1, nodePar= nP, edgePar = list(col='gray', lwd=2), horiz=TRUE, center=TRUE, hang= -1)
  30    dev.off()
  31 }
  32
  33 #PlotAfc<- function(afc, filename, width=800, height=800, quality=100, reso=200, toplot=c('all','all'), PARCEX=PARCEX) {
  34 #       if (Sys.info()["sysname"]=='Darwin') {
  35 #               width<-width/74.97
  36 #               height<-height/74.97
  37 #               quartz(file=filename,type='jpeg',width=width,height=height)
  38 #       } else {
  39 #               jpeg(filename,width=width,height=height,quality=quality,res=reso)
  40 #       }
  41 #       par(cex=PARCEX)
  42 #       plot(afc,what=toplot,labels=c(1,1),contrib=c('absolute','relative'))
  43 #       dev.off()
  44 #}
  45
  46 PlotAfc2dCoul<- function(afc,chisqrtable,filename, what='coord',col=FALSE, axetoplot=c(1,2), deb=0,fin=0, width=900, height=900, quality=100, reso=200, parcex=PARCEX, xlab = NULL, ylab = NULL, xmin=NULL, xmax=NULL, ymin=NULL, ymax=NULL) {
  47         if (col) {
  48                 if (what == 'coord') {
  49                         rowcoord <- as.matrix(afc$colcoord)
  50                 } else {
  51                         rowcoord <- as.matrix(afc$colcrl)
  52                 }
  53         } else {
  54                 if (what == 'coord') {
  55                         rowcoord <- as.matrix(afc$rowcoord)
  56                 } else {
  57                         rowcoord <- as.matrix(afc$rowcrl)
  58                 }
  59         }
  60         x <- axetoplot[1]
  61         y <- axetoplot[2]
  62         if (col)
  63                 rownames(rowcoord) <- afc$colnames
  64         if (!col){
  65                 rownames(rowcoord) <- afc$rownames
  66                 rowcoord <- as.matrix(rowcoord[deb:fin,])
  67                 chitable<- as.matrix(chisqrtable[deb:fin,])
  68                 #row_keep <- select_point_nb(chitable,15)
  69         }
  70         if (ncol(rowcoord) == 1) {
  71                 rowcoord <- t(rowcoord)
  72         }
  73         clnb <- ncol(chisqrtable)
  74
  75         if (!col) {
  76         classes <- as.matrix(apply(chitable,1,which.max))
  77         cex.par <- norm.vec(apply(chitable,1,max), 0.8,3)
  78         row.keep <- select.chi.classe(chitable, 80)
  79         rowcoord <- rowcoord[row.keep,]
  80         classes <- classes[row.keep]
  81         cex.par <- cex.par[row.keep]
  82         } else {
  83         classes <- 1:clnb
  84         cex.par <- rep(1,clnb)
  85     }
  86     if (is.null(xmin)) {
  87         table.in <- rowcoord
  88         xminmax <- c(min(table.in[,1], na.rm = TRUE) + ((max(cex.par)/10) * min(table.in[,1], na.rm = TRUE)), max(table.in[,1], na.rm = TRUE) + ((max(cex.par)/10) * max(table.in[,1], na.rm = TRUE)))
  89         xmin <- xminmax[1]
  90         xmax <- xminmax[2]
  91         yminmax <- c(min(table.in[,2], na.rm = TRUE) + ((max(cex.par)/10) * min(table.in[,2], na.rm = TRUE)), max(table.in[,2], na.rm = TRUE) + ((max(cex.par)/10) * max(table.in[,2], na.rm = TRUE)))
  92         ymin <- yminmax[1]
  93         ymax <- yminmax[2]
  94      }
  95         #ntabtot <- cbind(rowcoord, classes)
  96         #if (!col) ntabtot <- ntabtot[row_keep,]
  97     xlab <- paste('facteur ', x, ' -')
  98     ylab <- paste('facteur ', y, ' -')
  99     xlab <- paste(xlab,round(afc_table$facteur[x,2],2),sep = ' ')
 100     xlab <- paste(xlab,' %%',sep = '')
 101     ylab <- paste(ylab,round(afc_table$facteur[y,2],2),sep = ' ')
 102     ylab <- paste(ylab,' %%',sep = '')
 103
 104         open_file_graph(filename, width = width, height = height)
 105         par(cex=PARCEX)
 106     table.in <- rowcoord[order(cex.par, decreasing = TRUE),]
 107     classes <- classes[order(cex.par, decreasing = TRUE)]
 108     cex.par <- cex.par[order(cex.par, decreasing = TRUE)]
 109     table.out <- stopoverlap(table.in, cex.par=cex.par, xlim = c(xmin,xmax), ylim = c(ymin,ymax))
 110     table.in <- table.out$toplot
 111     notplot <- table.out$notplot
 112     if (! is.null(notplot)) {
 113         write.csv2(notplot, file = paste(filename, '_notplotted.csv', sep = ''))
 114     }
 115     classes <- classes[table.in[,4]]
 116     cex.par <- cex.par[table.in[,4]]
 117     make_afc_graph(table.in, classes, clnb, xlab, ylab, cex.txt = cex.par, xminmax=c(xmin,xmax), yminmax=c(ymin,ymax))
 118     xyminmax <- list(yminmax = c(ymin,ymax), xminmax = c(xmin,xmax))
 119     xyminmax
 120         #plot(rowcoord[,x],rowcoord[,y], pch='', xlab = xlab, ylab = ylab)
 121         #abline(h=0,v=0)
 122         #for (i in 1:clnb) {
 123         #       ntab <- subset(ntabtot,ntabtot[,ncol(ntabtot)] == i)
 124         #       if (nrow(ntab) != 0)
 125         #               text(ntab[,x],ntab[,y],rownames(ntab),col=rainbow(clnb)[i])
 126         #}
 127         #dev.off()
 128 }
 129
 130 filename.to.svg <- function(filename) {
 131     filename <- gsub('.png', '.svg', filename)
 132     return(filename)
 133 }
 134
 135 open_file_graph <- function (filename, width=800, height = 800, quality = 100, svg = FALSE) {
 136         if (Sys.info()["sysname"] == 'Darwin') {
 137         width <- width/74.97
 138         height <- height/74.97
 139         if (!svg) {
 140                     quartz(file = filename, type = 'png', width = width, height = height)
 141         } else {
 142             svg(filename.to.svg(filename), width=width, height=height)
 143         }
 144         } else {
 145         #library(RSvgDevice)
 146         if (svg) {
 147             svg(filename.to.svg(filename), width=width/74.97, height=height/74.97)
 148         } else {
 149                     png(filename, width=width, height=height)#, quality = quality)
 150         }
 151         }
 152 }
 153
 154 #################################################@@
 155 #from wordcloud
 156 overlap <- function(x1, y1, sw1, sh1, boxes) {
 157     use.r.layout <- FALSE
 158         if(!use.r.layout)
 159                 return(.overlap(x1,y1,sw1,sh1,boxes))
 160         s <- 0
 161         if (length(boxes) == 0)
 162                 return(FALSE)
 163         for (i in c(last,1:length(boxes))) {
 164                 bnds <- boxes[[i]]
 165                 x2 <- bnds[1]
 166                 y2 <- bnds[2]
 167                 sw2 <- bnds[3]
 168                 sh2 <- bnds[4]
 169                 if (x1 < x2)
 170                         overlap <- x1 + sw1 > x2-s
 171                 else
 172                         overlap <- x2 + sw2 > x1-s
 173
 174                 if (y1 < y2)
 175                         overlap <- overlap && (y1 + sh1 > y2-s)
 176                 else
 177                         overlap <- overlap && (y2 + sh2 > y1-s)
 178                 if(overlap){
 179                         last <<- i
 180                         return(TRUE)
 181                 }
 182         }
 183         FALSE
 184 }
 185
 186 .overlap <- function(x11,y11,sw11,sh11,boxes1){
 187     .Call("is_overlap",x11,y11,sw11,sh11,boxes1)
 188 }
 189 ########################################################
 190 stopoverlap <- function(x, cex.par = NULL, xlim = NULL, ylim = NULL) {
 191 #from wordcloud
 192     library(wordcloud)
 193     tails <- "g|j|p|q|y"
 194     rot.per <- 0
 195     last <- 1
 196     thetaStep <- .1
 197     rStep <- .5
 198     toplot <- NULL
 199     notplot <- NULL
 200
 201 #    plot.new()
 202     plot(x[,1],x[,2], pch='', xlim = xlim, ylim = ylim)
 203
 204     words <- rownames(x)
 205     if  (is.null(cex.par))  {
 206         size <- rep(0.9, nrow(x))
 207     } else {
 208         size <- cex.par
 209     }
 210     #cols <- rainbow(clnb)
 211     boxes <- list()
 212     for (i in 1:nrow(x)) {
 213         rotWord <- runif(1)<rot.per
 214         r <-0
 215                 theta <- runif(1,0,2*pi)
 216                 x1<- x[i,1]
 217                 y1<- x[i,2]
 218                 wid <- strwidth(words[i],cex=size[i])
 219                 ht <- strheight(words[i],cex=size[i])
 220                 isOverlaped <- TRUE
 221                 while(isOverlaped){
 222                         if(!overlap(x1-.5*wid,y1-.5*ht,wid,ht, boxes)) { #&&
 223                 toplot <- rbind(toplot, c(x1, y1, size[i], i))
 224                                 #text(x1,y1,words[i],cex=size[i],offset=0,srt=rotWord*90,
 225                                 #               col=cols[classes[i]])
 226                                 boxes[[length(boxes)+1]] <- c(x1-.5*wid,y1-.5*ht,wid,ht)
 227                                 isOverlaped <- FALSE
 228                         } else {
 229                                 if(r>sqrt(.5)){
 230                                         print(paste(words[i], "could not be fit on page. It will not be plotted."))
 231                     notplot <- rbind(notplot,c(words[i], x[i,1], x[i,2]))
 232                                         isOverlaped <- FALSE
 233                                 }
 234                                 theta <- theta+thetaStep
 235                                 r <- r + rStep*thetaStep/(2*pi)
 236                 x1 <- x[i,1]+r*cos(theta)
 237                                 y1 <- x[i,2]+r*sin(theta)
 238                         }
 239                 }
 240     }
 241     row.names(toplot) <- words[toplot[,4]]
 242     return(list(toplot = toplot, notplot = notplot))
 243 }
 244 ###############################################################################
 245
 246 make_tree_tot <- function (chd) {
 247         library(ape)
 248         lf<-chd$list_fille
 249         clus<-'a1a;'
 250         for (i in 1:length(lf)) {
 251                 if (!is.null(lf[[i]])) {
 252                         clus<-gsub(paste('a',i,'a',sep=''),paste('(','a',lf[[i]][1],'a',',','a',lf[[i]][2],'a',')',sep=''),clus)
 253         }
 254         }
 255         dendro_tuple <- clus
 256         clus <- gsub('a','',clus)
 257         tree.cl <- read.tree(text = clus)
 258         res<-list(tree.cl = tree.cl, dendro_tuple = dendro_tuple)
 259         res
 260 }
 261
 262 make_dendro_cut_tuple <- function(dendro_in, coordok, classeuce, x, nbt = 9) {
 263         library(ape)
 264         dendro<-dendro_in
 265         i <- 0
 266         for (cl in coordok[,x]) {
 267                 i <- i + 1
 268                 fcl<-fille(cl,classeuce)
 269                 for (fi in fcl) {
 270                         dendro <- gsub(paste('a',fi,'a',sep=''),paste('b',i,'b',sep=''),dendro)
 271                 }
 272         }
 273         clnb <- nrow(coordok)
 274     tcl=((nbt+1) *2) - 2
 275         for (i in 1:(tcl + 1)) {
 276                 dendro <- gsub(paste('a',i,'a',sep=''),paste('b',0,'b',sep=''),dendro)
 277         }
 278         dendro <- gsub('b','',dendro)
 279         dendro <- gsub('a','',dendro)
 280         dendro_tot_cl <- read.tree(text = dendro)
 281         #FIXME
 282         for (i in 1:100) {
 283                 for (cl in 1:clnb) {
 284                         dendro <- gsub(paste('\\(',cl,',',cl,'\\)',sep=''),cl,dendro)
 285                 }
 286         }
 287         for (i in 1:100) {
 288                 dendro <- gsub(paste('\\(',0,',',0,'\\)',sep=''),0,dendro)
 289                 for (cl in 1:clnb) {
 290                         dendro <- gsub(paste('\\(',0,',',cl,'\\)',sep=''),cl,dendro)
 291                         dendro <- gsub(paste('\\(',cl,',',0,'\\)',sep=''),cl,dendro)
 292                 }
 293         }
 294         print(dendro)
 295         tree.cl <- read.tree(text = dendro)
 296     lab <- tree.cl$tip.label
 297     if ("0" %in% lab) {
 298         tovire <- which(lab == "0")
 299         tree.cl <- drop.tip(tree.cl, tip = tovire)
 300     }
 301         res <- list(tree.cl = tree.cl, dendro_tuple_cut = dendro, dendro_tot_cl = dendro_tot_cl)
 302         res
 303 }
 304
 305 select_point_nb <- function(tablechi, nb) {
 306         chimax<-as.matrix(apply(tablechi,1,max))
 307         chimax<-cbind(chimax,1:nrow(tablechi))
 308         order_chi<-as.matrix(chimax[order(chimax[,1],decreasing = TRUE),])
 309         row_keep <- order_chi[,2][1:nb]
 310         row_keep
 311 }
 312
 313 select_point_chi <- function(tablechi, chi_limit) {
 314         chimax<-as.matrix(apply(tablechi,1,max))
 315         row_keep <- which(chimax >= chi_limit)
 316         row_keep
 317 }
 318
 319 select.chi.classe <- function(tablechi, nb) {
 320     rowkeep <- NULL
 321     if (nb > nrow(tablechi)) {
 322         nb <- nrow(tablechi)
 323     }
 324     for (i in 1:ncol(tablechi)) {
 325         rowkeep <- append(rowkeep,order(tablechi[,i], decreasing = TRUE)[1:nb])
 326     }
 327     rowkeep <- unique(rowkeep)
 328     rowkeep
 329 }
 330
 331 #from summary.ca
 332 summary.ca.dm <- function(object, scree = TRUE, ...){
 333   obj <- object
 334   nd  <- obj$nd
 335   if (is.na(nd)){
 336     nd <- 2
 337     } else {
 338     if (nd > length(obj$sv)) nd <- length(obj$sv)
 339     }
 340  # principal coordinates:
 341   K   <- nd
 342   I   <- dim(obj$rowcoord)[1] ; J <- dim(obj$colcoord)[1]
 343   svF <- matrix(rep(obj$sv[1:K], I), I, K, byrow = TRUE)
 344   svG <- matrix(rep(obj$sv[1:K], J), J, K, byrow = TRUE)
 345   rpc <- obj$rowcoord[,1:K] * svF
 346   cpc <- obj$colcoord[,1:K] * svG
 347
 348  # rows:
 349   r.names <- obj$rownames
 350   sr      <- obj$rowsup
 351   if (!is.na(sr[1])) r.names[sr] <- paste("(*)", r.names[sr], sep = "")
 352   r.mass <- obj$rowmass
 353   r.inr  <- obj$rowinertia / sum(obj$rowinertia, na.rm = TRUE)
 354   r.COR  <- matrix(NA, nrow = length(r.names), ncol = nd)
 355   colnames(r.COR) <- paste('COR -facteur', 1:nd, sep=' ')
 356   r.CTR  <- matrix(NA, nrow = length(r.names), ncol = nd)
 357   colnames(r.CTR) <- paste('CTR -facteur', 1:nd, sep=' ')
 358   for (i in 1:nd){
 359     r.COR[,i] <- obj$rowmass * rpc[,i]^2 / obj$rowinertia
 360     r.CTR[,i] <- obj$rowmass * rpc[,i]^2 / obj$sv[i]^2
 361     }
 362  # cor and quality for supplementary rows
 363   if (length(obj$rowsup) > 0){
 364     i0 <- obj$rowsup
 365     for (i in 1:nd){
 366       r.COR[i0,i] <- obj$rowmass[i0] * rpc[i0,i]^2
 367       r.CTR[i0,i] <- NA
 368     }
 369     }
 370
 371  # columns:
 372   c.names <- obj$colnames
 373   sc      <- obj$colsup
 374   if (!is.na(sc[1])) c.names[sc] <- paste("(*)", c.names[sc], sep = "")
 375   c.mass  <- obj$colmass
 376   c.inr   <- obj$colinertia / sum(obj$colinertia, na.rm = TRUE)
 377   c.COR   <- matrix(NA, nrow = length(c.names), ncol = nd)
 378   colnames(c.COR) <- paste('COR -facteur', 1:nd, sep=' ')
 379   c.CTR   <- matrix(NA, nrow = length(c.names), ncol = nd)
 380   colnames(c.CTR) <- paste('CTR -facteur', 1:nd, sep=' ')
 381   for (i in 1:nd)
 382     {
 383     c.COR[,i] <- obj$colmass * cpc[,i]^2 / obj$colinertia
 384     c.CTR[,i] <- obj$colmass * cpc[,i]^2 / obj$sv[i]^2
 385     }
 386   if (length(obj$colsup) > 0){
 387     i0 <- obj$colsup
 388     for (i in 1:nd){
 389       c.COR[i0,i] <- obj$colmass[i0] * cpc[i0,i]^2
 390       c.CTR[i0,i] <- NA
 391       }
 392     }
 393
 394  # scree plot:
 395   if (scree) {
 396     values     <- obj$sv^2
 397     values2    <- 100*(obj$sv^2)/sum(obj$sv^2)
 398     values3    <- cumsum(100*(obj$sv^2)/sum(obj$sv^2))
 399     scree.out  <- cbind(values, values2, values3)
 400     } else {
 401     scree.out <- NA
 402     }
 403
 404   obj$r.COR <- r.COR
 405   obj$r.CTR <- r.CTR
 406   obj$c.COR <- c.COR
 407   obj$c.CTR <- c.CTR
 408   obj$facteur <- scree.out
 409   return(obj)
 410   }
 411
 412 create_afc_table <- function(x) {
 413    #x = afc
 414         facteur.table <- as.matrix(x$facteur)
 415     nd <- ncol(x$colcoord)
 416         rownames(facteur.table) <- paste('facteur',1:nrow(facteur.table),sep = ' ')
 417     colnames(facteur.table) <- c('Valeurs propres', 'Pourcentages', 'Pourcentage cumules')
 418         ligne.table <- as.matrix(x$rowcoord)
 419         rownames(ligne.table) <- x$rownames
 420         colnames(ligne.table) <- paste('Coord. facteur', 1:nd, sep=' ')
 421     tmp <- as.matrix(x$rowcrl)
 422         colnames(tmp) <- paste('Corr. facteur', 1:nd, sep=' ')
 423         ligne.table <- cbind(ligne.table,tmp)
 424         ligne.table <- cbind(ligne.table, x$r.COR)
 425         ligne.table <- cbind(ligne.table, x$r.CTR)
 426         ligne.table <- cbind(ligne.table, mass = x$rowmass)
 427         ligne.table <- cbind(ligne.table, chi.distance = x$rowdist)
 428         ligne.table <- cbind(ligne.table, inertie = x$rowinertia)
 429     colonne.table <- x$colcoord
 430         rownames(colonne.table) <- paste('classe', 1:(nrow(colonne.table)),sep=' ')
 431         colnames(colonne.table) <- paste('Coord. facteur', 1:nd, sep=' ')
 432     tmp <- as.matrix(x$colcrl)
 433         colnames(tmp) <- paste('Corr. facteur', 1:nd, sep=' ')
 434         colonne.table <- cbind(colonne.table, tmp)
 435         colonne.table <- cbind(colonne.table, x$c.COR)
 436         colonne.table <- cbind(colonne.table, x$c.CTR)
 437         colonne.table <- cbind(colonne.table, mass = x$colmass)
 438         colonne.table <- cbind(colonne.table, chi.distance = x$coldist)
 439         colonne.table <- cbind(colonne.table, inertie = x$colinertia)
 440     res <- list(facteur = facteur.table, ligne = ligne.table, colonne = colonne.table)
 441         res
 442 }
 443
 444 make_afc_graph <- function(toplot, classes, clnb, xlab, ylab, cex.txt = NULL, leg = FALSE, cmd = FALSE, black = FALSE, xminmax=NULL, yminmax=NULL) {
 445
 446     rain <- rainbow(clnb)
 447     compt <- 1
 448     tochange <- NULL
 449     for (my.color in rain) {
 450         my.color <- col2rgb(my.color)
 451         if ((my.color[1] > 200) & (my.color[2] > 200) & (my.color[3] < 20)) {
 452            tochange <- append(tochange, compt)
 453         }
 454         compt <- compt + 1
 455     }
 456     if (!is.null(tochange)) {
 457         gr.col <- grey.colors(length(tochange))
 458         compt <- 1
 459         for (val in tochange) {
 460             rain[val] <- gr.col[compt]
 461             compt <- compt + 1
 462         }
 463     }
 464         cl.color <- rain[classes]
 465     if (black) {
 466         cl.color <- 'black'
 467     }
 468         plot(toplot[,1],toplot[,2], pch='', xlab = xlab, ylab = ylab, xlim=xminmax, ylim = yminmax)
 469         abline(h=0, v=0, lty = 'dashed')
 470         if (is.null(cex.txt))
 471                 text(toplot[,1],toplot[,2],rownames(toplot),col=cl.color, offset=0)
 472         else
 473         text(toplot[,1],toplot[,2],rownames(toplot),col=cl.color, cex = cex.txt, offset=0)
 474
 475     if (!cmd) {
 476             dev.off()
 477     }
 478 }
 479
 480 plot.dendro.prof <- function(tree, classes, chisqtable, nbbycl = 60, type.dendro = "phylogram", from.cmd = FALSE, bw = FALSE, lab = NULL) {
 481     library(ape)
 482     library(wordcloud)
 483     classes<-classes[classes!=0]
 484         classes<-as.factor(classes)
 485         sum.cl<-as.matrix(summary(classes, maxsum=1000000))
 486         sum.cl<-(sum.cl/colSums(sum.cl)*100)
 487         sum.cl<-round(sum.cl,2)
 488         sum.cl<-cbind(sum.cl,as.matrix(100-sum.cl[,1]))
 489     sum.cl <- sum.cl[,1]
 490     tree.order<- as.numeric(tree$tip.label)
 491         vec.mat<-NULL
 492     row.keep <- select.chi.classe(chisqtable, nbbycl)
 493     toplot <- chisqtable[row.keep,]
 494     lclasses <- list()
 495     for (classe in 1:length(sum.cl)) {
 496        ntoplot <- toplot[,classe]
 497        ntoplot <- ntoplot[order(ntoplot, decreasing = TRUE)]
 498        ntoplot <- round(ntoplot, 0)
 499        ntoplot <- ntoplot[1:nbbycl]
 500        #ntoplot <- ntoplot[order(ntoplot)]
 501        #ntoplot <- ifelse(length(ntoplot) > nbbycl, ntoplot[1:nbbycl], ntoplot)
 502        lclasses[[classe]] <- ntoplot
 503     }
 504     vec.mat <- matrix(1, nrow = 2, ncol = length(sum.cl))
 505     vec.mat[2,] <- 2:(length(sum.cl)+1)
 506     layout(matrix(vec.mat, nrow=2, ncol=length(sum.cl)),heights=c(1,4))
 507     if (! bw) {
 508         col <- rainbow(length(sum.cl))[as.numeric(tree$tip.label)]
 509         colcloud <- rainbow(length(sum.cl))
 510     }
 511     par(mar=c(1,0,0,0))
 512     label.ori<-tree[[2]]
 513     if (!is.null(lab)) {
 514         tree$tip.label <- lab
 515     } else {
 516             tree[[2]]<-paste('classe ',tree[[2]])
 517     }
 518         plot.phylo(tree,label.offset=0.1,tip.col=col, type=type.dendro, direction = 'downwards', srt=90, adj = 0)
 519     for (i in tree.order) {
 520         par(mar=c(0,0,1,0),cex=0.7)
 521         #wordcloud(names(lclasses[[i]]), lclasses[[i]], scale = c(1.5, 0.2), random.order=FALSE, colors = colcloud[i])
 522         yval <- 1.1
 523         plot(0,0,pch='', axes = FALSE)
 524         vcex <- norm.vec(lclasses[[i]], 0.8, 3)
 525         for (j in 1:length(lclasses[[i]])) {
 526             yval <- yval-(strheight( names(lclasses[[i]])[j],cex=vcex[j])+0.02)
 527             text(-0.9, yval, names(lclasses[[i]])[j], cex = vcex[j], col = colcloud[i], adj=0)
 528         }
 529     }
 530
 531 }
 532
 533 plot.dendro.cloud <- function(tree, classes, chisqtable, nbbycl = 60, type.dendro = "phylogram", from.cmd = FALSE, bw = FALSE, lab = NULL) {
 534     library(wordcloud)
 535     library(ape)
 536     classes<-classes[classes!=0]
 537         classes<-as.factor(classes)
 538         sum.cl<-as.matrix(summary(classes, maxsum=1000000))
 539         sum.cl<-(sum.cl/colSums(sum.cl)*100)
 540         sum.cl<-round(sum.cl,2)
 541         sum.cl<-cbind(sum.cl,as.matrix(100-sum.cl[,1]))
 542     sum.cl <- sum.cl[,1]
 543     tree.order<- as.numeric(tree$tip.label)
 544         vec.mat<-NULL
 545     row.keep <- select.chi.classe(chisqtable, nbbycl)
 546     toplot <- chisqtable[row.keep,]
 547     lclasses <- list()
 548     for (classe in 1:length(sum.cl)) {
 549        ntoplot <- toplot[,classe]
 550        ntoplot <- ntoplot[order(ntoplot, decreasing = TRUE)]
 551        ntoplot <- round(ntoplot, 0)
 552        ntoplot <- ntoplot[1:nbbycl]
 553        ntoplot <- ntoplot[order(ntoplot)]
 554        #ntoplot <- ifelse(length(ntoplot) > nbbycl, ntoplot[1:nbbycl], ntoplot)
 555        lclasses[[classe]] <- ntoplot
 556     }
 557         for (i in 1:length(sum.cl)) vec.mat<-append(vec.mat,1)
 558         v<-2
 559         for (i in 1:length(sum.cl)) {
 560                 vec.mat<-append(vec.mat,v)
 561                 v<-v+1
 562         }
 563     layout(matrix(vec.mat,length(sum.cl),2),widths=c(1,2))
 564     if (! bw) {
 565         col <- rainbow(length(sum.cl))[as.numeric(tree$tip.label)]
 566         colcloud <- rainbow(length(sum.cl))
 567     }
 568     par(mar=c(0,0,0,0))
 569     label.ori<-tree[[2]]
 570     if (!is.null(lab)) {
 571         tree$tip.label <- lab
 572     } else {
 573             tree[[2]]<-paste('classe ',tree[[2]])
 574     }
 575         plot.phylo(tree,label.offset=0.1,tip.col=col, type=type.dendro)
 576     for (i in rev(tree.order)) {
 577         par(mar=c(0,0,1,0),cex=0.9)
 578         wordcloud(names(lclasses[[i]]), lclasses[[i]], scale = c(4, 0.8), random.order=FALSE, colors = colcloud[i])
 579     }
 580 }
 581
 582 plot.dendropr <- function(tree, classes, type.dendro="phylogram", histo=FALSE, from.cmd=FALSE, bw=FALSE, lab = NULL, tclasse=TRUE) {
 583         classes<-classes[classes!=0]
 584         classes<-as.factor(classes)
 585         sum.cl<-as.matrix(summary(classes, maxsum=1000000))
 586         sum.cl<-(sum.cl/colSums(sum.cl)*100)
 587         sum.cl<-round(sum.cl,2)
 588         sum.cl<-cbind(sum.cl,as.matrix(100-sum.cl[,1]))
 589     tree.order<- as.numeric(tree$tip.label)
 590
 591
 592     if (! bw) {
 593         col <- rainbow(nrow(sum.cl))[as.numeric(tree$tip.label)]
 594         col.bars <- col
 595         col.pie <- rainbow(nrow(sum.cl))
 596             #col.vec<-rainbow(nrow(sum.cl))[as.numeric(tree[[2]])]
 597     } else {
 598         col = 'black'
 599         col.bars = 'grey'
 600         col.pie <- rep('grey',nrow(sum.cl))
 601     }
 602         vec.mat<-NULL
 603         for (i in 1:nrow(sum.cl)) vec.mat<-append(vec.mat,1)
 604         v<-2
 605         for (i in 1:nrow(sum.cl)) {
 606                 vec.mat<-append(vec.mat,v)
 607                 v<-v+1
 608         }
 609         par(mar=c(0,0,0,0))
 610     if (tclasse) {
 611         if (! histo) {
 612                 layout(matrix(vec.mat,nrow(sum.cl),2),widths=c(3,1))
 613         } else {
 614             layout(matrix(c(1,2),1,byrow=TRUE), widths=c(3,2),TRUE)
 615         }
 616     }
 617         par(mar=c(0,0,0,0),cex=1)
 618         label.ori<-tree[[2]]
 619     if (!is.null(lab)) {
 620         tree$tip.label <- lab
 621     } else {
 622             tree[[2]]<-paste('classe ',tree[[2]])
 623     }
 624         plot.phylo(tree,label.offset=0.1,tip.col=col, type=type.dendro)
 625     #cl.order <- as.numeric(label.ori)
 626     #sum.cl[cl.order,1]
 627         #for (i in 1:nrow(sum.cl)) {
 628     if (tclasse) {
 629         if (! histo) {
 630             for (i in rev(tree.order)) {
 631                 par(mar=c(0,0,1,0),cex=0.7)
 632                     pie(sum.cl[i,],col=c(col.pie[i],'white'),radius = 1, labels='', clockwise=TRUE, main = paste('classe ',i,' - ',sum.cl[i,1],'%' ))
 633             }
 634         } else {
 635             par(cex=0.7)
 636             par(mar=c(0,0,0,1))
 637             to.plot <- sum.cl[tree.order,1]
 638             d <- barplot(to.plot,horiz=TRUE, col=col.bars, names.arg='', axes=FALSE, axisname=FALSE)
 639             text(x=to.plot, y=d[,1], label=paste(round(to.plot,1),'%'), adj=1.2)
 640         }
 641     }
 642     if (!from.cmd) dev.off()
 643         tree[[2]]<-label.ori
 644 }
 645 #tree <- tree.cut1$tree.cl
 646 #to.plot <- di
 647 plot.dendro.lex <- function(tree, to.plot, bw=FALSE, lab=NULL, lay.width=c(3,3,2), cmd=FALSE) {
 648     tree.order<- as.numeric(tree$tip.label)
 649     par(mar=c(0,0,0,0))
 650     layout(matrix(c(1,2,3),1,byrow=TRUE), widths=lay.width,TRUE)
 651         par(mar=c(3,0,2,0),cex=1)
 652         label.ori<-tree[[2]]
 653     if (!is.null(lab)) {
 654         tree$tip.label <- lab
 655     } else {
 656             tree[[2]]<-paste('classe ',tree[[2]])
 657     }
 658     to.plot <- matrix(to.plot[,tree.order], nrow=nrow(to.plot), dimnames=list(rownames(to.plot), colnames(to.plot)))
 659     if (!bw) {
 660         col <- rainbow(ncol(to.plot))
 661         col.bars <- rainbow(nrow(to.plot))
 662     } else {
 663         col <- 'black'
 664         col.bars <- grey.colors(nrow(to.plot),0,0.8)
 665     }
 666     col <- col[tree.order]
 667         plot.phylo(tree,label.offset=0.1,tip.col=col)
 668
 669     par(mar=c(3,0,2,1))
 670     d <- barplot(to.plot,horiz=TRUE, col=col.bars, beside=TRUE, names.arg='', space = c(0.1,0.6), axisname=FALSE)
 671     c <- colMeans(d)
 672     c1 <- c[-1]
 673     c2 <- c[-length(c)]
 674     cc <- cbind(c1,c2)
 675     lcoord <- apply(cc, 1, mean)
 676     abline(h=lcoord)
 677     if (min(to.plot) < 0) {
 678         amp <- abs(max(to.plot) - min(to.plot))
 679     } else {
 680         amp <- max(to.plot)
 681     }
 682     if (amp < 10) {
 683         d <- 2
 684     } else {
 685         d <- signif(amp%/%10,1)
 686     }
 687     mn <- round(min(to.plot))
 688     mx <- round(max(to.plot))
 689     for (i in mn:mx) {
 690         if ((i/d) == (i%/%d)) {
 691             abline(v=i,lty=3)
 692         }
 693     }
 694     par(mar=c(0,0,0,0))
 695     plot(0, axes = FALSE, pch = '')
 696     legend(x = 'center' , rownames(to.plot), fill = col.bars)
 697     if (!cmd) {
 698         dev.off()
 699     }
 700         tree[[2]]<-label.ori
 701 }
 702
 703 plot.alceste.graph <- function(rdata,nd=3,layout='fruke', chilim = 2) {
 704     load(rdata)
 705     if (is.null(debsup)) {
 706         tab.toplot<-afctable[1:(debet+1),]
 707         chitab<-chistabletot[1:(debet+1),]
 708     } else {
 709         tab.toplot<-afctable[1:(debsup+1),]
 710         chitab<-chistabletot[1:(debsup+1),]
 711     }
 712     rkeep<-select_point_chi(chitab,chilim)
 713     tab.toplot<-tab.toplot[rkeep,]
 714     chitab<-chitab[rkeep,]
 715     dm<-dist(tab.toplot,diag=TRUE,upper=TRUE)
 716     cn<-rownames(tab.toplot)
 717     cl.toplot<-apply(chitab,1,which.max)
 718     col<-rainbow(ncol(tab.toplot))[cl.toplot]
 719     library(igraph)
 720     g1 <- graph.adjacency(as.matrix(dm), mode = 'lower', weighted = TRUE)
 721     g.max<-minimum.spanning.tree(g1)
 722     we<-(rowSums(tab.toplot)/max(rowSums(tab.toplot)))*2
 723     #lo <- layout.fruchterman.reingold(g.max,dim=nd)
 724     lo<- layout.kamada.kawai(g.max,dim=nd)
 725     print(nrow(tab.toplot))
 726     print(nrow(chitab))
 727     print(length(we))
 728     print(length(col))
 729     print(length(cn))
 730     if (nd == 3) {
 731         rglplot(g.max, vertex.label = cn, vertex.size = we*3, edge.width = 0.5, edge.color='black', vertex.label.color = col,vertex.color = col, layout = lo, vertex.label.cex = 1)
 732     } else if (nd == 2) {
 733         plot(g.max, vertex.label = cn, vertex.size = we, edge.width = 0.5, edge.color='black', vertex.label.color = col,vertex.color = col, layout = lo, vertex.label.cex = 0.8)
 734     }
 735
 736 }
 737
 738 make.simi.afc <- function(x,chitable,lim=0, alpha = 0.1, movie = NULL) {
 739     library(igraph)
 740     chimax<-as.matrix(apply(chitable,1,max))
 741     chimax<-as.matrix(chimax[,1][1:nrow(x)])
 742     chimax<-cbind(chimax,1:nrow(x))
 743     order_chi<-as.matrix(chimax[order(chimax[,1],decreasing = TRUE),])
 744     if ((lim == 0) || (lim>nrow(x))) lim <- nrow(x)
 745     x<-x[order_chi[,2][1:lim],]
 746     maxchi <- chimax[order_chi[,2][1:lim],1]
 747     #-------------------------------------------------------
 748     limit<-nrow(x)
 749     distm<-dist(x,diag=TRUE)
 750     distm<-as.matrix(distm)
 751     g1<-graph.adjacency(distm,mode='lower',weighted=TRUE)
 752     g1<-minimum.spanning.tree(g1)
 753     lo<-layout.kamada.kawai(g1,dim=3)
 754     lo <- layout.norm(lo, -3, 3, -3, 3, -3, 3)
 755     mc<-rainbow(ncol(chistabletot))
 756     chitable<-chitable[order_chi[,2][1:lim],]
 757     cc <- apply(chitable, 1, which.max)
 758     cc<-mc[cc]
 759     #mass<-(rowSums(x)/max(rowSums(x))) * 5
 760     maxchi<-norm.vec(maxchi, 0.03, 0.3)
 761     rglplot(g1,vertex.label = vire.nonascii(rownames(x)),vertex.label.color= cc,vertex.label.cex = maxchi, vertex.size = 0.1, layout=lo, rescale=FALSE)
 762     text3d(lo[,1], lo[,2],lo[,3], rownames(x), cex=maxchi, col=cc)
 763     #rgl.spheres(lo, col = cc, radius = maxchi, alpha = alpha)
 764     rgl.bg(color = c('white','black'))
 765     if (!is.null(movie)) {
 766         require(tcltk)
 767         ReturnVal <- tkmessageBox(title="RGL 3 D",message="Cliquez pour commencer le film",icon="info",type="ok")
 768
 769         movie3d(spin3d(axis=c(0,1,0),rpm=6), movie = 'film_graph', frames = "tmpfilm", duration=10, clean=TRUE, top = TRUE, dir = movie)
 770         ReturnVal <- tkmessageBox(title="RGL 3 D",message="Film fini !",icon="info",type="ok")
 771     }
 772         while (rgl.cur() != 0)
 773                 Sys.sleep(1)
 774
 775 }
 776
 777 # from igraph
 778 norm.vec <- function(v, min, max) {
 779
 780   vr <- range(v)
 781   if (vr[1]==vr[2]) {
 782     fac <- 1
 783   } else {
 784     fac <- (max-min)/(vr[2]-vr[1])
 785   }
 786   (v-vr[1]) * fac + min
 787 }
 788
 789
 790 vire.nonascii <- function(rnames) {
 791     print('vire non ascii')
 792     couple <- list(c('é','e'),
 793                 c('è','e'),
 794                 c('ê','e'),
 795                 c('ë','e'),
 796                 c('î','i'),
 797                 c('ï','i'),
 798                 c('ì','i'),
 799                 c('à','a'),
 800                 c('â','a'),
 801                 c('ä','a'),
 802                 c('á','a'),
 803                 c('ù','u'),
 804                 c('û','u'),
 805                 c('ü','u'),
 806                 c('ç','c'),
 807                 c('ò','o'),
 808                 c('ô','o'),
 809                 c('ö','o'),
 810                 c('ñ','n')
 811                 )
 812
 813     for (c in couple) {
 814         rnames<-gsub(c[1],c[2], rnames)
 815     }
 816     rnames
 817 }
 818
 819
 820
 821 #par(mar=c(0,0,0,0))
 822 #layout(matrix(c(1,2),1,byrow=TRUE), widths=c(3,2),TRUE)
 823 #par(mar=c(1,0,1,0), cex=1)
 824 #plot.phylo(tree,label.offset=0.1)
 825 #par(mar=c(0,0,0,1))
 826 #to.plot <- sum.cl[cl.order,1]
 827 #d <- barplot(to.plot,horiz=TRUE, names.arg='', axes=FALSE, axisname=FALSE)
 828 #text(x=to.plot, y=d[,1], label=round(to.plot,1), adj=1.2)
 829