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