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.dendropr <- function(tree, classes, type.dendro="phylogram", histo=FALSE, from.cmd=FALSE, bw=FALSE, lab = NULL, tclasse=TRUE) {
 481         classes<-classes[classes!=0]
 482         classes<-as.factor(classes)
 483         sum.cl<-as.matrix(summary(classes))
 484         sum.cl<-(sum.cl/colSums(sum.cl)*100)
 485         sum.cl<-round(sum.cl,2)
 486         sum.cl<-cbind(sum.cl,as.matrix(100-sum.cl[,1]))
 487     tree.order<- as.numeric(tree$tip.label)
 488     if (! bw) {
 489         col = rainbow(nrow(sum.cl))[as.numeric(tree$tip.label)]
 490         col.bars <- col
 491         col.pie <- rainbow(nrow(sum.cl))
 492             #col.vec<-rainbow(nrow(sum.cl))[as.numeric(tree[[2]])]
 493     } else {
 494         col = 'black'
 495         col.bars = 'grey'
 496         col.pie <- rep('grey',nrow(sum.cl))
 497     }
 498         vec.mat<-NULL
 499         for (i in 1:nrow(sum.cl)) vec.mat<-append(vec.mat,1)
 500         v<-2
 501         for (i in 1:nrow(sum.cl)) {
 502                 vec.mat<-append(vec.mat,v)
 503                 v<-v+1
 504         }
 505         par(mar=c(0,0,0,0))
 506     if (tclasse) {
 507         if (! histo) {
 508                 layout(matrix(vec.mat,nrow(sum.cl),2),widths=c(3,1))
 509         } else {
 510             layout(matrix(c(1,2),1,byrow=TRUE), widths=c(3,2),TRUE)
 511         }
 512     }
 513         par(mar=c(0,0,0,0),cex=1)
 514         label.ori<-tree[[2]]
 515     if (!is.null(lab)) {
 516         tree$tip.label <- lab
 517     } else {
 518             tree[[2]]<-paste('classe ',tree[[2]])
 519     }
 520         plot.phylo(tree,label.offset=0.1,tip.col=col, type=type.dendro)
 521     #cl.order <- as.numeric(label.ori)
 522     #sum.cl[cl.order,1]
 523         #for (i in 1:nrow(sum.cl)) {
 524     if (tclasse) {
 525         if (! histo) {
 526             for (i in rev(tree.order)) {
 527                 par(mar=c(0,0,1,0),cex=0.7)
 528                     pie(sum.cl[i,],col=c(col.pie[i],'white'),radius = 1, labels='', clockwise=TRUE, main = paste('classe ',i,' - ',sum.cl[i,1],'%' ))
 529             }
 530         } else {
 531             par(cex=0.7)
 532             par(mar=c(0,0,0,1))
 533             to.plot <- sum.cl[tree.order,1]
 534             d <- barplot(to.plot,horiz=TRUE, col=col.bars, names.arg='', axes=FALSE, axisname=FALSE)
 535             text(x=to.plot, y=d[,1], label=paste(round(to.plot,1),'%'), adj=1.2)
 536         }
 537     }
 538     if (!from.cmd) dev.off()
 539         tree[[2]]<-label.ori
 540 }
 541 #tree <- tree.cut1$tree.cl
 542 #to.plot <- di
 543 plot.dendro.lex <- function(tree, to.plot, bw=FALSE, lab=NULL, lay.width=c(3,3,2), cmd=FALSE) {
 544     tree.order<- as.numeric(tree$tip.label)
 545     par(mar=c(0,0,0,0))
 546     layout(matrix(c(1,2,3),1,byrow=TRUE), widths=lay.width,TRUE)
 547         par(mar=c(3,0,2,0),cex=1)
 548         label.ori<-tree[[2]]
 549     if (!is.null(lab)) {
 550         tree$tip.label <- lab
 551     } else {
 552             tree[[2]]<-paste('classe ',tree[[2]])
 553     }
 554     to.plot <- matrix(to.plot[,tree.order], nrow=nrow(to.plot), dimnames=list(rownames(to.plot), colnames(to.plot)))
 555     if (!bw) {
 556         col <- rainbow(ncol(to.plot))
 557         col.bars <- rainbow(nrow(to.plot))
 558     } else {
 559         col <- 'black'
 560         col.bars <- grey.colors(nrow(to.plot),0,0.8)
 561     }
 562     col <- col[tree.order]
 563         plot.phylo(tree,label.offset=0.1,tip.col=col)
 564
 565     par(mar=c(3,0,2,1))
 566     d <- barplot(to.plot,horiz=TRUE, col=col.bars, beside=TRUE, names.arg='', space = c(0.1,0.6), axisname=FALSE)
 567     c <- colMeans(d)
 568     c1 <- c[-1]
 569     c2 <- c[-length(c)]
 570     cc <- cbind(c1,c2)
 571     lcoord <- apply(cc, 1, mean)
 572     abline(h=lcoord)
 573     if (min(to.plot) < 0) {
 574         amp <- abs(max(to.plot) - min(to.plot))
 575     } else {
 576         amp <- max(to.plot)
 577     }
 578     if (amp < 10) {
 579         d <- 2
 580     } else {
 581         d <- signif(amp%/%10,1)
 582     }
 583     mn <- round(min(to.plot))
 584     mx <- round(max(to.plot))
 585     for (i in mn:mx) {
 586         if ((i/d) == (i%/%d)) {
 587             abline(v=i,lty=3)
 588         }
 589     }
 590     par(mar=c(0,0,0,0))
 591     plot(0, axes = FALSE, pch = '')
 592     legend(x = 'center' , rownames(to.plot), fill = col.bars)
 593     if (!cmd) {
 594         dev.off()
 595     }
 596         tree[[2]]<-label.ori
 597 }
 598
 599 plot.alceste.graph <- function(rdata,nd=3,layout='fruke', chilim = 2) {
 600     load(rdata)
 601     if (is.null(debsup)) {
 602         tab.toplot<-afctable[1:(debet+1),]
 603         chitab<-chistabletot[1:(debet+1),]
 604     } else {
 605         tab.toplot<-afctable[1:(debsup+1),]
 606         chitab<-chistabletot[1:(debsup+1),]
 607     }
 608     rkeep<-select_point_chi(chitab,chilim)
 609     tab.toplot<-tab.toplot[rkeep,]
 610     chitab<-chitab[rkeep,]
 611     dm<-dist(tab.toplot,diag=TRUE,upper=TRUE)
 612     cn<-rownames(tab.toplot)
 613     cl.toplot<-apply(chitab,1,which.max)
 614     col<-rainbow(ncol(tab.toplot))[cl.toplot]
 615     library(igraph)
 616     g1 <- graph.adjacency(as.matrix(dm), mode = 'lower', weighted = TRUE)
 617     g.max<-minimum.spanning.tree(g1)
 618     we<-(rowSums(tab.toplot)/max(rowSums(tab.toplot)))*2
 619     #lo <- layout.fruchterman.reingold(g.max,dim=nd)
 620     lo<- layout.kamada.kawai(g.max,dim=nd)
 621     print(nrow(tab.toplot))
 622     print(nrow(chitab))
 623     print(length(we))
 624     print(length(col))
 625     print(length(cn))
 626     if (nd == 3) {
 627         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)
 628     } else if (nd == 2) {
 629         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)
 630     }
 631
 632 }
 633
 634 make.simi.afc <- function(x,chitable,lim=0, alpha = 0.1, movie = NULL) {
 635     library(igraph)
 636     chimax<-as.matrix(apply(chitable,1,max))
 637     chimax<-as.matrix(chimax[,1][1:nrow(x)])
 638     chimax<-cbind(chimax,1:nrow(x))
 639     order_chi<-as.matrix(chimax[order(chimax[,1],decreasing = TRUE),])
 640     if ((lim == 0) || (lim>nrow(x))) lim <- nrow(x)
 641     x<-x[order_chi[,2][1:lim],]
 642     maxchi <- chimax[order_chi[,2][1:lim],1]
 643     #-------------------------------------------------------
 644     limit<-nrow(x)
 645     distm<-dist(x,diag=TRUE)
 646     distm<-as.matrix(distm)
 647     g1<-graph.adjacency(distm,mode='lower',weighted=TRUE)
 648     g1<-minimum.spanning.tree(g1)
 649     lo<-layout.kamada.kawai(g1,dim=3)
 650     lo <- layout.norm(lo, -3, 3, -3, 3, -3, 3)
 651     mc<-rainbow(ncol(chistabletot))
 652     chitable<-chitable[order_chi[,2][1:lim],]
 653     cc <- apply(chitable, 1, which.max)
 654     cc<-mc[cc]
 655     #mass<-(rowSums(x)/max(rowSums(x))) * 5
 656     maxchi<-norm.vec(maxchi, 0.03, 0.3)
 657     rglplot(g1,vertex.label = vire.nonascii(rownames(x)),vertex.label.color= cc,vertex.label.cex = maxchi, vertex.size = 0.1, layout=lo, rescale=FALSE)
 658     text3d(lo[,1], lo[,2],lo[,3], rownames(x), cex=maxchi, col=cc)
 659     #rgl.spheres(lo, col = cc, radius = maxchi, alpha = alpha)
 660     rgl.bg(color = c('white','black'))
 661     if (!is.null(movie)) {
 662         require(tcltk)
 663         ReturnVal <- tkmessageBox(title="RGL 3 D",message="Cliquez pour commencer le film",icon="info",type="ok")
 664
 665         movie3d(spin3d(axis=c(0,1,0),rpm=6), movie = 'film_graph', frames = "tmpfilm", duration=10, clean=TRUE, top = TRUE, dir = movie)
 666         ReturnVal <- tkmessageBox(title="RGL 3 D",message="Film fini !",icon="info",type="ok")
 667     }
 668         while (rgl.cur() != 0)
 669                 Sys.sleep(1)
 670
 671 }
 672
 673 # from igraph
 674 norm.vec <- function(v, min, max) {
 675
 676   vr <- range(v)
 677   if (vr[1]==vr[2]) {
 678     fac <- 1
 679   } else {
 680     fac <- (max-min)/(vr[2]-vr[1])
 681   }
 682   (v-vr[1]) * fac + min
 683 }
 684
 685
 686 vire.nonascii <- function(rnames) {
 687     print('vire non ascii')
 688     couple <- list(c('é','e'),
 689                 c('è','e'),
 690                 c('ê','e'),
 691                 c('ë','e'),
 692                 c('î','i'),
 693                 c('ï','i'),
 694                 c('ì','i'),
 695                 c('à','a'),
 696                 c('â','a'),
 697                 c('ä','a'),
 698                 c('á','a'),
 699                 c('ù','u'),
 700                 c('û','u'),
 701                 c('ü','u'),
 702                 c('ç','c'),
 703                 c('ò','o'),
 704                 c('ô','o'),
 705                 c('ö','o'),
 706                 c('ñ','n')
 707                 )
 708
 709     for (c in couple) {
 710         rnames<-gsub(c[1],c[2], rnames)
 711     }
 712     rnames
 713 }
 714
 715
 716
 717 #par(mar=c(0,0,0,0))
 718 #layout(matrix(c(1,2),1,byrow=TRUE), widths=c(3,2),TRUE)
 719 #par(mar=c(1,0,1,0), cex=1)
 720 #plot.phylo(tree,label.offset=0.1)
 721 #par(mar=c(0,0,0,1))
 722 #to.plot <- sum.cl[cl.order,1]
 723 #d <- barplot(to.plot,horiz=TRUE, names.arg='', axes=FALSE, axisname=FALSE)
 724 #text(x=to.plot, y=d[,1], label=round(to.plot,1), adj=1.2)
 725