X-Git-Url: http://iramuteq.org/git?p=iramuteq;a=blobdiff_plain;f=Rscripts%2FRgraph.R;h=e947a402ed0e5993681e790cac77a8ed0215a1f3;hp=c38f0b44bc334fecc29ff2c25456451a5f223832;hb=2ffa9388c45dce689bb45c1cf6c7ad81d2636409;hpb=9fbe978a9b2734bd17d10721a44016cc0ac97153 diff --git a/Rscripts/Rgraph.R b/Rscripts/Rgraph.R index c38f0b4..e947a40 100644 --- a/Rscripts/Rgraph.R +++ b/Rscripts/Rgraph.R @@ -43,7 +43,7 @@ PlotDendroCut <- function(chd,filename,reso,clusternb) { # dev.off() #} -PlotAfc2dCoul<- function(afc,chisqrtable,filename, what='coord',col=FALSE, axetoplot=c(1,2), deb=0,fin=0, width=900, height=900, quality=100, reso=200, parcex=PARCEX, xlab = NULL, ylab = NULL, xmin=NULL, xmax=NULL, ymin=NULL, ymax=NUL) { +PlotAfc2dCoul<- function(afc,chisqrtable,filename, what='coord',col=FALSE, axetoplot=c(1,2), deb=0,fin=0, width=900, height=900, quality=100, reso=200, parcex=PARCEX, xlab = NULL, ylab = NULL, xmin=NULL, xmax=NULL, ymin=NULL, ymax=NULL) { if (col) { if (what == 'coord') { rowcoord <- as.matrix(afc$colcoord) @@ -75,7 +75,7 @@ PlotAfc2dCoul<- function(afc,chisqrtable,filename, what='coord',col=FALSE, axeto if (!col) { classes <- as.matrix(apply(chitable,1,which.max)) cex.par <- norm.vec(apply(chitable,1,max), 0.8,3) - row.keep <- select.chi.classe(chitable, 60) + row.keep <- select.chi.classe(chitable, 80) rowcoord <- rowcoord[row.keep,] classes <- classes[row.keep] cex.par <- cex.par[row.keep] @@ -83,6 +83,15 @@ PlotAfc2dCoul<- function(afc,chisqrtable,filename, what='coord',col=FALSE, axeto classes <- 1:clnb cex.par <- rep(1,clnb) } + if (is.null(xmin)) { + table.in <- rowcoord + 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))) + xmin <- xminmax[1] + xmax <- xminmax[2] + 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))) + ymin <- yminmax[1] + ymax <- yminmax[2] + } #ntabtot <- cbind(rowcoord, classes) #if (!col) ntabtot <- ntabtot[row_keep,] xlab <- paste('facteur ', x, ' -') @@ -94,15 +103,20 @@ PlotAfc2dCoul<- function(afc,chisqrtable,filename, what='coord',col=FALSE, axeto open_file_graph(filename, width = width, height = height) par(cex=PARCEX) - table.in <- rowcoord[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) + table.out <- stopoverlap(table.in, cex.par=cex.par, xlim = c(xmin,xmax), ylim = c(ymin,ymax)) + table.in <- table.out$toplot + notplot <- table.out$notplot + if (! is.null(notplot)) { + write.csv2(notplot, file = paste(filename, '_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, xminmax=c(xmin,xmax), yminmax=c(ymin,ymax)) - + xyminmax <- list(yminmax = c(ymin,ymax), xminmax = c(xmin,xmax)) + xyminmax #plot(rowcoord[,x],rowcoord[,y], pch='', xlab = xlab, ylab = ylab) #abline(h=0,v=0) #for (i in 1:clnb) { @@ -173,7 +187,7 @@ overlap <- function(x1, y1, sw1, sh1, boxes) { .Call("is_overlap",x11,y11,sw11,sh11,boxes1) } ######################################################## -stopoverlap <- function(x, cex.par = NULL) { +stopoverlap <- function(x, cex.par = NULL, xlim = NULL, ylim = NULL) { #from wordcloud library(wordcloud) tails <- "g|j|p|q|y" @@ -182,9 +196,10 @@ stopoverlap <- function(x, cex.par = NULL) { thetaStep <- .1 rStep <- .5 toplot <- NULL + notplot <- NULL # plot.new() - plot(x[,1],x[,2], pch='') + plot(x[,1],x[,2], pch='', xlim = xlim, ylim = ylim) words <- rownames(x) if (is.null(cex.par)) { @@ -202,8 +217,6 @@ stopoverlap <- function(x, cex.par = NULL) { y1<- x[i,2] wid <- strwidth(words[i],cex=size[i]) ht <- strheight(words[i],cex=size[i]) - ht <- (ht + ht*.2) + .01 - wid <- (wid + wid*.1) + .01 isOverlaped <- TRUE while(isOverlaped){ if(!overlap(x1-.5*wid,y1-.5*ht,wid,ht, boxes)) { #&& @@ -215,6 +228,7 @@ stopoverlap <- function(x, cex.par = NULL) { } else { if(r>sqrt(.5)){ print(paste(words[i], "could not be fit on page. It will not be plotted.")) + notplot <- rbind(notplot,c(words[i], x[i,1], x[i,2])) isOverlaped <- FALSE } theta <- theta+thetaStep @@ -225,7 +239,7 @@ stopoverlap <- function(x, cex.par = NULL) { } } row.names(toplot) <- words[toplot[,4]] - return(toplot) + return(list(toplot = toplot, notplot = notplot)) } ############################################################################### @@ -428,13 +442,8 @@ create_afc_table <- function(x) { } make_afc_graph <- function(toplot, classes, clnb, xlab, ylab, cex.txt = NULL, leg = FALSE, cmd = FALSE, black = FALSE, xminmax=NULL, yminmax=NULL) { - if (is.null(xminmax)) { - xminmax <- c(min(toplot[,1], na.rm = TRUE) + (0.1 * min(toplot[,1], na.rm = TRUE)), max(toplot[,1], na.rm = TRUE) + (0.1 * max(toplot[,1], na.rm = TRUE))) - } - if (is.null(yminmax)) { - yminmax <- c(min(toplot[,2], na.rm = TRUE) + (0.1 * min(toplot[,2], na.rm = TRUE)), max(toplot[,2], na.rm = TRUE) + (0.1 * max(toplot[,2], na.rm = TRUE))) - } - rain <- rainbow(clnb) + + rain <- rainbow(clnb) compt <- 1 tochange <- NULL for (my.color in rain) { @@ -468,16 +477,120 @@ make_afc_graph <- function(toplot, classes, clnb, xlab, ylab, cex.txt = NULL, le } } +plot.dendro.prof <- function(tree, classes, chisqtable, nbbycl = 60, type.dendro = "phylogram", from.cmd = FALSE, bw = FALSE, lab = NULL) { + library(ape) + library(wordcloud) + classes<-classes[classes!=0] + classes<-as.factor(classes) + sum.cl<-as.matrix(summary(classes, maxsum=1000000)) + sum.cl<-(sum.cl/colSums(sum.cl)*100) + sum.cl<-round(sum.cl,2) + sum.cl<-cbind(sum.cl,as.matrix(100-sum.cl[,1])) + sum.cl <- sum.cl[,1] + tree.order<- as.numeric(tree$tip.label) + vec.mat<-NULL + row.keep <- select.chi.classe(chisqtable, nbbycl) + toplot <- chisqtable[row.keep,] + lclasses <- list() + for (classe in 1:length(sum.cl)) { + ntoplot <- toplot[,classe] + ntoplot <- ntoplot[order(ntoplot, decreasing = TRUE)] + ntoplot <- round(ntoplot, 0) + ntoplot <- ntoplot[1:nbbycl] + #ntoplot <- ntoplot[order(ntoplot)] + #ntoplot <- ifelse(length(ntoplot) > nbbycl, ntoplot[1:nbbycl], ntoplot) + lclasses[[classe]] <- ntoplot + } + vec.mat <- matrix(1, nrow = 2, ncol = length(sum.cl)) + vec.mat[2,] <- 2:(length(sum.cl)+1) + layout(matrix(vec.mat, nrow=2, ncol=length(sum.cl)),heights=c(1,4)) + if (! bw) { + col <- rainbow(length(sum.cl))[as.numeric(tree$tip.label)] + colcloud <- rainbow(length(sum.cl)) + } + par(mar=c(1,0,0,0)) + label.ori<-tree[[2]] + if (!is.null(lab)) { + tree$tip.label <- lab + } else { + tree[[2]]<-paste('classe ',tree[[2]]) + } + plot.phylo(tree,label.offset=0.1,tip.col=col, type=type.dendro, direction = 'downwards', srt=90, adj = 0) + for (i in tree.order) { + par(mar=c(0,0,1,0),cex=0.7) + #wordcloud(names(lclasses[[i]]), lclasses[[i]], scale = c(1.5, 0.2), random.order=FALSE, colors = colcloud[i]) + yval <- 1.1 + plot(0,0,pch='', axes = FALSE) + vcex <- norm.vec(lclasses[[i]], 0.8, 3) + for (j in 1:length(lclasses[[i]])) { + yval <- yval-(strheight( names(lclasses[[i]])[j],cex=vcex[j])+0.02) + text(-0.9, yval, names(lclasses[[i]])[j], cex = vcex[j], col = colcloud[i], adj=0) + } + } + +} + +plot.dendro.cloud <- function(tree, classes, chisqtable, nbbycl = 60, type.dendro = "phylogram", from.cmd = FALSE, bw = FALSE, lab = NULL) { + library(wordcloud) + library(ape) + classes<-classes[classes!=0] + classes<-as.factor(classes) + sum.cl<-as.matrix(summary(classes, maxsum=1000000)) + sum.cl<-(sum.cl/colSums(sum.cl)*100) + sum.cl<-round(sum.cl,2) + sum.cl<-cbind(sum.cl,as.matrix(100-sum.cl[,1])) + sum.cl <- sum.cl[,1] + tree.order<- as.numeric(tree$tip.label) + vec.mat<-NULL + row.keep <- select.chi.classe(chisqtable, nbbycl) + toplot <- chisqtable[row.keep,] + lclasses <- list() + for (classe in 1:length(sum.cl)) { + ntoplot <- toplot[,classe] + ntoplot <- ntoplot[order(ntoplot, decreasing = TRUE)] + ntoplot <- round(ntoplot, 0) + ntoplot <- ntoplot[1:nbbycl] + ntoplot <- ntoplot[order(ntoplot)] + #ntoplot <- ifelse(length(ntoplot) > nbbycl, ntoplot[1:nbbycl], ntoplot) + lclasses[[classe]] <- ntoplot + } + for (i in 1:length(sum.cl)) vec.mat<-append(vec.mat,1) + v<-2 + for (i in 1:length(sum.cl)) { + vec.mat<-append(vec.mat,v) + v<-v+1 + } + layout(matrix(vec.mat,length(sum.cl),2),widths=c(1,2)) + if (! bw) { + col <- rainbow(length(sum.cl))[as.numeric(tree$tip.label)] + colcloud <- rainbow(length(sum.cl)) + } + par(mar=c(0,0,0,0)) + label.ori<-tree[[2]] + if (!is.null(lab)) { + tree$tip.label <- lab + } else { + tree[[2]]<-paste('classe ',tree[[2]]) + } + plot.phylo(tree,label.offset=0.1,tip.col=col, type=type.dendro) + for (i in rev(tree.order)) { + par(mar=c(0,0,1,0),cex=0.9) + wordcloud(names(lclasses[[i]]), lclasses[[i]], scale = c(4, 0.8), random.order=FALSE, colors = colcloud[i]) + } +} + plot.dendropr <- function(tree, classes, type.dendro="phylogram", histo=FALSE, from.cmd=FALSE, bw=FALSE, lab = NULL, tclasse=TRUE) { classes<-classes[classes!=0] classes<-as.factor(classes) - sum.cl<-as.matrix(summary(classes)) + sum.cl<-as.matrix(summary(classes, maxsum=1000000)) sum.cl<-(sum.cl/colSums(sum.cl)*100) sum.cl<-round(sum.cl,2) sum.cl<-cbind(sum.cl,as.matrix(100-sum.cl[,1])) tree.order<- as.numeric(tree$tip.label) + + if (! bw) { - col = rainbow(nrow(sum.cl))[as.numeric(tree$tip.label)] + col <- rainbow(nrow(sum.cl))[as.numeric(tree$tip.label)] col.bars <- col col.pie <- rainbow(nrow(sum.cl)) #col.vec<-rainbow(nrow(sum.cl))[as.numeric(tree[[2]])]