iramuteq.org Git - iramuteq/blob - Rscripts/afc_graph.R

   1 #Author: Pierre Ratinaud
   2 #Copyright (c) 20010-2013 Pierre Ratinaud
   3 #License: GNU/GPL
   4
   5
   6 #fichier genere par IRaMuTeq
   7 source('%s', encoding = 'utf8')
   8 typegraph <- %i
   9 edgesfile <- "%s"
  10 nodesfile <- "%s"
  11 what <- %i
  12 x <- %i
  13 y <- %i
  14 z <- %i
  15 qui <- %i
  16 over <- %s
  17 do.select.nb <- %s
  18 select.nb <- %i
  19 do.select.chi <- %s
  20 select.chi <- %i
  21 do.select.chi.classe <- %s
  22 ptbycluster <- %i
  23 cex.txt <- %s
  24 txt.min <- %i
  25 txt.max <- %i
  26 fileout <- "%s"
  27 width <- %i
  28 height <- %i
  29 taillecar <- %i
  30 alpha <- %i/100
  31 dofilm <- %s
  32 tchi <- %s
  33 tchi.min <- %i
  34 tchi.max <- %i
  35 dirout <- "%s"
  36 do.svg <- %s
  37 xminmax <- NULL
  38 yminmax <- NULL
  39
  40 xlab <- paste('facteur ', x, ' -')
  41 ylab <- paste('facteur ', y, ' -')
  42 if (!typegraph == 0) {zlab <- paste('facteur ', z, ' -')}
  43 xlab <- paste(xlab,round(afc_table$facteur[x,2],2),sep = ' ')
  44 xlab <- paste(xlab,' %%',sep = '')
  45 ylab <- paste(ylab,round(afc_table$facteur[y,2],2),sep = ' ')
  46 ylab <- paste(ylab,' %%',sep = '')
  47 if (!typegraph == 0) {
  48     zlab <- paste(zlab,round(afc_table$facteur[z,2],2),sep = ' ')
  49     zlab <- paste(zlab,' %%',sep = '')
  50 }
  51
  52 if ( qui == 3 ) {
  53     if ( what == 0 ) table.in <- afc$colcoord
  54     if ( what == 1 ) table.in <- afc$colcrl
  55     rownames(table.in) <- afc$colnames
  56     eff <- afc$colmass
  57     if (typegraph == 0) {
  58         table.in<-table.in[,c(x,y)]
  59     } else {
  60         table.in<-table.in[,c(x,y,z)]
  61         rx <- range(table.in[,1], na.rm = TRUE)
  62         ry <- range(table.in[,2], na.rm = TRUE)
  63         rz <- range(table.in[,3], na.rm = TRUE)
  64     }
  65     classes <- c(1:clnb)
  66     maxchi <- 1
  67     cex.par <- rep(taillecar/10, nrow(table.in))
  68 } else {
  69     if ( what == 0 ) table.in <- afc$rowcoord
  70     if ( what == 1 ) table.in <- afc$rowcrl
  71     rownames(table.in) <- afc$rownames
  72     tablechi <- chistabletot
  73     rn.keep <- c()
  74     if (typegraph == 0) {
  75         table.in<-table.in[,c(x,y)]
  76     } else {
  77         table.in<-table.in[,c(x,y,z)]
  78         rx <- range(table.in[,1], na.rm = TRUE)
  79         ry <- range(table.in[,2], na.rm = TRUE)
  80         rz <- range(table.in[,3], na.rm = TRUE)
  81     }
  82     if (exists('afctable')) {
  83         eff <- rowSums(afctable)
  84     } else {
  85         eff <- afc$rowmass
  86     }
  87
  88     if (!is.null(debsup)) {
  89         if ( qui == 0 ) {
  90            table.in <- table.in[1:(debsup-1),]
  91            tablechi <- tablechi[1:(debsup-1),]
  92            cex.par <- eff[1:(debsup-1)]
  93         }
  94         if ( qui == 1 ) {
  95            table.in <- table.in[debsup:(debet-1),]
  96            tablechi <- tablechi[debsup:(debet-1),]
  97            cex.par <- eff[debsup:(debet-1)]
  98         }
  99         if ( qui == 2 ) {
 100            fin <- nrow(table.in)
 101            table.in <- table.in[debet:nrow(table.in),]
 102            tablechi <- tablechi[debet:nrow(tablechi),]
 103            cex.par <- eff[debet:fin]
 104         }
 105     }
 106
 107     if (is.null(debsup)) {
 108         if (qui == 0) {
 109             if (!is.null(debet)) {
 110                 table.in <- table.in[1:(debet-1),]
 111                 tablechi <- tablechi[1:(debet-1),]
 112                 cex.par <- eff[1:(debet-1)]
 113             } else {
 114                 cex.par <- eff
 115             }
 116         } else {
 117             fin <- nrow(table.in)
 118             table.in <- table.in[debet:nrow(table.in),]
 119             tablechi <- tablechi[debet:nrow(tablechi),]
 120             cex.par <- eff[debet:fin]
 121         }
 122     }
 123
 124     if (do.select.nb) {
 125         if (select.nb > nrow(table.in)) select.nb <- nrow(table.in)
 126         row.keep <- select_point_nb(tablechi, select.nb)
 127         table.in <- table.in[row.keep,]
 128         tablechi <- tablechi[row.keep,]
 129     } else if (do.select.chi) {
 130         if (select.chi > max(tablechi)) select.chi <- max(tablechi)
 131         row.keep <- select_point_chi(tablechi, select.chi)
 132         table.in <- table.in[row.keep,]
 133         tablechi <- tablechi[row.keep,]
 134     } else if (do.select.chi.classe) {
 135         row.keep <- select.chi.classe(tablechi, ptbycluster, active=FALSE)
 136         table.in <- table.in[row.keep,]
 137         tablechi <- tablechi[row.keep,]
 138     } else {
 139         row.keep <- 1:nrow(table.in)
 140     }
 141     classes <- apply(tablechi, 1, which.max)
 142     maxchi <- apply(tablechi, 1, max)
 143     infp <-  which(is.infinite(maxchi) & maxchi > 0)
 144     if (length(infp)) {
 145         maxchi[infp] <- NA
 146         if (!length(infp) == length(maxchi)) {
 147             valmax <- max(maxchi, na.rm = TRUE)
 148         } else {
 149             valmax <- 8
 150         }
 151         maxchi[infp] <- valmax + 2
 152     }
 153     if (cex.txt) {
 154         #row.keep <- append(row.keep, rn.keep)
 155         #row.keep <- unique(row.keep)
 156         cex.par <- cex.par[row.keep]
 157         cex.par <- norm.vec(cex.par, txt.min/10, txt.max/10)
 158     } else if (tchi) {
 159         cex.par <- maxchi
 160         cex.par <- norm.vec(cex.par, tchi.min/10, tchi.max/10)
 161     } else {
 162         cex.par <- rep(taillecar/10, nrow(table.in))
 163     }
 164 }
 165
 166 if (is.null(xminmax)) {
 167         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)))
 168     }
 169     if (is.null(yminmax)) {
 170         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)))
 171     }
 172
 173 if (typegraph == 0 || typegraph == 2) {
 174
 175     open_file_graph(fileout, width = width, height = height, svg = do.svg)
 176     parcex <- taillecar/10
 177     par(cex = parcex)
 178     if (over) {
 179         table.in <- table.in[order(cex.par, decreasing = TRUE),]
 180         classes <- classes[order(cex.par, decreasing = TRUE)]
 181         cex.par <- cex.par[order(cex.par, decreasing = TRUE)]
 182         table.out <- stopoverlap(table.in, cex.par=cex.par, xlim = xminmax, ylim = yminmax)
 183         table.in <- table.out$toplot
 184         notplot <- table.out$notplot
 185         if (! is.null(notplot)) {
 186             write.csv2(notplot, file = paste(fileout,'_notplotted.csv', sep=''))
 187         }
 188         classes <- classes[table.in[,4]]
 189         cex.par <- cex.par[table.in[,4]]
 190     }
 191     if (typegraph == 0) {
 192         make_afc_graph(table.in, classes, clnb, xlab, ylab, cex.txt = cex.par, xminmax = xminmax, yminmax = yminmax)
 193     } else {
 194         dev.off()
 195         require(rgexf)
 196         nodes.attr <- make.afc.attributes(rownames(table.in), afc_table, afctable, clnb)
 197         if (qui != 3) {
 198             tokeep <- rownames(chistabletot) %%in%% rownames(table.in)
 199             chis <- chistabletot[tokeep,]
 200             chis<-chis[rownames(table.in),]
 201             nodes.attr$chiclasse <- chis
 202         } else {
 203             chis <- NULL
 204         }
 205         afctogexf(fileout, table.in, classes, clnb, cex.par, nodes.attr = nodes.attr)
 206     }
 207
 208 } else {
 209         if (typegraph == 4) {
 210                 library(igraph)
 211                 rain = rainbow(clnb)
 212             col = rain[classes]
 213                 g <- make_empty_graph()
 214                 vertex <- rownames(table.in)
 215                 g <- add.vertices(g, length(vertex), attr=list(weight=cex.par, names=vertex, color=col))
 216                 minx <- min(table.in[,1])
 217                 maxx <- max(table.in[,1])
 218                 miny <- min(table.in[,2])
 219                 maxy <- max(table.in[,2])
 220                 minz <- min(table.in[,3])
 221                 maxz <- max(table.in[,3])
 222                 table.in <- rbind(table.in, c(minx, 0, 0))
 223                 rminx <- nrow(table.in)
 224                 table.in <- rbind(table.in, c(maxx, 0, 0))
 225                 rmaxx <- nrow(table.in)
 226                 table.in <- rbind(table.in, c(0, miny, 0))
 227                 rminy <- nrow(table.in)
 228                 table.in <- rbind(table.in, c(0, maxy, 0))
 229                 rmaxy <- nrow(table.in)
 230                 table.in <- rbind(table.in, c(0, 0, minz))
 231                 rminz <- nrow(table.in)
 232                 table.in <- rbind(table.in, c(0, 0, maxz))
 233                 rmaxz <- nrow(table.in)
 234                 g <- add.vertices(g, 6, attr=list(weight=c(0.1,0.1,0.1,0.1,0.1,0.1), names=c(rminx,rmaxx,rminy,rmaxy,rminz,rmaxz), color=c('white','white','white','white','white','white')))
 235                 g <- g + edge(rminx, rmaxx, weight=0.1) + edge(rminy, rmaxy, weight=0.1) + edge(rminz, rmaxz, weight=0.1)
 236                 table.in <- layout.norm(table.in, -5,5,-5,5,-5,5)
 237                 graph.to.file2(g, table.in, nodesfile=nodesfile, edgesfile=edgesfile)
 238         } else {
 239             library(rgl)
 240             rn <- vire.nonascii(rownames(table.in))
 241             rain = rainbow(clnb)
 242             colors = rain[classes]
 243             #rn <- rownames(table.in)
 244             #rgl.open()
 245             bg3d('white')
 246             #rgl.bg(col = c('white', "#99bb99"), front = "lines", box=FALSE, sphere = TRUE)
 247
 248             par3d('userMatrix' = matrix(c(1,0,0,0, 0,1,0,0,0,0,1,0,0,0,0,1), ncol=4, nrow = 4))
 249             #par3d(cex=0.7)
 250             #par3d(windowRect = c(100,100,600,600))
 251             rgl.lines(c(rx), c(0, 0), c(0, 0), col = "#000000")
 252             rgl.lines(c(0,0),c(ry),c(0,0),col = "#000000")
 253             rgl.lines(c(0,0),c(0,0),c(rz),col = "#000000")
 254             text3d(rx[2]+1,0,0, xlab)
 255             text3d(0,ry[2]+1,0, ylab)
 256             text3d(0,0,rz[2]+1, zlab)
 257             splt <- split(seq_along(table.in[,1]), ceiling(seq_along(table.in[,1])/100))
 258             #colsplt <- split(seq_along(colors), ceiling(seq_along(colors)/100))
 259             #cexsplt <- split(seq_along(cex.par), ceiling(seq_along(cex.par)/100))
 260             for (i in splt) {
 261                 rgl.texts(table.in[i,1], table.in[i,2], table.in[i,3], rn[i], col = colors[i] , cex = cex.par[i])
 262             }
 263             #rgl.texts(table.in[,1], table.in[,2], table.in[,3], rn, col = colors , cex = cex.par)
 264
 265              if (tchi) {
 266                 maxchi <- norm.vec(maxchi, tchi.min/100, tchi.max/100)
 267             } else if (!is.null(cex.par)) {
 268                 maxchi <- norm.vec(cex.par, txt.min/100, txt.max/100)
 269             } else {
 270                 maxchi <- 0.1
 271             }
 272
 273
 274             #for (i in 1:clnb) {
 275             #    text3d(rx[2],(ry[2]+(0.2*i)),0,paste('classe',i),col=rain[i])
 276             #}
 277             if (tchi) {
 278                 rgl.spheres(table.in, col = colors, radius = maxchi, alpha = alpha)
 279             }
 280             par3d(skipRedraw=FALSE)
 281
 282             if (dofilm) {
 283                 require(tcltk)
 284                 ReturnVal <- tkmessageBox(title="RGL 3 D",message="Cliquez pour commencer le film",icon="info",type="ok")
 285
 286                 movie3d(spin3d(axis=c(0,1,0),rpm=6), movie = 'film', frames = "tmpfilm", duration=10, clean=TRUE, top = TRUE, dir = dirout)
 287                 ReturnVal <- tkmessageBox(title="RGL 3 D",message="Fini !",icon="info",type="ok")
 288             }
 289
 290             if (typegraph == 1) {
 291                 require(tcltk)
 292                 ReturnVal <- tkmessageBox(title="RGL 3 D",message="Cliquez pour fermer",icon="info",type="ok")
 293             } else {
 294                 writeWebGL(dir = fileout, width = width, height= height)
 295             }
 296             rgl.close()
 297         }
 298 }