1 #Author: Pierre Ratinaud
2 #Copyright (c) 20010-2013 Pierre Ratinaud
6 #fichier genere par IRaMuTeq
7 source('%s', encoding = 'utf8')
19 do.select.chi.classe <- %s
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 = '')
51 if ( what == 0 ) table.in <- afc$colcoord
52 if ( what == 1 ) table.in <- afc$colcrl
53 rownames(table.in) <- afc$colnames
56 table.in<-table.in[,c(x,y)]
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)
65 cex.par <- rep(taillecar/10, nrow(table.in))
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
73 table.in<-table.in[,c(x,y)]
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)
80 if (exists('afctable')) {
81 eff <- rowSums(afctable)
83 eff <- afctable$rowmass
86 if (!is.null(debsup)) {
88 table.in <- table.in[1:(debsup-1),]
89 tablechi <- tablechi[1:(debsup-1),]
90 cex.par <- eff[1:(debsup-1)]
93 table.in <- table.in[debsup:(debet-1),]
94 tablechi <- tablechi[debsup:(debet-1),]
95 cex.par <- eff[debsup:(debet-1)]
98 table.in <- table.in[debet:nrow(table.in),]
99 tablechi <- tablechi[debet:nrow(tablechi),]
100 cex.par <- eff[debet:nrow(afctable)]
104 if (is.null(debsup)) {
106 if (!is.null(debet)) {
107 table.in <- table.in[1:(debet-1),]
108 tablechi <- tablechi[1:(debet-1),]
109 cex.par <- eff[1:(debet-1)]
114 table.in <- table.in[debet:nrow(table.in),]
115 tablechi <- tablechi[debet:nrow(tablechi),]
116 cex.par <- eff[debet:nrow(afctable)]
121 if (select.nb > nrow(table.in)) select.nb <- nrow(table.in)
122 row.keep <- select_point_nb(tablechi, select.nb)
123 table.in <- table.in[row.keep,]
124 tablechi <- tablechi[row.keep,]
125 } else if (do.select.chi) {
126 if (select.chi > max(tablechi)) select.chi <- max(tablechi)
127 row.keep <- select_point_chi(tablechi, select.chi)
128 table.in <- table.in[row.keep,]
129 tablechi <- tablechi[row.keep,]
130 } else if (do.select.chi.classe) {
131 row.keep <- select.chi.classe(tablechi, ptbycluster)
132 table.in <- table.in[row.keep,]
133 tablechi <- tablechi[row.keep,]
135 row.keep <- 1:nrow(table.in)
137 classes <- apply(tablechi, 1, which.max)
138 maxchi <- apply(tablechi, 1, max)
139 infp <- which(is.infinite(maxchi) & maxchi > 0)
142 if (!length(infp) == length(maxchi)) {
143 valmax <- max(maxchi, na.rm = TRUE)
147 maxchi[infp] <- valmax + 2
150 #row.keep <- append(row.keep, rn.keep)
151 #row.keep <- unique(row.keep)
152 cex.par <- cex.par[row.keep]
153 cex.par <- norm.vec(cex.par, txt.min/10, txt.max/10)
156 cex.par <- norm.vec(cex.par, tchi.min/10, tchi.max/10)
158 cex.par <- rep(taillecar/10, nrow(table.in))
162 if (is.null(xminmax)) {
163 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)))
165 if (is.null(yminmax)) {
166 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 if (typegraph == 0) {
171 open_file_graph(fileout, width = width, height = height, svg = do.svg)
172 parcex <- taillecar/10
175 table.in <- table.in[order(cex.par, decreasing = TRUE),]
176 classes <- classes[order(cex.par, decreasing = TRUE)]
177 cex.par <- cex.par[order(cex.par, decreasing = TRUE)]
178 table.in <- stopoverlap(table.in, cex.par=cex.par, xlim = xminmax, ylim = yminmax)
179 classes <- classes[table.in[,4]]
180 cex.par <- cex.par[table.in[,4]]
182 make_afc_graph(table.in, classes, clnb, xlab, ylab, cex.txt = cex.par, xminmax = xminmax, yminmax = yminmax)
186 rn <- vire.nonascii(rownames(table.in))
188 colors = rain[classes]
189 #rn <- rownames(table.in)
191 par3d('userMatrix' = matrix(c(1,0,0,0, 0,1,0,0,0,0,1,0,0,0,0,1), ncol=4, nrow = 4))
192 text3d(table.in[,1], table.in[,2], table.in[,3], rn, col = colors , cex = cex.par)
193 rgl.bg(col = c('white', "#99bb99"), front = "lines", box=FALSE, sphere = TRUE)
195 #par3d(windowRect = c(100,100,600,600))
196 rgl.lines(c(rx), c(0, 0), c(0, 0), col = "#000000")
197 rgl.lines(c(0,0),c(ry),c(0,0),col = "#000000")
198 rgl.lines(c(0,0),c(0,0),c(rz),col = "#000000")
199 text3d(rx[2]+1,0,0, xlab)
200 text3d(0,ry[2]+1,0, ylab)
201 text3d(0,0,rz[2]+1, zlab)
204 maxchi <- norm.vec(maxchi, tchi.min/100, tchi.max/100)
205 } else if (!is.null(cex.par)) {
206 maxchi <- norm.vec(cex.par, txt.min/100, txt.max/100)
213 text3d(rx[2],(ry[2]+(0.2*i)),0,paste('classe',i),col=rain[i])
216 # rgl.spheres(table.in, col = colors, radius = maxchi, alpha = alpha)
221 ReturnVal <- tkmessageBox(title="RGL 3 D",message="Cliquez pour commencer le film",icon="info",type="ok")
223 movie3d(spin3d(axis=c(0,1,0),rpm=6), movie = 'film', frames = "tmpfilm", duration=10, clean=TRUE, top = TRUE, dir = dirout)
224 ReturnVal <- tkmessageBox(title="RGL 3 D",message="Fini !",icon="info",type="ok")
228 ReturnVal <- tkmessageBox(title="RGL 3 D",message="Cliquez pour fermer",icon="info",type="ok")