X-Git-Url: http://iramuteq.org/git?p=iramuteq;a=blobdiff_plain;f=Rscripts%2Fafc_graph.R;h=e0c2adfae25c440193a87e54e1075a2653c7478b;hp=17f065e8c6779c26af37372a15ae868ac0f24cfe;hb=12b4b71c8c8feb6154abc04dfa9bb93a521ef789;hpb=22cd27b2bbe9ab1ffa7ef06fa764b5147ae17dad diff --git a/Rscripts/afc_graph.R b/Rscripts/afc_graph.R index 17f065e..e0c2adf 100644 --- a/Rscripts/afc_graph.R +++ b/Rscripts/afc_graph.R @@ -16,6 +16,8 @@ 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 @@ -29,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, ' -') @@ -56,10 +61,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() @@ -71,21 +76,22 @@ if ( qui == 3 ) { ry <- range(table.in[,2], na.rm = TRUE) rz <- range(table.in[,3], na.rm = TRUE) } + eff <- rowSums(afctable) 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 ) { table.in <- table.in[debet:nrow(table.in),] tablechi <- tablechi[debet:nrow(tablechi),] - #cex.par <- afc$rowmass[debet:nrow(tablechi)] + cex.par <- eff[debet:nrow(afctable)] } } @@ -94,30 +100,17 @@ 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 { table.in <- table.in[debet:nrow(table.in),] tablechi <- tablechi[debet:nrow(tablechi),] - #cex.par <- afc$rowmass[debet:nrow(tablechi)] + cex.par <- eff[debet:nrow(afctable)] } } - 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) @@ -128,12 +121,25 @@ if ( qui == 3 ) { 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) @@ -143,16 +149,31 @@ 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)) } } +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) + open_file_graph(fileout, width = width, height = height, svg = do.svg) parcex <- taillecar/10 par(cex = parcex) - make_afc_graph(table.in, classes, clnb, xlab, ylab, cex.txt = cex.par) + 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 { @@ -184,8 +205,10 @@ if (typegraph == 0) { rnames } library(rgl) - rn <- vire.nonascii(rownames(table.in)) + #rn <- vire.nonascii(rownames(table.in)) + rn <- rownames(table.in) rgl.open() + 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") @@ -195,19 +218,21 @@ if (typegraph == 0) { text3d(0,ry[2]+1,0, ylab) text3d(0,0,rz[2]+1, zlab) rain = rainbow(clnb) - colors = rain[classes] - text3d(table.in[,1], table.in[,2], table.in[,3], rn, col='black') - if (tchi) { + 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 } + 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]) } - rgl.spheres(table.in, col = colors, radius = maxchi, alpha = alpha) + #if (tchi) { + # rgl.spheres(table.in, col = colors, radius = maxchi, alpha = alpha) + #} if (dofilm) { require(tcltk)