|
0
|
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)
|
