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