From 6c7a10958dd717a7dfb5d497dad81e8903d45979 Mon Sep 17 00:00:00 2001 From: pierre Date: Tue, 25 Jan 2022 10:27:58 +0100 Subject: [PATCH] correction --- Rscripts/prototypical.R | 116 ++++++++++++++++++++++++++++++++++++++++++------ 1 file changed, 103 insertions(+), 13 deletions(-) diff --git a/Rscripts/prototypical.R b/Rscripts/prototypical.R index c4fc02f..53a3d30 100644 --- a/Rscripts/prototypical.R +++ b/Rscripts/prototypical.R @@ -13,7 +13,8 @@ norm.vec <- function(v, min, max) { #x a table with freq and rank, rownames are words -prototypical <- function(x, mfreq = NULL, mrank = NULL, cexrange=c(0.8, 3), cexalpha = c(0.5, 1), labfreq = TRUE, labrank = TRUE, cloud = TRUE, type = 'classical') { + +prototypical <- function(x, mfreq = NULL, mrank = NULL, cexrange=c(0.8, 3), cexalpha = c(0.5, 1), labfreq = TRUE, labrank = TRUE, cloud = TRUE, type = 'classical', r.names=NULL, colors=NULL, mat.col.path = NULL) { library(wordcloud) if (is.null(mfreq)) { mfreq <- sum(x[,1]) / nrow(x) @@ -21,11 +22,15 @@ prototypical <- function(x, mfreq = NULL, mrank = NULL, cexrange=c(0.8, 3), cexa if (is.null(mrank)) { mrank <- sum(x[,1] * x[,2]) / sum(x[,1]) } - print(mfreq) - print(mrank) - + #print(mfreq) + #print(mrank) + if (is.null(r.names)) { + r.names <- rownames(x) + } + ord.ori <- order(x[,1], decreasing=T) + r.names <- r.names[order(x[,1], decreasing=T)] x <- x[order(x[,1], decreasing = TRUE),] - x[,2] <- round(x[,2],1) + x[,2] <- round(x[,2],2) ZN <- which(x[,1] >= mfreq & x[,2] <= mrank) FP <- which(x[,1] >= mfreq & x[,2] > mrank) SP <- which(x[,1] < mfreq & x[,2] > mrank) @@ -36,10 +41,16 @@ prototypical <- function(x, mfreq = NULL, mrank = NULL, cexrange=c(0.8, 3), cexa labcex <- norm.vec(x[,1], cexrange[1], cexrange[2]) labalpha <- norm.vec(x[,2], cexalpha[2], cexalpha[1]) labalpha <- rgb(0.1,0.2,0.1, labalpha) - labcol <- rep('black', nrow(x)) - labcol[FP] <- 'red' - labcol[SP] <- 'green' - labcol[ZN] <- 'blue' + if (is.null(colors)) { + labcol <- rep('orange', nrow(x)) + labcol[FP] <- 'red' + labcol[SP] <- 'green' + labcol[ZN] <- 'lightblue' + } else { + labcol <- colors[ord.ori] + } + mat.col <- cbind(r.names, labcol) + write.table(mat.col,file=mat.col.path) ti <- c("Zone du noyau", "Première périphérie", "Seconde périphérie", "Elements contrastés") if (type == 'classical') { par(oma=c(1,3,3,1)) @@ -49,7 +60,7 @@ prototypical <- function(x, mfreq = NULL, mrank = NULL, cexrange=c(0.8, 3), cexa if (length(rtoplot)) { par(mar=c(0,0,2,0)) if (cloud) { - labels <- paste(rownames(x)[rtoplot], x[rtoplot,1], x[rtoplot,2], sep='-') + labels <- paste(r.names[rtoplot], x[rtoplot,1], x[rtoplot,2], sep='-') wordcloud(labels, x[rtoplot,1], scale = c(max(labcex[rtoplot]), min(labcex[rtoplot])), color = labalpha[rtoplot], random.order=FALSE, rot.per = 0) box() } else { @@ -57,8 +68,8 @@ prototypical <- function(x, mfreq = NULL, mrank = NULL, cexrange=c(0.8, 3), cexa plot(0,0,pch='', axes = FALSE) k<- 0 for (val in rtoplot) { - yval <- yval-(strheight(rownames(x)[val],cex=labcex[val])+0.02) - text(-0.9, yval, paste(rownames(x)[val], x[val,1], x[val,2], sep = '-'), cex = labcex[val], col = labalpha[val], adj=0) + yval <- yval-(strheight(r.names[val],cex=labcex[val])+0.02) + text(-0.9, yval, paste(r.names[val], x[val,1], x[val,2], sep = '-'), cex = labcex[val], col = labalpha[val], adj=0) } box() } @@ -69,9 +80,88 @@ prototypical <- function(x, mfreq = NULL, mrank = NULL, cexrange=c(0.8, 3), cexa mtext(paste('<=', mrank, ' Rangs ', '>', mrank, sep = ' '), side=3, line=1, cex=1, col="red", outer=TRUE) } else if (type == 'plan') { par(oma=c(3,3,1,1)) - textplot(x[,1], x[,2], rownames(x), cex=labcex, xlim=c(min(x[,1])-nrow(x)/3, max(x[,1])+5), ylim = c(min(x[,2])-0.2, max(x[,2])+0.5), col=labcol, xlab="", ylab="") + textplot(x[,1], x[,2], r.names, cex=labcex, xlim=c(min(x[,1])-nrow(x)/3, max(x[,1])+5), ylim = c(min(x[,2])-0.2, max(x[,2])+0.5), col=labcol, xlab="", ylab="") abline(v=mfreq) abline(h=mrank) + legend('topright', ti, fill=c('lightblue', 'red', 'green', 'orange')) + mtext(paste('<', mfreq, ' Fréquences ', '>=', mfreq, sep = ' '), side=1, line=1, cex=1, col="red", outer=TRUE) + mtext(paste('<=', mrank, ' Rangs ', '>', mrank, sep = ' '), side=2, line=1, cex=1, col="red", outer=TRUE) + } +} + + +proto3D <- function(x, mfreq = NULL, mrank = NULL, cexrange=c(0.8, 3), cexalpha = c(0.5, 1), labfreq = TRUE, labrank = TRUE, cloud = TRUE, type = 'classical', r.names=NULL, colors=NULL) { + library(wordcloud) + if (is.null(mfreq)) { + mfreq <- sum(x[,1]) / nrow(x) + } + if (is.null(mrank)) { + mrank <- sum(x[,1] * x[,2]) / sum(x[,1]) + } + print(mfreq) + print(mrank) + if (is.null(r.names)) { + r.names <- rownames(x) + } + ord.ori <- order(x[,1], decreasing=T) + r.names <- r.names[order(x[,1], decreasing=T)] + x <- x[order(x[,1], decreasing = TRUE),] + x[,2] <- round(x[,2],1) + ZN <- which(x[,1] >= mfreq & x[,2] <= mrank) + FP <- which(x[,1] >= mfreq & x[,2] > mrank) + SP <- which(x[,1] < mfreq & x[,2] > mrank) + CE <- which(x[,1] < mfreq & x[,2] <= mrank) + mfreq <- round(mfreq, 2) + mrank <- round(mrank, 2) + toplot <- list(ZN, FP, SP, CE) + labcex <- norm.vec(x[,1], cexrange[1], cexrange[2]) + labalpha <- norm.vec(x[,2], cexalpha[2], cexalpha[1]) + labalpha <- rgb(0.1,0.2,0.1, labalpha) + if (is.null(colors)) { + labcol <- rep('black', nrow(x)) + labcol[FP] <- 'red' + labcol[SP] <- 'green' + labcol[ZN] <- 'blue' + } else { + labcol <- colors[ord.ori] + } + ti <- c("Zone du noyau", "Première périphérie", "Seconde périphérie", "Elements contrastés") + if (type == 'classical') { + par(oma=c(1,3,3,1)) + layout(matrix(c(1,4,2,3), nrow=2)) + for (i in 1:length(toplot)) { + rtoplot <- toplot[[i]] + if (length(rtoplot)) { + par(mar=c(0,0,2,0)) + if (cloud) { + labels <- paste(r.names[rtoplot], x[rtoplot,1], x[rtoplot,2], sep='-') + wordcloud(labels, x[rtoplot,1], scale = c(max(labcex[rtoplot]), min(labcex[rtoplot])), color = labalpha[rtoplot], random.order=FALSE, rot.per = 0) + box() + } else { + yval <- 1.1 + plot(0,0,pch='', axes = FALSE) + k<- 0 + for (val in rtoplot) { + yval <- yval-(strheight(r.names[val],cex=labcex[val])+0.02) + text(-0.9, yval, paste(r.names[val], x[val,1], x[val,2], sep = '-'), cex = labcex[val], col = labalpha[val], adj=0) + } + box() + } + title(ti[i]) + } + } + mtext(paste('<', mfreq, ' Fréquences ', '>=', mfreq, sep = ' '), side=2, line=1, cex=1, col="red", outer=TRUE) + mtext(paste('<=', mrank, ' Rangs ', '>', mrank, sep = ' '), side=3, line=1, cex=1, col="red", outer=TRUE) + } else if (type == 'plan') { + library(rgl) + rgl.open() + rgl.lines(c(range(x[,1])), c(mrank, mrank), c(0, 0), col = "#000000") + rgl.lines(c(mfreq,mfreq),c(range(x[,2])),c(0,0),col = "#000000") + rgl.lines(c(mfreq,mfreq),c(mrank,mrank),c(-1,1),col = "#000000") + plot3d(x) + #textplot(x[,1], x[,2], r.names, cex=labcex, xlim=c(min(x[,1])-nrow(x)/3, max(x[,1])+5), ylim = c(min(x[,2])-0.2, max(x[,2])+0.5), col=labcol, xlab="", ylab="") + #abline(v=mfreq) + #abline(h=mrank) legend('topright', ti, fill=c('blue', 'red', 'green', 'black')) mtext(paste('<', mfreq, ' Fréquences ', '>=', mfreq, sep = ' '), side=1, line=1, cex=1, col="red", outer=TRUE) mtext(paste('<=', mrank, ' Rangs ', '>', mrank, sep = ' '), side=2, line=1, cex=1, col="red", outer=TRUE) -- 2.7.4