X-Git-Url: http://iramuteq.org/git?p=iramuteq;a=blobdiff_plain;f=Rscripts%2Fafc_graph.R;h=5b12163e7d4136b97f7a77199cafc73bcaf3eccc;hp=cc70625022cda697ae31972bec97799ce6db445e;hb=fc14fc86c13eb0ed0f420771b08cc42a5db90c01;hpb=13666be5de5eeffbe63774c3c0aecd407b519ac6

diff --git a/Rscripts/afc_graph.R b/Rscripts/afc_graph.R
index cc70625..5b12163 100644
--- a/Rscripts/afc_graph.R
+++ b/Rscripts/afc_graph.R
@@ -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,27 @@ 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 <- afctable$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 ) {
            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)]
         }
     }
     
@@ -96,30 +106,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)
@@ -139,7 +136,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,118 +155,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))
     }
 }
 
-#################################################@@
-#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)<rot.per
-        r <-0
-		theta <- runif(1,0,2*pi)
-		x1<- x[i,1] 
-		y1<- x[i,2]
-		wid <- strwidth(words[i],cex=size[i])
-		ht <- strheight(words[i],cex=size[i])
-		if(grepl(tails,words[i]))
-			ht <- ht + ht*.2
-		if(rotWord){
-			tmp <- ht
-			ht <- wid
-			wid <- tmp	
-		}
-		isOverlaped <- TRUE
-		while(isOverlaped){
-			if(!overlap(x1-.5*wid,y1-.5*ht,wid,ht, boxes)) { #&&
-                toplot <- rbind(toplot, c(x1, y1, size[i], i)) 
-				#text(x1,y1,words[i],cex=size[i],offset=0,srt=rotWord*90,
-				#		col=cols[classes[i]])
-				boxes[[length(boxes)+1]] <- c(x1-.5*wid,y1-.5*ht,wid,ht)
-				isOverlaped <- FALSE
-			} else {
-				if(r>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) {
 
-    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)
+    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)
+    make_afc_graph(table.in, classes, clnb, xlab, ylab, cex.txt = cex.par, xminmax = xminmax, yminmax = yminmax)
 
 } else {