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

   1 #Author: Pierre Ratinaud
   2 #Copyright (c) 20010-2013 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 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 <- afctable$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            table.in <- table.in[debet:nrow(table.in),]
  99            tablechi <- tablechi[debet:nrow(tablechi),]
 100            cex.par <- eff[debet:nrow(afctable)]
 101         }
 102     }
 103
 104     if (is.null(debsup)) {
 105         if (qui == 0) {
 106             if (!is.null(debet)) {
 107                 table.in <- table.in[1:(debet-1),]
 108                 tablechi <- tablechi[1:(debet-1),]
 109                 cex.par <- eff[1:(debet-1)]
 110             } else {
 111                 cex.par <- eff
 112             }
 113         } else {
 114             table.in <- table.in[debet:nrow(table.in),]
 115             tablechi <- tablechi[debet:nrow(tablechi),]
 116             cex.par <- eff[debet:nrow(afctable)]
 117         }
 118     }
 119
 120     if (do.select.nb) {
 121         if (select.nb > nrow(table.in)) select.nb <- nrow(table.in)
 122         row.keep <- select_point_nb(tablechi, select.nb)
 123         table.in <- table.in[row.keep,]
 124         tablechi <- tablechi[row.keep,]
 125     } else if (do.select.chi) {
 126         if (select.chi > max(tablechi)) select.chi <- max(tablechi)
 127         row.keep <- select_point_chi(tablechi, select.chi)
 128         table.in <- table.in[row.keep,]
 129         tablechi <- tablechi[row.keep,]
 130     } else if (do.select.chi.classe) {
 131         row.keep <- select.chi.classe(tablechi, ptbycluster)
 132         table.in <- table.in[row.keep,]
 133         tablechi <- tablechi[row.keep,]
 134     } else {
 135         row.keep <- 1:nrow(table.in)
 136     }
 137     classes <- apply(tablechi, 1, which.max)
 138     maxchi <- apply(tablechi, 1, max)
 139     infp <-  which(is.infinite(maxchi) & maxchi > 0)
 140     if (length(infp)) {
 141         maxchi[infp] <- NA
 142         if (!length(infp) == length(maxchi)) {
 143             valmax <- max(maxchi, na.rm = TRUE)
 144         } else {
 145             valmax <- 8
 146         }
 147         maxchi[infp] <- valmax + 2
 148     }
 149     if (cex.txt) {
 150         #row.keep <- append(row.keep, rn.keep)
 151         #row.keep <- unique(row.keep)
 152         cex.par <- cex.par[row.keep]
 153         cex.par <- norm.vec(cex.par, txt.min/10, txt.max/10)
 154     } else if (tchi) {
 155         cex.par <- maxchi
 156         cex.par <- norm.vec(cex.par, tchi.min/10, tchi.max/10)
 157     } else {
 158         cex.par <- rep(taillecar/10, nrow(table.in))
 159     }
 160 }
 161
 162 if (is.null(xminmax)) {
 163         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)))
 164     }
 165     if (is.null(yminmax)) {
 166         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)))
 167     }
 168
 169 if (typegraph == 0) {
 170
 171     open_file_graph(fileout, width = width, height = height, svg = do.svg)
 172     parcex <- taillecar/10
 173     par(cex = parcex)
 174     if (over) {
 175     table.in <- table.in[order(cex.par, decreasing = TRUE),]
 176     classes <- classes[order(cex.par, decreasing = TRUE)]
 177     cex.par <- cex.par[order(cex.par, decreasing = TRUE)]
 178     table.in <- stopoverlap(table.in, cex.par=cex.par, xlim = xminmax, ylim = yminmax)
 179     classes <- classes[table.in[,4]]
 180     cex.par <- cex.par[table.in[,4]]
 181     }
 182     make_afc_graph(table.in, classes, clnb, xlab, ylab, cex.txt = cex.par, xminmax = xminmax, yminmax = yminmax)
 183
 184 } else {
 185
 186     vire.nonascii <- function(rnames) {
 187         print('vire non ascii')
 188         couple <- list(c('é','e'),
 189                     c('è','e'),
 190                     c('ê','e'),
 191                     c('ë','e'),
 192                     c('î','i'),
 193                     c('ï','i'),
 194                     c('ì','i'),
 195                     c('à','a'),
 196                     c('â','a'),
 197                     c('ä','a'),
 198                     c('á','a'),
 199                     c('ù','u'),
 200                     c('û','u'),
 201                     c('ü','u'),
 202                     c('ç','c'),
 203                     c('ò','o'),
 204                     c('ô','o'),
 205                     c('ö','o'),
 206                     c('ñ','n')
 207                     )
 208         for (c in couple) {
 209             rnames<-gsub(c[1],c[2], rnames)
 210         }
 211         rnames
 212     }
 213     library(rgl)
 214     #rn <- vire.nonascii(rownames(table.in))
 215     rn <- rownames(table.in)
 216     rgl.open()
 217     par3d(cex=0.7)
 218     #par3d(windowRect = c(100,100,600,600))
 219     rgl.bg(col = c('white', "#99bb99"), front = "lines", box=FALSE, sphere = TRUE)
 220     rgl.lines(c(rx), c(0, 0), c(0, 0), col = "#000000")
 221     rgl.lines(c(0,0),c(ry),c(0,0),col = "#000000")
 222     rgl.lines(c(0,0),c(0,0),c(rz),col = "#000000")
 223     text3d(rx[2]+1,0,0, xlab)
 224     text3d(0,ry[2]+1,0, ylab)
 225     text3d(0,0,rz[2]+1, zlab)
 226     rain = rainbow(clnb)
 227      if (tchi) {
 228         maxchi <- norm.vec(maxchi, tchi.min/100, tchi.max/100)
 229     } else if (!is.null(cex.par)) {
 230         maxchi <- norm.vec(cex.par, txt.min/100, txt.max/100)
 231     } else {
 232         maxchi <- 0.1
 233     }
 234     colors = rain[classes]
 235     text3d(table.in[,1], table.in[,2], table.in[,3], rn, col= colors , cex = cex.par)
 236     for (i in 1:clnb) {
 237         text3d(rx[2],(ry[2]+(0.2*i)),0,paste('classe',i),col=rain[i])
 238     }
 239     #if (tchi) {
 240     #    rgl.spheres(table.in, col = colors, radius = maxchi, alpha = alpha)
 241     #}
 242
 243     if (dofilm) {
 244         require(tcltk)
 245         ReturnVal <- tkmessageBox(title="RGL 3 D",message="Cliquez pour commencer le film",icon="info",type="ok")
 246
 247         movie3d(spin3d(axis=c(0,1,0),rpm=6), movie = 'film', frames = "tmpfilm", duration=10, clean=TRUE, top = TRUE, dir = dirout)
 248         ReturnVal <- tkmessageBox(title="RGL 3 D",message="Fini !",icon="info",type="ok")
 249     }
 250
 251     require(tcltk)
 252     ReturnVal <- tkmessageBox(title="RGL 3 D",message="Cliquez pour fermer",icon="info",type="ok")
 253     rgl.close()
 254 }