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 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     if (typegraph == 0) {
  55         table.in<-table.in[,c(x,y)]
  56     } else {
  57         table.in<-table.in[,c(x,y,z)]
  58         rx <- range(table.in[,1], na.rm = TRUE)
  59         ry <- range(table.in[,2], na.rm = TRUE)
  60         rz <- range(table.in[,3], na.rm = TRUE)
  61     }
  62     classes <- c(1:clnb)
  63     maxchi <- 1
  64     cex.par <- rep(taillecar/10, nrow(table.in))
  65 } else {
  66     if ( what == 0 ) table.in <- afc$rowcoord
  67     if ( what == 1 ) table.in <- afc$rowcrl
  68     rownames(table.in) <- afc$rownames
  69     tablechi <- chistabletot
  70     rn.keep <- c()
  71     if (typegraph == 0) {
  72         table.in<-table.in[,c(x,y)]
  73     } else {
  74         table.in<-table.in[,c(x,y,z)]
  75         rx <- range(table.in[,1], na.rm = TRUE)
  76         ry <- range(table.in[,2], na.rm = TRUE)
  77         rz <- range(table.in[,3], na.rm = TRUE)
  78     }
  79     eff <- rowSums(afctable)
  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 <- eff[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 <- eff[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 <- eff[debet:nrow(afctable)]
  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 <- eff[1:(debet-1)]
 104             } else {
 105                 cex.par <- eff
 106             }
 107         } else {
 108             table.in <- table.in[debet:nrow(table.in),]
 109             tablechi <- tablechi[debet:nrow(tablechi),]
 110             cex.par <- eff[debet:nrow(afctable)]
 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         if (!length(infp) == length(maxchi)) {
 137             valmax <- max(maxchi, na.rm = TRUE)
 138         } else {
 139             valmax <- 8
 140         }
 141         maxchi[infp] <- valmax + 2
 142     }
 143     if (cex.txt) {
 144         #row.keep <- append(row.keep, rn.keep)
 145         #row.keep <- unique(row.keep)
 146         cex.par <- cex.par[row.keep]
 147         cex.par <- norm.vec(cex.par, txt.min/10, txt.max/10)
 148     } else if (tchi) {
 149         cex.par <- maxchi
 150         cex.par <- norm.vec(cex.par, tchi.min/10, tchi.max/10)
 151     } else {
 152         cex.par <- rep(taillecar/10, nrow(table.in))
 153     }
 154 }
 155
 156 if (is.null(xminmax)) {
 157         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)))
 158     }
 159     if (is.null(yminmax)) {
 160         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)))
 161     }
 162
 163 if (typegraph == 0) {
 164
 165     open_file_graph(fileout, width = width, height = height, svg = do.svg)
 166     parcex <- taillecar/10
 167     par(cex = parcex)
 168     if (over) {
 169     table.in <- table.in[order(cex.par, decreasing = TRUE),]
 170     classes <- classes[order(cex.par, decreasing = TRUE)]
 171     cex.par <- cex.par[order(cex.par, decreasing = TRUE)]
 172     table.in <- stopoverlap(table.in, cex.par=cex.par, xlim = xminmax, ylim = yminmax)
 173     classes <- classes[table.in[,4]]
 174     cex.par <- cex.par[table.in[,4]]
 175     }
 176     make_afc_graph(table.in, classes, clnb, xlab, ylab, cex.txt = cex.par, xminmax = xminmax, yminmax = yminmax)
 177
 178 } else {
 179
 180     vire.nonascii <- function(rnames) {
 181         print('vire non ascii')
 182         couple <- list(c('é','e'),
 183                     c('è','e'),
 184                     c('ê','e'),
 185                     c('ë','e'),
 186                     c('î','i'),
 187                     c('ï','i'),
 188                     c('ì','i'),
 189                     c('à','a'),
 190                     c('â','a'),
 191                     c('ä','a'),
 192                     c('á','a'),
 193                     c('ù','u'),
 194                     c('û','u'),
 195                     c('ü','u'),
 196                     c('ç','c'),
 197                     c('ò','o'),
 198                     c('ô','o'),
 199                     c('ö','o'),
 200                     c('ñ','n')
 201                     )
 202         for (c in couple) {
 203             rnames<-gsub(c[1],c[2], rnames)
 204         }
 205         rnames
 206     }
 207     library(rgl)
 208     #rn <- vire.nonascii(rownames(table.in))
 209     rn <- rownames(table.in)
 210     rgl.open()
 211     par3d(cex=0.7)
 212     #par3d(windowRect = c(100,100,600,600))
 213     rgl.bg(col = c('white', "#99bb99"), front = "lines", box=FALSE, sphere = TRUE)
 214     rgl.lines(c(rx), c(0, 0), c(0, 0), col = "#000000")
 215     rgl.lines(c(0,0),c(ry),c(0,0),col = "#000000")
 216     rgl.lines(c(0,0),c(0,0),c(rz),col = "#000000")
 217     text3d(rx[2]+1,0,0, xlab)
 218     text3d(0,ry[2]+1,0, ylab)
 219     text3d(0,0,rz[2]+1, zlab)
 220     rain = rainbow(clnb)
 221      if (tchi) {
 222         maxchi <- norm.vec(maxchi, tchi.min/100, tchi.max/100)
 223     } else if (!is.null(cex.par)) {
 224         maxchi <- norm.vec(cex.par, txt.min/100, txt.max/100)
 225     } else {
 226         maxchi <- 0.1
 227     }
 228     colors = rain[classes]
 229     text3d(table.in[,1], table.in[,2], table.in[,3], rn, col= colors , cex = cex.par)
 230     for (i in 1:clnb) {
 231         text3d(rx[2],(ry[2]+(0.2*i)),0,paste('classe',i),col=rain[i])
 232     }
 233     #if (tchi) {
 234     #    rgl.spheres(table.in, col = colors, radius = maxchi, alpha = alpha)
 235     #}
 236
 237     if (dofilm) {
 238         require(tcltk)
 239         ReturnVal <- tkmessageBox(title="RGL 3 D",message="Cliquez pour commencer le film",icon="info",type="ok")
 240
 241         movie3d(spin3d(axis=c(0,1,0),rpm=6), movie = 'film', frames = "tmpfilm", duration=10, clean=TRUE, top = TRUE, dir = dirout)
 242         ReturnVal <- tkmessageBox(title="RGL 3 D",message="Fini !",icon="info",type="ok")
 243     }
 244
 245     require(tcltk)
 246     ReturnVal <- tkmessageBox(title="RGL 3 D",message="Cliquez pour fermer",icon="info",type="ok")
 247     rgl.close()
 248 }