X-Git-Url: http://iramuteq.org/git?p=iramuteq;a=blobdiff_plain;f=Rscripts%2Fafc_graph.R;h=bda5ce77ee0dea428626311029df38d8a3b5b9de;hp=cc70625022cda697ae31972bec97799ce6db445e;hb=0e02f9566eb56fcb0f16bd070248235f78093ff5;hpb=13666be5de5eeffbe63774c3c0aecd407b519ac6 diff --git a/Rscripts/afc_graph.R b/Rscripts/afc_graph.R index cc70625..bda5ce7 100644 --- a/Rscripts/afc_graph.R +++ b/Rscripts/afc_graph.R @@ -1,10 +1,10 @@ #Author: Pierre Ratinaud -#Copyright (c) 20010 Pierre Ratinaud -#Lisense: GNU/GPL +#Copyright (c) 20010-2013 Pierre Ratinaud +#License: GNU/GPL #fichier genere par IRaMuTeq -source('%s') +source('%s', encoding = 'utf8') typegraph <- %i what <- %i x <- %i @@ -31,6 +31,9 @@ tchi <- %s tchi.min <- %i tchi.max <- %i dirout <- '%s' +do.svg <- %s +xminmax <- NULL +yminmax <- NULL xlab <- paste('facteur ', x, ' -') ylab <- paste('facteur ', y, ' -') @@ -48,6 +51,7 @@ if ( qui == 3 ) { if ( what == 0 ) table.in <- afc$colcoord if ( what == 1 ) table.in <- afc$colcrl rownames(table.in) <- afc$colnames + eff <- afc$colmass if (typegraph == 0) { table.in<-table.in[,c(x,y)] } else { @@ -58,10 +62,10 @@ if ( qui == 3 ) { } classes <- c(1:clnb) maxchi <- 1 - cex.par <- NULL + cex.par <- rep(taillecar/10, nrow(table.in)) } else { if ( what == 0 ) table.in <- afc$rowcoord - if ( what == 1 ) table.in <- afc$rowcrl*2 + if ( what == 1 ) table.in <- afc$rowcrl rownames(table.in) <- afc$rownames tablechi <- chistabletot rn.keep <- c() @@ -73,21 +77,28 @@ if ( qui == 3 ) { ry <- range(table.in[,2], na.rm = TRUE) rz <- range(table.in[,3], na.rm = TRUE) } + if (exists('afctable')) { + eff <- rowSums(afctable) + } else { + eff <- afc$rowmass + } + if (!is.null(debsup)) { if ( qui == 0 ) { table.in <- table.in[1:(debsup-1),] tablechi <- tablechi[1:(debsup-1),] - cex.par <- afc$rowmass[1:(debsup-1)] + cex.par <- eff[1:(debsup-1)] } if ( qui == 1 ) { table.in <- table.in[debsup:(debet-1),] tablechi <- tablechi[debsup:(debet-1),] - #cex.par <- afc$rowmass[debsup:(debet-1)] + cex.par <- eff[debsup:(debet-1)] } if ( qui == 2 ) { + fin <- nrow(table.in) table.in <- table.in[debet:nrow(table.in),] tablechi <- tablechi[debet:nrow(tablechi),] - #cex.par <- afc$rowmass[debet:nrow(tablechi)] + cex.par <- eff[debet:fin] } } @@ -96,30 +107,18 @@ if ( qui == 3 ) { if (!is.null(debet)) { table.in <- table.in[1:(debet-1),] tablechi <- tablechi[1:(debet-1),] - cex.par <- afc$rowmass[1:(debet-1)] + cex.par <- eff[1:(debet-1)] } else { - cex.par <- afc$rowmass + cex.par <- eff } } else { + fin <- nrow(table.in) table.in <- table.in[debet:nrow(table.in),] tablechi <- tablechi[debet:nrow(tablechi),] - #cex.par <- afc$rowmass[debet:nrow(tablechi)] + cex.par <- eff[debet:fin] } } -# if (over) { -# rn <- rownames(table.in) -# rownames(table.in) <- 1:nrow(table.in) -# table.in <- unique(table.in) -# rn.keep <- as.numeric(rownames(table.in)) -# rownames(table.in) <- rn[rn.keep] -# tablechi <- tablechi[rn.keep,] -# if (qui==0) { -# cex.par <- cex.par[rn.keep] -# } else { -# cex.par <- NULL -# } -# } if (do.select.nb) { if (select.nb > nrow(table.in)) select.nb <- nrow(table.in) row.keep <- select_point_nb(tablechi, select.nb) @@ -131,7 +130,7 @@ if ( qui == 3 ) { table.in <- table.in[row.keep,] tablechi <- tablechi[row.keep,] } else if (do.select.chi.classe) { - row.keep <- select.chi.classe(tablechi, ptbycluster) + row.keep <- select.chi.classe(tablechi, ptbycluster, active=FALSE) table.in <- table.in[row.keep,] tablechi <- tablechi[row.keep,] } else { @@ -139,7 +138,16 @@ if ( qui == 3 ) { } classes <- apply(tablechi, 1, which.max) maxchi <- apply(tablechi, 1, max) - + infp <- which(is.infinite(maxchi) & maxchi > 0) + if (length(infp)) { + maxchi[infp] <- NA + if (!length(infp) == length(maxchi)) { + valmax <- max(maxchi, na.rm = TRUE) + } else { + valmax <- 8 + } + maxchi[infp] <- valmax + 2 + } if (cex.txt) { #row.keep <- append(row.keep, rn.keep) #row.keep <- unique(row.keep) @@ -149,162 +157,72 @@ if ( qui == 3 ) { cex.par <- maxchi cex.par <- norm.vec(cex.par, tchi.min/10, tchi.max/10) } else { - cex.par <- NULL + cex.par <- rep(taillecar/10, nrow(table.in)) } } -#################################################@@ -#from wordcloud -overlap <- function(x1, y1, sw1, sh1, boxes) { - use.r.layout <- FALSE - if(!use.r.layout) - return(.overlap(x1,y1,sw1,sh1,boxes)) - s <- 0 - if (length(boxes) == 0) - return(FALSE) - for (i in c(last,1:length(boxes))) { - bnds <- boxes[[i]] - x2 <- bnds[1] - y2 <- bnds[2] - sw2 <- bnds[3] - sh2 <- bnds[4] - if (x1 < x2) - overlap <- x1 + sw1 > x2-s - else - overlap <- x2 + sw2 > x1-s - - if (y1 < y2) - overlap <- overlap && (y1 + sh1 > y2-s) - else - overlap <- overlap && (y2 + sh2 > y1-s) - if(overlap){ - last <<- i - return(TRUE) - } - } - FALSE -} - -.overlap <- function(x11,y11,sw11,sh11,boxes1){ - .Call("is_overlap",x11,y11,sw11,sh11,boxes1) -} - -stopoverlap <- function(x, cex.par = NULL) { -#from wordcloud - library(wordcloud) - tails <- "g|j|p|q|y" - rot.per <- 0 - last <- 1 - thetaStep <- .1 - rStep <- .5 - toplot <- NULL - -# plot.new() - plot(x[,1],x[,2], pch='') - - words <- rownames(x) - if (is.null(cex.par)) { - size <- rep(0.9, nrow(x)) - } else { - size <- cex.par +if (is.null(xminmax)) { + 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))) } - #cols <- rainbow(clnb) - boxes <- list() - for (i in 1:nrow(x)) { - rotWord <- runif(1)sqrt(.5)){ - print(paste(words[i], "could not be fit on page. It will not be plotted.")) - isOverlaped <- FALSE - } - theta <- theta+thetaStep - r <- r + rStep*thetaStep/(2*pi) - x1 <- x[i,1]+r*cos(theta) - y1 <- x[i,2]+r*sin(theta) - } - } + if (is.null(yminmax)) { + 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))) } - row.names(toplot) <- words[toplot[,4]] - return(toplot) -} -############################################################################### -if (typegraph == 0) { +if (typegraph == 0 || typegraph == 2) { - open_file_graph(fileout, width = width, height = height) + open_file_graph(fileout, width = width, height = height, svg = do.svg) parcex <- taillecar/10 par(cex = parcex) if (over) { - table.in <- stopoverlap(table.in, cex.par=cex.par) - classes <- classes[table.in[,4]] - cex.par <- cex.par[table.in[,4]] + table.in <- table.in[order(cex.par, decreasing = TRUE),] + classes <- classes[order(cex.par, decreasing = TRUE)] + cex.par <- cex.par[order(cex.par, decreasing = TRUE)] + table.out <- stopoverlap(table.in, cex.par=cex.par, xlim = xminmax, ylim = yminmax) + table.in <- table.out$toplot + notplot <- table.out$notplot + if (! is.null(notplot)) { + write.csv2(notplot, file = paste(fileout,'_notplotted.csv', sep='')) + } + classes <- classes[table.in[,4]] + cex.par <- cex.par[table.in[,4]] } - make_afc_graph(table.in, classes, clnb, xlab, ylab, cex.txt = cex.par) - -} else { - - vire.nonascii <- function(rnames) { - print('vire non ascii') - couple <- list(c('é','e'), - c('è','e'), - c('ê','e'), - c('ë','e'), - c('î','i'), - c('ï','i'), - c('ì','i'), - c('à','a'), - c('â','a'), - c('ä','a'), - c('á','a'), - c('ù','u'), - c('û','u'), - c('ü','u'), - c('ç','c'), - c('ò','o'), - c('ô','o'), - c('ö','o'), - c('ñ','n') - ) - for (c in couple) { - rnames<-gsub(c[1],c[2], rnames) + if (typegraph == 0) { + make_afc_graph(table.in, classes, clnb, xlab, ylab, cex.txt = cex.par, xminmax = xminmax, yminmax = yminmax) + } else { + dev.off() + require(rgexf) + nodes.attr <- make.afc.attributes(rownames(table.in), afc_table, afctable, clnb) + if (qui != 3) { + tokeep <- rownames(chistabletot) %%in%% rownames(table.in) + chis <- chistabletot[tokeep,] + chis<-chis[rownames(table.in),] + nodes.attr$chiclasse <- chis + } else { + chis <- NULL } - rnames + afctogexf(fileout, table.in, classes, clnb, cex.par, nodes.attr = nodes.attr) } + +} else { library(rgl) - #rn <- vire.nonascii(rownames(table.in)) - rn <- rownames(table.in) - rgl.open() + rn <- vire.nonascii(rownames(table.in)) + rain = rainbow(clnb) + colors = rain[classes] + #rn <- rownames(table.in) + #rgl.open() + + text3d(table.in[,1], table.in[,2], table.in[,3], rn, col = colors , cex = cex.par) + rgl.bg(col = c('white', "#99bb99"), front = "lines", box=FALSE, sphere = TRUE) + par3d('userMatrix' = matrix(c(1,0,0,0, 0,1,0,0,0,0,1,0,0,0,0,1), ncol=4, nrow = 4)) par3d(cex=0.7) #par3d(windowRect = c(100,100,600,600)) - rgl.bg(col = c('white', "#99bb99"), front = "lines", box=FALSE, sphere = TRUE) rgl.lines(c(rx), c(0, 0), c(0, 0), col = "#000000") rgl.lines(c(0,0),c(ry),c(0,0),col = "#000000") rgl.lines(c(0,0),c(0,0),c(rz),col = "#000000") text3d(rx[2]+1,0,0, xlab) text3d(0,ry[2]+1,0, ylab) text3d(0,0,rz[2]+1, zlab) - rain = rainbow(clnb) + if (tchi) { maxchi <- norm.vec(maxchi, tchi.min/100, tchi.max/100) } else if (!is.null(cex.par)) { @@ -312,8 +230,8 @@ if (typegraph == 0) { } else { maxchi <- 0.1 } - colors = rain[classes] - text3d(table.in[,1], table.in[,2], table.in[,3], rn, col= colors , cex = cex.par) + + for (i in 1:clnb) { text3d(rx[2],(ry[2]+(0.2*i)),0,paste('classe',i),col=rain[i]) } @@ -329,7 +247,11 @@ if (typegraph == 0) { ReturnVal <- tkmessageBox(title="RGL 3 D",message="Fini !",icon="info",type="ok") } - require(tcltk) - ReturnVal <- tkmessageBox(title="RGL 3 D",message="Cliquez pour fermer",icon="info",type="ok") + if (typegraph == 1) { + require(tcltk) + ReturnVal <- tkmessageBox(title="RGL 3 D",message="Cliquez pour fermer",icon="info",type="ok") + } else { + writeWebGL(dir = fileout, width = width, height= height) + } rgl.close() }