#Author: Pierre Ratinaud #Copyright (c) 20010-2013 Pierre Ratinaud #Lisense: GNU/GPL #fichier genere par IRaMuTeq source('%s', encoding = 'utf8') typegraph <- %i what <- %i x <- %i y <- %i z <- %i qui <- %i over <- %s do.select.nb <- %s select.nb <- %i do.select.chi <- %s select.chi <- %i do.select.chi.classe <- %s ptbycluster <- %i cex.txt <- %s txt.min <- %i txt.max <- %i fileout <- '%s' width <- %i height <- %i taillecar <- %i alpha <- %i/100 dofilm <- %s 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, ' -') if (!typegraph == 0) {zlab <- paste('facteur ', z, ' -')} xlab <- paste(xlab,round(afc_table$facteur[x,2],2),sep = ' ') xlab <- paste(xlab,' %%',sep = '') ylab <- paste(ylab,round(afc_table$facteur[y,2],2),sep = ' ') ylab <- paste(ylab,' %%',sep = '') if (!typegraph == 0) { zlab <- paste(zlab,round(afc_table$facteur[z,2],2),sep = ' ') zlab <- paste(zlab,' %%',sep = '') } 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 { table.in<-table.in[,c(x,y,z)] rx <- range(table.in[,1], na.rm = TRUE) ry <- range(table.in[,2], na.rm = TRUE) rz <- range(table.in[,3], na.rm = TRUE) } classes <- c(1:clnb) maxchi <- 1 cex.par <- rep(taillecar/10, nrow(table.in)) } else { if ( what == 0 ) table.in <- afc$rowcoord if ( what == 1 ) table.in <- afc$rowcrl rownames(table.in) <- afc$rownames tablechi <- chistabletot rn.keep <- c() if (typegraph == 0) { table.in<-table.in[,c(x,y)] } else { table.in<-table.in[,c(x,y,z)] rx <- range(table.in[,1], na.rm = TRUE) ry <- range(table.in[,2], na.rm = TRUE) rz <- range(table.in[,3], na.rm = TRUE) } if (exists('afctable')) { eff <- rowSums(afctable) } else { eff <- afctable$rowmass } if (!is.null(debsup)) { if ( qui == 0 ) { table.in <- table.in[1:(debsup-1),] tablechi <- tablechi[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 <- eff[debsup:(debet-1)] } if ( qui == 2 ) { table.in <- table.in[debet:nrow(table.in),] tablechi <- tablechi[debet:nrow(tablechi),] cex.par <- eff[debet:nrow(afctable)] } } if (is.null(debsup)) { if (qui == 0) { if (!is.null(debet)) { table.in <- table.in[1:(debet-1),] tablechi <- tablechi[1:(debet-1),] cex.par <- eff[1:(debet-1)] } else { cex.par <- eff } } else { table.in <- table.in[debet:nrow(table.in),] tablechi <- tablechi[debet:nrow(tablechi),] cex.par <- eff[debet:nrow(afctable)] } } if (do.select.nb) { if (select.nb > nrow(table.in)) select.nb <- nrow(table.in) row.keep <- select_point_nb(tablechi, select.nb) table.in <- table.in[row.keep,] tablechi <- tablechi[row.keep,] } else if (do.select.chi) { if (select.chi > max(tablechi)) select.chi <- max(tablechi) row.keep <- select_point_chi(tablechi, select.chi) table.in <- table.in[row.keep,] tablechi <- tablechi[row.keep,] } else if (do.select.chi.classe) { row.keep <- select.chi.classe(tablechi, ptbycluster) table.in <- table.in[row.keep,] tablechi <- tablechi[row.keep,] } else { row.keep <- 1:nrow(table.in) } 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) cex.par <- cex.par[row.keep] cex.par <- norm.vec(cex.par, txt.min/10, txt.max/10) } else if (tchi) { cex.par <- maxchi cex.par <- norm.vec(cex.par, tchi.min/10, tchi.max/10) } else { cex.par <- rep(taillecar/10, nrow(table.in)) } } 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))) } 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))) } if (typegraph == 0) { open_file_graph(fileout, width = width, height = height, svg = do.svg) parcex <- taillecar/10 par(cex = parcex) if (over) { 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.in <- stopoverlap(table.in, cex.par=cex.par, xlim = xminmax, ylim = yminmax) 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, xminmax = xminmax, yminmax = yminmax) } else { library(rgl) rn <- vire.nonascii(rownames(table.in)) rain = rainbow(clnb) colors = rain[classes] #rn <- rownames(table.in) #rgl.open() par3d('userMatrix' = matrix(c(1,0,0,0, 0,1,0,0,0,0,1,0,0,0,0,1), ncol=4, nrow = 4)) 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(cex=0.7) #par3d(windowRect = c(100,100,600,600)) 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) if (tchi) { maxchi <- norm.vec(maxchi, tchi.min/100, tchi.max/100) } else if (!is.null(cex.par)) { maxchi <- norm.vec(cex.par, txt.min/100, txt.max/100) } else { maxchi <- 0.1 } for (i in 1:clnb) { text3d(rx[2],(ry[2]+(0.2*i)),0,paste('classe',i),col=rain[i]) } #if (tchi) { # rgl.spheres(table.in, col = colors, radius = maxchi, alpha = alpha) #} if (dofilm) { require(tcltk) ReturnVal <- tkmessageBox(title="RGL 3 D",message="Cliquez pour commencer le film",icon="info",type="ok") movie3d(spin3d(axis=c(0,1,0),rpm=6), movie = 'film', frames = "tmpfilm", duration=10, clean=TRUE, top = TRUE, dir = dirout) 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") rgl.close() }