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 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 #xmin <- xmin
  35 #xmax <- xmax
  36 #ymin <- ymin
  37 #ymax <- ymax
  38
  39 xlab <- paste('facteur ', x, ' -')
  40 ylab <- paste('facteur ', y, ' -')
  41 if (!typegraph == 0) {zlab <- paste('facteur ', z, ' -')}
  42 xlab <- paste(xlab,round(afc_table$facteur[x,2],2),sep = ' ')
  43 xlab <- paste(xlab,' %%',sep = '')
  44 ylab <- paste(ylab,round(afc_table$facteur[y,2],2),sep = ' ')
  45 ylab <- paste(ylab,' %%',sep = '')
  46 if (!typegraph == 0) {
  47     zlab <- paste(zlab,round(afc_table$facteur[z,2],2),sep = ' ')
  48     zlab <- paste(zlab,' %%',sep = '')
  49 }
  50
  51 if ( qui == 3 ) {
  52     if ( what == 0 ) table.in <- afc$colcoord
  53     if ( what == 1 ) table.in <- afc$colcrl
  54     rownames(table.in) <- afc$colnames
  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 (!is.null(debsup)) {
  81         if ( qui == 0 ) {
  82            table.in <- table.in[1:(debsup-1),]
  83            tablechi <- tablechi[1:(debsup-1),]
  84            cex.par <- afc$rowmass[1:(debsup-1)]
  85         }
  86         if ( qui == 1 ) {
  87            table.in <- table.in[debsup:(debet-1),]
  88            tablechi <- tablechi[debsup:(debet-1),]
  89            #cex.par <- afc$rowmass[debsup:(debet-1)]
  90         }
  91         if ( qui == 2 ) {
  92            table.in <- table.in[debet:nrow(table.in),]
  93            tablechi <- tablechi[debet:nrow(tablechi),]
  94            #cex.par <- afc$rowmass[debet:nrow(tablechi)]
  95         }
  96     }
  97
  98     if (is.null(debsup)) {
  99         if (qui == 0) {
 100             if (!is.null(debet)) {
 101                 table.in <- table.in[1:(debet-1),]
 102                 tablechi <- tablechi[1:(debet-1),]
 103                 cex.par <- afc$rowmass[1:(debet-1)]
 104             } else {
 105                 cex.par <- afc$rowmass
 106             }
 107         } else {
 108             table.in <- table.in[debet:nrow(table.in),]
 109             tablechi <- tablechi[debet:nrow(tablechi),]
 110             #cex.par <- afc$rowmass[debet:nrow(tablechi)]
 111         }
 112     }
 113
 114     if (do.select.nb) {
 115         if (select.nb > nrow(table.in)) select.nb <- nrow(table.in)
 116         row.keep <- select_point_nb(tablechi, select.nb)
 117         table.in <- table.in[row.keep,]
 118         tablechi <- tablechi[row.keep,]
 119     } else if (do.select.chi) {
 120         if (select.chi > max(tablechi)) select.chi <- max(tablechi)
 121         row.keep <- select_point_chi(tablechi, select.chi)
 122         table.in <- table.in[row.keep,]
 123         tablechi <- tablechi[row.keep,]
 124     } else if (do.select.chi.classe) {
 125         row.keep <- select.chi.classe(tablechi, ptbycluster)
 126         table.in <- table.in[row.keep,]
 127         tablechi <- tablechi[row.keep,]
 128     } else {
 129         row.keep <- 1:nrow(table.in)
 130     }
 131     classes <- apply(tablechi, 1, which.max)
 132     maxchi <- apply(tablechi, 1, max)
 133     infp <-  which(is.infinite(maxchi) & maxchi > 0)
 134     if (length(infp)) {
 135         maxchi[infp] <- NA
 136         valmax <- max(maxchi, na.rm = TRUE)
 137         maxchi[infp] <- valmax + 2
 138     }
 139     if (cex.txt) {
 140         #row.keep <- append(row.keep, rn.keep)
 141         #row.keep <- unique(row.keep)
 142         cex.par <- cex.par[row.keep]
 143         cex.par <- norm.vec(cex.par, txt.min/10, txt.max/10)
 144     } else if (tchi) {
 145         cex.par <- maxchi
 146         cex.par <- norm.vec(cex.par, tchi.min/10, tchi.max/10)
 147     } else {
 148         cex.par <- rep(taillecar/10, nrow(table.in))
 149     }
 150 }
 151
 152
 153 if (typegraph == 0) {
 154
 155     open_file_graph(fileout, width = width, height = height)
 156     parcex <- taillecar/10
 157     par(cex = parcex)
 158     if (over) {
 159     table.in <- table.in[order(cex.par, decreasing = TRUE),]
 160     classes <- classes[order(cex.par, decreasing = TRUE)]
 161     cex.par <- cex.par[order(cex.par, decreasing = TRUE)]
 162     table.in <- stopoverlap(table.in, cex.par=cex.par)
 163     classes <- classes[table.in[,4]]
 164     cex.par <- cex.par[table.in[,4]]
 165     }
 166     make_afc_graph(table.in, classes, clnb, xlab, ylab, cex.txt = cex.par)
 167
 168 } else {
 169
 170     vire.nonascii <- function(rnames) {
 171         print('vire non ascii')
 172         couple <- list(c('é','e'),
 173                     c('è','e'),
 174                     c('ê','e'),
 175                     c('ë','e'),
 176                     c('î','i'),
 177                     c('ï','i'),
 178                     c('ì','i'),
 179                     c('à','a'),
 180                     c('â','a'),
 181                     c('ä','a'),
 182                     c('á','a'),
 183                     c('ù','u'),
 184                     c('û','u'),
 185                     c('ü','u'),
 186                     c('ç','c'),
 187                     c('ò','o'),
 188                     c('ô','o'),
 189                     c('ö','o'),
 190                     c('ñ','n')
 191                     )
 192         for (c in couple) {
 193             rnames<-gsub(c[1],c[2], rnames)
 194         }
 195         rnames
 196     }
 197     library(rgl)
 198     #rn <- vire.nonascii(rownames(table.in))
 199     rn <- rownames(table.in)
 200     rgl.open()
 201     par3d(cex=0.7)
 202     #par3d(windowRect = c(100,100,600,600))
 203     rgl.bg(col = c('white', "#99bb99"), front = "lines", box=FALSE, sphere = TRUE)
 204     rgl.lines(c(rx), c(0, 0), c(0, 0), col = "#000000")
 205     rgl.lines(c(0,0),c(ry),c(0,0),col = "#000000")
 206     rgl.lines(c(0,0),c(0,0),c(rz),col = "#000000")
 207     text3d(rx[2]+1,0,0, xlab)
 208     text3d(0,ry[2]+1,0, ylab)
 209     text3d(0,0,rz[2]+1, zlab)
 210     rain = rainbow(clnb)
 211      if (tchi) {
 212         maxchi <- norm.vec(maxchi, tchi.min/100, tchi.max/100)
 213     } else if (!is.null(cex.par)) {
 214         maxchi <- norm.vec(cex.par, txt.min/100, txt.max/100)
 215     } else {
 216         maxchi <- 0.1
 217     }
 218     colors = rain[classes]
 219     text3d(table.in[,1], table.in[,2], table.in[,3], rn, col= colors , cex = cex.par)
 220     for (i in 1:clnb) {
 221         text3d(rx[2],(ry[2]+(0.2*i)),0,paste('classe',i),col=rain[i])
 222     }
 223     #if (tchi) {
 224     #    rgl.spheres(table.in, col = colors, radius = maxchi, alpha = alpha)
 225     #}
 226
 227     if (dofilm) {
 228         require(tcltk)
 229         ReturnVal <- tkmessageBox(title="RGL 3 D",message="Cliquez pour commencer le film",icon="info",type="ok")
 230
 231         movie3d(spin3d(axis=c(0,1,0),rpm=6), movie = 'film', frames = "tmpfilm", duration=10, clean=TRUE, top = TRUE, dir = dirout)
 232         ReturnVal <- tkmessageBox(title="RGL 3 D",message="Fini !",icon="info",type="ok")
 233     }
 234
 235     require(tcltk)
 236     ReturnVal <- tkmessageBox(title="RGL 3 D",message="Cliquez pour fermer",icon="info",type="ok")
 237     rgl.close()
 238 }