correction labbé
[iramuteq] / 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 }