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.02)
 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     chimax<-as.matrix(apply(chitable,1,max))
1000     chimax<-as.matrix(chimax[,1][1:nrow(x)])
1001     chimax<-cbind(chimax,1:nrow(x))
1002     order_chi<-as.matrix(chimax[order(chimax[,1],decreasing = TRUE),])
1003     if ((lim == 0) || (lim>nrow(x))) lim <- nrow(x)
1004     x<-x[order_chi[,2][1:lim],]
1005     maxchi <- chimax[order_chi[,2][1:lim],1]
1006     #-------------------------------------------------------
1007     limit<-nrow(x)
1008     distm<-dist(x,diag=TRUE)
1009     distm<-as.matrix(distm)
1010     g1<-graph.adjacency(distm,mode='lower',weighted=TRUE)
1011     g1<-minimum.spanning.tree(g1)
1012     lo<-layout.kamada.kawai(g1,dim=3)
1013     lo <- layout.norm(lo, -3, 3, -3, 3, -3, 3)
1014     mc<-rainbow(ncol(chistabletot))
1015     chitable<-chitable[order_chi[,2][1:lim],]
1016     cc <- apply(chitable, 1, which.max)
1017     cc<-mc[cc]
1018     #mass<-(rowSums(x)/max(rowSums(x))) * 5
1019     maxchi<-norm.vec(maxchi, 0.03, 0.3)
1020     rglplot(g1,vertex.label = vire.nonascii(rownames(x)),vertex.label.color= cc,vertex.label.cex = maxchi, vertex.size = 0.1, layout=lo, rescale=FALSE)
1021     text3d(lo[,1], lo[,2],lo[,3], rownames(x), cex=maxchi, col=cc)
1022     #rgl.spheres(lo, col = cc, radius = maxchi, alpha = alpha)
1023     rgl.bg(color = c('white','black'))
1024     if (!is.null(movie)) {
1025         require(tcltk)
1026         ReturnVal <- tkmessageBox(title="RGL 3 D",message="Cliquez pour commencer le film",icon="info",type="ok")
1027
1028         movie3d(spin3d(axis=c(0,1,0),rpm=6), movie = 'film_graph', frames = "tmpfilm", duration=10, clean=TRUE, top = TRUE, dir = movie)
1029         ReturnVal <- tkmessageBox(title="RGL 3 D",message="Film fini !",icon="info",type="ok")
1030     }
1031         while (rgl.cur() != 0)
1032                 Sys.sleep(1)
1033
1034 }
1035
1036 # from igraph
1037 norm.vec <- function(v, min, max) {
1038
1039   vr <- range(v)
1040   if (vr[1]==vr[2]) {
1041     fac <- 1
1042   } else {
1043     fac <- (max-min)/(vr[2]-vr[1])
1044   }
1045   (v-vr[1]) * fac + min
1046 }
1047
1048
1049 vire.nonascii <- function(rnames) {
1050     print('vire non ascii')
1051     couple <- list(c('é','e'),
1052                 c('è','e'),
1053                 c('ê','e'),
1054                 c('ë','e'),
1055                 c('î','i'),
1056                 c('ï','i'),
1057                 c('ì','i'),
1058                 c('à','a'),
1059                 c('â','a'),
1060                 c('ä','a'),
1061                 c('á','a'),
1062                 c('ù','u'),
1063                 c('û','u'),
1064                 c('ü','u'),
1065                 c('ç','c'),
1066                 c('ò','o'),
1067                 c('ô','o'),
1068                 c('ö','o'),
1069                 c('ñ','n')
1070                 )
1071
1072     for (c in couple) {
1073         rnames<-gsub(c[1],c[2], rnames)
1074     }
1075     rnames
1076 }
1077
1078
1079
1080 #par(mar=c(0,0,0,0))
1081 #layout(matrix(c(1,2),1,byrow=TRUE), widths=c(3,2),TRUE)
1082 #par(mar=c(1,0,1,0), cex=1)
1083 #plot.phylo(tree,label.offset=0.1)
1084 #par(mar=c(0,0,0,1))
1085 #to.plot <- sum.cl[cl.order,1]
1086 #d <- barplot(to.plot,horiz=TRUE, names.arg='', axes=FALSE, axisname=FALSE)
1087 #text(x=to.plot, y=d[,1], label=round(to.plot,1), adj=1.2)
1088
1089 make.afc.attributes <- function(rn, afc.table, contafc, clnb, column = FALSE, x=1, y=2) {
1090     if (!column){
1091         nd <- clnb - 1
1092         afc.res <- afc.table$ligne
1093         #tokeep <- which(row.names(afc.res) %in% rn)
1094         afc.res <- afc.res[rn,]
1095         debcor <- (nd*2) + 1
1096         cor <- afc.res[,debcor:(debcor+nd-1)][,c(x,y)]
1097         debctr <- (nd*3) + 1
1098         ctr <- afc.res[,debctr:(debctr+nd-1)][,c(x,y)]
1099         massdeb <- (nd*4) + 1
1100         mass <- afc.res[,massdeb]
1101         chideb <- massdeb + 1
1102         chi <- afc.res[,chideb]
1103         inertiadeb <- chideb + 1
1104         inertia <- afc.res[,inertiadeb]
1105         frequence <- rowSums(contafc[rn,])
1106     }
1107     res <- list(frequence=frequence, cor, ctr, mass = mass, chi=chi, inertia=inertia)
1108     return(res)
1109 }
1110
1111
1112 afctogexf <- function(fileout, toplot, classes, clnb, sizes, nodes.attr=NULL) {
1113     toplot <- toplot[,1:3]
1114     toplot[,3] <- 0
1115     #toplot <- afc$rowcoord[1:100,1:3]
1116     #toplot[,3] <- 0
1117     #rownames(toplot)<-afc$rownames[1:100]
1118     cc <- rainbow(clnb)[classes]
1119     cc <- t(sapply(cc, col2rgb, alpha=TRUE))
1120     #sizes <- apply(chistabletot[1:100,], 1, max)
1121
1122     nodes <- data.frame(cbind(1:nrow(toplot), rownames(toplot)))
1123     colnames(nodes) <- c('id', 'label')
1124     nodes[,1] <- as.character(nodes[,1])
1125     nodes[,2] <- as.character(nodes[,2])
1126     #nodes attributs
1127     if (! is.null(nodes.attr)) {
1128         nodesatt <- as.data.frame(nodes.attr)
1129     } else {
1130         nodesatt <- data.frame(cbind(toplot[,1],toplot[,2]))
1131     }
1132     #make axes
1133     edges<-matrix(c(1,1),ncol=2)
1134     xmin <- min(toplot[,1])
1135     xmax <- max(toplot[,1])
1136     ymin <- min(toplot[,2])
1137     ymax <- max(toplot[,2])
1138     nodes<-rbind(nodes, c(nrow(nodes)+1, 'F1'))
1139     nodes<-rbind(nodes, c(nrow(nodes)+1, 'F1'))
1140     nodes<-rbind(nodes, c(nrow(nodes)+1, 'F2'))
1141     nodes<-rbind(nodes, c(nrow(nodes)+1, 'F2'))
1142     nodesatt<-rbind(nodesatt, c(0,0))
1143     nodesatt<-rbind(nodesatt, c(0,0))
1144     nodesatt<-rbind(nodesatt, c(0,0))
1145     nodesatt<-rbind(nodesatt, c(0,0))
1146     toplot <- rbind(toplot, c(xmin, 0,0))
1147     toplot <- rbind(toplot, c(xmax,0,0))
1148     toplot <- rbind(toplot, c(0,ymin,0))
1149     toplot <- rbind(toplot, c(0,ymax,0))
1150     cc <- rbind(cc, c(255,255,255,1))
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     sizes <- c(sizes, c(0.5, 0.5, 0.5, 0.5))
1155     edges <- rbind(edges, c(nrow(nodes)-3, nrow(nodes)-2))
1156     edges <- rbind(edges, c(nrow(nodes)-1, nrow(nodes)))
1157     write.gexf(nodes, edges, output=fileout, nodesAtt=nodesatt, nodesVizAtt=list(color=cc, position=toplot, size=sizes))
1158 }
1159
1160 simi.to.gexf <- function(fileout, graph.simi, nodes.attr = NULL) {
1161         lo <- graph.simi$layout
1162         if (ncol(lo) == 3) {
1163                 lo[,3] <- 0
1164         } else {
1165                 lo <- cbind(lo, rep(0,nrow(lo)))
1166         }
1167         g <- graph.simi$graph
1168         nodes <- data.frame(cbind(1:nrow(lo), V(g)$name))
1169         colnames(nodes) <- c('id', 'label')
1170         if (! is.null(nodes.attr)) {
1171                 nodesatt <- as.data.frame(nodes.attr)
1172         } else {
1173                 nodesatt <- data.frame(cbind(lo[,1],lo[,2]))
1174         }
1175         edges <- as.data.frame(get.edges(g, c(1:ecount(g))))
1176         col <- graph.simi$color
1177         col <- t(sapply(col, col2rgb, alpha=TRUE))
1178         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))
1179 }
1180
1181 graphml.to.file <- function(graph.path) {
1182     library(igraph)
1183     g <- read.graph(graph.path, format='graphml')
1184     layout <- layout.fruchterman.reingold(g, dim=3)
1185     #print(V(g)$color)
1186     graph.simi <- list(graph=g, layout=layout, color = V(g)$color ,eff=V(g)$weight)
1187     graph.simi
1188 }
1189
1190
1191
1192 graph.to.file <- function(graph.simi, nodesfile = NULL, edgesfile = NULL, community = FALSE, color = NULL, sweight = NULL) {
1193         require(igraph)
1194         g <- graph.simi$graph
1195     print(graph.simi$eff)
1196     if (!is.null(graph.simi$eff)) {
1197             V(g)$weight <- graph.simi$eff
1198     } else {
1199         V(g)$weight <- graph.simi$label.cex
1200     }
1201         layout <- layout.norm(graph.simi$layout,-5,5,-5,5,-5,5)
1202         print(layout)
1203         V(g)$x <- layout[,1]
1204         V(g)$y <- layout[,2]
1205         if (ncol(layout) == 3) {
1206                 V(g)$z <- layout[,3]
1207         }
1208         if (community) {
1209                 member <- graph.simi$communities$membership
1210                 col <- rainbow(max(member))
1211                 v.colors <- col[member]
1212                 v.colors <- col2rgb(v.colors)
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(color)) {
1218                 v.colors <- col2rgb(color)
1219                 V(g)$r <- v.colors[1,]
1220                 V(g)$g <- v.colors[2,]
1221                 V(g)$b <- v.colors[3,]
1222         }
1223         if (!is.null(sweight)) {
1224                 V(g)$sweight <- sweight
1225         }
1226         df <- get.data.frame(g, what='both')
1227         if (!is.null(nodesfile)) {
1228                 write.table(df$vertices, nodesfile, sep='\t', row.names=FALSE)
1229         }
1230         if (!is.null(edgesfile)) {
1231                 write.table(df$edges, edgesfile, sep='\t', row.names=FALSE)
1232         }
1233         if (is.null(edgesfile) & is.null(nodesfile)) {
1234                 df
1235         }
1236 }
1237
1238 graph.to.file2 <- function(graph, layout, nodesfile = NULL, edgesfile = NULL, community = FALSE, color = NULL, sweight = NULL) {
1239         require(igraph)
1240         g <- graph
1241         V(g)$x <- layout[,1]
1242         V(g)$y <- layout[,2]
1243         if (ncol(layout) == 3) {
1244                 V(g)$z <- layout[,3]
1245         }
1246         v.colors <- col2rgb(V(g)$color)
1247         V(g)$r <- v.colors[1,]
1248         V(g)$g <- v.colors[2,]
1249         V(g)$b <- v.colors[3,]
1250
1251         if (!is.null(sweight)) {
1252                 V(g)$sweight <- sweight
1253         }
1254         if (is.null(V(g)$weight)) {
1255                 if (!is.null(sweight)) {
1256                         V(g)$weight <- sweight
1257                 } else {
1258                         V(g)$weight <- 1
1259                 }
1260         }
1261         df <- get.data.frame(g, what='both')
1262         if (!is.null(nodesfile)) {
1263                 write.table(df$vertices, nodesfile, sep='\t', row.names=FALSE)
1264         }
1265         if (!is.null(edgesfile)) {
1266                 write.table(df$edges, edgesfile, sep='\t', row.names=FALSE)
1267         }
1268         if (is.null(edgesfile) & is.null(nodesfile)) {
1269                 df
1270         }
1271 }
1272