X-Git-Url: http://iramuteq.org/git?p=iramuteq;a=blobdiff_plain;f=Rscripts%2FRgraph.R;h=e947a402ed0e5993681e790cac77a8ed0215a1f3;hp=b0b555c5af815ffc3dee5dc917943cea6c1b6e97;hb=2ffa9388c45dce689bb45c1cf6c7ad81d2636409;hpb=7f5e0ba6ece181a04d872a7b6eeb2f13b33aa455 diff --git a/Rscripts/Rgraph.R b/Rscripts/Rgraph.R index b0b555c..e947a40 100644 --- a/Rscripts/Rgraph.R +++ b/Rscripts/Rgraph.R @@ -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, ' -') @@ -97,11 +106,17 @@ PlotAfc2dCoul<- function(afc,chisqrtable,filename, what='coord',col=FALSE, axeto 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, xlim = c(xmin,xmax), ylim = c(ymin,ymax)) + 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) { @@ -181,6 +196,7 @@ stopoverlap <- function(x, cex.par = NULL, xlim = NULL, ylim = NULL) { thetaStep <- .1 rStep <- .5 toplot <- NULL + notplot <- NULL # plot.new() plot(x[,1],x[,2], pch='', xlim = xlim, ylim = ylim) @@ -212,6 +228,7 @@ stopoverlap <- function(x, cex.par = NULL, xlim = NULL, ylim = 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 @@ -222,7 +239,7 @@ stopoverlap <- function(x, cex.par = NULL, xlim = NULL, ylim = NULL) { } } row.names(toplot) <- words[toplot[,4]] - return(toplot) + return(list(toplot = toplot, notplot = notplot)) } ############################################################################### @@ -460,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]])]