1 #Author: Pierre Ratinaud
2 #Copyright (c) 20010 Pierre Ratinaud
6 #fichier genere par IRaMuTeq
19 do.select.chi.classe <- %s
35 xlab <- paste('facteur ', x, ' -')
36 ylab <- paste('facteur ', y, ' -')
37 if (!typegraph == 0) {zlab <- paste('facteur ', z, ' -')}
38 xlab <- paste(xlab,round(afc_table$facteur[x,2],2),sep = ' ')
39 xlab <- paste(xlab,' %%',sep = '')
40 ylab <- paste(ylab,round(afc_table$facteur[y,2],2),sep = ' ')
41 ylab <- paste(ylab,' %%',sep = '')
42 if (!typegraph == 0) {
43 zlab <- paste(zlab,round(afc_table$facteur[z,2],2),sep = ' ')
44 zlab <- paste(zlab,' %%',sep = '')
48 if ( what == 0 ) table.in <- afc$colcoord
49 if ( what == 1 ) table.in <- afc$colcrl
50 rownames(table.in) <- afc$colnames
52 table.in<-table.in[,c(x,y)]
54 table.in<-table.in[,c(x,y,z)]
55 rx <- range(table.in[,1], na.rm = TRUE)
56 ry <- range(table.in[,2], na.rm = TRUE)
57 rz <- range(table.in[,3], na.rm = TRUE)
63 if ( what == 0 ) table.in <- afc$rowcoord
64 if ( what == 1 ) table.in <- afc$rowcrl*2
65 rownames(table.in) <- afc$rownames
66 tablechi <- chistabletot
69 table.in<-table.in[,c(x,y)]
71 table.in<-table.in[,c(x,y,z)]
72 rx <- range(table.in[,1], na.rm = TRUE)
73 ry <- range(table.in[,2], na.rm = TRUE)
74 rz <- range(table.in[,3], na.rm = TRUE)
76 if (!is.null(debsup)) {
78 table.in <- table.in[1:(debsup-1),]
79 tablechi <- tablechi[1:(debsup-1),]
80 cex.par <- afc$rowmass[1:(debsup-1)]
83 table.in <- table.in[debsup:(debet-1),]
84 tablechi <- tablechi[debsup:(debet-1),]
85 #cex.par <- afc$rowmass[debsup:(debet-1)]
88 table.in <- table.in[debet:nrow(table.in),]
89 tablechi <- tablechi[debet:nrow(tablechi),]
90 #cex.par <- afc$rowmass[debet:nrow(tablechi)]
94 if (is.null(debsup)) {
96 if (!is.null(debet)) {
97 table.in <- table.in[1:(debet-1),]
98 tablechi <- tablechi[1:(debet-1),]
99 cex.par <- afc$rowmass[1:(debet-1)]
101 cex.par <- afc$rowmass
104 table.in <- table.in[debet:nrow(table.in),]
105 tablechi <- tablechi[debet:nrow(tablechi),]
106 #cex.par <- afc$rowmass[debet:nrow(tablechi)]
111 # rn <- rownames(table.in)
112 # rownames(table.in) <- 1:nrow(table.in)
113 # table.in <- unique(table.in)
114 # rn.keep <- as.numeric(rownames(table.in))
115 # rownames(table.in) <- rn[rn.keep]
116 # tablechi <- tablechi[rn.keep,]
118 # cex.par <- cex.par[rn.keep]
124 if (select.nb > nrow(table.in)) select.nb <- nrow(table.in)
125 row.keep <- select_point_nb(tablechi, select.nb)
126 table.in <- table.in[row.keep,]
127 tablechi <- tablechi[row.keep,]
128 } else if (do.select.chi) {
129 if (select.chi > max(tablechi)) select.chi <- max(tablechi)
130 row.keep <- select_point_chi(tablechi, select.chi)
131 table.in <- table.in[row.keep,]
132 tablechi <- tablechi[row.keep,]
133 } else if (do.select.chi.classe) {
134 row.keep <- select.chi.classe(tablechi, ptbycluster)
135 table.in <- table.in[row.keep,]
136 tablechi <- tablechi[row.keep,]
138 row.keep <- 1:nrow(table.in)
140 classes <- apply(tablechi, 1, which.max)
141 maxchi <- apply(tablechi, 1, max)
144 #row.keep <- append(row.keep, rn.keep)
145 #row.keep <- unique(row.keep)
146 cex.par <- cex.par[row.keep]
147 cex.par <- norm.vec(cex.par, txt.min/10, txt.max/10)
150 cex.par <- norm.vec(cex.par, tchi.min/10, tchi.max/10)
156 #################################################@@
158 overlap <- function(x1, y1, sw1, sh1, boxes) {
159 use.r.layout <- FALSE
161 return(.overlap(x1,y1,sw1,sh1,boxes))
163 if (length(boxes) == 0)
165 for (i in c(last,1:length(boxes))) {
172 overlap <- x1 + sw1 > x2-s
174 overlap <- x2 + sw2 > x1-s
177 overlap <- overlap && (y1 + sh1 > y2-s)
179 overlap <- overlap && (y2 + sh2 > y1-s)
188 .overlap <- function(x11,y11,sw11,sh11,boxes1){
189 .Call("is_overlap",x11,y11,sw11,sh11,boxes1)
192 stopoverlap <- function(x, cex.par = NULL) {
203 plot(x[,1],x[,2], pch='')
206 if (is.null(cex.par)) {
207 size <- rep(0.9, nrow(x))
211 #cols <- rainbow(clnb)
213 for (i in 1:nrow(x)) {
214 rotWord <- runif(1)<rot.per
216 theta <- runif(1,0,2*pi)
219 wid <- strwidth(words[i],cex=size[i])
220 ht <- strheight(words[i],cex=size[i])
221 if(grepl(tails,words[i]))
230 if(!overlap(x1-.5*wid,y1-.5*ht,wid,ht, boxes)) { #&&
231 toplot <- rbind(toplot, c(x1, y1, size[i], i))
232 #text(x1,y1,words[i],cex=size[i],offset=0,srt=rotWord*90,
233 # col=cols[classes[i]])
234 boxes[[length(boxes)+1]] <- c(x1-.5*wid,y1-.5*ht,wid,ht)
238 print(paste(words[i], "could not be fit on page. It will not be plotted."))
241 theta <- theta+thetaStep
242 r <- r + rStep*thetaStep/(2*pi)
243 x1 <- x[i,1]+r*cos(theta)
244 y1 <- x[i,2]+r*sin(theta)
248 row.names(toplot) <- words[toplot[,4]]
251 ###############################################################################
253 if (typegraph == 0) {
255 open_file_graph(fileout, width = width, height = height)
256 parcex <- taillecar/10
259 table.in <- stopoverlap(table.in, cex.par=cex.par)
260 classes <- classes[table.in[,4]]
261 cex.par <- cex.par[table.in[,4]]
263 make_afc_graph(table.in, classes, clnb, xlab, ylab, cex.txt = cex.par)
267 vire.nonascii <- function(rnames) {
268 print('vire non ascii')
269 couple <- list(c('é','e'),
290 rnames<-gsub(c[1],c[2], rnames)
295 #rn <- vire.nonascii(rownames(table.in))
296 rn <- rownames(table.in)
299 #par3d(windowRect = c(100,100,600,600))
300 rgl.bg(col = c('white', "#99bb99"), front = "lines", box=FALSE, sphere = TRUE)
301 rgl.lines(c(rx), c(0, 0), c(0, 0), col = "#000000")
302 rgl.lines(c(0,0),c(ry),c(0,0),col = "#000000")
303 rgl.lines(c(0,0),c(0,0),c(rz),col = "#000000")
304 text3d(rx[2]+1,0,0, xlab)
305 text3d(0,ry[2]+1,0, ylab)
306 text3d(0,0,rz[2]+1, zlab)
309 maxchi <- norm.vec(maxchi, tchi.min/100, tchi.max/100)
310 } else if (!is.null(cex.par)) {
311 maxchi <- norm.vec(cex.par, txt.min/100, txt.max/100)
315 colors = rain[classes]
316 text3d(table.in[,1], table.in[,2], table.in[,3], rn, col= colors , cex = cex.par)
318 text3d(rx[2],(ry[2]+(0.2*i)),0,paste('classe',i),col=rain[i])
321 # rgl.spheres(table.in, col = colors, radius = maxchi, alpha = alpha)
326 ReturnVal <- tkmessageBox(title="RGL 3 D",message="Cliquez pour commencer le film",icon="info",type="ok")
328 movie3d(spin3d(axis=c(0,1,0),rpm=6), movie = 'film', frames = "tmpfilm", duration=10, clean=TRUE, top = TRUE, dir = dirout)
329 ReturnVal <- tkmessageBox(title="RGL 3 D",message="Fini !",icon="info",type="ok")
333 ReturnVal <- tkmessageBox(title="RGL 3 D",message="Cliquez pour fermer",icon="info",type="ok")