Mercurial > repos > mnhn65mo > butterfly_analysis

comparison butterfly_crossplot.R @ 0:af2cdd97a434 draft

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Uploaded
author mnhn65mo
date Mon, 13 Aug 2018 04:21:56 -0400
parents
children 22813beb2fa8
comparison
equal deleted inserted replaced
-1:000000000000 0:af2cdd97a434
1 ##################################################################
2 #### Script generique pour realiser les figures en croix ######
3 #### a partir des donnees brut ######
4 ##################################################################
5
6 ### Version V1.2 _ 2018-07-31
7
8 library(ggplot2)
9 library(RColorBrewer)
10
11 args <- commandArgs(trailingOnly = TRUE)
12
13 ### importation code
14 sourcefunctions<-args[1]
15 source(sourcefunctions)
16
17 ## fonction d'importation des fichier des donnes
18 ### fonction d'importation, de concatenation des fichiers
19 ### verification des nom de colonnes
20 ### verification des doublon de ligne
21 read.data <- function(file=NULL,decimalSigne=".") {
22 # cat("1) IMPORTATION \n--------------\n")
23 # cat("<--",file,"\n")
24 data <- read.table(file,sep="\t",stringsAsFactors=FALSE,header=TRUE,dec=decimalSigne)
25 ## verification qu'il y a plusieur colonnes et essaye different separateur
26 if(ncol(data)==1) {
27 data <- read.table(file,sep=";",stringsAsFactors=FALSE,header=TRUE,dec=decimalSigne)
28 if(ncol(data)==1) {
29 data <- read.table(file,sep=",",stringsAsFactors=FALSE,header=TRUE,dec=decimalSigne)
30 if(ncol(data)==1) {
31 data <- read.table(file,sep=" ",stringsAsFactors=FALSE,header=TRUE,dec=decimalSigne)
32 if(ncol(data)==1) {
33 stop("!!!! L'importation a echoue\n les seperatateurs de colonne utilise ne sont pas parmi ([tabulation], ';' ',' [espace])\n -> veuillez verifier votre fichier de donnees\n")
34 }
35 }
36 }
37 }
38 return(data)
39 }
40
41
42
43
44
45 filtre1niveau <- function(func,
46 nom_fichier = filename,
47 dec=".",
48 nom_fichierCouleur= color_filename,
49 col_abscisse = "AB_MOYENNE",
50 figure_abscisse = "Abondance",
51 col_ordonnee = "DIVERSITE_MOYENNE",
52 figure_ordonnee = "Diversite",
53 nomGenerique="GLOBAL",
54 vec_figure_titre = c("Les Papillons"),
55 colourProtocole = TRUE,
56 nomProtocole = "Papillons",
57 vec_col_filtre = vec_col_filtre_usr,
58 col_sousGroup = NULL,#
59 val_filtre = NULL,#
60 figure_nom_filtre = NULL,#
61 bagplot = TRUE,
62 bagProp=c(.05,.5,.95),
63 seuilSegment=30,
64 segmentSousSeuil=TRUE,
65 forcageMajusculeFiltre=TRUE,
66 forcageMajusculeSousGroupe=TRUE){
67
68 dCouleur <- read.data(file=nom_fichierCouleur)
69 d <- read.data(file=nom_fichier,decimalSigne=dec)
70 if(colourProtocole & !is.null(nomProtocole)) colourProtocole_p <- as.character(dCouleur[dCouleur[,2]==nomProtocole,3]) else colourProtocole_p <- NULL
71
72 for(f in 1:length(vec_col_filtre)) {
73 if(length(vec_figure_titre)==1){
74 figure_titre_f <- vec_figure_titre
75 }else{
76 figure_titre_f <- vec_figure_titre[f]
77 }
78 col_filtre_f <- vec_col_filtre[f]
79 cat(col_sousGroup) #Just to check
80 if(func=="ggfiltre1niveau"){
81 cat("ggfiltre1niveau")
82 ggfiltre1niveau(d,
83 col_abscisse,
84 figure_abscisse,
85 col_ordonnee,
86 figure_ordonnee,
87 figure_titre = figure_titre_f,
88 col_filtre = col_filtre_f,
89 nomGenerique,
90 val_filtre = NULL,
91 figure_nom_filtre = NULL,
92 tab_figure_couleur= subset(dCouleur,Filtre==col_filtre_f),
93 colourProtocole = colourProtocole_p,
94 nomProtocole,
95 bagplot,
96 bagProp=c(.05,.5,.95),
97 seuilSegment,
98 segmentSousSeuil,
99 forcageMajusculeFiltre)
100 }else if(func=="gglocal"){
101 cat("gglocal")
102 gglocal(d,
103 col_abscisse,
104 figure_abscisse,
105 col_ordonnee,
106 figure_ordonnee,
107 figure_titre = figure_titre_f,
108 col_filtre = col_filtre_f,
109 nomGenerique = nomGenerique,
110 col_sousGroup = col_sousGroup,
111 val_filtre = NULL,
112 figure_nom_filtre = NULL,
113 tab_figure_couleur= subset(dCouleur,Filtre==col_filtre_f),
114 colourProtocole = colourProtocole_p,
115 nomProtocole,
116 couleurLocal="#f609c1",
117 bagplot,
118 bagProp,
119 seuilSegment,
120 segmentSousSeuil,
121 forcageMajusculeFiltre,
122 forcageMajusculeSousGroupe)
123 }else{
124 cat("ggCompareLevel")
125 ggCompareLevel(d,
126 col_abscisse,
127 figure_abscisse,
128 col_ordonnee,
129 figure_ordonnee,
130 figure_titre = figure_titre_f,
131 col_filtre = col_filtre_f,
132 nomGenerique = nomGenerique,
133 val_filtre = NULL,
134 figure_nom_filtre = NULL,
135 tab_figure_couleur= subset(dCouleur,Filtre==col_filtre_f),
136 colourProtocole = colourProtocole_p,
137 nomProtocole,
138 bagplot,
139 bagProp,
140 seuilSegment,
141 segmentSousSeuil,
142 forcageMajusculeFiltre)
143 }
144 }
145 }
146
147 ggfiltre1niveau <- function(d,
148 col_abscisse = "AB_MOYENNE",
149 figure_abscisse = "Abondance",
150 col_ordonnee = "DIVERSITE_MOYENNE",
151 figure_ordonnee = "Diversite",
152 figure_titre = "Referentiel papillon",
153 col_filtre = "nom_reseau",
154 nomGenerique = "Global",
155 val_filtre = NULL,
156 figure_nom_filtre = NULL,
157 tab_figure_couleur= NULL,
158 colourProtocole = NULL,
159 nomProtocole = NULL,
160 bagplot = TRUE,
161 bagProp=c(.05,.5,.95),
162 seuilSegment=30,
163 segmentSousSeuil=TRUE,
164 forcageMajusculeFiltre=TRUE,
165 result_dir="resultats/") {
166
167 d$groupe <- as.character(d[,col_filtre])
168 d$abscisse <- d[,col_abscisse]
169 d$ordonnee <- d[,col_ordonnee]
170 d$groupe <-gsub("/","_",d$groupe)
171 d$groupe <-gsub("!","",d$groupe)
172
173 if(forcageMajusculeFiltre){
174 d$groupe <- toupper(d$groupe)}
175
176 d <- subset(d,!(is.na(groupe)) & !(is.na(abscisse)) & !(is.na(ordonnee)) & groupe != "")
177
178 if(is.null(val_filtre)){
179 lesModalites <- unique(d$groupe)
180 }else{
181 lesModalites <- val_filtre
182 }
183
184 # repResult <- dir(result_dir)
185 # current_dir<-getwd()
186 # dir.create(file.path(current_dir,result_dir))
187 #
188 # if(!(col_filtre %in% repResult)){
189 # dir.create(file.path(".",paste(result_dir,col_filtre,sep="")))}
190 #
191 # nomRep1 <- paste(result_dir,col_filtre,"/",sep="")
192
193 d.autre <- d
194 d.autre$groupe <- nomGenerique
195
196 for(m in lesModalites) {
197 d.reseau <- subset(d,groupe==m)
198 d.reseau$groupe <- m
199 ggTable <- rbind(d.autre,d.reseau)
200
201 seuilResum <- nrow(d.reseau) >= seuilSegment
202
203 ggTableResum <- aggregate(cbind(ordonnee, abscisse) ~ groupe, data = ggTable,quantile, c(.25,.5,.75))
204 ggTableResum <- data.frame(ggTableResum[,1],ggTableResum[,2][,1:3],ggTableResum[,3][,1:3])
205 colnames(ggTableResum) <- c("groupe","ordonnee.inf","ordonnee.med","ordonnee.sup","abscisse.inf","abscisse.med","abscisse.sup")
206
207 if(ggTableResum$groupe[2]==nomGenerique){
208 ggTableResum <- ggTableResum[c(2,1),]}
209
210 if(!(is.null(tab_figure_couleur))) {
211 if(m %in% tab_figure_couleur$Modalite) {
212 figure_couleur <- setNames(c(as.character(tab_figure_couleur$couleur[tab_figure_couleur$Modalite == nomGenerique]),
213 as.character(tab_figure_couleur$couleur[tab_figure_couleur$Modalite == m])),
214 c(nomGenerique,m))
215 }else{
216 figure_couleur <- setNames(c(as.character(tab_figure_couleur$couleur[tab_figure_couleur$Modalite == nomGenerique]),
217 as.character(tab_figure_couleur$couleur[tab_figure_couleur$Modalite == ""])),
218 c(nomGenerique,m))
219 }
220 }
221
222 # repResult <- dir(nomRep1)
223 # if(!(m %in% repResult)){
224 # dir.create(paste(nomRep1,m,sep=""))}
225 # nomRep <- paste(nomRep1,m,"/",sep="")
226 #
227 #
228 # if(!is.null(nomProtocole)){
229 # repResult <- dir(nomRep)
230 # if(!(nomProtocole %in% repResult)){
231 # dir.create(paste(nomRep,nomProtocole,sep=""))}
232 # nomRep <- paste(nomRep,nomProtocole,"/",sep="")
233 # }
234
235
236 gg <- ggplot(ggTable,aes(x=abscisse,y=ordonnee,colour=groupe,fill=groupe))
237 if(bagplot){
238 gg <- gg + stat_bag(data=d.autre,prop=bagProp[1],colour=NA,alpha=.7) + stat_bag(data=d.autre,prop=bagProp[2],colour=NA,alpha=.4) + stat_bag(data=d.autre,prop=bagProp[3],colour=NA,alpha=.2) }
239 else {
240 gg <- gg + geom_point(alpha=.2)
241 }
242 gg <- gg + geom_hline(data=subset(ggTableResum,groupe== nomGenerique),aes(yintercept = ordonnee.med,colour=groupe),size=.5,linetype="dashed") + geom_vline(data=subset(ggTableResum,groupe==nomGenerique),aes(xintercept = abscisse.med,colour=groupe),size=.5,linetype="dashed")
243 if(segmentSousSeuil) {
244 gg <- gg + geom_segment(data=ggTableResum,aes(x = abscisse.med, y = ordonnee.inf, xend = abscisse.med, yend = ordonnee.sup),alpha=.8,size=2.5)
245 gg <- gg + geom_segment(data=ggTableResum,aes(x = abscisse.inf, y = ordonnee.med, xend = abscisse.sup, yend = ordonnee.med),alpha=.8,size=2.5)
246 if(!(seuilResum)) {
247 gg <- gg + geom_segment(data=subset(ggTableResum,groupe!=nomGenerique),aes(x = abscisse.med, y = ordonnee.inf, xend = abscisse.med, yend = ordonnee.sup),alpha=.5,size = 1.5,colour="white")
248 gg <- gg + geom_segment(data=subset(ggTableResum,groupe!=nomGenerique),aes(x = abscisse.inf, y = ordonnee.med, xend = abscisse.sup, yend = ordonnee.med),alpha=.5,size = 1.5,colour="white")
249 }
250 } else {
251 gg <- gg + geom_segment(data=subset(ggTableResum,groupe==nomGenerique),aes(x = abscisse.med, y = ordonnee.inf, xend = abscisse.med, yend = ordonnee.sup),alpha=.8,size = 2.5)
252 gg <- gg + geom_segment(data=subset(ggTableResum,groupe==nomGenerique),aes(x = abscisse.inf, y = ordonnee.med, xend = abscisse.sup, yend = ordonnee.med),alpha=.8,size = 2.5)
253 }
254
255 gg <- gg + geom_point(data=d.reseau,size=2)
256 gg <- gg + labs(list(title=figure_titre,x=figure_abscisse,y=figure_ordonnee))
257
258 if(!is.null(colourProtocole)){
259 gg <- gg + theme(legend.justification=c(1,0), legend.position=c(1,0),legend.text = element_text(size = 7),legend.background = element_rect(fill=NA), axis.ticks = element_line(colour = colourProtocole, size = 1), axis.ticks.length = unit(0.3, "cm"),plot.title = element_text(colour = colourProtocole))
260 }else{
261 gg <- gg + theme(legend.justification=c(1,0), legend.position=c(1,0),legend.text = element_text(size = 7),legend.background = element_rect(fill=NA))
262 }
263
264 if(!(is.null(tab_figure_couleur))){
265 gg <- gg + scale_colour_manual(values = figure_couleur,name = "") + scale_fill_manual(values = figure_couleur,name = "",guide=FALSE)}
266
267 ggfile <- paste(nomRep,nomProtocole,"_",m,".png",sep="")
268 cat("Check",ggfile,":")
269 ggsave(ggfile,gg)
270 cat("\n")
271 flush.console()
272 }
273 }
274
275
276 ##############################################################
277 gglocal <- function(d,
278 col_abscisse = "AB_MOYENNE",
279 figure_abscisse = "Abondance",
280 col_ordonnee = "DIVERSITE_MOYENNE",
281 figure_ordonnee = "Diversite",
282 figure_titre = "Graphe referentiel",
283 col_filtre = "NOM_RESEAU",
284 nomGenerique = "GLOBAL",
285 col_sousGroup = "PARCELLEID",
286 val_filtre = NULL,
287 figure_nom_filtre = NULL,
288 tab_figure_couleur= NULL,
289 colourProtocole = NULL,
290 nomProtocole = NULL,
291 couleurLocal="#f609c1",
292 bagplot = TRUE,
293 bagProp=c(.05,.5,.95),
294 seuilSegment=30,
295 segmentSousSeuil=TRUE,
296 forcageMajusculeFiltre=TRUE,
297 forcageMajusculeSousGroupe=TRUE) {
298
299 d$groupe <- d[,col_filtre]
300 d$abscisse <- d[,col_abscisse]
301 d$ordonnee <- d[,col_ordonnee]
302 d$sousGroup <- d[,col_sousGroup]
303 d$groupe <-gsub("/","_",d$groupe)
304 d$groupe <-gsub("!","",d$groupe)
305 d$sousGroup <-gsub("/","_",d$sousGroup)
306 d$sousGroup <-gsub("!","",d$sousGroup)
307 if(forcageMajusculeFiltre){
308 d$groupe <- toupper(d$groupe)}
309 if(forcageMajusculeSousGroupe){
310 d$sousGroup <- toupper(d$sousGroup)}
311 d <- subset(d,!(is.na(groupe)) & !(is.na(sousGroup)) & !(is.na(abscisse)) & !(is.na(ordonnee)) & groupe != "")
312 vecSousGroup <- as.character(unique(d$sousGroup))
313 if(is.null(val_filtre)){
314 lesModalites <- unique(d$groupe)}
315 else{ lesModalites <- val_filtre}
316 repResult <- dir("resultats/")
317 # if(!(col_filtre %in% repResult)){
318 # dir.create(paste("resultats/",col_filtre,sep=""))}
319 # nomRep1 <- paste("resultats/",col_filtre,"/",sep="")
320 d.autre <- d
321 d.autre$groupe <- nomGenerique
322 for(m in lesModalites) {
323 d.reseau <- subset(d,groupe==m)
324 d.reseau$groupe <- m
325 ggTable <- rbind(d.autre,d.reseau)
326 seuilResum <- nrow(d.reseau) >= seuilSegment
327 ggTableResum <- aggregate(cbind(ordonnee, abscisse) ~ groupe, data = ggTable,quantile, c(.25,.5,.75))
328 ggTableResum <- data.frame(ggTableResum[,1],ggTableResum[,2][,1:3],ggTableResum[,3][,1:3])
329 colnames(ggTableResum) <- c("groupe","ordonnee.inf","ordonnee.med","ordonnee.sup","abscisse.inf","abscisse.med","abscisse.sup")
330 if(ggTableResum$groupe[2]==nomGenerique){
331 ggTableResum <- ggTableResum[c(2,1),]}
332 if(!(is.null(tab_figure_couleur))) {
333 if(m %in% tab_figure_couleur$Modalite) {
334 figure_couleur <- setNames(c(as.character(tab_figure_couleur$couleur[tab_figure_couleur$Modalite == nomGenerique]),
335 as.character(tab_figure_couleur$couleur[tab_figure_couleur$Modalite == m]),couleurLocal),
336 c(nomGenerique,m,""))
337 } else {
338 figure_couleur <- setNames(c(as.character(tab_figure_couleur$couleur[tab_figure_couleur$Modalite == nomGenerique]),
339 as.character(tab_figure_couleur$couleur[tab_figure_couleur$Modalite == ""]),couleurLocal),
340 c(nomGenerique,m,""))
341 }
342 }
343 # repResult <- dir(nomRep1)
344 # if(!(m %in% repResult)){
345 # dir.create(paste(nomRep1,m,sep=""))}
346 # nomRep <- paste(nomRep1,m,"/",sep="")
347 # if(!is.null(nomProtocole)) {
348 # repResult <- dir(nomRep)
349 # if(!(nomProtocole %in% repResult)){
350 # dir.create(paste(nomRep,nomProtocole,sep=""))}
351 # nomRep <- paste(nomRep,nomProtocole,"/",sep="")
352 # }
353 d.reseau <- subset(d.reseau, !(is.na(sousGroup)))
354 figure_size<- setNames(c(1,3,2.5), c(nomGenerique,m,""))
355 figure_shape<- setNames(c(16,16,20), c(nomGenerique,m,""))
356 vecSousGroup <- as.character(unique(d.reseau$sousGroup))
357 for(p in vecSousGroup) {
358 dp <- subset(d.reseau,sousGroup == p)
359 dp$groupe <- dp$sousGroup
360 ggTableSous <- rbind(d.reseau,dp)
361 ggTableSous <- rbind(d.autre,d.reseau,dp)
362 names(figure_couleur)[3] <- p
363 names(figure_shape)[3] <- p
364 names(figure_size)[3] <- p
365 gg <- ggplot(ggTableSous,aes(x=abscisse,y=ordonnee,colour=groupe,fill=groupe,shape=groupe,size=groupe))
366 if(bagplot){
367 gg <- gg + stat_bag(data=d.autre,prop=bagProp[1],colour=NA,alpha=.7) + stat_bag(data=d.autre,prop=bagProp[2],colour=NA,alpha=.4) + stat_bag(data=d.autre,prop=bagProp[3],colour=NA,alpha=.2)
368 }else{
369 gg <- gg + geom_point(alpha=.2)}
370 gg <- gg + geom_hline(data=subset(ggTableResum,groupe == nomGenerique),aes(yintercept = ordonnee.med,colour=groupe),size=.5,linetype="dashed")
371 gg <- gg + geom_vline(data=subset(ggTableResum,groupe == nomGenerique),aes(xintercept = abscisse.med,colour=groupe),size=.5,linetype="dashed")
372 if(segmentSousSeuil) {
373 gg <- gg + geom_segment(data=ggTableResum,aes(x = abscisse.med, y = ordonnee.inf, xend = abscisse.med, yend = ordonnee.sup),alpha=.8,size=2.5)
374 gg <- gg + geom_segment(data=ggTableResum,aes(x = abscisse.inf, y = ordonnee.med, xend = abscisse.sup, yend = ordonnee.med),alpha=.8,size=2.5)
375 if(!(seuilResum)) {
376 gg <- gg + geom_segment(data=subset(ggTableResum,groupe!=nomGenerique),aes(x = abscisse.med, y = ordonnee.inf, xend = abscisse.med, yend = ordonnee.sup),alpha=.5,size = 1.5,colour="white")
377 gg <- gg + geom_segment(data=subset(ggTableResum,groupe!=nomGenerique),aes(x = abscisse.inf, y = ordonnee.med, xend = abscisse.sup, yend = ordonnee.med),alpha=.5,size = 1.5,colour="white")
378 }
379 } else {
380 gg <- gg + geom_segment(data=subset(ggTableResum,groupe==nomGenerique),aes(x = abscisse.med, y = ordonnee.inf, xend = abscisse.med, yend = ordonnee.sup),alpha=.8,size = 2.5)
381 gg <- gg + geom_segment(data=subset(ggTableResum,groupe==nomGenerique),aes(x = abscisse.inf, y = ordonnee.med, xend = abscisse.sup, yend = ordonnee.med),alpha=.8,size = 2.5)
382 }
383 gg <- gg + geom_point(data=subset(ggTableSous,groupe != nomGenerique))
384 if(!(is.null(tab_figure_couleur))){
385 gg <- gg + scale_colour_manual(values = figure_couleur,name = "") + scale_fill_manual(values = figure_couleur,name = "",guide=FALSE)}
386 gg <- gg + scale_shape_manual(values = figure_shape,name = "",guide=FALSE) + scale_size_manual(values = figure_size,guide=FALSE)
387 gg <- gg + labs(list(title=figure_titre,x=figure_abscisse,y=figure_ordonnee))
388 if(!is.null(colourProtocole)){
389 gg <- gg + theme(legend.justification=c(1,0), legend.position=c(1,0),legend.text = element_text(size = 7),legend.background = element_rect(fill=NA), axis.ticks = element_line(colour = colourProtocole, size = 1), axis.ticks.length = unit(0.3, "cm"),plot.title = element_text(colour = colourProtocole)) }
390 else{
391 gg <- gg + theme(legend.justification=c(1,0), legend.position=c(1,0),legend.text = element_text(size = 7),legend.background = element_rect(fill=NA))}
392 ggfile <- paste(nomRep,nomProtocole,"_",m,"-",p,".png",sep="")
393 cat("Check",ggfile,":")
394 ggsave(ggfile,gg)
395 cat("\n")
396 flush.console()
397 }
398 }
399 }
400
401
402
403 #####################################################
404 ggCompareLevel <- function(d,
405 col_abscisse = "abond_moyenne",
406 figure_abscisse = "Abondance",
407 col_ordonnee = "diversite_moyenne",
408 figure_ordonnee = "Diversite",
409 figure_titre = "Rhooo il dechire ce graphe",
410 col_filtre = "nom_reseau",
411 nomGenerique = "Global",
412 val_filtre = NULL,
413 figure_nom_filtre = NULL,
414 tab_figure_couleur= NULL,
415 colourProtocole = NULL,
416 nomProtocole = NULL,
417 bagplot = TRUE,
418 bagProp=c(.05,.5,.95),
419 seuilSegment=30,
420 segmentSousSeuil=FALSE,
421 forcageMajusculeFiltre=TRUE){
422
423 d$groupe <- d[,col_filtre]
424 d$abscisse <- d[,col_abscisse]
425 d$ordonnee <- d[,col_ordonnee]
426 d$groupe <-gsub("/","_",d$groupe)
427 d$groupe <-gsub("!","",d$groupe)
428
429 if(forcageMajusculeFiltre){
430 d$groupe <- toupper(d$groupe)}
431 d <- subset(d,!(is.na(groupe)) & !(is.na(abscisse)) & !(is.na(ordonnee)) & groupe != "")
432 if(is.null(val_filtre)){
433 lesModalites <- unique(d$groupe)
434 }else{
435 lesModalites <- val_filtre
436 }
437 # repResult <- dir("resultats/")
438 # if(!(col_filtre %in% repResult)){
439 # dir.create(paste("resultats/",col_filtre,sep=""))
440 # }
441 # if(!is.null(nomProtocole)){
442 # repResult <- dir(paste("resultats/",col_filtre,sep=""))
443 # if(!(nomProtocole %in% repResult)){
444 # dir.create(paste("resultats/",col_filtre,"/",nomProtocole,sep=""))}
445 # nomRep <- paste("resultats/",col_filtre,"/",nomProtocole,"/",sep="")
446 # }else{
447 # nomRep <- paste("resultats/",col_filtre,"/",sep="")
448 # }
449 d.autre <- d
450 d.autre$groupe <- nomGenerique
451 d.reseau <- subset(d,groupe %in% lesModalites)
452 ggTable <- rbind(d.autre,d.reseau)
453 ggTableResum <- aggregate(cbind(ordonnee, abscisse) ~ groupe, data = ggTable,quantile, c(.25,.5,.75))
454 ggTableResum <- data.frame(ggTableResum[,1],ggTableResum[,2][,1:3],ggTableResum[,3][,1:3])
455 colnames(ggTableResum) <- c("groupe","ordonnee.inf","ordonnee.med","ordonnee.sup","abscisse.inf","abscisse.med","abscisse.sup")
456 ggSeuil <- aggregate(ordonnee ~ groupe, data=ggTable,length)
457 ggSeuil$seuilResum <- ggSeuil$ordonnee >= seuilSegment
458 colnames(ggSeuil)[ncol(ggSeuil)] <- "seuil"
459 ggTableResum <- merge(ggTableResum,ggSeuil,by="groupe")
460 t_figure_couleur <- subset(tab_figure_couleur,Modalite %in% c(nomGenerique,lesModalites))
461 modaliteSansCouleur <- lesModalites[(!(lesModalites %in% t_figure_couleur$Modalite))]
462 nbNxCol <- length(modaliteSansCouleur)
463 mypalette<-brewer.pal(nbNxCol,"YlGnBu")
464 figure_couleur <- setNames(c(as.character(t_figure_couleur$couleur),mypalette),c(as.character(t_figure_couleur$Modalite),modaliteSansCouleur))
465 tab_coul <- data.frame(groupe=names(figure_couleur),couleur=figure_couleur)
466 tab_coul <- merge(tab_coul,ggTableResum,"groupe")
467 tab_coul$nom <- paste(tab_coul$groupe," (",tab_coul$ordonnee,")",sep="")
468 figure_couleur <- setNames(as.character(tab_coul$couleur),tab_coul$groupe)
469 figure_couleur_nom<- tab_coul$nom
470 gg <- ggplot(ggTable,aes(x=abscisse,y=ordonnee,colour=groupe,fill=groupe))
471 if(bagplot){
472 gg <- gg + stat_bag(data=d.autre,prop=bagProp[1],colour=NA,alpha=.7) + stat_bag(data=d.autre,prop=bagProp[2],colour=NA,alpha=.4) + stat_bag(data=d.autre,prop=bagProp[3],colour=NA,alpha=.2)
473 }else{
474 gg <- gg + geom_point(alpha=.2)
475 }
476 gg <- gg + geom_hline(data=subset(ggTableResum,groupe=="Autre"),aes(yintercept = ordonnee.med,colour=groupe),size=.5,linetype="dashed") + geom_vline(data=subset(ggTableResum,groupe=="Autre"),aes(xintercept = abscisse.med,colour=groupe),size=.5,linetype="dashed")
477 gg <- gg + geom_segment(data=ggTableResum,aes(x = abscisse.med, y = ordonnee.inf, xend = abscisse.med, yend = ordonnee.sup),alpha=.7,size = 2.5)
478 gg <- gg + geom_segment(data=ggTableResum,aes(x = abscisse.inf, y = ordonnee.med, xend = abscisse.sup, yend = ordonnee.med),alpha=.7,size = 2.5)
479 if(any(ggTableResum$seuil)){
480 gg <- gg + geom_segment(data=subset(ggTableResum,!(seuil)),aes(x = abscisse.med, y = ordonnee.inf, xend = abscisse.med, yend = ordonnee.sup),alpha=.5,size = 1.5,colour="white")
481 gg <- gg + geom_segment(data=subset(ggTableResum,!(seuil)),aes(x = abscisse.inf, y = ordonnee.med, xend = abscisse.sup, yend = ordonnee.med),alpha=.5,size = 1.5,colour="white")
482 }
483
484 #browser() # gg <- gg + geom_point(data=d.reseau,size=2)
485 gg <- gg + scale_colour_manual(values = figure_couleur,name = "",labels = figure_couleur_nom) + scale_fill_manual(values = figure_couleur,name = "",guide=FALSE)
486 gg <- gg + labs(list(title=figure_titre,x=figure_abscisse,y=figure_ordonnee))
487 if(!is.null(colourProtocole)){
488 gg <- gg + theme(legend.justification=c(1,0), legend.position=c(1,0),legend.text = element_text(size = 7),legend.background = element_rect(fill=NA), axis.ticks = element_line(colour = colourProtocole, size = 1), axis.ticks.length = unit(0.3, "cm"),plot.title = element_text(colour = colourProtocole))
489 }else{
490 gg <- gg + theme(legend.justification=c(1,0), legend.position=c(1,0),legend.text = element_text(size = 7),legend.background = element_rect(fill=NA))
491 }
492 ggfile <- paste(nomRep,nomProtocole,"_",col_filtre,"_","comparaison.png",sep="")
493 cat("Check",ggfile,":")
494 ggsave(ggfile,gg)
495 cat("\n")
496 flush.console()
497 }
498
499
500 #########################################
501
502 #Lancement des fonctions :
503
504 #Variables a definir :
505
506 #filename="BDD_PAPILLONS_2016.txt"
507 #color_filename<-"code_couleurs.csv"
508
509 #func
510 #func="ggCompareLevel"
511 #func="ggfiltre1niveau"
512 #func="gglocal"
513
514 #colSousGroupe
515 #col_sousGroup_usr = NULL #ggfiltre #ggCompareLevel
516 #col_sousGroup_usr = "PARCELLENOM" #gglocal
517
518 #vec_col_filtre_usr
519 #vec_col_filtre_usr = c("CONDUITEPARCELLE") #ggCompareLevel
520 #vec_col_filtre_usr = c("REGION") #ggfiltre
521 #vec_col_filtre_usr = c("NOM_RESEAU") #gglocal
522
523
524
525 #Exe fonction :
526
527 #filtre1niveau(func=func,nom_fichier=filename,nom_fichierCouleur=color_filename,col_sousGroup=NULL) #ggfiltre ou ggCompareLevel, depend de func et de vec_col_filtre_usr
528 #filtre1niveau(func=func,nom_fichier=filename,nom_fichierCouleur=color_filename,col_sousGroup = col_sousGroup_usr,vec_col_filtre=vec_col_filtre_usr) ## ==local
529
530 ########################################################
531
532 filename=args[2]
533 color_filename=args[3]
534 func=args[4]
535
536 if(func=="ggCompareLevel"){
537 col_sousGroup_usr=NULL
538 vec_col_filtre_usr=c("CONDUITEPARCELLE")
539 }else if(func=="ggfiltre1niveau"){
540 col_sousGroup_usr=NULL
541 vec_col_filtre_usr=c("REGION")
542 }else if(func=="gglocal"){
543 col_sousGroup_usr="PARCELLENOM"
544 vec_col_filtre_usr=c("NOM_RESEAU")
545 }else{
546 #sortie erreur
547 write("Error, unknown function. Exit(1).", stderr())
548 q('no')
549 }
550
551 #create result dir
552 nomRep="resultats/"
553 dir.create(file.path(".", nomRep), showWarnings = FALSE)
554
555
556 filtre1niveau(func=func,nom_fichier=filename,nom_fichierCouleur=color_filename,col_sousGroup=col_sousGroup_usr,vec_col_filtre=vec_col_filtre_usr)