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