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