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