translators
[iramuteq] / Rscripts / afc_graph.R
1 #Author: Pierre Ratinaud
2 #Copyright (c) 20010-2013 Pierre Ratinaud
3 #License: GNU/GPL
4
5
6 #fichier genere par IRaMuTeq
7 source('%s', encoding = 'utf8')
8 typegraph <- %i
9 what <- %i
10 x <- %i
11 y <- %i
12 z <- %i
13 qui <- %i
14 over <- %s
15 do.select.nb <- %s
16 select.nb <- %i
17 do.select.chi <- %s
18 select.chi <- %i
19 do.select.chi.classe <- %s
20 ptbycluster <- %i
21 cex.txt <- %s
22 txt.min <- %i
23 txt.max <- %i
24 fileout <- '%s'
25 width <- %i
26 height <- %i
27 taillecar <- %i
28 alpha <- %i/100
29 dofilm <- %s
30 tchi <- %s
31 tchi.min <- %i
32 tchi.max <- %i
33 dirout <- '%s'
34 do.svg <- %s
35 xminmax <- NULL
36 yminmax <- NULL
37
38 xlab <- paste('facteur ', x, ' -')
39 ylab <- paste('facteur ', y, ' -')
40 if (!typegraph == 0) {zlab <- paste('facteur ', z, ' -')}
41 xlab <- paste(xlab,round(afc_table$facteur[x,2],2),sep = ' ')
42 xlab <- paste(xlab,' %%',sep = '')
43 ylab <- paste(ylab,round(afc_table$facteur[y,2],2),sep = ' ')
44 ylab <- paste(ylab,' %%',sep = '')
45 if (!typegraph == 0) {
46     zlab <- paste(zlab,round(afc_table$facteur[z,2],2),sep = ' ')
47     zlab <- paste(zlab,' %%',sep = '')
48 }
49
50 if ( qui == 3 ) {
51     if ( what == 0 ) table.in <- afc$colcoord
52     if ( what == 1 ) table.in <- afc$colcrl
53     rownames(table.in) <- afc$colnames
54     eff <- afc$colmass
55     if (typegraph == 0) {
56         table.in<-table.in[,c(x,y)]
57     } else {
58         table.in<-table.in[,c(x,y,z)]
59         rx <- range(table.in[,1], na.rm = TRUE)
60         ry <- range(table.in[,2], na.rm = TRUE)
61         rz <- range(table.in[,3], na.rm = TRUE)
62     }
63     classes <- c(1:clnb)
64     maxchi <- 1
65     cex.par <- rep(taillecar/10, nrow(table.in))
66 } else {
67     if ( what == 0 ) table.in <- afc$rowcoord
68     if ( what == 1 ) table.in <- afc$rowcrl
69     rownames(table.in) <- afc$rownames
70     tablechi <- chistabletot
71     rn.keep <- c()
72     if (typegraph == 0) {
73         table.in<-table.in[,c(x,y)]
74     } else {
75         table.in<-table.in[,c(x,y,z)]
76         rx <- range(table.in[,1], na.rm = TRUE)
77         ry <- range(table.in[,2], na.rm = TRUE)
78         rz <- range(table.in[,3], na.rm = TRUE)
79     }
80     if (exists('afctable')) {
81         eff <- rowSums(afctable)
82     } else {
83         eff <- afc$rowmass
84     }
85
86     if (!is.null(debsup)) {
87         if ( qui == 0 ) {
88            table.in <- table.in[1:(debsup-1),]
89            tablechi <- tablechi[1:(debsup-1),]
90            cex.par <- eff[1:(debsup-1)]
91         }
92         if ( qui == 1 ) {
93            table.in <- table.in[debsup:(debet-1),] 
94            tablechi <- tablechi[debsup:(debet-1),]
95            cex.par <- eff[debsup:(debet-1)]
96         }
97         if ( qui == 2 ) {
98            fin <- nrow(table.in)
99            table.in <- table.in[debet:nrow(table.in),] 
100            tablechi <- tablechi[debet:nrow(tablechi),]
101            cex.par <- eff[debet:fin]
102         }
103     }
104     
105     if (is.null(debsup)) {
106         if (qui == 0) {
107             if (!is.null(debet)) {
108                 table.in <- table.in[1:(debet-1),] 
109                 tablechi <- tablechi[1:(debet-1),]
110                 cex.par <- eff[1:(debet-1)]
111             } else {
112                 cex.par <- eff
113             }
114         } else {
115             fin <- nrow(table.in)
116             table.in <- table.in[debet:nrow(table.in),]
117             tablechi <- tablechi[debet:nrow(tablechi),]
118             cex.par <- eff[debet:fin]
119         }
120     }
121         
122     if (do.select.nb) {
123         if (select.nb > nrow(table.in)) select.nb <- nrow(table.in)
124         row.keep <- select_point_nb(tablechi, select.nb)
125         table.in <- table.in[row.keep,]
126         tablechi <- tablechi[row.keep,]
127     } else if (do.select.chi) {
128         if (select.chi > max(tablechi)) select.chi <- max(tablechi)
129         row.keep <- select_point_chi(tablechi, select.chi)
130         table.in <- table.in[row.keep,]
131         tablechi <- tablechi[row.keep,]
132     } else if (do.select.chi.classe) {
133         row.keep <- select.chi.classe(tablechi, ptbycluster, active=FALSE)
134         table.in <- table.in[row.keep,]
135         tablechi <- tablechi[row.keep,]        
136     } else {
137         row.keep <- 1:nrow(table.in)
138     }
139     classes <- apply(tablechi, 1, which.max)
140     maxchi <- apply(tablechi, 1, max)
141     infp <-  which(is.infinite(maxchi) & maxchi > 0)
142     if (length(infp)) {
143         maxchi[infp] <- NA
144         if (!length(infp) == length(maxchi)) {
145             valmax <- max(maxchi, na.rm = TRUE)
146         } else {
147             valmax <- 8
148         }
149         maxchi[infp] <- valmax + 2
150     } 
151     if (cex.txt) {
152         #row.keep <- append(row.keep, rn.keep)
153         #row.keep <- unique(row.keep)
154         cex.par <- cex.par[row.keep]
155         cex.par <- norm.vec(cex.par, txt.min/10, txt.max/10)
156     } else if (tchi) {
157         cex.par <- maxchi
158         cex.par <- norm.vec(cex.par, tchi.min/10, tchi.max/10)
159     } else {
160         cex.par <- rep(taillecar/10, nrow(table.in))
161     }
162 }
163
164 if (is.null(xminmax)) {
165         xminmax <- c(min(table.in[,1], na.rm = TRUE) + ((max(cex.par)/10) * min(table.in[,1], na.rm = TRUE)), max(table.in[,1], na.rm = TRUE) + ((max(cex.par)/10) * max(table.in[,1], na.rm = TRUE)))
166     }
167     if (is.null(yminmax)) {
168         yminmax <- c(min(table.in[,2], na.rm = TRUE) + ((max(cex.par)/10) * min(table.in[,2], na.rm = TRUE)), max(table.in[,2], na.rm = TRUE) + ((max(cex.par)/10) * max(table.in[,2], na.rm = TRUE)))
169     }
170
171 if (typegraph == 0 || typegraph == 2) {
172
173     open_file_graph(fileout, width = width, height = height, svg = do.svg)
174     parcex <- taillecar/10
175     par(cex = parcex)
176     if (over) {
177         table.in <- table.in[order(cex.par, decreasing = TRUE),]
178         classes <- classes[order(cex.par, decreasing = TRUE)]
179         cex.par <- cex.par[order(cex.par, decreasing = TRUE)]
180         table.out <- stopoverlap(table.in, cex.par=cex.par, xlim = xminmax, ylim = yminmax)
181         table.in <- table.out$toplot
182         notplot <- table.out$notplot
183         if (! is.null(notplot)) {
184             write.csv2(notplot, file = paste(fileout,'_notplotted.csv', sep=''))
185         }    
186         classes <- classes[table.in[,4]]
187         cex.par <- cex.par[table.in[,4]]
188     }
189     if (typegraph == 0) {
190         make_afc_graph(table.in, classes, clnb, xlab, ylab, cex.txt = cex.par, xminmax = xminmax, yminmax = yminmax)
191     } else {
192         dev.off()
193         require(rgexf)
194         nodes.attr <- make.afc.attributes(rownames(table.in), afc_table, afctable, clnb)
195         if (qui != 3) {
196             tokeep <- rownames(chistabletot) %%in%% rownames(table.in)
197             chis <- chistabletot[tokeep,]
198             chis<-chis[rownames(table.in),]
199             nodes.attr$chiclasse <- chis
200         } else {
201             chis <- NULL
202         }
203         afctogexf(fileout, table.in, classes, clnb, cex.par, nodes.attr = nodes.attr)
204     }
205
206 } else {
207     library(rgl)
208     rn <- vire.nonascii(rownames(table.in))
209     rain = rainbow(clnb)
210     colors = rain[classes]
211     #rn <- rownames(table.in)
212     #rgl.open()
213     
214     text3d(table.in[,1], table.in[,2], table.in[,3], rn, col = colors , cex = cex.par)
215     rgl.bg(col = c('white', "#99bb99"), front = "lines", box=FALSE, sphere = TRUE)
216     par3d('userMatrix' = matrix(c(1,0,0,0, 0,1,0,0,0,0,1,0,0,0,0,1), ncol=4, nrow = 4))
217     par3d(cex=0.7)
218     #par3d(windowRect = c(100,100,600,600))
219     rgl.lines(c(rx), c(0, 0), c(0, 0), col = "#000000")
220     rgl.lines(c(0,0),c(ry),c(0,0),col = "#000000")
221     rgl.lines(c(0,0),c(0,0),c(rz),col = "#000000")
222     text3d(rx[2]+1,0,0, xlab)
223     text3d(0,ry[2]+1,0, ylab)
224     text3d(0,0,rz[2]+1, zlab)
225     
226      if (tchi) {
227         maxchi <- norm.vec(maxchi, tchi.min/100, tchi.max/100)
228     } else if (!is.null(cex.par)) {
229         maxchi <- norm.vec(cex.par, txt.min/100, txt.max/100)
230     } else {
231         maxchi <- 0.1
232     }
233     
234     
235     for (i in 1:clnb) {
236         text3d(rx[2],(ry[2]+(0.2*i)),0,paste('classe',i),col=rain[i])
237     }
238     #if (tchi) {
239     #    rgl.spheres(table.in, col = colors, radius = maxchi, alpha = alpha)
240     #}
241
242     if (dofilm) {
243         require(tcltk)
244         ReturnVal <- tkmessageBox(title="RGL 3 D",message="Cliquez pour commencer le film",icon="info",type="ok")
245
246         movie3d(spin3d(axis=c(0,1,0),rpm=6), movie = 'film', frames = "tmpfilm", duration=10, clean=TRUE, top = TRUE, dir = dirout)
247         ReturnVal <- tkmessageBox(title="RGL 3 D",message="Fini !",icon="info",type="ok")
248     }
249
250     if (typegraph == 1) {
251         require(tcltk)
252         ReturnVal <- tkmessageBox(title="RGL 3 D",message="Cliquez pour fermer",icon="info",type="ok")
253     } else {
254         writeWebGL(dir = fileout, width = width, height= height)
255     }
256     rgl.close()
257 }