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) {
  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     par(oma=c(1,3,3,1))
  40     layout(matrix(c(1,4,2,3), nrow=2))
  41     ti <- c("Zone du noyau", "Première périphérie", "Seconde périphérie", "Elements contrastés")
  42     for (i in 1:length(toplot)) {
  43         rtoplot <- toplot[[i]]
  44         if (length(rtoplot)) {
  45             par(mar=c(0,0,2,0))
  46             if (cloud) {
  47                 labels <- paste(rownames(x)[rtoplot], x[rtoplot,1], x[rtoplot,2], sep='-')
  48                 wordcloud(labels, x[rtoplot,1], scale = c(max(labcex[rtoplot]), min(labcex[rtoplot])), color = labalpha[rtoplot], random.order=FALSE, rot.per = 0)
  49                 box()
  50             } else {
  51                 yval <- 1.1
  52                 plot(0,0,pch='', axes = FALSE)
  53                 k<- 0
  54                 for (val in rtoplot) {
  55                     yval <- yval-(strheight(rownames(x)[val],cex=labcex[val])+0.02)
  56                     text(-0.9, yval, paste(rownames(x)[val], x[val,1], x[val,2], sep = '-'), cex = labcex[val], col = labalpha[val], adj=0)
  57                 }
  58                 box()
  59             }
  60             title(ti[i])
  61         }
  62     }
  63     mtext(paste('<', mfreq, '  Fréquences  ', '>=', mfreq, sep = ' '), side=2, line=1, cex=1, col="red", outer=TRUE)
  64     mtext(paste('<=', mrank,  '  Rangs  ', '>', mrank, sep = ' '), side=3, line=1, cex=1, col="red", outer=TRUE)
  65 }
  66
  67 intervalle.freq <- function(x, SX=NULL) {
  68         errorn <- (x/SX) + (1.96 * sqrt(((x/SX) * (1-(x/SX))/SX)))
  69         print(errorn)
  70 }