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

   1 #Author: Pierre Ratinaud
   2 #Copyright (c) 20010 Pierre Ratinaud
   3 #Lisense: GNU/GPL
   4
   5
   6 #fichier genere par IRaMuTeq
   7 source('%s')
   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 cex.txt <- %s
  20 txt.min <- %i
  21 txt.max <- %i
  22 fileout <- '%s'
  23 width <- %i
  24 height <- %i
  25 taillecar <- %i
  26 alpha <- %i/100
  27 dofilm <- %s
  28 tchi <- %s
  29 tchi.min <- %i
  30 tchi.max <- %i
  31 dirout <- '%s'
  32
  33 xlab <- paste('facteur ', x, ' -')
  34 ylab <- paste('facteur ', y, ' -')
  35 if (!typegraph == 0) {zlab <- paste('facteur ', z, ' -')}
  36 xlab <- paste(xlab,round(afc_table$facteur[x,2],2),sep = ' ')
  37 xlab <- paste(xlab,' %%',sep = '')
  38 ylab <- paste(ylab,round(afc_table$facteur[y,2],2),sep = ' ')
  39 ylab <- paste(ylab,' %%',sep = '')
  40 if (!typegraph == 0) {
  41     zlab <- paste(zlab,round(afc_table$facteur[z,2],2),sep = ' ')
  42     zlab <- paste(zlab,' %%',sep = '')
  43 }
  44
  45 if ( qui == 3 ) {
  46     if ( what == 0 ) table.in <- afc$colcoord
  47     if ( what == 1 ) table.in <- afc$colcrl
  48     rownames(table.in) <- afc$colnames
  49     if (typegraph == 0) {
  50         table.in<-table.in[,c(x,y)]
  51     } else {
  52         table.in<-table.in[,c(x,y,z)]
  53         rx <- range(table.in[,1], na.rm = TRUE)
  54         ry <- range(table.in[,2], na.rm = TRUE)
  55         rz <- range(table.in[,3], na.rm = TRUE)
  56     }
  57     classes <- c(1:clnb)
  58     maxchi <- 1
  59     cex.par <- NULL
  60 } else {
  61     if ( what == 0 ) table.in <- afc$rowcoord
  62     if ( what == 1 ) table.in <- afc$rowcrl*2
  63     rownames(table.in) <- afc$rownames
  64     tablechi <- chistabletot
  65     rn.keep <- c()
  66     if (typegraph == 0) {
  67         table.in<-table.in[,c(x,y)]
  68     } else {
  69         table.in<-table.in[,c(x,y,z)]
  70         rx <- range(table.in[,1], na.rm = TRUE)
  71         ry <- range(table.in[,2], na.rm = TRUE)
  72         rz <- range(table.in[,3], na.rm = TRUE)
  73     }
  74     if (!is.null(debsup)) {
  75         if ( qui == 0 ) {
  76            table.in <- table.in[1:(debsup-1),]
  77            tablechi <- tablechi[1:(debsup-1),]
  78            cex.par <- afc$rowmass[1:(debsup-1)]
  79         }
  80         if ( qui == 1 ) {
  81            table.in <- table.in[debsup:(debet-1),]
  82            tablechi <- tablechi[debsup:(debet-1),]
  83            #cex.par <- afc$rowmass[debsup:(debet-1)]
  84         }
  85         if ( qui == 2 ) {
  86            table.in <- table.in[debet:nrow(table.in),]
  87            tablechi <- tablechi[debet:nrow(tablechi),]
  88            #cex.par <- afc$rowmass[debet:nrow(tablechi)]
  89         }
  90     }
  91
  92     if (is.null(debsup)) {
  93         if (qui == 0) {
  94             if (!is.null(debet)) {
  95                 table.in <- table.in[1:(debet-1),]
  96                 tablechi <- tablechi[1:(debet-1),]
  97                 cex.par <- afc$rowmass[1:(debet-1)]
  98             } else {
  99                 cex.par <- afc$rowmass
 100             }
 101         } else {
 102             table.in <- table.in[debet:nrow(table.in),]
 103             tablechi <- tablechi[debet:nrow(tablechi),]
 104             #cex.par <- afc$rowmass[debet:nrow(tablechi)]
 105         }
 106     }
 107
 108     if (over) {
 109         rn <- rownames(table.in)
 110         rownames(table.in) <- 1:nrow(table.in)
 111         table.in <- unique(table.in)
 112         rn.keep <- as.numeric(rownames(table.in))
 113         rownames(table.in) <- rn[rn.keep]
 114         tablechi <- tablechi[rn.keep,]
 115         if (qui==0) {
 116             cex.par <- cex.par[rn.keep]
 117         } else {
 118             cex.par <- NULL
 119         }
 120     }
 121     if (do.select.nb) {
 122         if (select.nb > nrow(table.in)) select.nb <- nrow(table.in)
 123         row.keep <- select_point_nb(tablechi, select.nb)
 124         table.in <- table.in[row.keep,]
 125         tablechi <- tablechi[row.keep,]
 126     } else if (do.select.chi) {
 127         if (select.chi > max(tablechi)) select.chi <- max(tablechi)
 128         row.keep <- select_point_chi(tablechi, select.chi)
 129         table.in <- table.in[row.keep,]
 130         tablechi <- tablechi[row.keep,]
 131     } else {
 132         row.keep <- 1:nrow(table.in)
 133     }
 134     classes <- apply(tablechi, 1, which.max)
 135     maxchi <- apply(tablechi, 1, max)
 136
 137     if (cex.txt) {
 138         #row.keep <- append(row.keep, rn.keep)
 139         #row.keep <- unique(row.keep)
 140         cex.par <- cex.par[row.keep]
 141         cex.par <- norm.vec(cex.par, txt.min/10, txt.max/10)
 142     } else if (tchi) {
 143         cex.par <- maxchi
 144         cex.par <- norm.vec(cex.par, tchi.min/10, tchi.max/10)
 145     } else {
 146         cex.par <- NULL
 147     }
 148 }
 149
 150 if (typegraph == 0) {
 151
 152     open_file_graph(fileout, width = width, height = height)
 153     parcex <- taillecar/10
 154     par(cex = parcex)
 155     make_afc_graph(table.in, classes, clnb, xlab, ylab, cex.txt = cex.par)
 156
 157 } else {
 158
 159     vire.nonascii <- function(rnames) {
 160         print('vire non ascii')
 161         couple <- list(c('é','e'),
 162                     c('è','e'),
 163                     c('ê','e'),
 164                     c('ë','e'),
 165                     c('î','i'),
 166                     c('ï','i'),
 167                     c('ì','i'),
 168                     c('à','a'),
 169                     c('â','a'),
 170                     c('ä','a'),
 171                     c('á','a'),
 172                     c('ù','u'),
 173                     c('û','u'),
 174                     c('ü','u'),
 175                     c('ç','c'),
 176                     c('ò','o'),
 177                     c('ô','o'),
 178                     c('ö','o'),
 179                     c('ñ','n')
 180                     )
 181         for (c in couple) {
 182             rnames<-gsub(c[1],c[2], rnames)
 183         }
 184         rnames
 185     }
 186     library(rgl)
 187     rn <- vire.nonascii(rownames(table.in))
 188     rgl.open()
 189     #par3d(windowRect = c(100,100,600,600))
 190     rgl.bg(col = c('white', "#99bb99"), front = "lines", box=FALSE, sphere = TRUE)
 191     rgl.lines(c(rx), c(0, 0), c(0, 0), col = "#000000")
 192     rgl.lines(c(0,0),c(ry),c(0,0),col = "#000000")
 193     rgl.lines(c(0,0),c(0,0),c(rz),col = "#000000")
 194     text3d(rx[2]+1,0,0, xlab)
 195     text3d(0,ry[2]+1,0, ylab)
 196     text3d(0,0,rz[2]+1, zlab)
 197     rain = rainbow(clnb)
 198     colors = rain[classes]
 199     text3d(table.in[,1], table.in[,2], table.in[,3], rn, col='black')
 200     if (tchi) {
 201         maxchi <- norm.vec(maxchi, tchi.min/100, tchi.max/100)
 202     } else if (!is.null(cex.par)) {
 203         maxchi <- norm.vec(cex.par, txt.min/100, txt.max/100)
 204     } else {
 205         maxchi <- 0.1
 206     }
 207     for (i in 1:clnb) {
 208         text3d(rx[2],(ry[2]+(0.2*i)),0,paste('classe',i),col=rain[i])
 209     }
 210     rgl.spheres(table.in, col = colors, radius = maxchi, alpha = alpha)
 211
 212     if (dofilm) {
 213         require(tcltk)
 214         ReturnVal <- tkmessageBox(title="RGL 3 D",message="Cliquez pour commencer le film",icon="info",type="ok")
 215
 216         movie3d(spin3d(axis=c(0,1,0),rpm=6), movie = 'film', frames = "tmpfilm", duration=10, clean=TRUE, top = TRUE, dir = dirout)
 217         ReturnVal <- tkmessageBox(title="RGL 3 D",message="Fini !",icon="info",type="ok")
 218     }
 219
 220     require(tcltk)
 221     ReturnVal <- tkmessageBox(title="RGL 3 D",message="Cliquez pour fermer",icon="info",type="ok")
 222     rgl.close()
 223 }