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     rn <- rownames(table.in)
 189     rgl.open()
 190     par3d(cex=0.7)
 191     #par3d(windowRect = c(100,100,600,600))
 192     rgl.bg(col = c('white', "#99bb99"), front = "lines", box=FALSE, sphere = TRUE)
 193     rgl.lines(c(rx), c(0, 0), c(0, 0), col = "#000000")
 194     rgl.lines(c(0,0),c(ry),c(0,0),col = "#000000")
 195     rgl.lines(c(0,0),c(0,0),c(rz),col = "#000000")
 196     text3d(rx[2]+1,0,0, xlab)
 197     text3d(0,ry[2]+1,0, ylab)
 198     text3d(0,0,rz[2]+1, zlab)
 199     rain = rainbow(clnb)
 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     colors = rain[classes]
 208     text3d(table.in[,1], table.in[,2], table.in[,3], rn, col= colors , cex = cex.par)
 209     for (i in 1:clnb) {
 210         text3d(rx[2],(ry[2]+(0.2*i)),0,paste('classe',i),col=rain[i])
 211     }
 212     #if (tchi) {
 213     #    rgl.spheres(table.in, col = colors, radius = maxchi, alpha = alpha)
 214     #}
 215
 216     if (dofilm) {
 217         require(tcltk)
 218         ReturnVal <- tkmessageBox(title="RGL 3 D",message="Cliquez pour commencer le film",icon="info",type="ok")
 219
 220         movie3d(spin3d(axis=c(0,1,0),rpm=6), movie = 'film', frames = "tmpfilm", duration=10, clean=TRUE, top = TRUE, dir = dirout)
 221         ReturnVal <- tkmessageBox(title="RGL 3 D",message="Fini !",icon="info",type="ok")
 222     }
 223
 224     require(tcltk)
 225     ReturnVal <- tkmessageBox(title="RGL 3 D",message="Cliquez pour fermer",icon="info",type="ok")
 226     rgl.close()
 227 }