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)
 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         cl.color <- rain[classes]
 593     if (black) {
 594         cl.color <- 'black'
 595     }
 596         plot(toplot[,1],toplot[,2], pch='', xlab = xlab, ylab = ylab, xlim=xminmax, ylim = yminmax)
 597         abline(h=0, v=0, lty = 'dashed')
 598         if (is.null(cex.txt))
 599                 text(toplot[,1],toplot[,2],rownames(toplot),col=cl.color, offset=0)
 600         else
 601                 #require(wordcloud)
 602                 #textplot(toplot[,1],toplot[,2],rownames(toplot),col=cl.color, cex = cex.txt, xlim=xminmax, ylim = yminmax)
 603         text(toplot[,1],toplot[,2],rownames(toplot),col=cl.color, cex = cex.txt, offset=0)
 604
 605     if (!cmd) {
 606             dev.off()
 607     }
 608 }
 609
 610 plot.dendro.prof <- function(tree, classes, chisqtable, nbbycl = 60, type.dendro = "phylogram", from.cmd = FALSE, bw = FALSE, lab = NULL) {
 611     library(ape)
 612     library(wordcloud)
 613     classes<-classes[classes!=0]
 614         classes<-as.factor(classes)
 615         sum.cl<-as.matrix(summary(classes, maxsum=1000000))
 616         sum.cl<-(sum.cl/colSums(sum.cl)*100)
 617         sum.cl<-round(sum.cl,2)
 618         sum.cl<-cbind(sum.cl,as.matrix(100-sum.cl[,1]))
 619     sum.cl <- sum.cl[,1]
 620     tree.order<- as.numeric(tree$tip.label)
 621         vec.mat<-NULL
 622     row.keep <- select.chi.classe(chisqtable, nbbycl)
 623     toplot <- chisqtable[row.keep,]
 624     lclasses <- list()
 625     for (classe in 1:length(sum.cl)) {
 626        ntoplot <- toplot[,classe]
 627        names(ntoplot) <- rownames(toplot)
 628        ntoplot <- ntoplot[order(ntoplot, decreasing = TRUE)]
 629        ntoplot <- round(ntoplot, 0)
 630        ntoplot <- ntoplot[1:nbbycl]
 631        #ntoplot <- ntoplot[order(ntoplot)]
 632        #ntoplot <- ifelse(length(ntoplot) > nbbycl, ntoplot[1:nbbycl], ntoplot)
 633        lclasses[[classe]] <- ntoplot
 634     }
 635     vec.mat <- matrix(1, nrow = 3, ncol = length(sum.cl))
 636         vec.mat[2,] <- 2
 637     vec.mat[3,] <- 3:(length(sum.cl)+2)
 638     layout(matrix(vec.mat, nrow=3, ncol=length(sum.cl)),heights=c(2,1,6))
 639     if (! bw) {
 640         col <- rainbow(length(sum.cl))[as.numeric(tree$tip.label)]
 641         col <- del.yellow(col)
 642         colcloud <- rainbow(length(sum.cl))
 643         colcloud <- del.yellow(colcloud)
 644     }
 645     label.ori<-tree[[2]]
 646     if (!is.null(lab)) {
 647         tree$tip.label <- lab
 648     } else {
 649             tree[[2]]<-paste('classe ',tree[[2]])
 650     }
 651         par(mar=c(2,1,0,1))
 652         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))
 653         par(mar=c(0,0,0,0))
 654         d <- barplot(-sum.cl[tree.order], col=col, names.arg='', axes=FALSE, axisname=FALSE)
 655         text(x=d, y=(-sum.cl[tree.order]+3), label=paste(round(sum.cl[tree.order],1),'%'), cex=1.4)
 656     for (i in tree.order) {
 657         par(mar=c(0,0,1,0),cex=0.7)
 658         #wordcloud(names(lclasses[[i]]), lclasses[[i]], scale = c(1.5, 0.2), random.order=FALSE, colors = colcloud[i])
 659         yval <- 1.1
 660         plot(0,0,pch='', axes = FALSE)
 661         vcex <- norm.vec(lclasses[[i]], 1.5, 2.5)
 662         for (j in 1:length(lclasses[[i]])) {
 663             yval <- yval-(strheight( names(lclasses[[i]])[j],cex=vcex[j])+0.02)
 664             text(-0.9, yval, names(lclasses[[i]])[j], cex = vcex[j], col = colcloud[i], adj=0)
 665         }
 666     }
 667
 668 }
 669
 670 plot.dendro.cloud <- function(tree, classes, chisqtable, nbbycl = 60, type.dendro = "phylogram", from.cmd = FALSE, bw = FALSE, lab = NULL) {
 671     library(wordcloud)
 672     library(ape)
 673     classes<-classes[classes!=0]
 674         classes<-as.factor(classes)
 675         sum.cl<-as.matrix(summary(classes, maxsum=1000000))
 676         sum.cl<-(sum.cl/colSums(sum.cl)*100)
 677         sum.cl<-round(sum.cl,2)
 678         sum.cl<-cbind(sum.cl,as.matrix(100-sum.cl[,1]))
 679     sum.cl <- sum.cl[,1]
 680     tree.order<- as.numeric(tree$tip.label)
 681         vec.mat<-NULL
 682     row.keep <- select.chi.classe(chisqtable, nbbycl)
 683     toplot <- chisqtable[row.keep,]
 684     lclasses <- list()
 685     for (classe in 1:length(sum.cl)) {
 686        ntoplot <- toplot[,classe]
 687        ntoplot <- ntoplot[order(ntoplot, decreasing = TRUE)]
 688        ntoplot <- round(ntoplot, 0)
 689        ntoplot <- ntoplot[1:nbbycl]
 690        ntoplot <- ntoplot[order(ntoplot)]
 691        #ntoplot <- ifelse(length(ntoplot) > nbbycl, ntoplot[1:nbbycl], ntoplot)
 692        lclasses[[classe]] <- ntoplot
 693     }
 694         for (i in 1:length(sum.cl)) vec.mat<-append(vec.mat,1)
 695         v<-2
 696         for (i in 1:length(sum.cl)) {
 697                 vec.mat<-append(vec.mat,v)
 698                 v<-v+1
 699         }
 700     layout(matrix(vec.mat,length(sum.cl),2),widths=c(1,2))
 701     if (! bw) {
 702         col <- rainbow(length(sum.cl))[as.numeric(tree$tip.label)]
 703         colcloud <- rainbow(length(sum.cl))
 704     }
 705     par(mar=c(0,0,0,0))
 706     label.ori<-tree[[2]]
 707     if (!is.null(lab)) {
 708         tree$tip.label <- lab
 709     } else {
 710             tree[[2]]<-paste('classe ',tree[[2]])
 711     }
 712         plot.phylo(tree,label.offset=0.1,tip.col=col, type=type.dendro)
 713     for (i in rev(tree.order)) {
 714         par(mar=c(0,0,1,0),cex=0.9)
 715         wordcloud(names(lclasses[[i]]), lclasses[[i]], scale = c(4, 0.8), random.order=FALSE, colors = colcloud[i])
 716     }
 717 }
 718
 719 plot.dendropr <- function(tree, classes, type.dendro="phylogram", histo=FALSE, from.cmd=FALSE, bw=FALSE, lab = NULL, tclasse=TRUE) {
 720         classes<-classes[classes!=0]
 721         classes<-as.factor(classes)
 722         sum.cl<-as.matrix(summary(classes, maxsum=1000000))
 723         sum.cl<-(sum.cl/colSums(sum.cl)*100)
 724         sum.cl<-round(sum.cl,2)
 725         sum.cl<-cbind(sum.cl,as.matrix(100-sum.cl[,1]))
 726     tree.order<- as.numeric(tree$tip.label)
 727
 728
 729     if (! bw) {
 730         col <- rainbow(nrow(sum.cl))[as.numeric(tree$tip.label)]
 731         col <- del.yellow(col)
 732         col.bars <- col
 733         col.pie <- rainbow(nrow(sum.cl))
 734         col.pie <- del.yellow(col.pie)
 735             #col.vec<-rainbow(nrow(sum.cl))[as.numeric(tree[[2]])]
 736     } else {
 737         col = 'black'
 738         col.bars = 'grey'
 739         col.pie <- rep('grey',nrow(sum.cl))
 740     }
 741         vec.mat<-NULL
 742         for (i in 1:nrow(sum.cl)) vec.mat<-append(vec.mat,1)
 743         v<-2
 744         for (i in 1:nrow(sum.cl)) {
 745                 vec.mat<-append(vec.mat,v)
 746                 v<-v+1
 747         }
 748         par(mar=c(0,0,0,0))
 749     if (tclasse) {
 750         if (! histo) {
 751                 layout(matrix(vec.mat,nrow(sum.cl),2),widths=c(3,1))
 752         } else {
 753             layout(matrix(c(1,2),1,byrow=TRUE), widths=c(3,2),TRUE)
 754         }
 755     }
 756         par(mar=c(0,0,0,0),cex=1)
 757         label.ori<-tree[[2]]
 758     if (!is.null(lab)) {
 759         tree$tip.label <- lab
 760     } else {
 761             tree[[2]]<-paste('classe ',tree[[2]])
 762     }
 763         plot.phylo(tree,label.offset=0.1,tip.col=col, type=type.dendro)
 764     #cl.order <- as.numeric(label.ori)
 765     #sum.cl[cl.order,1]
 766         #for (i in 1:nrow(sum.cl)) {
 767     if (tclasse) {
 768         if (! histo) {
 769             for (i in rev(tree.order)) {
 770                 par(mar=c(0,0,1,0),cex=0.7)
 771                     pie(sum.cl[i,],col=c(col.pie[i],'white'),radius = 1, labels='', clockwise=TRUE, main = paste('classe ',i,' - ',sum.cl[i,1],'%' ))
 772             }
 773         } else {
 774             par(cex=0.7)
 775             par(mar=c(0,0,0,1))
 776             to.plot <- sum.cl[tree.order,1]
 777             d <- barplot(to.plot,horiz=TRUE, col=col.bars, names.arg='', axes=FALSE, axisname=FALSE)
 778             text(x=to.plot, y=d[,1], label=paste(round(to.plot,1),'%'), adj=1.2)
 779         }
 780     }
 781     if (!from.cmd) dev.off()
 782         tree[[2]]<-label.ori
 783 }
 784 #tree <- tree.cut1$tree.cl
 785 #to.plot <- di
 786 plot.dendro.lex <- function(tree, to.plot, bw=FALSE, lab=NULL, lay.width=c(3,3,2), colbar=NULL, classes=NULL, cmd=FALSE) {
 787     tree.order<- as.numeric(tree$tip.label)
 788         if (!is.null(classes)) {
 789                 classes<-classes[classes!=0]
 790                 classes<-as.factor(classes)
 791                 sum.cl<-as.matrix(summary(classes, maxsum=1000000))
 792                 sum.cl<-(sum.cl/colSums(sum.cl)*100)
 793                 sum.cl<-round(sum.cl,2)
 794                 sum.cl<-cbind(sum.cl,as.matrix(100-sum.cl[,1]))
 795         }
 796     par(mar=c(0,0,0,0))
 797         if (!is.null(classes)) {
 798                 matlay <- matrix(c(1,2,3,4),1,byrow=TRUE)
 799                 lay.width <- c(3,1,3,2)
 800         } else {
 801                 matlay <- matrix(c(1,2,3),1,byrow=TRUE)
 802         }
 803     layout(matlay, widths=lay.width,TRUE)
 804         par(mar=c(3,0,2,0),cex=1)
 805         label.ori<-tree[[2]]
 806     if (!is.null(lab)) {
 807         tree$tip.label <- lab
 808     } else {
 809             tree[[2]]<-paste('classe ',tree[[2]])
 810     }
 811     to.plot <- matrix(to.plot[,tree.order], nrow=nrow(to.plot), dimnames=list(rownames(to.plot), colnames(to.plot)))
 812     if (!bw) {
 813                 col <- rainbow(ncol(to.plot))
 814                 col <- del.yellow(col)
 815                 if (is.null(colbar)) {
 816                 col.bars <- rainbow(nrow(to.plot))
 817                 col.bars <- del.yellow(col.bars)
 818                 } else {
 819                         col.bars <- colbar
 820                 }
 821     } else {
 822         col <- 'black'
 823         col.bars <- grey.colors(nrow(to.plot),0,0.8)
 824     }
 825     col <- col[tree.order]
 826         plot.phylo(tree,label.offset=0.1,tip.col=col)
 827         if (!is.null(classes)) {
 828                 par(cex=0.7)
 829                 par(mar=c(3,0,2,1))
 830                 to.plota <- sum.cl[tree.order,1]
 831                 d <- barplot(to.plota,horiz=TRUE, col=col, names.arg='', axes=FALSE, axisname=FALSE)
 832                 text(x=to.plota, y=d[,1], label=paste(round(to.plota,1),'%'), adj=1.2)
 833         }
 834     par(mar=c(3,0,2,1))
 835     d <- barplot(to.plot,horiz=TRUE, col=col.bars, beside=TRUE, names.arg='', space = c(0.1,0.6), axisname=FALSE)
 836     c <- colMeans(d)
 837     c1 <- c[-1]
 838     c2 <- c[-length(c)]
 839     cc <- cbind(c1,c2)
 840     lcoord <- apply(cc, 1, mean)
 841     abline(h=lcoord)
 842     if (min(to.plot) < 0) {
 843         amp <- abs(max(to.plot) - min(to.plot))
 844     } else {
 845         amp <- max(to.plot)
 846     }
 847     if (amp < 10) {
 848         d <- 2
 849     } else {
 850         d <- signif(amp%/%10,1)
 851     }
 852     mn <- round(min(to.plot))
 853     mx <- round(max(to.plot))
 854     for (i in mn:mx) {
 855         if ((i/d) == (i%/%d)) {
 856             abline(v=i,lty=3)
 857         }
 858     }
 859     par(mar=c(0,0,0,0))
 860     plot(0, axes = FALSE, pch = '')
 861     legend(x = 'center' , rownames(to.plot), fill = col.bars)
 862     if (!cmd) {
 863         dev.off()
 864     }
 865         tree[[2]]<-label.ori
 866 }
 867
 868 plot.alceste.graph <- function(rdata,nd=3,layout='fruke', chilim = 2) {
 869     load(rdata)
 870     if (is.null(debsup)) {
 871         tab.toplot<-afctable[1:(debet+1),]
 872         chitab<-chistabletot[1:(debet+1),]
 873     } else {
 874         tab.toplot<-afctable[1:(debsup+1),]
 875         chitab<-chistabletot[1:(debsup+1),]
 876     }
 877     rkeep<-select_point_chi(chitab,chilim)
 878     tab.toplot<-tab.toplot[rkeep,]
 879     chitab<-chitab[rkeep,]
 880     dm<-dist(tab.toplot,diag=TRUE,upper=TRUE)
 881     cn<-rownames(tab.toplot)
 882     cl.toplot<-apply(chitab,1,which.max)
 883     col<-rainbow(ncol(tab.toplot))[cl.toplot]
 884     library(igraph)
 885     g1 <- graph.adjacency(as.matrix(dm), mode = 'lower', weighted = TRUE)
 886     g.max<-minimum.spanning.tree(g1)
 887     we<-(rowSums(tab.toplot)/max(rowSums(tab.toplot)))*2
 888     #lo <- layout.fruchterman.reingold(g.max,dim=nd)
 889     lo<- layout.kamada.kawai(g.max,dim=nd)
 890     print(nrow(tab.toplot))
 891     print(nrow(chitab))
 892     print(length(we))
 893     print(length(col))
 894     print(length(cn))
 895     if (nd == 3) {
 896         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)
 897     } else if (nd == 2) {
 898         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)
 899     }
 900
 901 }
 902
 903 make.simi.afc <- function(x,chitable,lim=0, alpha = 0.1, movie = NULL) {
 904     library(igraph)
 905     chimax<-as.matrix(apply(chitable,1,max))
 906     chimax<-as.matrix(chimax[,1][1:nrow(x)])
 907     chimax<-cbind(chimax,1:nrow(x))
 908     order_chi<-as.matrix(chimax[order(chimax[,1],decreasing = TRUE),])
 909     if ((lim == 0) || (lim>nrow(x))) lim <- nrow(x)
 910     x<-x[order_chi[,2][1:lim],]
 911     maxchi <- chimax[order_chi[,2][1:lim],1]
 912     #-------------------------------------------------------
 913     limit<-nrow(x)
 914     distm<-dist(x,diag=TRUE)
 915     distm<-as.matrix(distm)
 916     g1<-graph.adjacency(distm,mode='lower',weighted=TRUE)
 917     g1<-minimum.spanning.tree(g1)
 918     lo<-layout.kamada.kawai(g1,dim=3)
 919     lo <- layout.norm(lo, -3, 3, -3, 3, -3, 3)
 920     mc<-rainbow(ncol(chistabletot))
 921     chitable<-chitable[order_chi[,2][1:lim],]
 922     cc <- apply(chitable, 1, which.max)
 923     cc<-mc[cc]
 924     #mass<-(rowSums(x)/max(rowSums(x))) * 5
 925     maxchi<-norm.vec(maxchi, 0.03, 0.3)
 926     rglplot(g1,vertex.label = vire.nonascii(rownames(x)),vertex.label.color= cc,vertex.label.cex = maxchi, vertex.size = 0.1, layout=lo, rescale=FALSE)
 927     text3d(lo[,1], lo[,2],lo[,3], rownames(x), cex=maxchi, col=cc)
 928     #rgl.spheres(lo, col = cc, radius = maxchi, alpha = alpha)
 929     rgl.bg(color = c('white','black'))
 930     if (!is.null(movie)) {
 931         require(tcltk)
 932         ReturnVal <- tkmessageBox(title="RGL 3 D",message="Cliquez pour commencer le film",icon="info",type="ok")
 933
 934         movie3d(spin3d(axis=c(0,1,0),rpm=6), movie = 'film_graph', frames = "tmpfilm", duration=10, clean=TRUE, top = TRUE, dir = movie)
 935         ReturnVal <- tkmessageBox(title="RGL 3 D",message="Film fini !",icon="info",type="ok")
 936     }
 937         while (rgl.cur() != 0)
 938                 Sys.sleep(1)
 939
 940 }
 941
 942 # from igraph
 943 norm.vec <- function(v, min, max) {
 944
 945   vr <- range(v)
 946   if (vr[1]==vr[2]) {
 947     fac <- 1
 948   } else {
 949     fac <- (max-min)/(vr[2]-vr[1])
 950   }
 951   (v-vr[1]) * fac + min
 952 }
 953
 954
 955 vire.nonascii <- function(rnames) {
 956     print('vire non ascii')
 957     couple <- list(c('é','e'),
 958                 c('è','e'),
 959                 c('ê','e'),
 960                 c('ë','e'),
 961                 c('î','i'),
 962                 c('ï','i'),
 963                 c('ì','i'),
 964                 c('à','a'),
 965                 c('â','a'),
 966                 c('ä','a'),
 967                 c('á','a'),
 968                 c('ù','u'),
 969                 c('û','u'),
 970                 c('ü','u'),
 971                 c('ç','c'),
 972                 c('ò','o'),
 973                 c('ô','o'),
 974                 c('ö','o'),
 975                 c('ñ','n')
 976                 )
 977
 978     for (c in couple) {
 979         rnames<-gsub(c[1],c[2], rnames)
 980     }
 981     rnames
 982 }
 983
 984
 985
 986 #par(mar=c(0,0,0,0))
 987 #layout(matrix(c(1,2),1,byrow=TRUE), widths=c(3,2),TRUE)
 988 #par(mar=c(1,0,1,0), cex=1)
 989 #plot.phylo(tree,label.offset=0.1)
 990 #par(mar=c(0,0,0,1))
 991 #to.plot <- sum.cl[cl.order,1]
 992 #d <- barplot(to.plot,horiz=TRUE, names.arg='', axes=FALSE, axisname=FALSE)
 993 #text(x=to.plot, y=d[,1], label=round(to.plot,1), adj=1.2)
 994
 995 make.afc.attributes <- function(rn, afc.table, contafc, clnb, column = FALSE, x=1, y=2) {
 996     if (!column){
 997         nd <- clnb - 1
 998         afc.res <- afc.table$ligne
 999         #tokeep <- which(row.names(afc.res) %in% rn)
1000         afc.res <- afc.res[rn,]
1001         debcor <- (nd*2) + 1
1002         cor <- afc.res[,debcor:(debcor+nd-1)][,c(x,y)]
1003         debctr <- (nd*3) + 1
1004         ctr <- afc.res[,debctr:(debctr+nd-1)][,c(x,y)]
1005         massdeb <- (nd*4) + 1
1006         mass <- afc.res[,massdeb]
1007         chideb <- massdeb + 1
1008         chi <- afc.res[,chideb]
1009         inertiadeb <- chideb + 1
1010         inertia <- afc.res[,inertiadeb]
1011         frequence <- rowSums(contafc[rn,])
1012     }
1013     res <- list(frequence=frequence, cor, ctr, mass = mass, chi=chi, inertia=inertia)
1014     return(res)
1015 }
1016
1017
1018 afctogexf <- function(fileout, toplot, classes, clnb, sizes, nodes.attr=NULL) {
1019     toplot <- toplot[,1:3]
1020     toplot[,3] <- 0
1021     #toplot <- afc$rowcoord[1:100,1:3]
1022     #toplot[,3] <- 0
1023     #rownames(toplot)<-afc$rownames[1:100]
1024     cc <- rainbow(clnb)[classes]
1025     cc <- t(sapply(cc, col2rgb, alpha=TRUE))
1026     #sizes <- apply(chistabletot[1:100,], 1, max)
1027
1028     nodes <- data.frame(cbind(1:nrow(toplot), rownames(toplot)))
1029     colnames(nodes) <- c('id', 'label')
1030     nodes[,1] <- as.character(nodes[,1])
1031     nodes[,2] <- as.character(nodes[,2])
1032     #nodes attributs
1033     if (! is.null(nodes.attr)) {
1034         nodesatt <- as.data.frame(nodes.attr)
1035     } else {
1036         nodesatt <- data.frame(cbind(toplot[,1],toplot[,2]))
1037     }
1038     #make axes
1039     edges<-matrix(c(1,1),ncol=2)
1040     xmin <- min(toplot[,1])
1041     xmax <- max(toplot[,1])
1042     ymin <- min(toplot[,2])
1043     ymax <- max(toplot[,2])
1044     nodes<-rbind(nodes, c(nrow(nodes)+1, 'F1'))
1045     nodes<-rbind(nodes, c(nrow(nodes)+1, 'F1'))
1046     nodes<-rbind(nodes, c(nrow(nodes)+1, 'F2'))
1047     nodes<-rbind(nodes, c(nrow(nodes)+1, 'F2'))
1048     nodesatt<-rbind(nodesatt, c(0,0))
1049     nodesatt<-rbind(nodesatt, c(0,0))
1050     nodesatt<-rbind(nodesatt, c(0,0))
1051     nodesatt<-rbind(nodesatt, c(0,0))
1052     toplot <- rbind(toplot, c(xmin, 0,0))
1053     toplot <- rbind(toplot, c(xmax,0,0))
1054     toplot <- rbind(toplot, c(0,ymin,0))
1055     toplot <- rbind(toplot, c(0,ymax,0))
1056     cc <- rbind(cc, c(255,255,255,1))
1057     cc <- rbind(cc, c(255,255,255,1))
1058     cc <- rbind(cc, c(255,255,255,1))
1059     cc <- rbind(cc, c(255,255,255,1))
1060     sizes <- c(sizes, c(0.5, 0.5, 0.5, 0.5))
1061     edges <- rbind(edges, c(nrow(nodes)-3, nrow(nodes)-2))
1062     edges <- rbind(edges, c(nrow(nodes)-1, nrow(nodes)))
1063     write.gexf(nodes, edges, output=fileout, nodesAtt=nodesatt, nodesVizAtt=list(color=cc, position=toplot, size=sizes))
1064 }
1065
1066 simi.to.gexf <- function(fileout, graph.simi, nodes.attr = NULL) {
1067         lo <- graph.simi$layout
1068         if (ncol(lo) == 3) {
1069                 lo[,3] <- 0
1070         } else {
1071                 lo <- cbind(lo, rep(0,nrow(lo)))
1072         }
1073         g <- graph.simi$graph
1074         nodes <- data.frame(cbind(1:nrow(lo), V(g)$name))
1075         colnames(nodes) <- c('id', 'label')
1076         print(nodes)
1077         if (! is.null(nodes.attr)) {
1078                 nodesatt <- as.data.frame(nodes.attr)
1079         } else {
1080                 nodesatt <- data.frame(cbind(lo[,1],lo[,2]))
1081         }
1082         edges <- as.data.frame(get.edges(g, c(1:ecount(g))))
1083         col <- rep('red', nrow(lo))
1084         col <- t(sapply(col, col2rgb, alpha=TRUE))
1085         write.gexf(nodes, edges, output=fileout, nodesAtt=nodesatt, nodesVizAtt=list(color=col,position=lo))
1086 }
1087
1088
1089 graph.to.file <- function(grah.simi, nodesfile = NULL, edgesfile = NULL, community = FALSE, color = NULL, sweight = NULL) {
1090         require(igraph)
1091         g <- graph.simi$graph
1092         V(g)$weight <- graph.simi$eff
1093         V(g)$x <- graph.simi$layout[,1]
1094         V(g)$y <- graph.simi$layout[,2]
1095         if (ncol(graph.simi$layout) == 3) {
1096                 V(g)$z <- graph.simi$layout[,3]
1097         }
1098         if (community) {
1099                 member <- graph.simi$communities$membership
1100                 col <- rainbow(max(member))
1101                 v.colors <- col[member]
1102                 v.colors <- col2rgb(v.colors)
1103                 V(g)$r <- v.colors[1,]
1104                 V(g)$g <- v.colors[2,]
1105                 V(g)$b <- v.colors[3,]
1106         }
1107         if (!is.null(color)) {
1108                 v.colors <- col2rgb(color)
1109                 V(g)$r <- v.colors[1,]
1110                 V(g)$g <- v.colors[2,]
1111                 V(g)$b <- v.colors[3,]
1112         }
1113         if (!is.null(sweight)) {
1114                 V(g)$sweight <- sweight
1115         }
1116         df <- get.data.frame(g, what='both')
1117         if (!is.null(nodesfile)) {
1118                 write.table(df$vertices, nodesfile, sep='\t')
1119         }
1120         if (!is.null(edgesfile)) {
1121                 write.table(df$edges, edgesfile, sep='\t')
1122         }
1123         if (is.null(edgesfile) & is.null(nodesfile)) {
1124                 df
1125         }
1126 }