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, active = TRUE) {
  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, active=active)
  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         if (svg) {
 146             svg(filename.to.svg(filename), width=width/74.97, height=height/74.97)
 147         } else {
 148                     png(filename, width=width, height=height)#, quality = quality)
 149         }
 150         }
 151 }
 152
 153 #################################################@@
 154 #from wordcloud
 155 overlap <- function(x1, y1, sw1, sh1, boxes) {
 156     use.r.layout <- FALSE
 157         if(!use.r.layout)
 158                 return(.overlap(x1,y1,sw1,sh1,boxes))
 159         s <- 0
 160         if (length(boxes) == 0)
 161                 return(FALSE)
 162         for (i in c(last,1:length(boxes))) {
 163                 bnds <- boxes[[i]]
 164                 x2 <- bnds[1]
 165                 y2 <- bnds[2]
 166                 sw2 <- bnds[3]
 167                 sh2 <- bnds[4]
 168                 if (x1 < x2)
 169                         overlap <- x1 + sw1 > x2-s
 170                 else
 171                         overlap <- x2 + sw2 > x1-s
 172
 173                 if (y1 < y2)
 174                         overlap <- overlap && (y1 + sh1 > y2-s)
 175                 else
 176                         overlap <- overlap && (y2 + sh2 > y1-s)
 177                 if(overlap){
 178                         last <<- i
 179                         return(TRUE)
 180                 }
 181         }
 182         FALSE
 183 }
 184
 185 .overlap <- function(x11,y11,sw11,sh11,boxes1){
 186     .Call("is_overlap",x11,y11,sw11,sh11,boxes1)
 187 }
 188 ########################################################
 189 stopoverlap <- function(x, cex.par = NULL, xlim = NULL, ylim = NULL) {
 190 #from wordcloud
 191     library(wordcloud)
 192     tails <- "g|j|p|q|y"
 193     rot.per <- 0
 194     last <- 1
 195     thetaStep <- .1
 196     rStep <- .5
 197     toplot <- NULL
 198     notplot <- NULL
 199
 200 #    plot.new()
 201     plot(x[,1],x[,2], pch='', xlim = xlim, ylim = ylim)
 202
 203     words <- rownames(x)
 204     if  (is.null(cex.par))  {
 205         size <- rep(0.9, nrow(x))
 206     } else {
 207         size <- cex.par
 208     }
 209     #cols <- rainbow(clnb)
 210     boxes <- list()
 211     for (i in 1:nrow(x)) {
 212         rotWord <- runif(1)<rot.per
 213         r <-0
 214                 theta <- runif(1,0,2*pi)
 215                 x1<- x[i,1]
 216                 y1<- x[i,2]
 217                 wid <- strwidth(words[i],cex=size[i])
 218                 ht <- strheight(words[i],cex=size[i])
 219                 isOverlaped <- TRUE
 220                 while(isOverlaped){
 221                         if(!overlap(x1-.5*wid,y1-.5*ht,wid,ht, boxes)) { #&&
 222                 toplot <- rbind(toplot, c(x1, y1, size[i], i))
 223                                 #text(x1,y1,words[i],cex=size[i],offset=0,srt=rotWord*90,
 224                                 #               col=cols[classes[i]])
 225                                 boxes[[length(boxes)+1]] <- c(x1-.5*wid,y1-.5*ht,wid,ht)
 226                                 isOverlaped <- FALSE
 227                         } else {
 228                                 if(r>sqrt(.5)){
 229                                         print(paste(words[i], "could not be fit on page. It will not be plotted."))
 230                     notplot <- rbind(notplot,c(words[i], x[i,1], x[i,2]))
 231                                         isOverlaped <- FALSE
 232                                 }
 233                                 theta <- theta+thetaStep
 234                                 r <- r + rStep*thetaStep/(2*pi)
 235                 x1 <- x[i,1]+r*cos(theta)
 236                                 y1 <- x[i,2]+r*sin(theta)
 237                         }
 238                 }
 239     }
 240     row.names(toplot) <- words[toplot[,4]]
 241     return(list(toplot = toplot, notplot = notplot))
 242 }
 243 ###############################################################################
 244
 245 make_tree_tot <- function (chd) {
 246         library(ape)
 247         lf<-chd$list_fille
 248         clus<-'a1a;'
 249         for (i in 1:length(lf)) {
 250                 if (!is.null(lf[[i]])) {
 251                         clus<-gsub(paste('a',i,'a',sep=''),paste('(','a',lf[[i]][1],'a',',','a',lf[[i]][2],'a',')',sep=''),clus)
 252         }
 253         }
 254         dendro_tuple <- clus
 255         clus <- gsub('a','',clus)
 256         tree.cl <- read.tree(text = clus)
 257         res<-list(tree.cl = tree.cl, dendro_tuple = dendro_tuple)
 258         res
 259 }
 260
 261 make_dendro_cut_tuple <- function(dendro_in, coordok, classeuce, x, nbt = 9) {
 262         library(ape)
 263         dendro<-dendro_in
 264         i <- 0
 265         for (cl in coordok[,x]) {
 266                 i <- i + 1
 267                 fcl<-fille(cl,classeuce)
 268                 for (fi in fcl) {
 269                         dendro <- gsub(paste('a',fi,'a',sep=''),paste('b',i,'b',sep=''),dendro)
 270                 }
 271         }
 272         clnb <- nrow(coordok)
 273     tcl=((nbt+1) *2) - 2
 274         for (i in 1:(tcl + 1)) {
 275                 dendro <- gsub(paste('a',i,'a',sep=''),paste('b',0,'b',sep=''),dendro)
 276         }
 277         dendro <- gsub('b','',dendro)
 278         dendro <- gsub('a','',dendro)
 279         dendro_tot_cl <- read.tree(text = dendro)
 280         #FIXME
 281         for (i in 1:100) {
 282                 for (cl in 1:clnb) {
 283                         dendro <- gsub(paste('\\(',cl,',',cl,'\\)',sep=''),cl,dendro)
 284                 }
 285         }
 286         for (i in 1:100) {
 287                 dendro <- gsub(paste('\\(',0,',',0,'\\)',sep=''),0,dendro)
 288                 for (cl in 1:clnb) {
 289                         dendro <- gsub(paste('\\(',0,',',cl,'\\)',sep=''),cl,dendro)
 290                         dendro <- gsub(paste('\\(',cl,',',0,'\\)',sep=''),cl,dendro)
 291                 }
 292         }
 293         print(dendro)
 294         tree.cl <- read.tree(text = dendro)
 295     lab <- tree.cl$tip.label
 296     if ("0" %in% lab) {
 297         tovire <- which(lab == "0")
 298         tree.cl <- drop.tip(tree.cl, tip = tovire)
 299     }
 300         res <- list(tree.cl = tree.cl, dendro_tuple_cut = dendro, dendro_tot_cl = dendro_tot_cl)
 301         res
 302 }
 303
 304 select_point_nb <- function(tablechi, nb) {
 305         chimax<-as.matrix(apply(tablechi,1,max))
 306         chimax<-cbind(chimax,1:nrow(tablechi))
 307         order_chi<-as.matrix(chimax[order(chimax[,1],decreasing = TRUE),])
 308         row_keep <- order_chi[,2][1:nb]
 309         row_keep
 310 }
 311
 312 select_point_chi <- function(tablechi, chi_limit) {
 313         chimax<-as.matrix(apply(tablechi,1,max))
 314         row_keep <- which(chimax >= chi_limit)
 315         row_keep
 316 }
 317
 318 select.chi.classe <- function(tablechi, nb, active = TRUE) {
 319     rowkeep <- NULL
 320     if (active & !is.null(debsup)) {
 321         print(debsup)
 322         print('###############################################################@')
 323         tablechi <- tablechi[1:(debsup-1),]
 324     }
 325     if (nb > nrow(tablechi)) {
 326         nb <- nrow(tablechi)
 327     }
 328     for (i in 1:ncol(tablechi)) {
 329         rowkeep <- append(rowkeep,order(tablechi[,i], decreasing = TRUE)[1:nb])
 330     }
 331     rowkeep <- unique(rowkeep)
 332     rowkeep
 333 }
 334
 335 #from summary.ca
 336 summary.ca.dm <- function(object, scree = TRUE, ...){
 337   obj <- object
 338   nd  <- obj$nd
 339   if (is.na(nd)){
 340     nd <- 2
 341     } else {
 342     if (nd > length(obj$sv)) nd <- length(obj$sv)
 343     }
 344  # principal coordinates:
 345   K   <- nd
 346   I   <- dim(obj$rowcoord)[1] ; J <- dim(obj$colcoord)[1]
 347   svF <- matrix(rep(obj$sv[1:K], I), I, K, byrow = TRUE)
 348   svG <- matrix(rep(obj$sv[1:K], J), J, K, byrow = TRUE)
 349   rpc <- obj$rowcoord[,1:K] * svF
 350   cpc <- obj$colcoord[,1:K] * svG
 351
 352  # rows:
 353   r.names <- obj$rownames
 354   sr      <- obj$rowsup
 355   if (!is.na(sr[1])) r.names[sr] <- paste("(*)", r.names[sr], sep = "")
 356   r.mass <- obj$rowmass
 357   r.inr  <- obj$rowinertia / sum(obj$rowinertia, na.rm = TRUE)
 358   r.COR  <- matrix(NA, nrow = length(r.names), ncol = nd)
 359   colnames(r.COR) <- paste('COR -facteur', 1:nd, sep=' ')
 360   r.CTR  <- matrix(NA, nrow = length(r.names), ncol = nd)
 361   colnames(r.CTR) <- paste('CTR -facteur', 1:nd, sep=' ')
 362   for (i in 1:nd){
 363     r.COR[,i] <- obj$rowmass * rpc[,i]^2 / obj$rowinertia
 364     r.CTR[,i] <- obj$rowmass * rpc[,i]^2 / obj$sv[i]^2
 365     }
 366  # cor and quality for supplementary rows
 367   if (length(obj$rowsup) > 0){
 368     i0 <- obj$rowsup
 369     for (i in 1:nd){
 370       r.COR[i0,i] <- obj$rowmass[i0] * rpc[i0,i]^2
 371       r.CTR[i0,i] <- NA
 372     }
 373     }
 374
 375  # columns:
 376   c.names <- obj$colnames
 377   sc      <- obj$colsup
 378   if (!is.na(sc[1])) c.names[sc] <- paste("(*)", c.names[sc], sep = "")
 379   c.mass  <- obj$colmass
 380   c.inr   <- obj$colinertia / sum(obj$colinertia, na.rm = TRUE)
 381   c.COR   <- matrix(NA, nrow = length(c.names), ncol = nd)
 382   colnames(c.COR) <- paste('COR -facteur', 1:nd, sep=' ')
 383   c.CTR   <- matrix(NA, nrow = length(c.names), ncol = nd)
 384   colnames(c.CTR) <- paste('CTR -facteur', 1:nd, sep=' ')
 385   for (i in 1:nd)
 386     {
 387     c.COR[,i] <- obj$colmass * cpc[,i]^2 / obj$colinertia
 388     c.CTR[,i] <- obj$colmass * cpc[,i]^2 / obj$sv[i]^2
 389     }
 390   if (length(obj$colsup) > 0){
 391     i0 <- obj$colsup
 392     for (i in 1:nd){
 393       c.COR[i0,i] <- obj$colmass[i0] * cpc[i0,i]^2
 394       c.CTR[i0,i] <- NA
 395       }
 396     }
 397
 398  # scree plot:
 399   if (scree) {
 400     values     <- obj$sv^2
 401     values2    <- 100*(obj$sv^2)/sum(obj$sv^2)
 402     values3    <- cumsum(100*(obj$sv^2)/sum(obj$sv^2))
 403     scree.out  <- cbind(values, values2, values3)
 404     } else {
 405     scree.out <- NA
 406     }
 407
 408   obj$r.COR <- r.COR
 409   obj$r.CTR <- r.CTR
 410   obj$c.COR <- c.COR
 411   obj$c.CTR <- c.CTR
 412   obj$facteur <- scree.out
 413   return(obj)
 414   }
 415
 416 create_afc_table <- function(x) {
 417    #x = afc
 418         facteur.table <- as.matrix(x$facteur)
 419     nd <- ncol(x$colcoord)
 420         rownames(facteur.table) <- paste('facteur',1:nrow(facteur.table),sep = ' ')
 421     colnames(facteur.table) <- c('Valeurs propres', 'Pourcentages', 'Pourcentage cumules')
 422         ligne.table <- as.matrix(x$rowcoord)
 423         rownames(ligne.table) <- x$rownames
 424         colnames(ligne.table) <- paste('Coord. facteur', 1:nd, sep=' ')
 425     tmp <- as.matrix(x$rowcrl)
 426         colnames(tmp) <- paste('Corr. facteur', 1:nd, sep=' ')
 427         ligne.table <- cbind(ligne.table,tmp)
 428         ligne.table <- cbind(ligne.table, x$r.COR)
 429         ligne.table <- cbind(ligne.table, x$r.CTR)
 430         ligne.table <- cbind(ligne.table, mass = x$rowmass)
 431         ligne.table <- cbind(ligne.table, chi.distance = x$rowdist)
 432         ligne.table <- cbind(ligne.table, inertie = x$rowinertia)
 433     colonne.table <- x$colcoord
 434         rownames(colonne.table) <- paste('classe', 1:(nrow(colonne.table)),sep=' ')
 435         colnames(colonne.table) <- paste('Coord. facteur', 1:nd, sep=' ')
 436     tmp <- as.matrix(x$colcrl)
 437         colnames(tmp) <- paste('Corr. facteur', 1:nd, sep=' ')
 438         colonne.table <- cbind(colonne.table, tmp)
 439         colonne.table <- cbind(colonne.table, x$c.COR)
 440         colonne.table <- cbind(colonne.table, x$c.CTR)
 441         colonne.table <- cbind(colonne.table, mass = x$colmass)
 442         colonne.table <- cbind(colonne.table, chi.distance = x$coldist)
 443         colonne.table <- cbind(colonne.table, inertie = x$colinertia)
 444     res <- list(facteur = facteur.table, ligne = ligne.table, colonne = colonne.table)
 445         res
 446 }
 447
 448 is.yellow <- function(my.color) {
 449     if ((my.color[1] > 200) & (my.color[2] > 200) & (my.color[3] < 20)) {
 450         return(TRUE)
 451     } else {
 452         return(FALSE)
 453     }
 454 }
 455
 456 del.yellow <- function(colors) {
 457     rgbs <- col2rgb(colors)
 458     tochange <- apply(rgbs, 2, is.yellow)
 459     tochange <- which(tochange)
 460     if (length(tochange)) {
 461         gr.col <- grey.colors(length(tochange))
 462     }
 463     compt <- 1
 464     for (val in tochange) {
 465         colors[val] <- gr.col[compt]
 466         compt <- compt + 1
 467     }
 468     colors
 469 }
 470
 471 make_afc_graph <- function(toplot, classes, clnb, xlab, ylab, cex.txt = NULL, leg = FALSE, cmd = FALSE, black = FALSE, xminmax=NULL, yminmax=NULL) {
 472
 473     rain <- rainbow(clnb)
 474     compt <- 1
 475     tochange <- NULL
 476     for (my.color in rain) {
 477         my.color <- col2rgb(my.color)
 478         if ((my.color[1] > 200) & (my.color[2] > 200) & (my.color[3] < 20)) {
 479            tochange <- append(tochange, compt)
 480         }
 481         compt <- compt + 1
 482     }
 483     if (!is.null(tochange)) {
 484         gr.col <- grey.colors(length(tochange))
 485         compt <- 1
 486         for (val in tochange) {
 487             rain[val] <- gr.col[compt]
 488             compt <- compt + 1
 489         }
 490     }
 491         cl.color <- rain[classes]
 492     if (black) {
 493         cl.color <- 'black'
 494     }
 495         plot(toplot[,1],toplot[,2], pch='', xlab = xlab, ylab = ylab, xlim=xminmax, ylim = yminmax)
 496         abline(h=0, v=0, lty = 'dashed')
 497         if (is.null(cex.txt))
 498                 text(toplot[,1],toplot[,2],rownames(toplot),col=cl.color, offset=0)
 499         else
 500         text(toplot[,1],toplot[,2],rownames(toplot),col=cl.color, cex = cex.txt, offset=0)
 501
 502     if (!cmd) {
 503             dev.off()
 504     }
 505 }
 506
 507 plot.dendro.prof <- function(tree, classes, chisqtable, nbbycl = 60, type.dendro = "phylogram", from.cmd = FALSE, bw = FALSE, lab = NULL) {
 508     library(ape)
 509     library(wordcloud)
 510     classes<-classes[classes!=0]
 511         classes<-as.factor(classes)
 512         sum.cl<-as.matrix(summary(classes, maxsum=1000000))
 513         sum.cl<-(sum.cl/colSums(sum.cl)*100)
 514         sum.cl<-round(sum.cl,2)
 515         sum.cl<-cbind(sum.cl,as.matrix(100-sum.cl[,1]))
 516     sum.cl <- sum.cl[,1]
 517     tree.order<- as.numeric(tree$tip.label)
 518         vec.mat<-NULL
 519     row.keep <- select.chi.classe(chisqtable, nbbycl)
 520     toplot <- chisqtable[row.keep,]
 521     lclasses <- list()
 522     for (classe in 1:length(sum.cl)) {
 523        ntoplot <- toplot[,classe]
 524        names(ntoplot) <- rownames(toplot)
 525        ntoplot <- ntoplot[order(ntoplot, decreasing = TRUE)]
 526        ntoplot <- round(ntoplot, 0)
 527        ntoplot <- ntoplot[1:nbbycl]
 528        #ntoplot <- ntoplot[order(ntoplot)]
 529        #ntoplot <- ifelse(length(ntoplot) > nbbycl, ntoplot[1:nbbycl], ntoplot)
 530        lclasses[[classe]] <- ntoplot
 531     }
 532     vec.mat <- matrix(1, nrow = 3, ncol = length(sum.cl))
 533         vec.mat[2,] <- 2
 534     vec.mat[3,] <- 3:(length(sum.cl)+2)
 535     layout(matrix(vec.mat, nrow=3, ncol=length(sum.cl)),heights=c(1,1,6))
 536     if (! bw) {
 537         col <- rainbow(length(sum.cl))[as.numeric(tree$tip.label)]
 538         col <- del.yellow(col)
 539         colcloud <- rainbow(length(sum.cl))
 540         colcloud <- del.yellow(colcloud)
 541     }
 542     label.ori<-tree[[2]]
 543     if (!is.null(lab)) {
 544         tree$tip.label <- lab
 545     } else {
 546             tree[[2]]<-paste('classe ',tree[[2]])
 547     }
 548         par(mar=c(1,1,0,1))
 549         plot.phylo(tree,label.offset=0, tip.col=col, type=type.dendro, direction = 'downwards', srt=90, adj = 0.5, cex = 1.4, y.lim=c(-0.3,tree$Nnode))
 550         par(mar=c(0,0,0,0))
 551         d <- barplot(-sum.cl[tree.order], col=col, names.arg='', axes=FALSE, axisname=FALSE)
 552         text(x=d, y=(-sum.cl[tree.order]+3), label=paste(round(sum.cl[tree.order],1),'%'), cex=1.4)
 553     for (i in tree.order) {
 554         par(mar=c(0,0,1,0),cex=0.7)
 555         #wordcloud(names(lclasses[[i]]), lclasses[[i]], scale = c(1.5, 0.2), random.order=FALSE, colors = colcloud[i])
 556         yval <- 1.1
 557         plot(0,0,pch='', axes = FALSE)
 558         vcex <- norm.vec(lclasses[[i]], 1.5, 2.5)
 559         for (j in 1:length(lclasses[[i]])) {
 560             yval <- yval-(strheight( names(lclasses[[i]])[j],cex=vcex[j])+0.02)
 561             text(-0.9, yval, names(lclasses[[i]])[j], cex = vcex[j], col = colcloud[i], adj=0)
 562         }
 563     }
 564
 565 }
 566
 567 plot.dendro.cloud <- function(tree, classes, chisqtable, nbbycl = 60, type.dendro = "phylogram", from.cmd = FALSE, bw = FALSE, lab = NULL) {
 568     library(wordcloud)
 569     library(ape)
 570     classes<-classes[classes!=0]
 571         classes<-as.factor(classes)
 572         sum.cl<-as.matrix(summary(classes, maxsum=1000000))
 573         sum.cl<-(sum.cl/colSums(sum.cl)*100)
 574         sum.cl<-round(sum.cl,2)
 575         sum.cl<-cbind(sum.cl,as.matrix(100-sum.cl[,1]))
 576     sum.cl <- sum.cl[,1]
 577     tree.order<- as.numeric(tree$tip.label)
 578         vec.mat<-NULL
 579     row.keep <- select.chi.classe(chisqtable, nbbycl)
 580     toplot <- chisqtable[row.keep,]
 581     lclasses <- list()
 582     for (classe in 1:length(sum.cl)) {
 583        ntoplot <- toplot[,classe]
 584        ntoplot <- ntoplot[order(ntoplot, decreasing = TRUE)]
 585        ntoplot <- round(ntoplot, 0)
 586        ntoplot <- ntoplot[1:nbbycl]
 587        ntoplot <- ntoplot[order(ntoplot)]
 588        #ntoplot <- ifelse(length(ntoplot) > nbbycl, ntoplot[1:nbbycl], ntoplot)
 589        lclasses[[classe]] <- ntoplot
 590     }
 591         for (i in 1:length(sum.cl)) vec.mat<-append(vec.mat,1)
 592         v<-2
 593         for (i in 1:length(sum.cl)) {
 594                 vec.mat<-append(vec.mat,v)
 595                 v<-v+1
 596         }
 597     layout(matrix(vec.mat,length(sum.cl),2),widths=c(1,2))
 598     if (! bw) {
 599         col <- rainbow(length(sum.cl))[as.numeric(tree$tip.label)]
 600         colcloud <- rainbow(length(sum.cl))
 601     }
 602     par(mar=c(0,0,0,0))
 603     label.ori<-tree[[2]]
 604     if (!is.null(lab)) {
 605         tree$tip.label <- lab
 606     } else {
 607             tree[[2]]<-paste('classe ',tree[[2]])
 608     }
 609         plot.phylo(tree,label.offset=0.1,tip.col=col, type=type.dendro)
 610     for (i in rev(tree.order)) {
 611         par(mar=c(0,0,1,0),cex=0.9)
 612         wordcloud(names(lclasses[[i]]), lclasses[[i]], scale = c(4, 0.8), random.order=FALSE, colors = colcloud[i])
 613     }
 614 }
 615
 616 plot.dendropr <- function(tree, classes, type.dendro="phylogram", histo=FALSE, from.cmd=FALSE, bw=FALSE, lab = NULL, tclasse=TRUE) {
 617         classes<-classes[classes!=0]
 618         classes<-as.factor(classes)
 619         sum.cl<-as.matrix(summary(classes, maxsum=1000000))
 620         sum.cl<-(sum.cl/colSums(sum.cl)*100)
 621         sum.cl<-round(sum.cl,2)
 622         sum.cl<-cbind(sum.cl,as.matrix(100-sum.cl[,1]))
 623     tree.order<- as.numeric(tree$tip.label)
 624
 625
 626     if (! bw) {
 627         col <- rainbow(nrow(sum.cl))[as.numeric(tree$tip.label)]
 628         col <- del.yellow(col)
 629         col.bars <- col
 630         col.pie <- rainbow(nrow(sum.cl))
 631         col.pie <- del.yellow(col.pie)
 632             #col.vec<-rainbow(nrow(sum.cl))[as.numeric(tree[[2]])]
 633     } else {
 634         col = 'black'
 635         col.bars = 'grey'
 636         col.pie <- rep('grey',nrow(sum.cl))
 637     }
 638         vec.mat<-NULL
 639         for (i in 1:nrow(sum.cl)) vec.mat<-append(vec.mat,1)
 640         v<-2
 641         for (i in 1:nrow(sum.cl)) {
 642                 vec.mat<-append(vec.mat,v)
 643                 v<-v+1
 644         }
 645         par(mar=c(0,0,0,0))
 646     if (tclasse) {
 647         if (! histo) {
 648                 layout(matrix(vec.mat,nrow(sum.cl),2),widths=c(3,1))
 649         } else {
 650             layout(matrix(c(1,2),1,byrow=TRUE), widths=c(3,2),TRUE)
 651         }
 652     }
 653         par(mar=c(0,0,0,0),cex=1)
 654         label.ori<-tree[[2]]
 655     if (!is.null(lab)) {
 656         tree$tip.label <- lab
 657     } else {
 658             tree[[2]]<-paste('classe ',tree[[2]])
 659     }
 660         plot.phylo(tree,label.offset=0.1,tip.col=col, type=type.dendro)
 661     #cl.order <- as.numeric(label.ori)
 662     #sum.cl[cl.order,1]
 663         #for (i in 1:nrow(sum.cl)) {
 664     if (tclasse) {
 665         if (! histo) {
 666             for (i in rev(tree.order)) {
 667                 par(mar=c(0,0,1,0),cex=0.7)
 668                     pie(sum.cl[i,],col=c(col.pie[i],'white'),radius = 1, labels='', clockwise=TRUE, main = paste('classe ',i,' - ',sum.cl[i,1],'%' ))
 669             }
 670         } else {
 671             par(cex=0.7)
 672             par(mar=c(0,0,0,1))
 673             to.plot <- sum.cl[tree.order,1]
 674             d <- barplot(to.plot,horiz=TRUE, col=col.bars, names.arg='', axes=FALSE, axisname=FALSE)
 675             text(x=to.plot, y=d[,1], label=paste(round(to.plot,1),'%'), adj=1.2)
 676         }
 677     }
 678     if (!from.cmd) dev.off()
 679         tree[[2]]<-label.ori
 680 }
 681 #tree <- tree.cut1$tree.cl
 682 #to.plot <- di
 683 plot.dendro.lex <- function(tree, to.plot, bw=FALSE, lab=NULL, lay.width=c(3,3,2), colbar=NULL, classes=NULL, cmd=FALSE) {
 684     tree.order<- as.numeric(tree$tip.label)
 685         if (!is.null(classes)) {
 686                 classes<-classes[classes!=0]
 687                 classes<-as.factor(classes)
 688                 sum.cl<-as.matrix(summary(classes, maxsum=1000000))
 689                 sum.cl<-(sum.cl/colSums(sum.cl)*100)
 690                 sum.cl<-round(sum.cl,2)
 691                 sum.cl<-cbind(sum.cl,as.matrix(100-sum.cl[,1]))
 692         }
 693     par(mar=c(0,0,0,0))
 694         if (!is.null(classes)) {
 695                 matlay <- matrix(c(1,2,3,4),1,byrow=TRUE)
 696                 lay.width <- c(3,1,3,2)
 697         } else {
 698                 matlay <- matrix(c(1,2,3),1,byrow=TRUE)
 699         }
 700     layout(matlay, widths=lay.width,TRUE)
 701         par(mar=c(3,0,2,0),cex=1)
 702         label.ori<-tree[[2]]
 703     if (!is.null(lab)) {
 704         tree$tip.label <- lab
 705     } else {
 706             tree[[2]]<-paste('classe ',tree[[2]])
 707     }
 708     to.plot <- matrix(to.plot[,tree.order], nrow=nrow(to.plot), dimnames=list(rownames(to.plot), colnames(to.plot)))
 709     if (!bw) {
 710                 col <- rainbow(ncol(to.plot))
 711                 col <- del.yellow(col)
 712                 if (is.null(colbar)) {
 713                 col.bars <- rainbow(nrow(to.plot))
 714                 col.bars <- del.yellow(col.bars)
 715                 } else {
 716                         col.bars <- colbar
 717                 }
 718     } else {
 719         col <- 'black'
 720         col.bars <- grey.colors(nrow(to.plot),0,0.8)
 721     }
 722     col <- col[tree.order]
 723         plot.phylo(tree,label.offset=0.1,tip.col=col)
 724         if (!is.null(classes)) {
 725                 par(cex=0.7)
 726                 par(mar=c(3,0,2,1))
 727                 to.plota <- sum.cl[tree.order,1]
 728                 d <- barplot(to.plota,horiz=TRUE, col=col, names.arg='', axes=FALSE, axisname=FALSE)
 729                 text(x=to.plota, y=d[,1], label=paste(round(to.plota,1),'%'), adj=1.2)
 730         }
 731     par(mar=c(3,0,2,1))
 732     d <- barplot(to.plot,horiz=TRUE, col=col.bars, beside=TRUE, names.arg='', space = c(0.1,0.6), axisname=FALSE)
 733     c <- colMeans(d)
 734     c1 <- c[-1]
 735     c2 <- c[-length(c)]
 736     cc <- cbind(c1,c2)
 737     lcoord <- apply(cc, 1, mean)
 738     abline(h=lcoord)
 739     if (min(to.plot) < 0) {
 740         amp <- abs(max(to.plot) - min(to.plot))
 741     } else {
 742         amp <- max(to.plot)
 743     }
 744     if (amp < 10) {
 745         d <- 2
 746     } else {
 747         d <- signif(amp%/%10,1)
 748     }
 749     mn <- round(min(to.plot))
 750     mx <- round(max(to.plot))
 751     for (i in mn:mx) {
 752         if ((i/d) == (i%/%d)) {
 753             abline(v=i,lty=3)
 754         }
 755     }
 756     par(mar=c(0,0,0,0))
 757     plot(0, axes = FALSE, pch = '')
 758     legend(x = 'center' , rownames(to.plot), fill = col.bars)
 759     if (!cmd) {
 760         dev.off()
 761     }
 762         tree[[2]]<-label.ori
 763 }
 764
 765 plot.alceste.graph <- function(rdata,nd=3,layout='fruke', chilim = 2) {
 766     load(rdata)
 767     if (is.null(debsup)) {
 768         tab.toplot<-afctable[1:(debet+1),]
 769         chitab<-chistabletot[1:(debet+1),]
 770     } else {
 771         tab.toplot<-afctable[1:(debsup+1),]
 772         chitab<-chistabletot[1:(debsup+1),]
 773     }
 774     rkeep<-select_point_chi(chitab,chilim)
 775     tab.toplot<-tab.toplot[rkeep,]
 776     chitab<-chitab[rkeep,]
 777     dm<-dist(tab.toplot,diag=TRUE,upper=TRUE)
 778     cn<-rownames(tab.toplot)
 779     cl.toplot<-apply(chitab,1,which.max)
 780     col<-rainbow(ncol(tab.toplot))[cl.toplot]
 781     library(igraph)
 782     g1 <- graph.adjacency(as.matrix(dm), mode = 'lower', weighted = TRUE)
 783     g.max<-minimum.spanning.tree(g1)
 784     we<-(rowSums(tab.toplot)/max(rowSums(tab.toplot)))*2
 785     #lo <- layout.fruchterman.reingold(g.max,dim=nd)
 786     lo<- layout.kamada.kawai(g.max,dim=nd)
 787     print(nrow(tab.toplot))
 788     print(nrow(chitab))
 789     print(length(we))
 790     print(length(col))
 791     print(length(cn))
 792     if (nd == 3) {
 793         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)
 794     } else if (nd == 2) {
 795         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)
 796     }
 797
 798 }
 799
 800 make.simi.afc <- function(x,chitable,lim=0, alpha = 0.1, movie = NULL) {
 801     library(igraph)
 802     chimax<-as.matrix(apply(chitable,1,max))
 803     chimax<-as.matrix(chimax[,1][1:nrow(x)])
 804     chimax<-cbind(chimax,1:nrow(x))
 805     order_chi<-as.matrix(chimax[order(chimax[,1],decreasing = TRUE),])
 806     if ((lim == 0) || (lim>nrow(x))) lim <- nrow(x)
 807     x<-x[order_chi[,2][1:lim],]
 808     maxchi <- chimax[order_chi[,2][1:lim],1]
 809     #-------------------------------------------------------
 810     limit<-nrow(x)
 811     distm<-dist(x,diag=TRUE)
 812     distm<-as.matrix(distm)
 813     g1<-graph.adjacency(distm,mode='lower',weighted=TRUE)
 814     g1<-minimum.spanning.tree(g1)
 815     lo<-layout.kamada.kawai(g1,dim=3)
 816     lo <- layout.norm(lo, -3, 3, -3, 3, -3, 3)
 817     mc<-rainbow(ncol(chistabletot))
 818     chitable<-chitable[order_chi[,2][1:lim],]
 819     cc <- apply(chitable, 1, which.max)
 820     cc<-mc[cc]
 821     #mass<-(rowSums(x)/max(rowSums(x))) * 5
 822     maxchi<-norm.vec(maxchi, 0.03, 0.3)
 823     rglplot(g1,vertex.label = vire.nonascii(rownames(x)),vertex.label.color= cc,vertex.label.cex = maxchi, vertex.size = 0.1, layout=lo, rescale=FALSE)
 824     text3d(lo[,1], lo[,2],lo[,3], rownames(x), cex=maxchi, col=cc)
 825     #rgl.spheres(lo, col = cc, radius = maxchi, alpha = alpha)
 826     rgl.bg(color = c('white','black'))
 827     if (!is.null(movie)) {
 828         require(tcltk)
 829         ReturnVal <- tkmessageBox(title="RGL 3 D",message="Cliquez pour commencer le film",icon="info",type="ok")
 830
 831         movie3d(spin3d(axis=c(0,1,0),rpm=6), movie = 'film_graph', frames = "tmpfilm", duration=10, clean=TRUE, top = TRUE, dir = movie)
 832         ReturnVal <- tkmessageBox(title="RGL 3 D",message="Film fini !",icon="info",type="ok")
 833     }
 834         while (rgl.cur() != 0)
 835                 Sys.sleep(1)
 836
 837 }
 838
 839 # from igraph
 840 norm.vec <- function(v, min, max) {
 841
 842   vr <- range(v)
 843   if (vr[1]==vr[2]) {
 844     fac <- 1
 845   } else {
 846     fac <- (max-min)/(vr[2]-vr[1])
 847   }
 848   (v-vr[1]) * fac + min
 849 }
 850
 851
 852 vire.nonascii <- function(rnames) {
 853     print('vire non ascii')
 854     couple <- list(c('é','e'),
 855                 c('è','e'),
 856                 c('ê','e'),
 857                 c('ë','e'),
 858                 c('î','i'),
 859                 c('ï','i'),
 860                 c('ì','i'),
 861                 c('à','a'),
 862                 c('â','a'),
 863                 c('ä','a'),
 864                 c('á','a'),
 865                 c('ù','u'),
 866                 c('û','u'),
 867                 c('ü','u'),
 868                 c('ç','c'),
 869                 c('ò','o'),
 870                 c('ô','o'),
 871                 c('ö','o'),
 872                 c('ñ','n')
 873                 )
 874
 875     for (c in couple) {
 876         rnames<-gsub(c[1],c[2], rnames)
 877     }
 878     rnames
 879 }
 880
 881
 882
 883 #par(mar=c(0,0,0,0))
 884 #layout(matrix(c(1,2),1,byrow=TRUE), widths=c(3,2),TRUE)
 885 #par(mar=c(1,0,1,0), cex=1)
 886 #plot.phylo(tree,label.offset=0.1)
 887 #par(mar=c(0,0,0,1))
 888 #to.plot <- sum.cl[cl.order,1]
 889 #d <- barplot(to.plot,horiz=TRUE, names.arg='', axes=FALSE, axisname=FALSE)
 890 #text(x=to.plot, y=d[,1], label=round(to.plot,1), adj=1.2)
 891
 892 make.afc.attributes <- function(rn, afc.table, contafc, clnb, column = FALSE, x=1, y=2) {
 893     if (!column){
 894         nd <- clnb - 1
 895         afc.res <- afc.table$ligne
 896         #tokeep <- which(row.names(afc.res) %in% rn)
 897         afc.res <- afc.res[rn,]
 898         debcor <- (nd*2) + 1
 899         cor <- afc.res[,debcor:(debcor+nd-1)][,c(x,y)]
 900         debctr <- (nd*3) + 1
 901         ctr <- afc.res[,debctr:(debctr+nd-1)][,c(x,y)]
 902         massdeb <- (nd*4) + 1
 903         mass <- afc.res[,massdeb]
 904         chideb <- massdeb + 1
 905         chi <- afc.res[,chideb]
 906         inertiadeb <- chideb + 1
 907         inertia <- afc.res[,inertiadeb]
 908         frequence <- rowSums(contafc[rn,])
 909     }
 910     res <- list(frequence=frequence, cor, ctr, mass = mass, chi=chi, inertia=inertia)
 911     return(res)
 912 }
 913
 914
 915 afctogexf <- function(fileout, toplot, classes, clnb, sizes, nodes.attr=NULL) {
 916     toplot <- toplot[,1:3]
 917     toplot[,3] <- 0
 918     #toplot <- afc$rowcoord[1:100,1:3]
 919     #toplot[,3] <- 0
 920     #rownames(toplot)<-afc$rownames[1:100]
 921     cc <- rainbow(clnb)[classes]
 922     cc <- t(sapply(cc, col2rgb, alpha=TRUE))
 923     #sizes <- apply(chistabletot[1:100,], 1, max)
 924
 925     nodes <- data.frame(cbind(1:nrow(toplot), rownames(toplot)))
 926     colnames(nodes) <- c('id', 'label')
 927     nodes[,1] <- as.character(nodes[,1])
 928     nodes[,2] <- as.character(nodes[,2])
 929     #nodes attributs
 930     if (! is.null(nodes.attr)) {
 931         nodesatt <- as.data.frame(nodes.attr)
 932     } else {
 933         nodesatt <- data.frame(cbind(toplot[,1],toplot[,2]))
 934     }
 935     #make axes
 936     edges<-matrix(c(1,1),ncol=2)
 937     xmin <- min(toplot[,1])
 938     xmax <- max(toplot[,1])
 939     ymin <- min(toplot[,2])
 940     ymax <- max(toplot[,2])
 941     nodes<-rbind(nodes, c(nrow(nodes)+1, 'F1'))
 942     nodes<-rbind(nodes, c(nrow(nodes)+1, 'F1'))
 943     nodes<-rbind(nodes, c(nrow(nodes)+1, 'F2'))
 944     nodes<-rbind(nodes, c(nrow(nodes)+1, 'F2'))
 945     nodesatt<-rbind(nodesatt, c(0,0))
 946     nodesatt<-rbind(nodesatt, c(0,0))
 947     nodesatt<-rbind(nodesatt, c(0,0))
 948     nodesatt<-rbind(nodesatt, c(0,0))
 949     toplot <- rbind(toplot, c(xmin, 0,0))
 950     toplot <- rbind(toplot, c(xmax,0,0))
 951     toplot <- rbind(toplot, c(0,ymin,0))
 952     toplot <- rbind(toplot, c(0,ymax,0))
 953     cc <- rbind(cc, c(255,255,255,1))
 954     cc <- rbind(cc, c(255,255,255,1))
 955     cc <- rbind(cc, c(255,255,255,1))
 956     cc <- rbind(cc, c(255,255,255,1))
 957     sizes <- c(sizes, c(0.5, 0.5, 0.5, 0.5))
 958     edges <- rbind(edges, c(nrow(nodes)-3, nrow(nodes)-2))
 959     edges <- rbind(edges, c(nrow(nodes)-1, nrow(nodes)))
 960     write.gexf(nodes, edges, output=fileout, nodesAtt=nodesatt, nodesVizAtt=list(color=cc, position=toplot, size=sizes))
 961 }
 962
 963 simi.to.gexf <- function(fileout, graph.simi, nodes.attr = NULL) {
 964         lo <- graph.simi$layout
 965         if (ncol(lo) == 3) {
 966                 lo[,3] <- 0
 967         } else {
 968                 lo <- cbind(lo, rep(0,nrow(lo)))
 969         }
 970         g <- graph.simi$graph
 971         nodes <- data.frame(cbind(1:nrow(lo), V(g)$name))
 972         colnames(nodes) <- c('id', 'label')
 973         print(nodes)
 974         if (! is.null(nodes.attr)) {
 975                 nodesatt <- as.data.frame(nodes.attr)
 976         } else {
 977                 nodesatt <- data.frame(cbind(lo[,1],lo[,2]))
 978         }
 979         edges <- as.data.frame(get.edges(g, c(1:ecount(g))))
 980         col <- rep('red', nrow(lo))
 981         col <- t(sapply(col, col2rgb, alpha=TRUE))
 982         write.gexf(nodes, edges, output=fileout, nodesAtt=nodesatt, nodesVizAtt=list(color=col,position=lo))
 983 }