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