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