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, 60)
  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.in <- stopoverlap(table.in, cex.par=cex.par, xlim = c(xmin,xmax), ylim = c(ymin,ymax))
 110     classes <- classes[table.in[,4]]
 111     cex.par <- cex.par[table.in[,4]]
 112     make_afc_graph(table.in, classes, clnb, xlab, ylab, cex.txt = cex.par, xminmax=c(xmin,xmax), yminmax=c(ymin,ymax))
 113     xyminmax <- list(yminmax = c(ymin,ymax), xminmax = c(xmin,xmax))
 114     xyminmax
 115         #plot(rowcoord[,x],rowcoord[,y], pch='', xlab = xlab, ylab = ylab)
 116         #abline(h=0,v=0)
 117         #for (i in 1:clnb) {
 118         #       ntab <- subset(ntabtot,ntabtot[,ncol(ntabtot)] == i)
 119         #       if (nrow(ntab) != 0)
 120         #               text(ntab[,x],ntab[,y],rownames(ntab),col=rainbow(clnb)[i])
 121         #}
 122         #dev.off()
 123 }
 124
 125 filename.to.svg <- function(filename) {
 126     filename <- gsub('.png', '.svg', filename)
 127     return(filename)
 128 }
 129
 130 open_file_graph <- function (filename, width=800, height = 800, quality = 100, svg = FALSE) {
 131         if (Sys.info()["sysname"] == 'Darwin') {
 132         width <- width/74.97
 133         height <- height/74.97
 134         if (!svg) {
 135                     quartz(file = filename, type = 'png', width = width, height = height)
 136         } else {
 137             svg(filename.to.svg(filename), width=width, height=height)
 138         }
 139         } else {
 140         #library(RSvgDevice)
 141         if (svg) {
 142             svg(filename.to.svg(filename), width=width/74.97, height=height/74.97)
 143         } else {
 144                     png(filename, width=width, height=height)#, quality = quality)
 145         }
 146         }
 147 }
 148
 149 #################################################@@
 150 #from wordcloud
 151 overlap <- function(x1, y1, sw1, sh1, boxes) {
 152     use.r.layout <- FALSE
 153         if(!use.r.layout)
 154                 return(.overlap(x1,y1,sw1,sh1,boxes))
 155         s <- 0
 156         if (length(boxes) == 0)
 157                 return(FALSE)
 158         for (i in c(last,1:length(boxes))) {
 159                 bnds <- boxes[[i]]
 160                 x2 <- bnds[1]
 161                 y2 <- bnds[2]
 162                 sw2 <- bnds[3]
 163                 sh2 <- bnds[4]
 164                 if (x1 < x2)
 165                         overlap <- x1 + sw1 > x2-s
 166                 else
 167                         overlap <- x2 + sw2 > x1-s
 168
 169                 if (y1 < y2)
 170                         overlap <- overlap && (y1 + sh1 > y2-s)
 171                 else
 172                         overlap <- overlap && (y2 + sh2 > y1-s)
 173                 if(overlap){
 174                         last <<- i
 175                         return(TRUE)
 176                 }
 177         }
 178         FALSE
 179 }
 180
 181 .overlap <- function(x11,y11,sw11,sh11,boxes1){
 182     .Call("is_overlap",x11,y11,sw11,sh11,boxes1)
 183 }
 184 ########################################################
 185 stopoverlap <- function(x, cex.par = NULL, xlim = NULL, ylim = NULL) {
 186 #from wordcloud
 187     library(wordcloud)
 188     tails <- "g|j|p|q|y"
 189     rot.per <- 0
 190     last <- 1
 191     thetaStep <- .1
 192     rStep <- .5
 193     toplot <- NULL
 194
 195 #    plot.new()
 196     plot(x[,1],x[,2], pch='', xlim = xlim, ylim = ylim)
 197
 198     words <- rownames(x)
 199     if  (is.null(cex.par))  {
 200         size <- rep(0.9, nrow(x))
 201     } else {
 202         size <- cex.par
 203     }
 204     #cols <- rainbow(clnb)
 205     boxes <- list()
 206     for (i in 1:nrow(x)) {
 207         rotWord <- runif(1)<rot.per
 208         r <-0
 209                 theta <- runif(1,0,2*pi)
 210                 x1<- x[i,1]
 211                 y1<- x[i,2]
 212                 wid <- strwidth(words[i],cex=size[i])
 213                 ht <- strheight(words[i],cex=size[i])
 214                 isOverlaped <- TRUE
 215                 while(isOverlaped){
 216                         if(!overlap(x1-.5*wid,y1-.5*ht,wid,ht, boxes)) { #&&
 217                 toplot <- rbind(toplot, c(x1, y1, size[i], i))
 218                                 #text(x1,y1,words[i],cex=size[i],offset=0,srt=rotWord*90,
 219                                 #               col=cols[classes[i]])
 220                                 boxes[[length(boxes)+1]] <- c(x1-.5*wid,y1-.5*ht,wid,ht)
 221                                 isOverlaped <- FALSE
 222                         } else {
 223                                 if(r>sqrt(.5)){
 224                                         print(paste(words[i], "could not be fit on page. It will not be plotted."))
 225                                         isOverlaped <- FALSE
 226                                 }
 227                                 theta <- theta+thetaStep
 228                                 r <- r + rStep*thetaStep/(2*pi)
 229                 x1 <- x[i,1]+r*cos(theta)
 230                                 y1 <- x[i,2]+r*sin(theta)
 231                         }
 232                 }
 233     }
 234     row.names(toplot) <- words[toplot[,4]]
 235     return(toplot)
 236 }
 237 ###############################################################################
 238
 239 make_tree_tot <- function (chd) {
 240         library(ape)
 241         lf<-chd$list_fille
 242         clus<-'a1a;'
 243         for (i in 1:length(lf)) {
 244                 if (!is.null(lf[[i]])) {
 245                         clus<-gsub(paste('a',i,'a',sep=''),paste('(','a',lf[[i]][1],'a',',','a',lf[[i]][2],'a',')',sep=''),clus)
 246         }
 247         }
 248         dendro_tuple <- clus
 249         clus <- gsub('a','',clus)
 250         tree.cl <- read.tree(text = clus)
 251         res<-list(tree.cl = tree.cl, dendro_tuple = dendro_tuple)
 252         res
 253 }
 254
 255 make_dendro_cut_tuple <- function(dendro_in, coordok, classeuce, x, nbt = 9) {
 256         library(ape)
 257         dendro<-dendro_in
 258         i <- 0
 259         for (cl in coordok[,x]) {
 260                 i <- i + 1
 261                 fcl<-fille(cl,classeuce)
 262                 for (fi in fcl) {
 263                         dendro <- gsub(paste('a',fi,'a',sep=''),paste('b',i,'b',sep=''),dendro)
 264                 }
 265         }
 266         clnb <- nrow(coordok)
 267     tcl=((nbt+1) *2) - 2
 268         for (i in 1:(tcl + 1)) {
 269                 dendro <- gsub(paste('a',i,'a',sep=''),paste('b',0,'b',sep=''),dendro)
 270         }
 271         dendro <- gsub('b','',dendro)
 272         dendro <- gsub('a','',dendro)
 273         dendro_tot_cl <- read.tree(text = dendro)
 274         #FIXME
 275         for (i in 1:100) {
 276                 for (cl in 1:clnb) {
 277                         dendro <- gsub(paste('\\(',cl,',',cl,'\\)',sep=''),cl,dendro)
 278                 }
 279         }
 280         for (i in 1:100) {
 281                 dendro <- gsub(paste('\\(',0,',',0,'\\)',sep=''),0,dendro)
 282                 for (cl in 1:clnb) {
 283                         dendro <- gsub(paste('\\(',0,',',cl,'\\)',sep=''),cl,dendro)
 284                         dendro <- gsub(paste('\\(',cl,',',0,'\\)',sep=''),cl,dendro)
 285                 }
 286         }
 287         print(dendro)
 288         tree.cl <- read.tree(text = dendro)
 289     lab <- tree.cl$tip.label
 290     if ("0" %in% lab) {
 291         tovire <- which(lab == "0")
 292         tree.cl <- drop.tip(tree.cl, tip = tovire)
 293     }
 294         res <- list(tree.cl = tree.cl, dendro_tuple_cut = dendro, dendro_tot_cl = dendro_tot_cl)
 295         res
 296 }
 297
 298 select_point_nb <- function(tablechi, nb) {
 299         chimax<-as.matrix(apply(tablechi,1,max))
 300         chimax<-cbind(chimax,1:nrow(tablechi))
 301         order_chi<-as.matrix(chimax[order(chimax[,1],decreasing = TRUE),])
 302         row_keep <- order_chi[,2][1:nb]
 303         row_keep
 304 }
 305
 306 select_point_chi <- function(tablechi, chi_limit) {
 307         chimax<-as.matrix(apply(tablechi,1,max))
 308         row_keep <- which(chimax >= chi_limit)
 309         row_keep
 310 }
 311
 312 select.chi.classe <- function(tablechi, nb) {
 313     rowkeep <- NULL
 314     if (nb > nrow(tablechi)) {
 315         nb <- nrow(tablechi)
 316     }
 317     for (i in 1:ncol(tablechi)) {
 318         rowkeep <- append(rowkeep,order(tablechi[,i], decreasing = TRUE)[1:nb])
 319     }
 320     rowkeep <- unique(rowkeep)
 321     rowkeep
 322 }
 323
 324 #from summary.ca
 325 summary.ca.dm <- function(object, scree = TRUE, ...){
 326   obj <- object
 327   nd  <- obj$nd
 328   if (is.na(nd)){
 329     nd <- 2
 330     } else {
 331     if (nd > length(obj$sv)) nd <- length(obj$sv)
 332     }
 333  # principal coordinates:
 334   K   <- nd
 335   I   <- dim(obj$rowcoord)[1] ; J <- dim(obj$colcoord)[1]
 336   svF <- matrix(rep(obj$sv[1:K], I), I, K, byrow = TRUE)
 337   svG <- matrix(rep(obj$sv[1:K], J), J, K, byrow = TRUE)
 338   rpc <- obj$rowcoord[,1:K] * svF
 339   cpc <- obj$colcoord[,1:K] * svG
 340
 341  # rows:
 342   r.names <- obj$rownames
 343   sr      <- obj$rowsup
 344   if (!is.na(sr[1])) r.names[sr] <- paste("(*)", r.names[sr], sep = "")
 345   r.mass <- obj$rowmass
 346   r.inr  <- obj$rowinertia / sum(obj$rowinertia, na.rm = TRUE)
 347   r.COR  <- matrix(NA, nrow = length(r.names), ncol = nd)
 348   colnames(r.COR) <- paste('COR -facteur', 1:nd, sep=' ')
 349   r.CTR  <- matrix(NA, nrow = length(r.names), ncol = nd)
 350   colnames(r.CTR) <- paste('CTR -facteur', 1:nd, sep=' ')
 351   for (i in 1:nd){
 352     r.COR[,i] <- obj$rowmass * rpc[,i]^2 / obj$rowinertia
 353     r.CTR[,i] <- obj$rowmass * rpc[,i]^2 / obj$sv[i]^2
 354     }
 355  # cor and quality for supplementary rows
 356   if (length(obj$rowsup) > 0){
 357     i0 <- obj$rowsup
 358     for (i in 1:nd){
 359       r.COR[i0,i] <- obj$rowmass[i0] * rpc[i0,i]^2
 360       r.CTR[i0,i] <- NA
 361     }
 362     }
 363
 364  # columns:
 365   c.names <- obj$colnames
 366   sc      <- obj$colsup
 367   if (!is.na(sc[1])) c.names[sc] <- paste("(*)", c.names[sc], sep = "")
 368   c.mass  <- obj$colmass
 369   c.inr   <- obj$colinertia / sum(obj$colinertia, na.rm = TRUE)
 370   c.COR   <- matrix(NA, nrow = length(c.names), ncol = nd)
 371   colnames(c.COR) <- paste('COR -facteur', 1:nd, sep=' ')
 372   c.CTR   <- matrix(NA, nrow = length(c.names), ncol = nd)
 373   colnames(c.CTR) <- paste('CTR -facteur', 1:nd, sep=' ')
 374   for (i in 1:nd)
 375     {
 376     c.COR[,i] <- obj$colmass * cpc[,i]^2 / obj$colinertia
 377     c.CTR[,i] <- obj$colmass * cpc[,i]^2 / obj$sv[i]^2
 378     }
 379   if (length(obj$colsup) > 0){
 380     i0 <- obj$colsup
 381     for (i in 1:nd){
 382       c.COR[i0,i] <- obj$colmass[i0] * cpc[i0,i]^2
 383       c.CTR[i0,i] <- NA
 384       }
 385     }
 386
 387  # scree plot:
 388   if (scree) {
 389     values     <- obj$sv^2
 390     values2    <- 100*(obj$sv^2)/sum(obj$sv^2)
 391     values3    <- cumsum(100*(obj$sv^2)/sum(obj$sv^2))
 392     scree.out  <- cbind(values, values2, values3)
 393     } else {
 394     scree.out <- NA
 395     }
 396
 397   obj$r.COR <- r.COR
 398   obj$r.CTR <- r.CTR
 399   obj$c.COR <- c.COR
 400   obj$c.CTR <- c.CTR
 401   obj$facteur <- scree.out
 402   return(obj)
 403   }
 404
 405 create_afc_table <- function(x) {
 406    #x = afc
 407         facteur.table <- as.matrix(x$facteur)
 408     nd <- ncol(x$colcoord)
 409         rownames(facteur.table) <- paste('facteur',1:nrow(facteur.table),sep = ' ')
 410     colnames(facteur.table) <- c('Valeurs propres', 'Pourcentages', 'Pourcentage cumules')
 411         ligne.table <- as.matrix(x$rowcoord)
 412         rownames(ligne.table) <- x$rownames
 413         colnames(ligne.table) <- paste('Coord. facteur', 1:nd, sep=' ')
 414     tmp <- as.matrix(x$rowcrl)
 415         colnames(tmp) <- paste('Corr. facteur', 1:nd, sep=' ')
 416         ligne.table <- cbind(ligne.table,tmp)
 417         ligne.table <- cbind(ligne.table, x$r.COR)
 418         ligne.table <- cbind(ligne.table, x$r.CTR)
 419         ligne.table <- cbind(ligne.table, mass = x$rowmass)
 420         ligne.table <- cbind(ligne.table, chi.distance = x$rowdist)
 421         ligne.table <- cbind(ligne.table, inertie = x$rowinertia)
 422     colonne.table <- x$colcoord
 423         rownames(colonne.table) <- paste('classe', 1:(nrow(colonne.table)),sep=' ')
 424         colnames(colonne.table) <- paste('Coord. facteur', 1:nd, sep=' ')
 425     tmp <- as.matrix(x$colcrl)
 426         colnames(tmp) <- paste('Corr. facteur', 1:nd, sep=' ')
 427         colonne.table <- cbind(colonne.table, tmp)
 428         colonne.table <- cbind(colonne.table, x$c.COR)
 429         colonne.table <- cbind(colonne.table, x$c.CTR)
 430         colonne.table <- cbind(colonne.table, mass = x$colmass)
 431         colonne.table <- cbind(colonne.table, chi.distance = x$coldist)
 432         colonne.table <- cbind(colonne.table, inertie = x$colinertia)
 433     res <- list(facteur = facteur.table, ligne = ligne.table, colonne = colonne.table)
 434         res
 435 }
 436
 437 make_afc_graph <- function(toplot, classes, clnb, xlab, ylab, cex.txt = NULL, leg = FALSE, cmd = FALSE, black = FALSE, xminmax=NULL, yminmax=NULL) {
 438
 439     rain <- rainbow(clnb)
 440     compt <- 1
 441     tochange <- NULL
 442     for (my.color in rain) {
 443         my.color <- col2rgb(my.color)
 444         if ((my.color[1] > 200) & (my.color[2] > 200) & (my.color[3] < 20)) {
 445            tochange <- append(tochange, compt)
 446         }
 447         compt <- compt + 1
 448     }
 449     if (!is.null(tochange)) {
 450         gr.col <- grey.colors(length(tochange))
 451         compt <- 1
 452         for (val in tochange) {
 453             rain[val] <- gr.col[compt]
 454             compt <- compt + 1
 455         }
 456     }
 457         cl.color <- rain[classes]
 458     if (black) {
 459         cl.color <- 'black'
 460     }
 461         plot(toplot[,1],toplot[,2], pch='', xlab = xlab, ylab = ylab, xlim=xminmax, ylim = yminmax)
 462         abline(h=0, v=0, lty = 'dashed')
 463         if (is.null(cex.txt))
 464                 text(toplot[,1],toplot[,2],rownames(toplot),col=cl.color, offset=0)
 465         else
 466         text(toplot[,1],toplot[,2],rownames(toplot),col=cl.color, cex = cex.txt, offset=0)
 467
 468     if (!cmd) {
 469             dev.off()
 470     }
 471 }
 472
 473 plot.dendropr <- function(tree, classes, type.dendro="phylogram", histo=FALSE, from.cmd=FALSE, bw=FALSE, lab = NULL, tclasse=TRUE) {
 474         classes<-classes[classes!=0]
 475         classes<-as.factor(classes)
 476         sum.cl<-as.matrix(summary(classes))
 477         sum.cl<-(sum.cl/colSums(sum.cl)*100)
 478         sum.cl<-round(sum.cl,2)
 479         sum.cl<-cbind(sum.cl,as.matrix(100-sum.cl[,1]))
 480     tree.order<- as.numeric(tree$tip.label)
 481     if (! bw) {
 482         col = rainbow(nrow(sum.cl))[as.numeric(tree$tip.label)]
 483         col.bars <- col
 484         col.pie <- rainbow(nrow(sum.cl))
 485             #col.vec<-rainbow(nrow(sum.cl))[as.numeric(tree[[2]])]
 486     } else {
 487         col = 'black'
 488         col.bars = 'grey'
 489         col.pie <- rep('grey',nrow(sum.cl))
 490     }
 491         vec.mat<-NULL
 492         for (i in 1:nrow(sum.cl)) vec.mat<-append(vec.mat,1)
 493         v<-2
 494         for (i in 1:nrow(sum.cl)) {
 495                 vec.mat<-append(vec.mat,v)
 496                 v<-v+1
 497         }
 498         par(mar=c(0,0,0,0))
 499     if (tclasse) {
 500         if (! histo) {
 501                 layout(matrix(vec.mat,nrow(sum.cl),2),widths=c(3,1))
 502         } else {
 503             layout(matrix(c(1,2),1,byrow=TRUE), widths=c(3,2),TRUE)
 504         }
 505     }
 506         par(mar=c(0,0,0,0),cex=1)
 507         label.ori<-tree[[2]]
 508     if (!is.null(lab)) {
 509         tree$tip.label <- lab
 510     } else {
 511             tree[[2]]<-paste('classe ',tree[[2]])
 512     }
 513         plot.phylo(tree,label.offset=0.1,tip.col=col, type=type.dendro)
 514     #cl.order <- as.numeric(label.ori)
 515     #sum.cl[cl.order,1]
 516         #for (i in 1:nrow(sum.cl)) {
 517     if (tclasse) {
 518         if (! histo) {
 519             for (i in rev(tree.order)) {
 520                 par(mar=c(0,0,1,0),cex=0.7)
 521                     pie(sum.cl[i,],col=c(col.pie[i],'white'),radius = 1, labels='', clockwise=TRUE, main = paste('classe ',i,' - ',sum.cl[i,1],'%' ))
 522             }
 523         } else {
 524             par(cex=0.7)
 525             par(mar=c(0,0,0,1))
 526             to.plot <- sum.cl[tree.order,1]
 527             d <- barplot(to.plot,horiz=TRUE, col=col.bars, names.arg='', axes=FALSE, axisname=FALSE)
 528             text(x=to.plot, y=d[,1], label=paste(round(to.plot,1),'%'), adj=1.2)
 529         }
 530     }
 531     if (!from.cmd) dev.off()
 532         tree[[2]]<-label.ori
 533 }
 534 #tree <- tree.cut1$tree.cl
 535 #to.plot <- di
 536 plot.dendro.lex <- function(tree, to.plot, bw=FALSE, lab=NULL, lay.width=c(3,3,2), cmd=FALSE) {
 537     tree.order<- as.numeric(tree$tip.label)
 538     par(mar=c(0,0,0,0))
 539     layout(matrix(c(1,2,3),1,byrow=TRUE), widths=lay.width,TRUE)
 540         par(mar=c(3,0,2,0),cex=1)
 541         label.ori<-tree[[2]]
 542     if (!is.null(lab)) {
 543         tree$tip.label <- lab
 544     } else {
 545             tree[[2]]<-paste('classe ',tree[[2]])
 546     }
 547     to.plot <- matrix(to.plot[,tree.order], nrow=nrow(to.plot), dimnames=list(rownames(to.plot), colnames(to.plot)))
 548     if (!bw) {
 549         col <- rainbow(ncol(to.plot))
 550         col.bars <- rainbow(nrow(to.plot))
 551     } else {
 552         col <- 'black'
 553         col.bars <- grey.colors(nrow(to.plot),0,0.8)
 554     }
 555     col <- col[tree.order]
 556         plot.phylo(tree,label.offset=0.1,tip.col=col)
 557
 558     par(mar=c(3,0,2,1))
 559     d <- barplot(to.plot,horiz=TRUE, col=col.bars, beside=TRUE, names.arg='', space = c(0.1,0.6), axisname=FALSE)
 560     c <- colMeans(d)
 561     c1 <- c[-1]
 562     c2 <- c[-length(c)]
 563     cc <- cbind(c1,c2)
 564     lcoord <- apply(cc, 1, mean)
 565     abline(h=lcoord)
 566     if (min(to.plot) < 0) {
 567         amp <- abs(max(to.plot) - min(to.plot))
 568     } else {
 569         amp <- max(to.plot)
 570     }
 571     if (amp < 10) {
 572         d <- 2
 573     } else {
 574         d <- signif(amp%/%10,1)
 575     }
 576     mn <- round(min(to.plot))
 577     mx <- round(max(to.plot))
 578     for (i in mn:mx) {
 579         if ((i/d) == (i%/%d)) {
 580             abline(v=i,lty=3)
 581         }
 582     }
 583     par(mar=c(0,0,0,0))
 584     plot(0, axes = FALSE, pch = '')
 585     legend(x = 'center' , rownames(to.plot), fill = col.bars)
 586     if (!cmd) {
 587         dev.off()
 588     }
 589         tree[[2]]<-label.ori
 590 }
 591
 592 plot.alceste.graph <- function(rdata,nd=3,layout='fruke', chilim = 2) {
 593     load(rdata)
 594     if (is.null(debsup)) {
 595         tab.toplot<-afctable[1:(debet+1),]
 596         chitab<-chistabletot[1:(debet+1),]
 597     } else {
 598         tab.toplot<-afctable[1:(debsup+1),]
 599         chitab<-chistabletot[1:(debsup+1),]
 600     }
 601     rkeep<-select_point_chi(chitab,chilim)
 602     tab.toplot<-tab.toplot[rkeep,]
 603     chitab<-chitab[rkeep,]
 604     dm<-dist(tab.toplot,diag=TRUE,upper=TRUE)
 605     cn<-rownames(tab.toplot)
 606     cl.toplot<-apply(chitab,1,which.max)
 607     col<-rainbow(ncol(tab.toplot))[cl.toplot]
 608     library(igraph)
 609     g1 <- graph.adjacency(as.matrix(dm), mode = 'lower', weighted = TRUE)
 610     g.max<-minimum.spanning.tree(g1)
 611     we<-(rowSums(tab.toplot)/max(rowSums(tab.toplot)))*2
 612     #lo <- layout.fruchterman.reingold(g.max,dim=nd)
 613     lo<- layout.kamada.kawai(g.max,dim=nd)
 614     print(nrow(tab.toplot))
 615     print(nrow(chitab))
 616     print(length(we))
 617     print(length(col))
 618     print(length(cn))
 619     if (nd == 3) {
 620         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)
 621     } else if (nd == 2) {
 622         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)
 623     }
 624
 625 }
 626
 627 make.simi.afc <- function(x,chitable,lim=0, alpha = 0.1, movie = NULL) {
 628     library(igraph)
 629     chimax<-as.matrix(apply(chitable,1,max))
 630     chimax<-as.matrix(chimax[,1][1:nrow(x)])
 631     chimax<-cbind(chimax,1:nrow(x))
 632     order_chi<-as.matrix(chimax[order(chimax[,1],decreasing = TRUE),])
 633     if ((lim == 0) || (lim>nrow(x))) lim <- nrow(x)
 634     x<-x[order_chi[,2][1:lim],]
 635     maxchi <- chimax[order_chi[,2][1:lim],1]
 636     #-------------------------------------------------------
 637     limit<-nrow(x)
 638     distm<-dist(x,diag=TRUE)
 639     distm<-as.matrix(distm)
 640     g1<-graph.adjacency(distm,mode='lower',weighted=TRUE)
 641     g1<-minimum.spanning.tree(g1)
 642     lo<-layout.kamada.kawai(g1,dim=3)
 643     lo <- layout.norm(lo, -3, 3, -3, 3, -3, 3)
 644     mc<-rainbow(ncol(chistabletot))
 645     chitable<-chitable[order_chi[,2][1:lim],]
 646     cc <- apply(chitable, 1, which.max)
 647     cc<-mc[cc]
 648     #mass<-(rowSums(x)/max(rowSums(x))) * 5
 649     maxchi<-norm.vec(maxchi, 0.03, 0.3)
 650     rglplot(g1,vertex.label = vire.nonascii(rownames(x)),vertex.label.color= cc,vertex.label.cex = maxchi, vertex.size = 0.1, layout=lo, rescale=FALSE)
 651     text3d(lo[,1], lo[,2],lo[,3], rownames(x), cex=maxchi, col=cc)
 652     #rgl.spheres(lo, col = cc, radius = maxchi, alpha = alpha)
 653     rgl.bg(color = c('white','black'))
 654     if (!is.null(movie)) {
 655         require(tcltk)
 656         ReturnVal <- tkmessageBox(title="RGL 3 D",message="Cliquez pour commencer le film",icon="info",type="ok")
 657
 658         movie3d(spin3d(axis=c(0,1,0),rpm=6), movie = 'film_graph', frames = "tmpfilm", duration=10, clean=TRUE, top = TRUE, dir = movie)
 659         ReturnVal <- tkmessageBox(title="RGL 3 D",message="Film fini !",icon="info",type="ok")
 660     }
 661         while (rgl.cur() != 0)
 662                 Sys.sleep(1)
 663
 664 }
 665
 666 # from igraph
 667 norm.vec <- function(v, min, max) {
 668
 669   vr <- range(v)
 670   if (vr[1]==vr[2]) {
 671     fac <- 1
 672   } else {
 673     fac <- (max-min)/(vr[2]-vr[1])
 674   }
 675   (v-vr[1]) * fac + min
 676 }
 677
 678
 679 vire.nonascii <- function(rnames) {
 680     print('vire non ascii')
 681     couple <- list(c('é','e'),
 682                 c('è','e'),
 683                 c('ê','e'),
 684                 c('ë','e'),
 685                 c('î','i'),
 686                 c('ï','i'),
 687                 c('ì','i'),
 688                 c('à','a'),
 689                 c('â','a'),
 690                 c('ä','a'),
 691                 c('á','a'),
 692                 c('ù','u'),
 693                 c('û','u'),
 694                 c('ü','u'),
 695                 c('ç','c'),
 696                 c('ò','o'),
 697                 c('ô','o'),
 698                 c('ö','o'),
 699                 c('ñ','n')
 700                 )
 701
 702     for (c in couple) {
 703         rnames<-gsub(c[1],c[2], rnames)
 704     }
 705     rnames
 706 }
 707
 708
 709
 710 #par(mar=c(0,0,0,0))
 711 #layout(matrix(c(1,2),1,byrow=TRUE), widths=c(3,2),TRUE)
 712 #par(mar=c(1,0,1,0), cex=1)
 713 #plot.phylo(tree,label.offset=0.1)
 714 #par(mar=c(0,0,0,1))
 715 #to.plot <- sum.cl[cl.order,1]
 716 #d <- barplot(to.plot,horiz=TRUE, names.arg='', axes=FALSE, axisname=FALSE)
 717 #text(x=to.plot, y=d[,1], label=round(to.plot,1), adj=1.2)
 718