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