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', encoding = 'utf8')
   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     library(rgl)
 186     rn <- vire.nonascii(rownames(table.in))
 187     print(rn)
 188     rain = rainbow(clnb)
 189     colors = rain[classes]
 190     #rn <- rownames(table.in)
 191     open3d()
 192     text3d(table.in[,1], table.in[,2], table.in[,3], rn, col = colors , cex = cex.par)
 193     par3d(cex=0.7)
 194     #par3d(windowRect = c(100,100,600,600))
 195     rgl.bg(col = c('white', "#99bb99"), front = "lines", box=FALSE, sphere = FALSE)
 196     rgl.lines(c(rx), c(0, 0), c(0, 0), col = "#000000")
 197     rgl.lines(c(0,0),c(ry),c(0,0),col = "#000000")
 198     rgl.lines(c(0,0),c(0,0),c(rz),col = "#000000")
 199     text3d(rx[2]+1,0,0, xlab)
 200     text3d(0,ry[2]+1,0, ylab)
 201     text3d(0,0,rz[2]+1, zlab)
 202
 203      if (tchi) {
 204         maxchi <- norm.vec(maxchi, tchi.min/100, tchi.max/100)
 205     } else if (!is.null(cex.par)) {
 206         maxchi <- norm.vec(cex.par, txt.min/100, txt.max/100)
 207     } else {
 208         maxchi <- 0.1
 209     }
 210
 211
 212     for (i in 1:clnb) {
 213         text3d(rx[2],(ry[2]+(0.2*i)),0,paste('classe',i),col=rain[i])
 214     }
 215     #if (tchi) {
 216     #    rgl.spheres(table.in, col = colors, radius = maxchi, alpha = alpha)
 217     #}
 218
 219     if (dofilm) {
 220         require(tcltk)
 221         ReturnVal <- tkmessageBox(title="RGL 3 D",message="Cliquez pour commencer le film",icon="info",type="ok")
 222
 223         movie3d(spin3d(axis=c(0,1,0),rpm=6), movie = 'film', frames = "tmpfilm", duration=10, clean=TRUE, top = TRUE, dir = dirout)
 224         ReturnVal <- tkmessageBox(title="RGL 3 D",message="Fini !",icon="info",type="ok")
 225     }
 226
 227     require(tcltk)
 228     ReturnVal <- tkmessageBox(title="RGL 3 D",message="Cliquez pour fermer",icon="info",type="ok")
 229     rgl.close()
 230 }