...
[iramuteq] / 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 }