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
  35 xlab <- paste('facteur ', x, ' -')
  36 ylab <- paste('facteur ', y, ' -')
  37 if (!typegraph == 0) {zlab <- paste('facteur ', z, ' -')}
  38 xlab <- paste(xlab,round(afc_table$facteur[x,2],2),sep = ' ')
  39 xlab <- paste(xlab,' %%',sep = '')
  40 ylab <- paste(ylab,round(afc_table$facteur[y,2],2),sep = ' ')
  41 ylab <- paste(ylab,' %%',sep = '')
  42 if (!typegraph == 0) {
  43     zlab <- paste(zlab,round(afc_table$facteur[z,2],2),sep = ' ')
  44     zlab <- paste(zlab,' %%',sep = '')
  45 }
  46
  47 if ( qui == 3 ) {
  48     if ( what == 0 ) table.in <- afc$colcoord
  49     if ( what == 1 ) table.in <- afc$colcrl
  50     rownames(table.in) <- afc$colnames
  51     if (typegraph == 0) {
  52         table.in<-table.in[,c(x,y)]
  53     } else {
  54         table.in<-table.in[,c(x,y,z)]
  55         rx <- range(table.in[,1], na.rm = TRUE)
  56         ry <- range(table.in[,2], na.rm = TRUE)
  57         rz <- range(table.in[,3], na.rm = TRUE)
  58     }
  59     classes <- c(1:clnb)
  60     maxchi <- 1
  61     cex.par <- NULL
  62 } else {
  63     if ( what == 0 ) table.in <- afc$rowcoord
  64     if ( what == 1 ) table.in <- afc$rowcrl*2
  65     rownames(table.in) <- afc$rownames
  66     tablechi <- chistabletot
  67     rn.keep <- c()
  68     if (typegraph == 0) {
  69         table.in<-table.in[,c(x,y)]
  70     } else {
  71         table.in<-table.in[,c(x,y,z)]
  72         rx <- range(table.in[,1], na.rm = TRUE)
  73         ry <- range(table.in[,2], na.rm = TRUE)
  74         rz <- range(table.in[,3], na.rm = TRUE)
  75     }
  76     if (!is.null(debsup)) {
  77         if ( qui == 0 ) {
  78            table.in <- table.in[1:(debsup-1),]
  79            tablechi <- tablechi[1:(debsup-1),]
  80            cex.par <- afc$rowmass[1:(debsup-1)]
  81         }
  82         if ( qui == 1 ) {
  83            table.in <- table.in[debsup:(debet-1),]
  84            tablechi <- tablechi[debsup:(debet-1),]
  85            #cex.par <- afc$rowmass[debsup:(debet-1)]
  86         }
  87         if ( qui == 2 ) {
  88            table.in <- table.in[debet:nrow(table.in),]
  89            tablechi <- tablechi[debet:nrow(tablechi),]
  90            #cex.par <- afc$rowmass[debet:nrow(tablechi)]
  91         }
  92     }
  93
  94     if (is.null(debsup)) {
  95         if (qui == 0) {
  96             if (!is.null(debet)) {
  97                 table.in <- table.in[1:(debet-1),]
  98                 tablechi <- tablechi[1:(debet-1),]
  99                 cex.par <- afc$rowmass[1:(debet-1)]
 100             } else {
 101                 cex.par <- afc$rowmass
 102             }
 103         } else {
 104             table.in <- table.in[debet:nrow(table.in),]
 105             tablechi <- tablechi[debet:nrow(tablechi),]
 106             #cex.par <- afc$rowmass[debet:nrow(tablechi)]
 107         }
 108     }
 109
 110 #    if (over) {
 111 #        rn <- rownames(table.in)
 112 #        rownames(table.in) <- 1:nrow(table.in)
 113 #        table.in <- unique(table.in)
 114 #        rn.keep <- as.numeric(rownames(table.in))
 115 #        rownames(table.in) <- rn[rn.keep]
 116 #        tablechi <- tablechi[rn.keep,]
 117 #        if (qui==0) {
 118 #            cex.par <- cex.par[rn.keep]
 119 #        } else {
 120 #            cex.par <- NULL
 121 #        }
 122 #    }
 123     if (do.select.nb) {
 124         if (select.nb > nrow(table.in)) select.nb <- nrow(table.in)
 125         row.keep <- select_point_nb(tablechi, select.nb)
 126         table.in <- table.in[row.keep,]
 127         tablechi <- tablechi[row.keep,]
 128     } else if (do.select.chi) {
 129         if (select.chi > max(tablechi)) select.chi <- max(tablechi)
 130         row.keep <- select_point_chi(tablechi, select.chi)
 131         table.in <- table.in[row.keep,]
 132         tablechi <- tablechi[row.keep,]
 133     } else if (do.select.chi.classe) {
 134         row.keep <- select.chi.classe(tablechi, ptbycluster)
 135         table.in <- table.in[row.keep,]
 136         tablechi <- tablechi[row.keep,]
 137     } else {
 138         row.keep <- 1:nrow(table.in)
 139     }
 140     classes <- apply(tablechi, 1, which.max)
 141     maxchi <- apply(tablechi, 1, max)
 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 <- NULL
 153     }
 154 }
 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)
 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)
 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 }