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