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], size[i], i))
 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         tablechi <- tablechi[1:(debsup-1),]
 423     }
 424     if (nb > nrow(tablechi)) {
 425         nb <- nrow(tablechi)
 426     }
 427     for (i in 1:ncol(tablechi)) {
 428         rowkeep <- append(rowkeep,order(tablechi[,i], decreasing = TRUE)[1:nb])
 429     }
 430     rowkeep <- unique(rowkeep)
 431     rowkeep
 432 }
 433
 434 select.chi.classe.et <- function(tablechi, nb){
 435     rowkeep <- NULL
 436     if (!is.null(debet)) {
 437         ntablechi <- tablechi[debet:nrow(tablechi),]
 438     }
 439     if (nb > nrow(ntablechi)) {
 440         nb <- nrow(ntablechi)
 441     }
 442     for (i in 1:ncol(ntablechi)) {
 443         rowkeep <- append(rowkeep,order(ntablechi[,i], decreasing = TRUE)[1:nb])
 444     }
 445     rowkeep <- unique(rowkeep)
 446     rowkeep
 447 }
 448
 449 #from summary.ca
 450 summary.ca.dm <- function(object, scree = TRUE, ...){
 451   obj <- object
 452   nd  <- obj$nd
 453   if (is.na(nd)){
 454     nd <- 2
 455     } else {
 456     if (nd > length(obj$sv)) nd <- length(obj$sv)
 457     }
 458  # principal coordinates:
 459   K   <- nd
 460   I   <- dim(obj$rowcoord)[1] ; J <- dim(obj$colcoord)[1]
 461   svF <- matrix(rep(obj$sv[1:K], I), I, K, byrow = TRUE)
 462   svG <- matrix(rep(obj$sv[1:K], J), J, K, byrow = TRUE)
 463   rpc <- obj$rowcoord[,1:K] * svF
 464   cpc <- obj$colcoord[,1:K] * svG
 465
 466  # rows:
 467   r.names <- obj$rownames
 468   sr      <- obj$rowsup
 469   if (!is.na(sr[1])) r.names[sr] <- paste("(*)", r.names[sr], sep = "")
 470   r.mass <- obj$rowmass
 471   r.inr  <- obj$rowinertia / sum(obj$rowinertia, na.rm = TRUE)
 472   r.COR  <- matrix(NA, nrow = length(r.names), ncol = nd)
 473   colnames(r.COR) <- paste('COR -facteur', 1:nd, sep=' ')
 474   r.CTR  <- matrix(NA, nrow = length(r.names), ncol = nd)
 475   colnames(r.CTR) <- paste('CTR -facteur', 1:nd, sep=' ')
 476   for (i in 1:nd){
 477     r.COR[,i] <- obj$rowmass * rpc[,i]^2 / obj$rowinertia
 478     r.CTR[,i] <- obj$rowmass * rpc[,i]^2 / obj$sv[i]^2
 479     }
 480  # cor and quality for supplementary rows
 481   if (length(obj$rowsup) > 0){
 482     i0 <- obj$rowsup
 483     for (i in 1:nd){
 484       r.COR[i0,i] <- obj$rowmass[i0] * rpc[i0,i]^2
 485       r.CTR[i0,i] <- NA
 486     }
 487     }
 488
 489  # columns:
 490   c.names <- obj$colnames
 491   sc      <- obj$colsup
 492   if (!is.na(sc[1])) c.names[sc] <- paste("(*)", c.names[sc], sep = "")
 493   c.mass  <- obj$colmass
 494   c.inr   <- obj$colinertia / sum(obj$colinertia, na.rm = TRUE)
 495   c.COR   <- matrix(NA, nrow = length(c.names), ncol = nd)
 496   colnames(c.COR) <- paste('COR -facteur', 1:nd, sep=' ')
 497   c.CTR   <- matrix(NA, nrow = length(c.names), ncol = nd)
 498   colnames(c.CTR) <- paste('CTR -facteur', 1:nd, sep=' ')
 499   for (i in 1:nd)
 500     {
 501     c.COR[,i] <- obj$colmass * cpc[,i]^2 / obj$colinertia
 502     c.CTR[,i] <- obj$colmass * cpc[,i]^2 / obj$sv[i]^2
 503     }
 504   if (length(obj$colsup) > 0){
 505     i0 <- obj$colsup
 506     for (i in 1:nd){
 507       c.COR[i0,i] <- obj$colmass[i0] * cpc[i0,i]^2
 508       c.CTR[i0,i] <- NA
 509       }
 510     }
 511
 512  # scree plot:
 513   if (scree) {
 514     values     <- obj$sv^2
 515     values2    <- 100*(obj$sv^2)/sum(obj$sv^2)
 516     values3    <- cumsum(100*(obj$sv^2)/sum(obj$sv^2))
 517     scree.out  <- cbind(values, values2, values3)
 518     } else {
 519     scree.out <- NA
 520     }
 521
 522   obj$r.COR <- r.COR
 523   obj$r.CTR <- r.CTR
 524   obj$c.COR <- c.COR
 525   obj$c.CTR <- c.CTR
 526   obj$facteur <- scree.out
 527   return(obj)
 528   }
 529
 530 create_afc_table <- function(x) {
 531    #x = afc
 532         facteur.table <- as.matrix(x$facteur)
 533     nd <- ncol(x$colcoord)
 534         rownames(facteur.table) <- paste('facteur',1:nrow(facteur.table),sep = ' ')
 535     colnames(facteur.table) <- c('Valeurs propres', 'Pourcentages', 'Pourcentage cumules')
 536         ligne.table <- as.matrix(x$rowcoord)
 537         rownames(ligne.table) <- x$rownames
 538         colnames(ligne.table) <- paste('Coord. facteur', 1:nd, sep=' ')
 539     tmp <- as.matrix(x$rowcrl)
 540         colnames(tmp) <- paste('Corr. facteur', 1:nd, sep=' ')
 541         ligne.table <- cbind(ligne.table,tmp)
 542         ligne.table <- cbind(ligne.table, x$r.COR)
 543         ligne.table <- cbind(ligne.table, x$r.CTR)
 544         ligne.table <- cbind(ligne.table, mass = x$rowmass)
 545         ligne.table <- cbind(ligne.table, chi.distance = x$rowdist)
 546         ligne.table <- cbind(ligne.table, inertie = x$rowinertia)
 547     colonne.table <- x$colcoord
 548         rownames(colonne.table) <- paste('classe', 1:(nrow(colonne.table)),sep=' ')
 549         colnames(colonne.table) <- paste('Coord. facteur', 1:nd, sep=' ')
 550     tmp <- as.matrix(x$colcrl)
 551         colnames(tmp) <- paste('Corr. facteur', 1:nd, sep=' ')
 552         colonne.table <- cbind(colonne.table, tmp)
 553         colonne.table <- cbind(colonne.table, x$c.COR)
 554         colonne.table <- cbind(colonne.table, x$c.CTR)
 555         colonne.table <- cbind(colonne.table, mass = x$colmass)
 556         colonne.table <- cbind(colonne.table, chi.distance = x$coldist)
 557         colonne.table <- cbind(colonne.table, inertie = x$colinertia)
 558     res <- list(facteur = facteur.table, ligne = ligne.table, colonne = colonne.table)
 559         res
 560 }
 561
 562 is.yellow <- function(my.color) {
 563     if ((my.color[1] > 200) & (my.color[2] > 200) & (my.color[3] < 20)) {
 564         return(TRUE)
 565     } else {
 566         return(FALSE)
 567     }
 568 }
 569
 570 del.yellow <- function(colors) {
 571     rgbs <- col2rgb(colors)
 572     tochange <- apply(rgbs, 2, is.yellow)
 573     tochange <- which(tochange)
 574     if (length(tochange)) {
 575         gr.col <- grey.colors(length(tochange), start = 0.5, end = 0.8)
 576     }
 577     compt <- 1
 578     for (val in tochange) {
 579         colors[val] <- gr.col[compt]
 580         compt <- compt + 1
 581     }
 582     colors
 583 }
 584
 585 make_afc_graph <- function(toplot, classes, clnb, xlab, ylab, cex.txt = NULL, leg = FALSE, cmd = FALSE, black = FALSE, xminmax=NULL, yminmax=NULL) {
 586
 587     rain <- rainbow(clnb)
 588     compt <- 1
 589     tochange <- NULL
 590     #for (my.color in rain) {
 591     #    my.color <- col2rgb(my.color)
 592     #    if ((my.color[1] > 200) & (my.color[2] > 200) & (my.color[3] < 20)) {
 593     #       tochange <- append(tochange, compt)
 594     #    }
 595     #    compt <- compt + 1
 596     #}
 597     #if (!is.null(tochange)) {
 598     #    gr.col <- grey.colors(length(tochange))
 599     #    compt <- 1
 600     #    for (val in tochange) {
 601     #        rain[val] <- gr.col[compt]
 602     #        compt <- compt + 1
 603     #    }
 604     #}
 605         rain <- del.yellow(rain)
 606     cl.color <- rain[classes]
 607     if (black) {
 608         cl.color <- 'black'
 609     }
 610         plot(toplot[,1],toplot[,2], pch='', xlab = xlab, ylab = ylab, xlim=xminmax, ylim = yminmax)
 611         abline(h=0, v=0, lty = 'dashed')
 612         if (is.null(cex.txt))
 613                 text(toplot[,1],toplot[,2],rownames(toplot),col=cl.color, offset=0)
 614         else
 615                 #require(wordcloud)
 616                 #textplot(toplot[,1],toplot[,2],rownames(toplot),col=cl.color, cex = cex.txt, xlim=xminmax, ylim = yminmax)
 617         text(toplot[,1],toplot[,2],rownames(toplot),col=cl.color, cex = cex.txt, offset=0)
 618
 619     if (!cmd) {
 620             dev.off()
 621     }
 622 }
 623
 624 plot.dendro.prof <- function(tree, classes, chisqtable, nbbycl = 60, type.dendro = "phylogram", from.cmd = FALSE, bw = FALSE, lab = NULL) {
 625     library(ape)
 626     library(wordcloud)
 627     classes<-classes[classes!=0]
 628         classes<-as.factor(classes)
 629         sum.cl<-as.matrix(summary(classes, maxsum=1000000))
 630         sum.cl<-(sum.cl/colSums(sum.cl)*100)
 631         sum.cl<-round(sum.cl,2)
 632         sum.cl<-cbind(sum.cl,as.matrix(100-sum.cl[,1]))
 633     sum.cl <- sum.cl[,1]
 634     tree.order<- as.numeric(tree$tip.label)
 635         vec.mat<-NULL
 636     row.keep <- select.chi.classe(chisqtable, nbbycl)
 637     #et.keep <- select.chi.classe.et(chisqtable, 10)
 638     #print(chistable[et.keep,])
 639     toplot <- chisqtable[row.keep,]
 640     lclasses <- list()
 641     for (classe in 1:length(sum.cl)) {
 642        ntoplot <- toplot[,classe]
 643        names(ntoplot) <- rownames(toplot)
 644        ntoplot <- ntoplot[order(ntoplot, decreasing = TRUE)]
 645        ntoplot <- round(ntoplot, 0)
 646        if (length(toplot) > nbbycl) {
 647            ntoplot <- ntoplot[1:nbbycl]
 648        }
 649        ntoplot <- ntoplot[which(ntoplot > 0)]
 650        #ntoplot <- ntoplot[order(ntoplot)]
 651        #ntoplot <- ifelse(length(ntoplot) > nbbycl, ntoplot[1:nbbycl], ntoplot)
 652        lclasses[[classe]] <- ntoplot
 653     }
 654     vec.mat <- matrix(1, nrow = 3, ncol = length(sum.cl))
 655         vec.mat[2,] <- 2
 656     vec.mat[3,] <- 3:(length(sum.cl)+2)
 657     layout(matrix(vec.mat, nrow=3, ncol=length(sum.cl)),heights=c(2,1,6))
 658     if (! bw) {
 659         col <- rainbow(length(sum.cl))
 660         col <- del.yellow(col)
 661         col <- col[as.numeric(tree$tip.label)]
 662         colcloud <- rainbow(length(sum.cl))
 663         colcloud <- del.yellow(colcloud)
 664     }
 665     label.ori<-tree[[2]]
 666     if (!is.null(lab)) {
 667         tree$tip.label <- lab
 668     } else {
 669             tree[[2]]<-paste('classe ',tree[[2]])
 670     }
 671         par(mar=c(2,1,0,1))
 672         plot.phylo(tree,label.offset=0, tip.col=col, type=type.dendro, direction = 'downwards', srt=90, adj = 0.5, cex = 1, y.lim=c(-0.3,tree$Nnode))
 673         par(mar=c(0,0,0,0))
 674         d <- barplot(-sum.cl[tree.order], col=col, names.arg='', axes=FALSE, axisname=FALSE)
 675         text(x=d, y=(-sum.cl[tree.order]+3), label=paste(round(sum.cl[tree.order],1),'%'), cex=1)
 676     for (i in tree.order) {
 677         par(mar=c(0,0,1,0),cex=0.7)
 678         #wordcloud(names(lclasses[[i]]), lclasses[[i]], scale = c(1.5, 0.2), random.order=FALSE, colors = colcloud[i])
 679         yval <- 1.1
 680         plot(0,0,pch='', axes = FALSE)
 681         vcex <- norm.vec(lclasses[[i]], 1, 3)
 682         for (j in 1:length(lclasses[[i]])) {
 683             yval <- yval-(strheight( names(lclasses[[i]])[j],cex=vcex[j])+0.02)
 684             text(-0.9, yval, names(lclasses[[i]])[j], cex = vcex[j], col = colcloud[i], adj=0)
 685         }
 686     }
 687     if (!from.cmd) {
 688         dev.off()
 689     }
 690
 691 }
 692
 693 plot.dendro.cloud <- function(tree, classes, chisqtable, nbbycl = 60, type.dendro = "phylogram", from.cmd = FALSE, bw = FALSE, lab = NULL) {
 694     library(wordcloud)
 695     library(ape)
 696     classes<-classes[classes!=0]
 697         classes<-as.factor(classes)
 698         sum.cl<-as.matrix(summary(classes, maxsum=1000000))
 699         sum.cl<-(sum.cl/colSums(sum.cl)*100)
 700         sum.cl<-round(sum.cl,2)
 701         sum.cl<-cbind(sum.cl,as.matrix(100-sum.cl[,1]))
 702     sum.cl <- sum.cl[,1]
 703     tree.order<- as.numeric(tree$tip.label)
 704         vec.mat<-NULL
 705     row.keep <- select.chi.classe(chisqtable, nbbycl)
 706     toplot <- chisqtable[row.keep,]
 707     lclasses <- list()
 708     for (classe in 1:length(sum.cl)) {
 709        ntoplot <- toplot[,classe]
 710        names(ntoplot) <- rownames(toplot)
 711        ntoplot <- ntoplot[order(ntoplot, decreasing = TRUE)]
 712        ntoplot <- round(ntoplot, 0)
 713        if (length(toplot) > nbbycl) {
 714             ntoplot <- ntoplot[1:nbbycl]
 715        }
 716        ntoplot <- ntoplot[order(ntoplot)]
 717        ntoplot <- ntoplot[which(ntoplot > 0)]
 718        #ntoplot <- ifelse(length(ntoplot) > nbbycl, ntoplot[1:nbbycl], ntoplot)
 719        lclasses[[classe]] <- ntoplot
 720     }
 721         for (i in 1:length(sum.cl)) vec.mat<-append(vec.mat,1)
 722         v<-2
 723         for (i in 1:length(sum.cl)) {
 724                 vec.mat<-append(vec.mat,v)
 725                 v<-v+1
 726         }
 727     layout(matrix(vec.mat,length(sum.cl),2),widths=c(1,2))
 728     if (! bw) {
 729         col <- rainbow(length(sum.cl))[as.numeric(tree$tip.label)]
 730         colcloud <- rainbow(length(sum.cl))
 731     }
 732     par(mar=c(0,0,0,0))
 733     label.ori<-tree[[2]]
 734     if (!is.null(lab)) {
 735         tree$tip.label <- lab
 736     } else {
 737             tree[[2]]<-paste('classe ',tree[[2]])
 738     }
 739         plot.phylo(tree,label.offset=0.1,tip.col=col, type=type.dendro)
 740     for (i in rev(tree.order)) {
 741         par(mar=c(0,0,1,0),cex=0.9)
 742         wordcloud(names(lclasses[[i]]), lclasses[[i]], scale = c(2.5, 0.5), random.order=FALSE, colors = colcloud[i])
 743     }
 744 }
 745
 746 plot.dendropr <- function(tree, classes, type.dendro="phylogram", histo=FALSE, from.cmd=FALSE, bw=FALSE, lab = NULL, tclasse=TRUE) {
 747         classes<-classes[classes!=0]
 748         classes<-as.factor(classes)
 749         sum.cl<-as.matrix(summary(classes, maxsum=1000000))
 750         sum.cl<-(sum.cl/colSums(sum.cl)*100)
 751         sum.cl<-round(sum.cl,2)
 752         sum.cl<-cbind(sum.cl,as.matrix(100-sum.cl[,1]))
 753     tree.order<- as.numeric(tree$tip.label)
 754
 755
 756     if (! bw) {
 757         col <- rainbow(nrow(sum.cl))[as.numeric(tree$tip.label)]
 758         col <- del.yellow(col)
 759         col.bars <- col
 760         col.pie <- rainbow(nrow(sum.cl))
 761         col.pie <- del.yellow(col.pie)
 762             #col.vec<-rainbow(nrow(sum.cl))[as.numeric(tree[[2]])]
 763     } else {
 764         col = 'black'
 765         col.bars = 'grey'
 766         col.pie <- rep('grey',nrow(sum.cl))
 767     }
 768         vec.mat<-NULL
 769         for (i in 1:nrow(sum.cl)) vec.mat<-append(vec.mat,1)
 770         v<-2
 771         for (i in 1:nrow(sum.cl)) {
 772                 vec.mat<-append(vec.mat,v)
 773                 v<-v+1
 774         }
 775         par(mar=c(0,0,0,0))
 776     if (tclasse) {
 777         if (! histo) {
 778                 layout(matrix(vec.mat,nrow(sum.cl),2),widths=c(3,1))
 779         } else {
 780             layout(matrix(c(1,2),1,byrow=TRUE), widths=c(3,2),TRUE)
 781         }
 782     }
 783         par(mar=c(0,0,0,0),cex=1)
 784         label.ori<-tree[[2]]
 785     if (!is.null(lab)) {
 786         tree$tip.label <- lab
 787     } else {
 788             tree[[2]]<-paste('classe ',tree[[2]])
 789     }
 790         plot.phylo(tree,label.offset=0.1,tip.col=col, type=type.dendro)
 791     #cl.order <- as.numeric(label.ori)
 792     #sum.cl[cl.order,1]
 793         #for (i in 1:nrow(sum.cl)) {
 794     if (tclasse) {
 795         if (! histo) {
 796             for (i in rev(tree.order)) {
 797                 par(mar=c(0,0,1,0),cex=0.7)
 798                     pie(sum.cl[i,],col=c(col.pie[i],'white'),radius = 1, labels='', clockwise=TRUE, main = paste('classe ',i,' - ',sum.cl[i,1],'%' ))
 799             }
 800         } else {
 801             par(cex=0.7)
 802             par(mar=c(0,0,0,1))
 803             to.plot <- sum.cl[tree.order,1]
 804             d <- barplot(to.plot,horiz=TRUE, col=col.bars, names.arg='', axes=FALSE, axisname=FALSE)
 805             text(x=to.plot, y=d[,1], label=paste(round(to.plot,1),'%'), adj=1.2)
 806         }
 807     }
 808     if (!from.cmd) dev.off()
 809         tree[[2]]<-label.ori
 810 }
 811 #tree <- tree.cut1$tree.cl
 812 #to.plot <- di
 813 plot.dendro.lex <- function(tree, to.plot, bw=FALSE, lab=NULL, lay.width=c(3,3,2), colbar=NULL, classes=NULL, direction = 'rightwards', cmd=FALSE) {
 814     tree.order<- as.numeric(tree$tip.label)
 815         if (!is.null(classes)) {
 816                 classes<-classes[classes!=0]
 817                 classes<-as.factor(classes)
 818                 sum.cl<-as.matrix(summary(classes, maxsum=1000000))
 819                 sum.cl<-(sum.cl/colSums(sum.cl)*100)
 820                 sum.cl<-round(sum.cl,2)
 821                 sum.cl<-cbind(sum.cl,as.matrix(100-sum.cl[,1]))
 822         }
 823     par(mar=c(0,0,0,0))
 824     if (direction == 'rightwards') {
 825         srt <- 0
 826         adj <- NULL
 827         horiz <- TRUE
 828             if (!is.null(classes)) {
 829                     matlay <- matrix(c(1,2,3,4),1,byrow=TRUE)
 830                     lay.width <- c(3,2,3,2)
 831             } else {
 832                     matlay <- matrix(c(1,2,3),1,byrow=TRUE)
 833             }
 834     } else {
 835         srt <- 90
 836         adj <- 0.5
 837         horiz <- FALSE
 838         if (!is.null(classes)) {
 839             matlay <- matrix(c(1,2,3,4,4,4),3)
 840         } else {
 841             matlay <- matrix(c(1,2,3,3),2)
 842         }
 843         lay.width <- c(5,2)
 844     }
 845     layout(matlay, widths=lay.width,TRUE)
 846         par(mar=c(3,0,2,4),cex=1)
 847         label.ori<-tree[[2]]
 848     if (!is.null(lab)) {
 849         tree$tip.label <- lab[tree.order]
 850     } else {
 851             tree[[2]]<-paste('classe ',tree[[2]])
 852     }
 853     to.plot <- matrix(to.plot[,tree.order], nrow=nrow(to.plot), dimnames=list(rownames(to.plot), colnames(to.plot)))
 854     if (!bw) {
 855                 col <- rainbow(ncol(to.plot))
 856                 col <- del.yellow(col)
 857                 if (is.null(colbar)) {
 858                 col.bars <- rainbow(nrow(to.plot))
 859                 col.bars <- del.yellow(col.bars)
 860                 } else {
 861                         col.bars <- colbar
 862                 }
 863     } else {
 864         col <- 'black'
 865         col.bars <- grey.colors(nrow(to.plot),0,0.8)
 866     }
 867     col <- col[tree.order]
 868         plot.phylo(tree,label.offset=0.2,tip.col=col, direction = direction, srt=srt, adj = 0.5, edge.width = 2)
 869         if (!is.null(classes)) {
 870                 par(cex=0.7)
 871                 par(mar=c(3,0,2,1))
 872                 to.plota <- sum.cl[tree.order,1]
 873                 d <- barplot(to.plota,horiz=TRUE, col=col, names.arg='', axes=FALSE, axisname=FALSE)
 874                 text(x=to.plota, y=d[,1], label=paste(round(to.plota,1),'%'), adj=1.2)
 875         }
 876     par(mar=c(3,0,2,1))
 877     d <- barplot(to.plot,horiz=horiz, col=col.bars, beside=TRUE, names.arg='', space = c(0.1,0.6), axisname=FALSE)
 878     c <- colMeans(d)
 879     c1 <- c[-1]
 880     c2 <- c[-length(c)]
 881     cc <- cbind(c1,c2)
 882     lcoord <- apply(cc, 1, mean)
 883     abline(h=lcoord)
 884     if (min(to.plot) < 0) {
 885         amp <- abs(max(to.plot) - min(to.plot))
 886     } else {
 887         amp <- max(to.plot)
 888     }
 889     if (amp < 10) {
 890         d <- 2
 891     } else {
 892         d <- signif(amp%/%10,1)
 893     }
 894     mn <- round(min(to.plot))
 895     mx <- round(max(to.plot))
 896     for (i in mn:mx) {
 897         if ((i/d) == (i%/%d)) {
 898             abline(v=i,lty=3)
 899         }
 900     }
 901     par(mar=c(0,0,0,0))
 902     plot(0, axes = FALSE, pch = '')
 903     legend(x = 'center' , rownames(to.plot), fill = col.bars)
 904     if (!cmd) {
 905         dev.off()
 906     }
 907         tree[[2]]<-label.ori
 908 }
 909
 910 plot.alceste.graph <- function(rdata,nd=3,layout='fruke', chilim = 2) {
 911     load(rdata)
 912     if (is.null(debsup)) {
 913         tab.toplot<-afctable[1:(debet+1),]
 914         chitab<-chistabletot[1:(debet+1),]
 915     } else {
 916         tab.toplot<-afctable[1:(debsup+1),]
 917         chitab<-chistabletot[1:(debsup+1),]
 918     }
 919     rkeep<-select_point_chi(chitab,chilim)
 920     tab.toplot<-tab.toplot[rkeep,]
 921     chitab<-chitab[rkeep,]
 922     dm<-dist(tab.toplot,diag=TRUE,upper=TRUE)
 923     cn<-rownames(tab.toplot)
 924     cl.toplot<-apply(chitab,1,which.max)
 925     col<-rainbow(ncol(tab.toplot))[cl.toplot]
 926     library(igraph)
 927     g1 <- graph.adjacency(as.matrix(dm), mode = 'lower', weighted = TRUE)
 928     g.max<-minimum.spanning.tree(g1)
 929     we<-(rowSums(tab.toplot)/max(rowSums(tab.toplot)))*2
 930     #lo <- layout.fruchterman.reingold(g.max,dim=nd)
 931     lo<- layout.kamada.kawai(g.max,dim=nd)
 932     print(nrow(tab.toplot))
 933     print(nrow(chitab))
 934     print(length(we))
 935     print(length(col))
 936     print(length(cn))
 937     if (nd == 3) {
 938         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)
 939     } else if (nd == 2) {
 940         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)
 941     }
 942
 943 }
 944
 945 make.simi.afc <- function(x,chitable,lim=0, alpha = 0.1, movie = NULL) {
 946     library(igraph)
 947     chimax<-as.matrix(apply(chitable,1,max))
 948     chimax<-as.matrix(chimax[,1][1:nrow(x)])
 949     chimax<-cbind(chimax,1:nrow(x))
 950     order_chi<-as.matrix(chimax[order(chimax[,1],decreasing = TRUE),])
 951     if ((lim == 0) || (lim>nrow(x))) lim <- nrow(x)
 952     x<-x[order_chi[,2][1:lim],]
 953     maxchi <- chimax[order_chi[,2][1:lim],1]
 954     #-------------------------------------------------------
 955     limit<-nrow(x)
 956     distm<-dist(x,diag=TRUE)
 957     distm<-as.matrix(distm)
 958     g1<-graph.adjacency(distm,mode='lower',weighted=TRUE)
 959     g1<-minimum.spanning.tree(g1)
 960     lo<-layout.kamada.kawai(g1,dim=3)
 961     lo <- layout.norm(lo, -3, 3, -3, 3, -3, 3)
 962     mc<-rainbow(ncol(chistabletot))
 963     chitable<-chitable[order_chi[,2][1:lim],]
 964     cc <- apply(chitable, 1, which.max)
 965     cc<-mc[cc]
 966     #mass<-(rowSums(x)/max(rowSums(x))) * 5
 967     maxchi<-norm.vec(maxchi, 0.03, 0.3)
 968     rglplot(g1,vertex.label = vire.nonascii(rownames(x)),vertex.label.color= cc,vertex.label.cex = maxchi, vertex.size = 0.1, layout=lo, rescale=FALSE)
 969     text3d(lo[,1], lo[,2],lo[,3], rownames(x), cex=maxchi, col=cc)
 970     #rgl.spheres(lo, col = cc, radius = maxchi, alpha = alpha)
 971     rgl.bg(color = c('white','black'))
 972     if (!is.null(movie)) {
 973         require(tcltk)
 974         ReturnVal <- tkmessageBox(title="RGL 3 D",message="Cliquez pour commencer le film",icon="info",type="ok")
 975
 976         movie3d(spin3d(axis=c(0,1,0),rpm=6), movie = 'film_graph', frames = "tmpfilm", duration=10, clean=TRUE, top = TRUE, dir = movie)
 977         ReturnVal <- tkmessageBox(title="RGL 3 D",message="Film fini !",icon="info",type="ok")
 978     }
 979         while (rgl.cur() != 0)
 980                 Sys.sleep(1)
 981
 982 }
 983
 984 # from igraph
 985 norm.vec <- function(v, min, max) {
 986
 987   vr <- range(v)
 988   if (vr[1]==vr[2]) {
 989     fac <- 1
 990   } else {
 991     fac <- (max-min)/(vr[2]-vr[1])
 992   }
 993   (v-vr[1]) * fac + min
 994 }
 995
 996
 997 vire.nonascii <- function(rnames) {
 998     print('vire non ascii')
 999     couple <- list(c('é','e'),
1000                 c('è','e'),
1001                 c('ê','e'),
1002                 c('ë','e'),
1003                 c('î','i'),
1004                 c('ï','i'),
1005                 c('ì','i'),
1006                 c('à','a'),
1007                 c('â','a'),
1008                 c('ä','a'),
1009                 c('á','a'),
1010                 c('ù','u'),
1011                 c('û','u'),
1012                 c('ü','u'),
1013                 c('ç','c'),
1014                 c('ò','o'),
1015                 c('ô','o'),
1016                 c('ö','o'),
1017                 c('ñ','n')
1018                 )
1019
1020     for (c in couple) {
1021         rnames<-gsub(c[1],c[2], rnames)
1022     }
1023     rnames
1024 }
1025
1026
1027
1028 #par(mar=c(0,0,0,0))
1029 #layout(matrix(c(1,2),1,byrow=TRUE), widths=c(3,2),TRUE)
1030 #par(mar=c(1,0,1,0), cex=1)
1031 #plot.phylo(tree,label.offset=0.1)
1032 #par(mar=c(0,0,0,1))
1033 #to.plot <- sum.cl[cl.order,1]
1034 #d <- barplot(to.plot,horiz=TRUE, names.arg='', axes=FALSE, axisname=FALSE)
1035 #text(x=to.plot, y=d[,1], label=round(to.plot,1), adj=1.2)
1036
1037 make.afc.attributes <- function(rn, afc.table, contafc, clnb, column = FALSE, x=1, y=2) {
1038     if (!column){
1039         nd <- clnb - 1
1040         afc.res <- afc.table$ligne
1041         #tokeep <- which(row.names(afc.res) %in% rn)
1042         afc.res <- afc.res[rn,]
1043         debcor <- (nd*2) + 1
1044         cor <- afc.res[,debcor:(debcor+nd-1)][,c(x,y)]
1045         debctr <- (nd*3) + 1
1046         ctr <- afc.res[,debctr:(debctr+nd-1)][,c(x,y)]
1047         massdeb <- (nd*4) + 1
1048         mass <- afc.res[,massdeb]
1049         chideb <- massdeb + 1
1050         chi <- afc.res[,chideb]
1051         inertiadeb <- chideb + 1
1052         inertia <- afc.res[,inertiadeb]
1053         frequence <- rowSums(contafc[rn,])
1054     }
1055     res <- list(frequence=frequence, cor, ctr, mass = mass, chi=chi, inertia=inertia)
1056     return(res)
1057 }
1058
1059
1060 afctogexf <- function(fileout, toplot, classes, clnb, sizes, nodes.attr=NULL) {
1061     toplot <- toplot[,1:3]
1062     toplot[,3] <- 0
1063     #toplot <- afc$rowcoord[1:100,1:3]
1064     #toplot[,3] <- 0
1065     #rownames(toplot)<-afc$rownames[1:100]
1066     cc <- rainbow(clnb)[classes]
1067     cc <- t(sapply(cc, col2rgb, alpha=TRUE))
1068     #sizes <- apply(chistabletot[1:100,], 1, max)
1069
1070     nodes <- data.frame(cbind(1:nrow(toplot), rownames(toplot)))
1071     colnames(nodes) <- c('id', 'label')
1072     nodes[,1] <- as.character(nodes[,1])
1073     nodes[,2] <- as.character(nodes[,2])
1074     #nodes attributs
1075     if (! is.null(nodes.attr)) {
1076         nodesatt <- as.data.frame(nodes.attr)
1077     } else {
1078         nodesatt <- data.frame(cbind(toplot[,1],toplot[,2]))
1079     }
1080     #make axes
1081     edges<-matrix(c(1,1),ncol=2)
1082     xmin <- min(toplot[,1])
1083     xmax <- max(toplot[,1])
1084     ymin <- min(toplot[,2])
1085     ymax <- max(toplot[,2])
1086     nodes<-rbind(nodes, c(nrow(nodes)+1, 'F1'))
1087     nodes<-rbind(nodes, c(nrow(nodes)+1, 'F1'))
1088     nodes<-rbind(nodes, c(nrow(nodes)+1, 'F2'))
1089     nodes<-rbind(nodes, c(nrow(nodes)+1, 'F2'))
1090     nodesatt<-rbind(nodesatt, c(0,0))
1091     nodesatt<-rbind(nodesatt, c(0,0))
1092     nodesatt<-rbind(nodesatt, c(0,0))
1093     nodesatt<-rbind(nodesatt, c(0,0))
1094     toplot <- rbind(toplot, c(xmin, 0,0))
1095     toplot <- rbind(toplot, c(xmax,0,0))
1096     toplot <- rbind(toplot, c(0,ymin,0))
1097     toplot <- rbind(toplot, c(0,ymax,0))
1098     cc <- rbind(cc, c(255,255,255,1))
1099     cc <- rbind(cc, c(255,255,255,1))
1100     cc <- rbind(cc, c(255,255,255,1))
1101     cc <- rbind(cc, c(255,255,255,1))
1102     sizes <- c(sizes, c(0.5, 0.5, 0.5, 0.5))
1103     edges <- rbind(edges, c(nrow(nodes)-3, nrow(nodes)-2))
1104     edges <- rbind(edges, c(nrow(nodes)-1, nrow(nodes)))
1105     write.gexf(nodes, edges, output=fileout, nodesAtt=nodesatt, nodesVizAtt=list(color=cc, position=toplot, size=sizes))
1106 }
1107
1108 simi.to.gexf <- function(fileout, graph.simi, nodes.attr = NULL) {
1109         lo <- graph.simi$layout
1110         if (ncol(lo) == 3) {
1111                 lo[,3] <- 0
1112         } else {
1113                 lo <- cbind(lo, rep(0,nrow(lo)))
1114         }
1115         g <- graph.simi$graph
1116         nodes <- data.frame(cbind(1:nrow(lo), V(g)$name))
1117         colnames(nodes) <- c('id', 'label')
1118         if (! is.null(nodes.attr)) {
1119                 nodesatt <- as.data.frame(nodes.attr)
1120         } else {
1121                 nodesatt <- data.frame(cbind(lo[,1],lo[,2]))
1122         }
1123         edges <- as.data.frame(get.edges(g, c(1:ecount(g))))
1124         col <- graph.simi$color
1125         col <- t(sapply(col, col2rgb, alpha=TRUE))
1126         write.gexf(nodes, edges, output=fileout, nodesAtt=nodesatt, nodesVizAtt=list(color=col,position=lo, size=graph.simi$label.cex), edgesVizAtt=list(size=graph.simi$we.width))
1127 }
1128
1129 graphml.to.file <- function(graph.path) {
1130     library(igraph)
1131     g <- read.graph(graph.path, format='graphml')
1132     layout <- layout.fruchterman.reingold(g, dim=3)
1133     #print(V(g)$color)
1134     graph.simi <- list(graph=g, layout=layout, color = V(g)$color ,eff=V(g)$weight)
1135     graph.simi
1136 }
1137
1138
1139 graph.to.file <- function(graph.simi, nodesfile = NULL, edgesfile = NULL, community = FALSE, color = NULL, sweight = NULL) {
1140         require(igraph)
1141         g <- graph.simi$graph
1142     print(graph.simi$eff)
1143     if (!is.null(graph.simi$eff)) {
1144             V(g)$weight <- graph.simi$eff
1145     } else {
1146         V(g)$weight <- graph.simi$label.cex
1147     }
1148         V(g)$x <- graph.simi$layout[,1]
1149         V(g)$y <- graph.simi$layout[,2]
1150         if (ncol(graph.simi$layout) == 3) {
1151                 V(g)$z <- graph.simi$layout[,3]
1152         }
1153         if (community) {
1154                 member <- graph.simi$communities$membership
1155                 col <- rainbow(max(member))
1156                 v.colors <- col[member]
1157                 v.colors <- col2rgb(v.colors)
1158                 V(g)$r <- v.colors[1,]
1159                 V(g)$g <- v.colors[2,]
1160                 V(g)$b <- v.colors[3,]
1161         }
1162         if (!is.null(color)) {
1163                 v.colors <- col2rgb(color)
1164                 V(g)$r <- v.colors[1,]
1165                 V(g)$g <- v.colors[2,]
1166                 V(g)$b <- v.colors[3,]
1167         }
1168         if (!is.null(sweight)) {
1169                 V(g)$sweight <- sweight
1170         }
1171         df <- get.data.frame(g, what='both')
1172         if (!is.null(nodesfile)) {
1173                 write.table(df$vertices, nodesfile, sep='\t', row.names=FALSE)
1174         }
1175         if (!is.null(edgesfile)) {
1176                 write.table(df$edges, edgesfile, sep='\t', row.names=FALSE)
1177         }
1178         if (is.null(edgesfile) & is.null(nodesfile)) {
1179                 df
1180         }
1181 }