correction
[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
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 }