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