# HG changeset patch # User mnhn65mo # Date 1534150077 14400 # Node ID c5a10acd34e3b7cbc87c2df226cf808f4e4c96b0 # Parent af2cdd97a434149bbe8b15ec0b2f105f02c6f0f4 Uploaded diff -r af2cdd97a434 -r c5a10acd34e3 butterfly_crossplot.R --- a/butterfly_crossplot.R Mon Aug 13 04:21:56 2018 -0400 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,556 +0,0 @@ -################################################################## -#### Script generique pour realiser les figures en croix ###### -#### a partir des donnees brut ###### -################################################################## - -### Version V1.2 _ 2018-07-31 - -library(ggplot2) -library(RColorBrewer) - -args <- commandArgs(trailingOnly = TRUE) - -### importation code -sourcefunctions<-args[1] -source(sourcefunctions) - -## fonction d'importation des fichier des donnes -### fonction d'importation, de concatenation des fichiers -### verification des nom de colonnes -### verification des doublon de ligne -read.data <- function(file=NULL,decimalSigne=".") { -# cat("1) IMPORTATION \n--------------\n") -# cat("<--",file,"\n") - data <- read.table(file,sep="\t",stringsAsFactors=FALSE,header=TRUE,dec=decimalSigne) - ## verification qu'il y a plusieur colonnes et essaye different separateur - if(ncol(data)==1) { - data <- read.table(file,sep=";",stringsAsFactors=FALSE,header=TRUE,dec=decimalSigne) - if(ncol(data)==1) { - data <- read.table(file,sep=",",stringsAsFactors=FALSE,header=TRUE,dec=decimalSigne) - if(ncol(data)==1) { - data <- read.table(file,sep=" ",stringsAsFactors=FALSE,header=TRUE,dec=decimalSigne) - if(ncol(data)==1) { - 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") - } - } - } - } - return(data) -} - - - - - -filtre1niveau <- function(func, - nom_fichier = filename, - dec=".", - nom_fichierCouleur= color_filename, - col_abscisse = "AB_MOYENNE", - figure_abscisse = "Abondance", - col_ordonnee = "DIVERSITE_MOYENNE", - figure_ordonnee = "Diversite", - nomGenerique="GLOBAL", - vec_figure_titre = c("Les Papillons"), - colourProtocole = TRUE, - nomProtocole = "Papillons", - vec_col_filtre = vec_col_filtre_usr, - col_sousGroup = NULL,# - val_filtre = NULL,# - figure_nom_filtre = NULL,# - bagplot = TRUE, - bagProp=c(.05,.5,.95), - seuilSegment=30, - segmentSousSeuil=TRUE, - forcageMajusculeFiltre=TRUE, - forcageMajusculeSousGroupe=TRUE){ - - dCouleur <- read.data(file=nom_fichierCouleur) - d <- read.data(file=nom_fichier,decimalSigne=dec) - if(colourProtocole & !is.null(nomProtocole)) colourProtocole_p <- as.character(dCouleur[dCouleur[,2]==nomProtocole,3]) else colourProtocole_p <- NULL - - for(f in 1:length(vec_col_filtre)) { - if(length(vec_figure_titre)==1){ - figure_titre_f <- vec_figure_titre - }else{ - figure_titre_f <- vec_figure_titre[f] - } - col_filtre_f <- vec_col_filtre[f] - cat(col_sousGroup) #Just to check - if(func=="ggfiltre1niveau"){ - cat("ggfiltre1niveau") - ggfiltre1niveau(d, - col_abscisse, - figure_abscisse, - col_ordonnee, - figure_ordonnee, - figure_titre = figure_titre_f, - col_filtre = col_filtre_f, - nomGenerique, - val_filtre = NULL, - figure_nom_filtre = NULL, - tab_figure_couleur= subset(dCouleur,Filtre==col_filtre_f), - colourProtocole = colourProtocole_p, - nomProtocole, - bagplot, - bagProp=c(.05,.5,.95), - seuilSegment, - segmentSousSeuil, - forcageMajusculeFiltre) - }else if(func=="gglocal"){ - cat("gglocal") - gglocal(d, - col_abscisse, - figure_abscisse, - col_ordonnee, - figure_ordonnee, - figure_titre = figure_titre_f, - col_filtre = col_filtre_f, - nomGenerique = nomGenerique, - col_sousGroup = col_sousGroup, - val_filtre = NULL, - figure_nom_filtre = NULL, - tab_figure_couleur= subset(dCouleur,Filtre==col_filtre_f), - colourProtocole = colourProtocole_p, - nomProtocole, - couleurLocal="#f609c1", - bagplot, - bagProp, - seuilSegment, - segmentSousSeuil, - forcageMajusculeFiltre, - forcageMajusculeSousGroupe) - }else{ - cat("ggCompareLevel") - ggCompareLevel(d, - col_abscisse, - figure_abscisse, - col_ordonnee, - figure_ordonnee, - figure_titre = figure_titre_f, - col_filtre = col_filtre_f, - nomGenerique = nomGenerique, - val_filtre = NULL, - figure_nom_filtre = NULL, - tab_figure_couleur= subset(dCouleur,Filtre==col_filtre_f), - colourProtocole = colourProtocole_p, - nomProtocole, - bagplot, - bagProp, - seuilSegment, - segmentSousSeuil, - forcageMajusculeFiltre) - } - } -} - -ggfiltre1niveau <- function(d, - col_abscisse = "AB_MOYENNE", - figure_abscisse = "Abondance", - col_ordonnee = "DIVERSITE_MOYENNE", - figure_ordonnee = "Diversite", - figure_titre = "Referentiel papillon", - col_filtre = "nom_reseau", - nomGenerique = "Global", - val_filtre = NULL, - figure_nom_filtre = NULL, - tab_figure_couleur= NULL, - colourProtocole = NULL, - nomProtocole = NULL, - bagplot = TRUE, - bagProp=c(.05,.5,.95), - seuilSegment=30, - segmentSousSeuil=TRUE, - forcageMajusculeFiltre=TRUE, - result_dir="resultats/") { - - d$groupe <- as.character(d[,col_filtre]) - d$abscisse <- d[,col_abscisse] - d$ordonnee <- d[,col_ordonnee] - d$groupe <-gsub("/","_",d$groupe) - d$groupe <-gsub("!","",d$groupe) - - if(forcageMajusculeFiltre){ - d$groupe <- toupper(d$groupe)} - - d <- subset(d,!(is.na(groupe)) & !(is.na(abscisse)) & !(is.na(ordonnee)) & groupe != "") - - if(is.null(val_filtre)){ - lesModalites <- unique(d$groupe) - }else{ - lesModalites <- val_filtre - } - -# repResult <- dir(result_dir) -# current_dir<-getwd() -# dir.create(file.path(current_dir,result_dir)) -# -# if(!(col_filtre %in% repResult)){ -# dir.create(file.path(".",paste(result_dir,col_filtre,sep="")))} -# -# nomRep1 <- paste(result_dir,col_filtre,"/",sep="") - - d.autre <- d - d.autre$groupe <- nomGenerique - - for(m in lesModalites) { - d.reseau <- subset(d,groupe==m) - d.reseau$groupe <- m - ggTable <- rbind(d.autre,d.reseau) - - seuilResum <- nrow(d.reseau) >= seuilSegment - - ggTableResum <- aggregate(cbind(ordonnee, abscisse) ~ groupe, data = ggTable,quantile, c(.25,.5,.75)) - ggTableResum <- data.frame(ggTableResum[,1],ggTableResum[,2][,1:3],ggTableResum[,3][,1:3]) - colnames(ggTableResum) <- c("groupe","ordonnee.inf","ordonnee.med","ordonnee.sup","abscisse.inf","abscisse.med","abscisse.sup") - - if(ggTableResum$groupe[2]==nomGenerique){ - ggTableResum <- ggTableResum[c(2,1),]} - - if(!(is.null(tab_figure_couleur))) { - if(m %in% tab_figure_couleur$Modalite) { - figure_couleur <- setNames(c(as.character(tab_figure_couleur$couleur[tab_figure_couleur$Modalite == nomGenerique]), - as.character(tab_figure_couleur$couleur[tab_figure_couleur$Modalite == m])), - c(nomGenerique,m)) - }else{ - figure_couleur <- setNames(c(as.character(tab_figure_couleur$couleur[tab_figure_couleur$Modalite == nomGenerique]), - as.character(tab_figure_couleur$couleur[tab_figure_couleur$Modalite == ""])), - c(nomGenerique,m)) - } - } - -# repResult <- dir(nomRep1) -# if(!(m %in% repResult)){ -# dir.create(paste(nomRep1,m,sep=""))} -# nomRep <- paste(nomRep1,m,"/",sep="") -# -# -# if(!is.null(nomProtocole)){ -# repResult <- dir(nomRep) -# if(!(nomProtocole %in% repResult)){ -# dir.create(paste(nomRep,nomProtocole,sep=""))} -# nomRep <- paste(nomRep,nomProtocole,"/",sep="") -# } - - - gg <- ggplot(ggTable,aes(x=abscisse,y=ordonnee,colour=groupe,fill=groupe)) - if(bagplot){ - 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) } - else { - gg <- gg + geom_point(alpha=.2) - } - 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") - if(segmentSousSeuil) { - gg <- gg + geom_segment(data=ggTableResum,aes(x = abscisse.med, y = ordonnee.inf, xend = abscisse.med, yend = ordonnee.sup),alpha=.8,size=2.5) - gg <- gg + geom_segment(data=ggTableResum,aes(x = abscisse.inf, y = ordonnee.med, xend = abscisse.sup, yend = ordonnee.med),alpha=.8,size=2.5) - if(!(seuilResum)) { - 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") - 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") - } - } else { - 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) - 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) - } - - gg <- gg + geom_point(data=d.reseau,size=2) - gg <- gg + labs(list(title=figure_titre,x=figure_abscisse,y=figure_ordonnee)) - - if(!is.null(colourProtocole)){ - 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)) - }else{ - 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)) - } - - if(!(is.null(tab_figure_couleur))){ - gg <- gg + scale_colour_manual(values = figure_couleur,name = "") + scale_fill_manual(values = figure_couleur,name = "",guide=FALSE)} - - ggfile <- paste(nomRep,nomProtocole,"_",m,".png",sep="") - cat("Check",ggfile,":") - ggsave(ggfile,gg) - cat("\n") - flush.console() - } -} - - -############################################################## -gglocal <- function(d, - col_abscisse = "AB_MOYENNE", - figure_abscisse = "Abondance", - col_ordonnee = "DIVERSITE_MOYENNE", - figure_ordonnee = "Diversite", - figure_titre = "Graphe referentiel", - col_filtre = "NOM_RESEAU", - nomGenerique = "GLOBAL", - col_sousGroup = "PARCELLEID", - val_filtre = NULL, - figure_nom_filtre = NULL, - tab_figure_couleur= NULL, - colourProtocole = NULL, - nomProtocole = NULL, - couleurLocal="#f609c1", - bagplot = TRUE, - bagProp=c(.05,.5,.95), - seuilSegment=30, - segmentSousSeuil=TRUE, - forcageMajusculeFiltre=TRUE, - forcageMajusculeSousGroupe=TRUE) { - - d$groupe <- d[,col_filtre] - d$abscisse <- d[,col_abscisse] - d$ordonnee <- d[,col_ordonnee] - d$sousGroup <- d[,col_sousGroup] - d$groupe <-gsub("/","_",d$groupe) - d$groupe <-gsub("!","",d$groupe) - d$sousGroup <-gsub("/","_",d$sousGroup) - d$sousGroup <-gsub("!","",d$sousGroup) - if(forcageMajusculeFiltre){ - d$groupe <- toupper(d$groupe)} - if(forcageMajusculeSousGroupe){ - d$sousGroup <- toupper(d$sousGroup)} - d <- subset(d,!(is.na(groupe)) & !(is.na(sousGroup)) & !(is.na(abscisse)) & !(is.na(ordonnee)) & groupe != "") - vecSousGroup <- as.character(unique(d$sousGroup)) - if(is.null(val_filtre)){ - lesModalites <- unique(d$groupe)} - else{ lesModalites <- val_filtre} - repResult <- dir("resultats/") -# if(!(col_filtre %in% repResult)){ -# dir.create(paste("resultats/",col_filtre,sep=""))} -# nomRep1 <- paste("resultats/",col_filtre,"/",sep="") - d.autre <- d - d.autre$groupe <- nomGenerique - for(m in lesModalites) { - d.reseau <- subset(d,groupe==m) - d.reseau$groupe <- m - ggTable <- rbind(d.autre,d.reseau) - seuilResum <- nrow(d.reseau) >= seuilSegment - ggTableResum <- aggregate(cbind(ordonnee, abscisse) ~ groupe, data = ggTable,quantile, c(.25,.5,.75)) - ggTableResum <- data.frame(ggTableResum[,1],ggTableResum[,2][,1:3],ggTableResum[,3][,1:3]) - colnames(ggTableResum) <- c("groupe","ordonnee.inf","ordonnee.med","ordonnee.sup","abscisse.inf","abscisse.med","abscisse.sup") - if(ggTableResum$groupe[2]==nomGenerique){ - ggTableResum <- ggTableResum[c(2,1),]} - if(!(is.null(tab_figure_couleur))) { - if(m %in% tab_figure_couleur$Modalite) { - figure_couleur <- setNames(c(as.character(tab_figure_couleur$couleur[tab_figure_couleur$Modalite == nomGenerique]), - as.character(tab_figure_couleur$couleur[tab_figure_couleur$Modalite == m]),couleurLocal), - c(nomGenerique,m,"")) - } else { - figure_couleur <- setNames(c(as.character(tab_figure_couleur$couleur[tab_figure_couleur$Modalite == nomGenerique]), - as.character(tab_figure_couleur$couleur[tab_figure_couleur$Modalite == ""]),couleurLocal), - c(nomGenerique,m,"")) - } - } -# repResult <- dir(nomRep1) -# if(!(m %in% repResult)){ -# dir.create(paste(nomRep1,m,sep=""))} -# nomRep <- paste(nomRep1,m,"/",sep="") -# if(!is.null(nomProtocole)) { -# repResult <- dir(nomRep) -# if(!(nomProtocole %in% repResult)){ -# dir.create(paste(nomRep,nomProtocole,sep=""))} -# nomRep <- paste(nomRep,nomProtocole,"/",sep="") -# } - d.reseau <- subset(d.reseau, !(is.na(sousGroup))) - figure_size<- setNames(c(1,3,2.5), c(nomGenerique,m,"")) - figure_shape<- setNames(c(16,16,20), c(nomGenerique,m,"")) - vecSousGroup <- as.character(unique(d.reseau$sousGroup)) - for(p in vecSousGroup) { - dp <- subset(d.reseau,sousGroup == p) - dp$groupe <- dp$sousGroup - ggTableSous <- rbind(d.reseau,dp) - ggTableSous <- rbind(d.autre,d.reseau,dp) - names(figure_couleur)[3] <- p - names(figure_shape)[3] <- p - names(figure_size)[3] <- p - gg <- ggplot(ggTableSous,aes(x=abscisse,y=ordonnee,colour=groupe,fill=groupe,shape=groupe,size=groupe)) - if(bagplot){ - 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) - }else{ - gg <- gg + geom_point(alpha=.2)} - gg <- gg + geom_hline(data=subset(ggTableResum,groupe == nomGenerique),aes(yintercept = ordonnee.med,colour=groupe),size=.5,linetype="dashed") - gg <- gg + geom_vline(data=subset(ggTableResum,groupe == nomGenerique),aes(xintercept = abscisse.med,colour=groupe),size=.5,linetype="dashed") - if(segmentSousSeuil) { - gg <- gg + geom_segment(data=ggTableResum,aes(x = abscisse.med, y = ordonnee.inf, xend = abscisse.med, yend = ordonnee.sup),alpha=.8,size=2.5) - gg <- gg + geom_segment(data=ggTableResum,aes(x = abscisse.inf, y = ordonnee.med, xend = abscisse.sup, yend = ordonnee.med),alpha=.8,size=2.5) - if(!(seuilResum)) { - 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") - 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") - } - } else { - 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) - 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) - } - gg <- gg + geom_point(data=subset(ggTableSous,groupe != nomGenerique)) - if(!(is.null(tab_figure_couleur))){ - gg <- gg + scale_colour_manual(values = figure_couleur,name = "") + scale_fill_manual(values = figure_couleur,name = "",guide=FALSE)} - gg <- gg + scale_shape_manual(values = figure_shape,name = "",guide=FALSE) + scale_size_manual(values = figure_size,guide=FALSE) - gg <- gg + labs(list(title=figure_titre,x=figure_abscisse,y=figure_ordonnee)) - if(!is.null(colourProtocole)){ - 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)) } - else{ - 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))} - ggfile <- paste(nomRep,nomProtocole,"_",m,"-",p,".png",sep="") - cat("Check",ggfile,":") - ggsave(ggfile,gg) - cat("\n") - flush.console() - } - } -} - - - -##################################################### -ggCompareLevel <- function(d, - col_abscisse = "abond_moyenne", - figure_abscisse = "Abondance", - col_ordonnee = "diversite_moyenne", - figure_ordonnee = "Diversite", - figure_titre = "Rhooo il dechire ce graphe", - col_filtre = "nom_reseau", - nomGenerique = "Global", - val_filtre = NULL, - figure_nom_filtre = NULL, - tab_figure_couleur= NULL, - colourProtocole = NULL, - nomProtocole = NULL, - bagplot = TRUE, - bagProp=c(.05,.5,.95), - seuilSegment=30, - segmentSousSeuil=FALSE, - forcageMajusculeFiltre=TRUE){ - - d$groupe <- d[,col_filtre] - d$abscisse <- d[,col_abscisse] - d$ordonnee <- d[,col_ordonnee] - d$groupe <-gsub("/","_",d$groupe) - d$groupe <-gsub("!","",d$groupe) - - if(forcageMajusculeFiltre){ - d$groupe <- toupper(d$groupe)} - d <- subset(d,!(is.na(groupe)) & !(is.na(abscisse)) & !(is.na(ordonnee)) & groupe != "") - if(is.null(val_filtre)){ - lesModalites <- unique(d$groupe) - }else{ - lesModalites <- val_filtre - } -# repResult <- dir("resultats/") -# if(!(col_filtre %in% repResult)){ -# dir.create(paste("resultats/",col_filtre,sep="")) -# } -# if(!is.null(nomProtocole)){ -# repResult <- dir(paste("resultats/",col_filtre,sep="")) -# if(!(nomProtocole %in% repResult)){ -# dir.create(paste("resultats/",col_filtre,"/",nomProtocole,sep=""))} -# nomRep <- paste("resultats/",col_filtre,"/",nomProtocole,"/",sep="") -# }else{ -# nomRep <- paste("resultats/",col_filtre,"/",sep="") -# } - d.autre <- d - d.autre$groupe <- nomGenerique - d.reseau <- subset(d,groupe %in% lesModalites) - ggTable <- rbind(d.autre,d.reseau) - ggTableResum <- aggregate(cbind(ordonnee, abscisse) ~ groupe, data = ggTable,quantile, c(.25,.5,.75)) - ggTableResum <- data.frame(ggTableResum[,1],ggTableResum[,2][,1:3],ggTableResum[,3][,1:3]) - colnames(ggTableResum) <- c("groupe","ordonnee.inf","ordonnee.med","ordonnee.sup","abscisse.inf","abscisse.med","abscisse.sup") - ggSeuil <- aggregate(ordonnee ~ groupe, data=ggTable,length) - ggSeuil$seuilResum <- ggSeuil$ordonnee >= seuilSegment - colnames(ggSeuil)[ncol(ggSeuil)] <- "seuil" - ggTableResum <- merge(ggTableResum,ggSeuil,by="groupe") - t_figure_couleur <- subset(tab_figure_couleur,Modalite %in% c(nomGenerique,lesModalites)) - modaliteSansCouleur <- lesModalites[(!(lesModalites %in% t_figure_couleur$Modalite))] - nbNxCol <- length(modaliteSansCouleur) - mypalette<-brewer.pal(nbNxCol,"YlGnBu") - figure_couleur <- setNames(c(as.character(t_figure_couleur$couleur),mypalette),c(as.character(t_figure_couleur$Modalite),modaliteSansCouleur)) - tab_coul <- data.frame(groupe=names(figure_couleur),couleur=figure_couleur) - tab_coul <- merge(tab_coul,ggTableResum,"groupe") - tab_coul$nom <- paste(tab_coul$groupe," (",tab_coul$ordonnee,")",sep="") - figure_couleur <- setNames(as.character(tab_coul$couleur),tab_coul$groupe) - figure_couleur_nom<- tab_coul$nom - gg <- ggplot(ggTable,aes(x=abscisse,y=ordonnee,colour=groupe,fill=groupe)) - if(bagplot){ - 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) - }else{ - gg <- gg + geom_point(alpha=.2) - } - 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") - gg <- gg + geom_segment(data=ggTableResum,aes(x = abscisse.med, y = ordonnee.inf, xend = abscisse.med, yend = ordonnee.sup),alpha=.7,size = 2.5) - gg <- gg + geom_segment(data=ggTableResum,aes(x = abscisse.inf, y = ordonnee.med, xend = abscisse.sup, yend = ordonnee.med),alpha=.7,size = 2.5) - if(any(ggTableResum$seuil)){ - 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") - 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") - } - - #browser() # gg <- gg + geom_point(data=d.reseau,size=2) - gg <- gg + scale_colour_manual(values = figure_couleur,name = "",labels = figure_couleur_nom) + scale_fill_manual(values = figure_couleur,name = "",guide=FALSE) - gg <- gg + labs(list(title=figure_titre,x=figure_abscisse,y=figure_ordonnee)) - if(!is.null(colourProtocole)){ - 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)) - }else{ - 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)) - } - ggfile <- paste(nomRep,nomProtocole,"_",col_filtre,"_","comparaison.png",sep="") - cat("Check",ggfile,":") - ggsave(ggfile,gg) - cat("\n") -flush.console() -} - - -######################################### - -#Lancement des fonctions : - - #Variables a definir : - -#filename="BDD_PAPILLONS_2016.txt" -#color_filename<-"code_couleurs.csv" - - #func -#func="ggCompareLevel" -#func="ggfiltre1niveau" -#func="gglocal" - - #colSousGroupe -#col_sousGroup_usr = NULL #ggfiltre #ggCompareLevel -#col_sousGroup_usr = "PARCELLENOM" #gglocal - - #vec_col_filtre_usr -#vec_col_filtre_usr = c("CONDUITEPARCELLE") #ggCompareLevel -#vec_col_filtre_usr = c("REGION") #ggfiltre -#vec_col_filtre_usr = c("NOM_RESEAU") #gglocal - - - -#Exe fonction : - -#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 -#filtre1niveau(func=func,nom_fichier=filename,nom_fichierCouleur=color_filename,col_sousGroup = col_sousGroup_usr,vec_col_filtre=vec_col_filtre_usr) ## ==local - -######################################################## - -filename=args[2] -color_filename=args[3] -func=args[4] - -if(func=="ggCompareLevel"){ -col_sousGroup_usr=NULL -vec_col_filtre_usr=c("CONDUITEPARCELLE") -}else if(func=="ggfiltre1niveau"){ -col_sousGroup_usr=NULL -vec_col_filtre_usr=c("REGION") -}else if(func=="gglocal"){ -col_sousGroup_usr="PARCELLENOM" -vec_col_filtre_usr=c("NOM_RESEAU") -}else{ -#sortie erreur -write("Error, unknown function. Exit(1).", stderr()) -q('no') -} - -#create result dir -nomRep="resultats/" -dir.create(file.path(".", nomRep), showWarnings = FALSE) - - -filtre1niveau(func=func,nom_fichier=filename,nom_fichierCouleur=color_filename,col_sousGroup=col_sousGroup_usr,vec_col_filtre=vec_col_filtre_usr) diff -r af2cdd97a434 -r c5a10acd34e3 butterfly_crossplot.xml --- a/butterfly_crossplot.xml Mon Aug 13 04:21:56 2018 -0400 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,34 +0,0 @@ - - - r-ggplot2 - r-rcolorbrewer - - - - - - - - - - - - - function=='ggCompareLevel' - - - - function=='ggfiltre1niveau' - - - - function=='gglocal' - - - - diff -r af2cdd97a434 -r c5a10acd34e3 clim_data.R --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/clim_data.R Mon Aug 13 04:47:57 2018 -0400 @@ -0,0 +1,136 @@ +#!/usr/bin/env Rscript + + +args <- commandArgs(trailingOnly = TRUE) + +#Rscript clim_data.R 'worldclim' 'var' 'resolution' 'OutputFormat' #'FRA' #'prec1' +if (length(args)==0 | args[1]=="-h" | args[1]=="--help"){ + print ("general script execution : Rscript clim_data.R \'worldclim\' \'var\' resolution \'OutputFormat\' #\'variable-to-plot\' #\'region_code\'") + print ("eg : Rscript clim_data.R \'worldclim\' \'prec\' 10 \'raster\' #\'prec1' #\'FRA\'") + q('no') +} + + +#Climatic variables dictionaries +months<-c("January","February","March","April","May","June","July","August","September","October","November","December") +bioclimatic_vars<-c("Annual Mean Temperature", "Mean Diurnal Range (Mean of monthly (max temp - min temp))", "Isothermality (BIO2/BIO7) (x 100)","Temperature Seasonality (standard deviation x100)","Max Temperature of Warmest Month","Min Temperature of Coldest Month","Temperature Annual Range (BIO5-BIO6)","Mean Temperature of Wettest Quarter","Mean Temperature of Driest Quarter","Mean Temperature of Warmest Quarter","Mean Temperature of Coldest Quarter","Annual Precipitation","Precipitation of Wettest Month","Precipitation of Driest Month","Precipitation Seasonality (Coefficient of Variation)","Precipitation of Wettest Quarter","Precipitation of Driest Quarter","Precipitation of Warmest Quarter","Precipitation of Coldest Quarter") + +#Function to create custom plot title +get_plot_title<-function(usr_var,usr_var_to_plot){ + match<-str_extract(usr_var_to_plot,"[0-9]+") + if(usr_var %in% c("prec","tmin","tmax")){ + printable_var<-(months[as.integer(match)]) + if(usr_var=="prec"){ + printable_var<-paste(printable_var," precipitations (mm)",sep="") + }else if(usr_var=="tmin"){ + printable_var<-paste(printable_var," minimum temperature (°C *10)",sep="") + }else{ + printable_var<-paste(printable_var," maximum temperature (°C *10)",sep="") + } + }else if(usr_var=="bio"){ + printable_var<-(bioclimatic_vars[as.integer(match)]) + printable_var<-paste("Bioclimatic variable - ",printable_var,sep="") + } + title<-paste("Worldclim data - ",printable_var,".",sep="") + return(title) +} + + +#Call libraries +library('raster',quietly=TRUE) +library(sp,quietly = TRUE, warn.conflicts = FALSE) +library(ncdf4,quietly = TRUE, warn.conflicts = FALSE) +#library(rgdal,quietly = TRUE, warn.conflicts = FALSE) #To save as geotif +library(stringr) + + +#Get args +usr_data=args[1] +usr_var=args[2] +usr_res=as.numeric(args[3]) +usr_of=args[4] + + +# Retrieve 'var' data from WorldClim +global.var <- getData(usr_data, download = TRUE, var = usr_var, res = usr_res) + +# Check if we actualy get some +if (length(global.var)==0){ + cat("No data found.") +}else{ + writeRaster(global.var, "output_writeRaster", format=usr_of,overwrite=TRUE) + final_msg<-paste("WorldClim data for ", usr_var, " at resolution ", usr_res, " in ", usr_of, " format\n", sep="") + cat(final_msg) +} + + + + + + +################# +##Visualisation## +################# + +#Get args +if(length(args[5])>=0 && length(args[6])>=0){ + usr_var_to_plot=args[5] + usr_plot_region=args[6] +}else{q('no')} + +list_region_mask<-c("FRA","DEU","GBR","ESP","ITA") + +if(usr_plot_region %in% list_region_mask){ +#Country mask + region <- getData("GADM",country=usr_plot_region,level=0) + region_mask <- mask(global.var, region) + region_var_to_plot_expression<-paste("region_mask$",usr_var_to_plot,sep="") +}else{ #All map and resize manualy + region_var_to_plot_expression<-paste("global.var$",usr_var_to_plot,sep="") +} + + +region_var_to_plot<-eval(parse(text=region_var_to_plot_expression)) + +#PLotmap +jpeg(file="worldclim_plot_usr_region.jpeg",bg="white") + +title<-get_plot_title(usr_var,usr_var_to_plot) + + +if(usr_plot_region=="FRA"){ + #FRA + plot(region_var_to_plot, xlim = c(-7, 12), ylim = c(40, 52), axes=TRUE,xlab="Longitude",ylab="Latitude",main=title) +}else if(usr_plot_region=="GBR"){ + #GBR + plot(region_var_to_plot, xlim = c(-10, 5), ylim = c(46, 63), axes=TRUE,xlab="Longitude",ylab="Latitude",main=title) +}else if(usr_plot_region=="NA"){ + #North America : + plot(region_ar_to_plot,xlim=c(-180,-50),ylim=c(10,75),xlab="Longitude",ylab="Latitude",main=title) +}else if(usr_plot_region=="EU"){ + #Europe + plot(region_var_to_plot,xlim=c(-28,48),ylim=c(34,72),xlab="Longitude",ylab="Latitude",main=title) +}else if(usr_plot_region=="DEU"){ + #DEU + plot(region_var_to_plot, xlim = c(5, 15), ylim = c(45, 57),axes=TRUE,xlab="Longitude",ylab="Latitude",main=title) +}else if(usr_plot_region=="ESP"){ + #ESP + plot(region_var_to_plot, xlim = c(-10, 6), ylim = c(35, 45), axes=TRUE,xlab="Longitude",ylab="Latitude", main=title) +}else if(usr_plot_region=="ITA"){ + #ITA + plot(region_var_to_plot, xlim = c(4, 20), ylim = c(35, 48), axes=TRUE,xlab="Longitude",ylab="Latitude", main=title) +}else if(usr_plot_region=="WM"){ + #Worldmap + plot(region_var_to_plot,xlab="Longitude",ylab="Latitude",main=title) +}else if(usr_plot_region=="AUS"){ + #AUS + plot(region_var_to_plot,xlim=c(110,155),ylim=c(-45,-10),xlab="Longitude",ylab="Latitude",axes=TRUE,main=title) +}else{ + write("Error with country code.", stderr()) + q('no') +} + +garbage_output<-dev.off + +#Exit +q('no') diff -r af2cdd97a434 -r c5a10acd34e3 raster_getdata.xml --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/raster_getdata.xml Mon Aug 13 04:47:57 2018 -0400 @@ -0,0 +1,208 @@ + + + + + + r-getopt + r-ncdf4 + r-raster + r-stringr + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + usr_of=='CDF' + + + usr_of=='raster' + + + usr_of=='raster' + + + plot=='yes_plot' + + + +