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 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') {
  17     library(wordcloud)
  18     if (is.null(mfreq)) {
  19         mfreq <- sum(x[,1]) / nrow(x)
  20     }
  21     if (is.null(mrank)) {
  22         mrank <- sum(x[,1] * x[,2]) / sum(x[,1])
  23     }
  24     print(mfreq)
  25     print(mrank)
  26
  27     x <- x[order(x[,1], decreasing = TRUE),]
  28     x[,2] <- round(x[,2],1)
  29     ZN <- which(x[,1] >= mfreq & x[,2] <= mrank)
  30     FP <- which(x[,1] >= mfreq & x[,2] > mrank)
  31     SP <- which(x[,1] < mfreq & x[,2] > mrank)
  32     CE <- which(x[,1] < mfreq & x[,2] <= mrank)
  33     mfreq <- round(mfreq, 2)
  34     mrank <- round(mrank, 2)
  35     toplot <- list(ZN, FP, SP, CE)
  36     labcex <- norm.vec(x[,1], cexrange[1], cexrange[2])
  37     labalpha <- norm.vec(x[,2], cexalpha[2], cexalpha[1])
  38     labalpha <- rgb(0.1,0.2,0.1, labalpha)
  39         labcol <- rep('black', nrow(x))
  40         labcol[FP] <- 'red'
  41         labcol[SP] <- 'green'
  42         labcol[ZN] <- 'blue'
  43     ti <- c("Zone du noyau", "Première périphérie", "Seconde périphérie", "Elements contrastés")
  44         if (type == 'classical') {
  45             par(oma=c(1,3,3,1))
  46             layout(matrix(c(1,4,2,3), nrow=2))
  47             for (i in 1:length(toplot)) {
  48                 rtoplot <- toplot[[i]]
  49                 if (length(rtoplot)) {
  50                     par(mar=c(0,0,2,0))
  51                     if (cloud) {
  52                         labels <- paste(rownames(x)[rtoplot], x[rtoplot,1], x[rtoplot,2], sep='-')
  53                         wordcloud(labels, x[rtoplot,1], scale = c(max(labcex[rtoplot]), min(labcex[rtoplot])), color = labalpha[rtoplot], random.order=FALSE, rot.per = 0)
  54                         box()
  55                     } else {
  56                         yval <- 1.1
  57                         plot(0,0,pch='', axes = FALSE)
  58                         k<- 0
  59                         for (val in rtoplot) {
  60                             yval <- yval-(strheight(rownames(x)[val],cex=labcex[val])+0.02)
  61                             text(-0.9, yval, paste(rownames(x)[val], x[val,1], x[val,2], sep = '-'), cex = labcex[val], col = labalpha[val], adj=0)
  62                         }
  63                         box()
  64                     }
  65                     title(ti[i])
  66                 }
  67             }
  68             mtext(paste('<', mfreq, '  Fréquences  ', '>=', mfreq, sep = ' '), side=2, line=1, cex=1, col="red", outer=TRUE)
  69             mtext(paste('<=', mrank,  '  Rangs  ', '>', mrank, sep = ' '), side=3, line=1, cex=1, col="red", outer=TRUE)
  70         } else if (type == 'plan') {
  71                 par(oma=c(3,3,1,1))
  72                 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="")
  73             abline(v=mfreq)
  74                 abline(h=mrank)
  75                 legend('topright', ti, fill=c('blue', 'red', 'green', 'black'))
  76                 mtext(paste('<', mfreq, '  Fréquences  ', '>=', mfreq, sep = ' '), side=1, line=1, cex=1, col="red", outer=TRUE)
  77                 mtext(paste('<=', mrank,  '  Rangs  ', '>', mrank, sep = ' '), side=2, line=1, cex=1, col="red", outer=TRUE)
  78         }
  79 }
  80
  81 intervalle.freq <- function(x, SX=NULL) {
  82         errorn <- (x/SX) + (1.96 * sqrt(((x/SX) * (1-(x/SX))/SX)))
  83         print(errorn)
  84 }