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 #from wordcloud
 158 overlap <- function(x1, y1, sw1, sh1, boxes) {
 159     use.r.layout <- FALSE
 160         if(!use.r.layout)
 161                 return(.overlap(x1,y1,sw1,sh1,boxes))
 162         s <- 0
 163         if (length(boxes) == 0)
 164                 return(FALSE)
 165         for (i in c(last,1:length(boxes))) {
 166                 bnds <- boxes[[i]]
 167                 x2 <- bnds[1]
 168                 y2 <- bnds[2]
 169                 sw2 <- bnds[3]
 170                 sh2 <- bnds[4]
 171                 if (x1 < x2)
 172                         overlap <- x1 + sw1 > x2-s
 173                 else
 174                         overlap <- x2 + sw2 > x1-s
 175
 176                 if (y1 < y2)
 177                         overlap <- overlap && (y1 + sh1 > y2-s)
 178                 else
 179                         overlap <- overlap && (y2 + sh2 > y1-s)
 180                 if(overlap){
 181                         last <<- i
 182                         return(TRUE)
 183                 }
 184         }
 185         FALSE
 186 }
 187
 188 .overlap <- function(x11,y11,sw11,sh11,boxes1){
 189     .Call("is_overlap",x11,y11,sw11,sh11,boxes1)
 190 }
 191
 192 stopoverlap <- function(x, cex.par = NULL) {
 193 #from wordcloud
 194     library(wordcloud)
 195     tails <- "g|j|p|q|y"
 196     rot.per <- 0
 197     last <- 1
 198     thetaStep <- .1
 199     rStep <- .5
 200     toplot <- NULL
 201
 202 #    plot.new()
 203     plot(x[,1],x[,2], pch='')
 204
 205     words <- rownames(x)
 206     if  (is.null(cex.par))  {
 207         size <- rep(0.9, nrow(x))
 208     } else {
 209         size <- cex.par
 210     }
 211     #cols <- rainbow(clnb)
 212     boxes <- list()
 213     for (i in 1:nrow(x)) {
 214         rotWord <- runif(1)<rot.per
 215         r <-0
 216                 theta <- runif(1,0,2*pi)
 217                 x1<- x[i,1]
 218                 y1<- x[i,2]
 219                 wid <- strwidth(words[i],cex=size[i])
 220                 ht <- strheight(words[i],cex=size[i])
 221                 if(grepl(tails,words[i]))
 222                         ht <- ht + ht*.2
 223                 if(rotWord){
 224                         tmp <- ht
 225                         ht <- wid
 226                         wid <- tmp
 227                 }
 228                 isOverlaped <- TRUE
 229                 while(isOverlaped){
 230                         if(!overlap(x1-.5*wid,y1-.5*ht,wid,ht, boxes)) { #&&
 231                 toplot <- rbind(toplot, c(x1, y1, size[i], i))
 232                                 #text(x1,y1,words[i],cex=size[i],offset=0,srt=rotWord*90,
 233                                 #               col=cols[classes[i]])
 234                                 boxes[[length(boxes)+1]] <- c(x1-.5*wid,y1-.5*ht,wid,ht)
 235                                 isOverlaped <- FALSE
 236                         } else {
 237                                 if(r>sqrt(.5)){
 238                                         print(paste(words[i], "could not be fit on page. It will not be plotted."))
 239                                         isOverlaped <- FALSE
 240                                 }
 241                                 theta <- theta+thetaStep
 242                                 r <- r + rStep*thetaStep/(2*pi)
 243                                 x1 <- x[i,1]+r*cos(theta)
 244                                 y1 <- x[i,2]+r*sin(theta)
 245                         }
 246                 }
 247     }
 248     row.names(toplot) <- words[toplot[,4]]
 249     return(toplot)
 250 }
 251 ###############################################################################
 252
 253 if (typegraph == 0) {
 254
 255     open_file_graph(fileout, width = width, height = height)
 256     parcex <- taillecar/10
 257     par(cex = parcex)
 258     if (over) {
 259     table.in <- stopoverlap(table.in, cex.par=cex.par)
 260     classes <- classes[table.in[,4]]
 261     cex.par <- cex.par[table.in[,4]]
 262     }
 263     make_afc_graph(table.in, classes, clnb, xlab, ylab, cex.txt = cex.par)
 264
 265 } else {
 266
 267     vire.nonascii <- function(rnames) {
 268         print('vire non ascii')
 269         couple <- list(c('é','e'),
 270                     c('è','e'),
 271                     c('ê','e'),
 272                     c('ë','e'),
 273                     c('î','i'),
 274                     c('ï','i'),
 275                     c('ì','i'),
 276                     c('à','a'),
 277                     c('â','a'),
 278                     c('ä','a'),
 279                     c('á','a'),
 280                     c('ù','u'),
 281                     c('û','u'),
 282                     c('ü','u'),
 283                     c('ç','c'),
 284                     c('ò','o'),
 285                     c('ô','o'),
 286                     c('ö','o'),
 287                     c('ñ','n')
 288                     )
 289         for (c in couple) {
 290             rnames<-gsub(c[1],c[2], rnames)
 291         }
 292         rnames
 293     }
 294     library(rgl)
 295     #rn <- vire.nonascii(rownames(table.in))
 296     rn <- rownames(table.in)
 297     rgl.open()
 298     par3d(cex=0.7)
 299     #par3d(windowRect = c(100,100,600,600))
 300     rgl.bg(col = c('white', "#99bb99"), front = "lines", box=FALSE, sphere = TRUE)
 301     rgl.lines(c(rx), c(0, 0), c(0, 0), col = "#000000")
 302     rgl.lines(c(0,0),c(ry),c(0,0),col = "#000000")
 303     rgl.lines(c(0,0),c(0,0),c(rz),col = "#000000")
 304     text3d(rx[2]+1,0,0, xlab)
 305     text3d(0,ry[2]+1,0, ylab)
 306     text3d(0,0,rz[2]+1, zlab)
 307     rain = rainbow(clnb)
 308      if (tchi) {
 309         maxchi <- norm.vec(maxchi, tchi.min/100, tchi.max/100)
 310     } else if (!is.null(cex.par)) {
 311         maxchi <- norm.vec(cex.par, txt.min/100, txt.max/100)
 312     } else {
 313         maxchi <- 0.1
 314     }
 315     colors = rain[classes]
 316     text3d(table.in[,1], table.in[,2], table.in[,3], rn, col= colors , cex = cex.par)
 317     for (i in 1:clnb) {
 318         text3d(rx[2],(ry[2]+(0.2*i)),0,paste('classe',i),col=rain[i])
 319     }
 320     #if (tchi) {
 321     #    rgl.spheres(table.in, col = colors, radius = maxchi, alpha = alpha)
 322     #}
 323
 324     if (dofilm) {
 325         require(tcltk)
 326         ReturnVal <- tkmessageBox(title="RGL 3 D",message="Cliquez pour commencer le film",icon="info",type="ok")
 327
 328         movie3d(spin3d(axis=c(0,1,0),rpm=6), movie = 'film', frames = "tmpfilm", duration=10, clean=TRUE, top = TRUE, dir = dirout)
 329         ReturnVal <- tkmessageBox(title="RGL 3 D",message="Fini !",icon="info",type="ok")
 330     }
 331
 332     require(tcltk)
 333     ReturnVal <- tkmessageBox(title="RGL 3 D",message="Cliquez pour fermer",icon="info",type="ok")
 334     rgl.close()
 335 }