www.iramuteq.org Git - iramuteq/blob - Rscripts/prototypical.R

   1
   2 norm.vec <- function(v, min, max) {
   3
   4   vr <- range(v)
   5   if (vr[1]==vr[2]) {
   6     fac <- 1
   7   } else {
   8     fac <- (max-min)/(vr[2]-vr[1])
   9   }
  10   (v-vr[1]) * fac + min
  11 }
  12
  13
  14 #x a table with freq and rank, rownames are words
  15
  16
  17 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) {
  18     library(wordcloud)
  19     if (is.null(mfreq)) {
  20         mfreq <- sum(x[,1]) / nrow(x)
  21     }
  22     if (is.null(mrank)) {
  23         mrank <- sum(x[,1] * x[,2]) / sum(x[,1])
  24     }
  25     #print(mfreq)
  26     #print(mrank)
  27     if (is.null(r.names)) {
  28         r.names <- rownames(x)
  29     }
  30     ord.ori <- order(x[,1], decreasing=T)
  31     r.names <- r.names[order(x[,1], decreasing=T)]
  32     x <- x[order(x[,1], decreasing = TRUE),]
  33     x[,2] <- round(x[,2],2)
  34     ZN <- which(x[,1] >= mfreq & x[,2] <= mrank)
  35     FP <- which(x[,1] >= mfreq & x[,2] > mrank)
  36     SP <- which(x[,1] < mfreq & x[,2] > mrank)
  37     CE <- which(x[,1] < mfreq & x[,2] <= mrank)
  38     mfreq <- round(mfreq, 2)
  39     mrank <- round(mrank, 2)
  40     toplot <- list(ZN, FP, SP, CE)
  41     labcex <- norm.vec(x[,1], cexrange[1], cexrange[2])
  42     labalpha <- norm.vec(x[,2], cexalpha[2], cexalpha[1])
  43     labalpha <- rgb(0.1,0.2,0.1, labalpha)
  44     if (is.null(colors)) {
  45             labcol <- rep('orange', nrow(x))
  46             labcol[FP] <- 'red'
  47             labcol[SP] <- 'green'
  48             labcol[ZN] <- 'lightblue'
  49     } else {
  50         labcol <- colors[ord.ori]
  51     }
  52         mat.col <- cbind(r.names, labcol)
  53         write.table(mat.col,file=mat.col.path)
  54     ti <- c("Zone du noyau", "Première périphérie", "Seconde périphérie", "Elements contrastés")
  55         if (type == 'classical') {
  56             par(oma=c(1,3,3,1))
  57             layout(matrix(c(1,4,2,3), nrow=2))
  58             for (i in 1:length(toplot)) {
  59                 rtoplot <- toplot[[i]]
  60                 if (length(rtoplot)) {
  61                     par(mar=c(0,0,2,0))
  62                     if (cloud) {
  63                         labels <- paste(r.names[rtoplot], x[rtoplot,1], x[rtoplot,2], sep='-')
  64                         wordcloud(labels, x[rtoplot,1], scale = c(max(labcex[rtoplot]), min(labcex[rtoplot])), color = labalpha[rtoplot], random.order=FALSE, rot.per = 0)
  65                         box()
  66                     } else {
  67                         yval <- 1.1
  68                         plot(0,0,pch='', axes = FALSE)
  69                         k<- 0
  70                         for (val in rtoplot) {
  71                             yval <- yval-(strheight(r.names[val],cex=labcex[val])+0.02)
  72                             text(-0.9, yval, paste(r.names[val], x[val,1], x[val,2], sep = '-'), cex = labcex[val], col = labalpha[val], adj=0)
  73                         }
  74                         box()
  75                     }
  76                     title(ti[i])
  77                 }
  78             }
  79             mtext(paste('<', mfreq, '  Fréquences  ', '>=', mfreq, sep = ' '), side=2, line=1, cex=1, col="red", outer=TRUE)
  80             mtext(paste('<=', mrank,  '  Rangs  ', '>', mrank, sep = ' '), side=3, line=1, cex=1, col="red", outer=TRUE)
  81         } else if (type == 'plan') {
  82                 par(oma=c(3,3,1,1))
  83                 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="")
  84             abline(v=mfreq)
  85                 abline(h=mrank)
  86                 legend('topright', ti, fill=c('lightblue', 'red', 'green', 'orange'))
  87                 mtext(paste('<', mfreq, '  Fréquences  ', '>=', mfreq, sep = ' '), side=1, line=1, cex=1, col="red", outer=TRUE)
  88                 mtext(paste('<=', mrank,  '  Rangs  ', '>', mrank, sep = ' '), side=2, line=1, cex=1, col="red", outer=TRUE)
  89         }
  90 }
  91
  92
  93 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) {
  94         library(wordcloud)
  95         if (is.null(mfreq)) {
  96                 mfreq <- sum(x[,1]) / nrow(x)
  97         }
  98         if (is.null(mrank)) {
  99                 mrank <- sum(x[,1] * x[,2]) / sum(x[,1])
 100         }
 101         print(mfreq)
 102         print(mrank)
 103         if (is.null(r.names)) {
 104                 r.names <- rownames(x)
 105         }
 106         ord.ori <- order(x[,1], decreasing=T)
 107         r.names <- r.names[order(x[,1], decreasing=T)]
 108         x <- x[order(x[,1], decreasing = TRUE),]
 109         x[,2] <- round(x[,2],1)
 110         ZN <- which(x[,1] >= mfreq & x[,2] <= mrank)
 111         FP <- which(x[,1] >= mfreq & x[,2] > mrank)
 112         SP <- which(x[,1] < mfreq & x[,2] > mrank)
 113         CE <- which(x[,1] < mfreq & x[,2] <= mrank)
 114         mfreq <- round(mfreq, 2)
 115         mrank <- round(mrank, 2)
 116         toplot <- list(ZN, FP, SP, CE)
 117         labcex <- norm.vec(x[,1], cexrange[1], cexrange[2])
 118         labalpha <- norm.vec(x[,2], cexalpha[2], cexalpha[1])
 119         labalpha <- rgb(0.1,0.2,0.1, labalpha)
 120         if (is.null(colors)) {
 121                 labcol <- rep('black', nrow(x))
 122                 labcol[FP] <- 'red'
 123                 labcol[SP] <- 'green'
 124                 labcol[ZN] <- 'blue'
 125         } else {
 126                 labcol <- colors[ord.ori]
 127         }
 128         ti <- c("Zone du noyau", "Première périphérie", "Seconde périphérie", "Elements contrastés")
 129         if (type == 'classical') {
 130                 par(oma=c(1,3,3,1))
 131                 layout(matrix(c(1,4,2,3), nrow=2))
 132                 for (i in 1:length(toplot)) {
 133                         rtoplot <- toplot[[i]]
 134                         if (length(rtoplot)) {
 135                                 par(mar=c(0,0,2,0))
 136                                 if (cloud) {
 137                                         labels <- paste(r.names[rtoplot], x[rtoplot,1], x[rtoplot,2], sep='-')
 138                                         wordcloud(labels, x[rtoplot,1], scale = c(max(labcex[rtoplot]), min(labcex[rtoplot])), color = labalpha[rtoplot], random.order=FALSE, rot.per = 0)
 139                                         box()
 140                                 } else {
 141                                         yval <- 1.1
 142                                         plot(0,0,pch='', axes = FALSE)
 143                                         k<- 0
 144                                         for (val in rtoplot) {
 145                                                 yval <- yval-(strheight(r.names[val],cex=labcex[val])+0.02)
 146                                                 text(-0.9, yval, paste(r.names[val], x[val,1], x[val,2], sep = '-'), cex = labcex[val], col = labalpha[val], adj=0)
 147                                         }
 148                                         box()
 149                                 }
 150                                 title(ti[i])
 151                         }
 152                 }
 153                 mtext(paste('<', mfreq, '  Fréquences  ', '>=', mfreq, sep = ' '), side=2, line=1, cex=1, col="red", outer=TRUE)
 154                 mtext(paste('<=', mrank,  '  Rangs  ', '>', mrank, sep = ' '), side=3, line=1, cex=1, col="red", outer=TRUE)
 155         } else if (type == 'plan') {
 156                 library(rgl)
 157                 rgl.open()
 158                 rgl.lines(c(range(x[,1])), c(mrank, mrank), c(0, 0), col = "#000000")
 159                 rgl.lines(c(mfreq,mfreq),c(range(x[,2])),c(0,0),col = "#000000")
 160                 rgl.lines(c(mfreq,mfreq),c(mrank,mrank),c(-1,1),col = "#000000")
 161                 plot3d(x)
 162                 #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="")
 163                 #abline(v=mfreq)
 164                 #abline(h=mrank)
 165                 legend('topright', ti, fill=c('blue', 'red', 'green', 'black'))
 166                 mtext(paste('<', mfreq, '  Fréquences  ', '>=', mfreq, sep = ' '), side=1, line=1, cex=1, col="red", outer=TRUE)
 167                 mtext(paste('<=', mrank,  '  Rangs  ', '>', mrank, sep = ' '), side=2, line=1, cex=1, col="red", outer=TRUE)
 168         }
 169 }
 170
 171 intervalle.freq <- function(x, SX=NULL) {
 172         errorn <- (x/SX) + (1.96 * sqrt(((x/SX) * (1-(x/SX))/SX)))
 173         print(errorn)
 174 }