Mercurial > repos > ecology > stoc_maketable
diff FunctTrendSTOCGalaxy.r @ 0:22a784d2b0e0 draft
"planemo upload for repository https://github.com/Alanamosse/Galaxy-E/tree/stoctool/tools/stoc commit f82f897ab22464de40c878e17616333855814e25"
| author | ecology |
|---|---|
| date | Thu, 02 Apr 2020 03:33:29 -0400 |
| parents | |
| children | af4987066235 |
line wrap: on
line diff
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/FunctTrendSTOCGalaxy.r Thu Apr 02 03:33:29 2020 -0400 @@ -0,0 +1,776 @@ +#!/usr/bin/env Rscript + + +################################################################################################################################## +############## FUNCTION TO CALCULATE AND PLOT EVOLUTION OF SPECIES POPULATION function:main.glm ############################## +################################################################################################################################## + +#### Based on Romain Lorrillière R script +#### Modified by Alan Amosse and Benjamin Yguel for integrating within Galaxy-E + +##### workes with the R version 3.5.1 (2018-07-02) +##### Package used with the version: +#suppressMessages(library(lme4)) version 1.1.18.1 +#suppressMessages(library(ggplot2)) version 3.0.0 +#suppressMessages(library(speedglm)) version 0.3.2 +#suppressMessages(library(arm)) version 1.10.1 +#suppressMessages(library(reshape)) version 0.8.8 +#suppressMessages(library(data.table)) version 1.12.0 +#suppressMessages(library(reshape2)) version 1.4.3 + + + +######################################### debut de la fonction makeTableAnalyse / stard of the function makeTableAnalyse +## mise en colonne des especes et rajout de zero mais sur la base des carrés selectionné sans l'import / Species are placed in separated columns and addition of zero on plots where at least one selected species is present + +makeTableAnalyse <- function(data) { + tab <- reshape(data + ,v.names="abond" + ,idvar=c("carre","annee") + ,timevar="espece" + ,direction="wide") + tab[is.na(tab)] <- 0 ###### remplace les na par des 0 / replace NAs by 0 + + colnames(tab) <- sub("abond.","",colnames(tab))### remplace le premier pattern "abond." par le second "" / replace the column names "abond." by "" + return(tab) +} + +######################################### fin de la fonction makeTableAnalyse / end of the function makeTableAnalyse + + + + + +############################################# les fonctions qui filtrent les données pas suffisantes pour analyses fiables / The filtering functions removing species with not enough data to perform accurate analyses + +filter_absent_species<-function(tab){ +##################### Filtre les espèces jamais présentes (abondance=0) / Filter of species with 0 abundance +################################################################################# PARTIE POTENTIELLEMENT ISOLABLE ET INSERABLE AVANT LA BOUCLE = permet de gagner du temps sur la boucle car supprime sps pas vu, donc pas repris par la boucle + + ## Fait la somme des abondances totales par espèce / calculate the sum of all abundance per species + if(ncol(tab)==3) { + tabSum <- sum(tab[,3])## cas d'une seule especes (problème de format et manip un peu differente) / when selecting only one species, use a different method + names(tabSum) <- colnames(tab)[3] + } else { ## cas de plusieurs espèce/ when selecting more than one species + tabSum <- colSums(tab[,-(1:2)]) + } + ## colNull= espece(s) toujours absente /species with 0 total abundance + colNull <- names(which(tabSum==0)) + ## colconserve= espece(s) au moins presente 1 fois/ species at least with 1 presence + colConserve <- names(which(tabSum>0)) + ## Affichage des espèces rejetees / show species eliminated for the analyses + if(length(colNull)>0){ + cat("\n",length(colNull)," Species removed from the analysis, abundance is always 0.\n\n",sep="") #Espèces enlevées de l'analyse car abondance toujours égale a 0\n\n",sep="") + #tabNull <- data.frame(Code_espece = colNull, nom_espece = tabsp[colNull,"nom"]) + #cat("\n\n",sep="") + tab <- tab[,c("carre","annee",colConserve)] + } +################################################################################ FIN DE LA PARTIE ISOLABLE + return(tab) +} + + + + +###################### Filtre les especes trop rare pour avoir des analyses robustes i.e. espèce non presente la 1ère année, avec plus de 3 ans consecutif sans données et moins de 3 ans consécutif avec données +###################### Filter too rare species for accurate analysis i.e. species absent the first year, with more than 3 consecutive years with 0 abundance, or with less than 3 consecutive years with presence + +### +filter_rare_species<-function(tab){ + exclude_threshold <- NULL + ## calcul et filtre pour chaque (colonne) espece / measure and filter for each species + for(i in 3:ncol(tab)) { + ## v =abondance par annee / v= abundance per year + v <- tapply(tab[,i],tab$annee,sum) #################### + ## v0 =presence(1) abscence(0) per year + v0 <- ifelse(v>0,1,0) ##### + tx <- paste(v0,collapse="") #### colle les 0 et 1 / stick the 0 and 1 + + p <- unlist(strsplit(tx,"0"))#### Enleve les 0, ce qui séparent les sequences de "1", les sequences de "1" = nbre d'années consécutives avec data / remove 0, splitting sequences of "1" which correspond to consecutve year with data (e.g. 111 = 3 years consecutive years with data) + p <- p[p!=""] #### ne garde pas les partie sans 1 ou 0 dans les sequences + ## gsSup0 = plus grande serie temporelle de presence =calcul du nbre de 1 consécutif max / calcul of the biggest temporal series which corresponds to the maximum number of consecutive "1" + gsSup0 <- max(nchar(p))#### + ## gsInf0 plus grande serie temporelle d'absccence ou sans données = enlève les 1 séparant sequence de 0 qui correspondent au nbre d'année consecutive sans données / calcul of the biggest temporal series without data which corresponds to max numbzer fo consecutive "0" + gsInf0 <- max(nchar(unlist(strsplit(tx,"1")))) #### + ## y0is0 absence la premiere annee + y0is0 <- v0[1]==0 #### True ou false pour presence de "0"(=pas de données) dans la 1ère année / look if the first year of the time sequence analyzed has no data + ## seuil d'exclusion / exclusion threshold + exclude_threshold <- c(exclude_threshold,as.vector(ifelse( y0is0 | gsInf0 > 3 | gsSup0 < 3 ,"exclu","bon"))) ############## exclu sps absente la 1ère année, avec plus de 3 ans consécutifs sans données, et avec moins de 3 années consécutives sans données / indicate if the max consecutive year with data and without data, as well as whether the first year of the time sequence analyzed has data + } + names(exclude_threshold) <- colnames(tab)[3:ncol(tab)] + + ## colonnes conservees avec assez de données / Column with enough data + colConserve <- names(exclude_threshold)[exclude_threshold=="bon"] + + + ## colonnes supprimees / Column that will conserved + colSupr <- names(exclude_threshold)[exclude_threshold=="exclu"] + tabCLEAN <- tab[,c("carre","annee",colConserve)] #### Garde les sps à conserver / select only species with enough data + lfiltre <- list(tabCLEAN=tabCLEAN,colConserve=colConserve,colSupr=colSupr) + +################################################################################# + + ## colConserve espece conservees / extract species that will be kept to print them + colConserve <- lfiltre$colConserve + ## colsupr espece trop rare et donc supprimée de l'analyse / extract species that will be deleted to print them + colSupr <- lfiltre$colSupr + ## affichage des especes retirer de l'analyse / print species that will be deleted + if(length(colSupr)>0){ + cat("\n",length(colSupr)," Rare species removed from the analysis.\n\n",sep="") + #tabSupr <- subset(tabsp,espece %in% colSupr ,select=c("espece","nom")) + #tabSupr <- tabSupr[order(tabSupr$espece),] + #cat("\n\n",sep="") + + } + if(length(colConserve)==0) { + mess <- "No species available to calculate abundance variation in this dataset." + stop(mess) + } + + tabCLEAN <- lfiltre$tabCLEAN + + #### MARCHE PAS NE SAIT PAS PQUOI + tabCLEAN <- melt(tabCLEAN, id.vars=c("carre", "annee")) #### remet le format de base :le nom d'espèce et abondance dans des colonnes séparées / back to the first format of the file: species name and abundance in separated column + + colnames(tabCLEAN)[3:4] <- c("espece","abond") + tabCLEAN$annee <- as.numeric(as.character(tabCLEAN$annee)) +################################################################################ + return(tabCLEAN) +} + +####################################################################################################################### fin des 2 fonctions de filtre des données / end of the two function to filter the data + + + + + + + + + + + + + + + + + + + + + + + + + + +############################################################################################ debut de la Function main.glm / start of the function main.glm + +main.glm <- function(id="france",donneesAll=dataCLEAN,assessIC= TRUE,tabsp=tabsp,annees=annees,figure=TRUE,description=TRUE,tendanceSurFigure=TRUE, ###### declaration des arguments listSp=sp était avant declaré avant la fonction mais il me semble que ca marche aussi comme cela + seuilOccu=14,seuilAbond=NA) { + + + + filesaveAn <- paste("Output/",id,"/variationsAnnuellesEspece_",id,".tabular", ##### Nom du dossier ET fichier de sortie des resultats par année / name of the output file with results for each years + sep = "") + filesaveTrend <- paste("Output/",id,"/tendanceGlobalEspece_",id,".tabular", ##### Nom du dossier ET fichier de sortie des resultats pour la période "annee" complete / name of the output file with the results for the period + sep = "") + fileSaveGLMs <- paste("Output/",id,"/listGLM_",id,sep = "") ##### Nom du dossier ET fichier de sortie des modèles lineaire generalisés / name of the output file of the generlized linear models + + + + + seuilSignif <- 0.05 ## seuil de significativite / significancy threshold + + + rownames(tabsp) <- tabsp$espece ## change nom des lignes de tabsp (table de reference des especes) + + + ##vpan vecteur des panels de la figure ###### POUR FAIRE LES GRAPHIQUES + vpan <- c("Variation abondance") + if(description) vpan <- c(vpan,"Occurrences","Abondances brutes") + + + ## specifications des variables temporelles necesaires pour les analyses / specification of temporal variable necessary for the analyses + annee <- sort(unique(donneesAll$annee)) + nbans <- length(annee) + pasdetemps <- nbans-1 + firstY <- min(annee) + lastY <- max(annee) + + + + + + ## Ordre de traitement des especes ### order of species to be analyzed + spOrdre <- aggregate(abond~espece,data=donneesAll,sum) #### calcul les sommes des abondances pour ordonner / calculate the sum for the ordination + spOrdre <- merge(spOrdre,tabsp,by="espece") #### rajoute la colonne avec les abondances totales par espece / add a new column with the sum + + spOrdre <- spOrdre[order(as.numeric(spOrdre$indicateur),spOrdre$abond,decreasing = TRUE),] #### mets les especes plus abondantes en premiers (plus long pour faire tourner le modèle) / order the species by abundance, the most abundant species being the less fast analysis + + + listSp <- spOrdre$espece + i <- 0 + nbSp <- length(listSp) + # browser() + ## analyse par espece +### browser() + ## affichage des especes conservees pour l'analyse ### PAS SUR QUE CE SOIT ENCORE UTILE + cat("\n",nbSp," Espèces conservées pour l'analyse\n\n",sep="") + rownames(tabsp) <- tabsp$espece + print(tabsp[,1:2]) + #tabCons <- data.frame(Code_espece = listSp, nom_espece = tabsp[as.character(listSp),"nom"]) + #print(tabCons) + cat("\n\n",sep="") + flush.console() + + + ## initialisation de la liste de sauvegarde + + +##browser() + + for (sp in listSp) { ######## Boucle pour analyse par espèce / loop for the analysis by species + + + i <- i + 1 + + d <- subset(donneesAll,espece==sp) ## d data pour l'espece en court / cut the data keeping only the i species + + #nomSp <- as.character(tabsp[sp,"nom"]) ## info sp + nomSp <- tabsp$nom[which(tabsp$espece==sp)] ## info sp + cat("\n(",i,"/",nbSp,") ",sp," | ", nomSp,"\n",sep="") + flush.console() + + #indic <- tabsp[sp,"indicateur"] ## indic :espece utilisee pour le calcul des indicateurs par groupe de specialisation / list the species used as species indicators by trophic specialization + indic <- tabsp$indicateur[which(tabsp$espece==sp)] ## indic :espece utilisee pour le calcul des indicateurs par groupe de specialisation / list the species used as species indicators by trophic specialization + nb_carre = tapply(rep(1,nrow(d)),d$annee,sum) ## nb_carre nombre de carre suivie par annee / number of plots per year + + nb_carre_presence = tapply(ifelse(d$abond>0,1,0),d$annee,sum) ## nb_carre_presence nombre de carre de presence par annee / number the plots where the species were observed + + tab2 <- data.frame(annee=rep(annee,2),val=c(nb_carre,nb_carre_presence),LL = NA,UL=NA, ## tab2 table de resultat d'analyse / data.frame of the analyses results + catPoint=NA,pval=NA, + courbe=rep(c("carre","presence"),each=length(annee)),panel=vpan[2]) + tab2$catPoint <- ifelse(tab2$val == 0,"0",ifelse(tab2$val < seuilOccu,"infSeuil",NA)) + + abond <- tapply(d$abond,d$annee,sum) ## abond abondance par annee / abundance per year + + tab3 <- data.frame(annee=annee,val=abond,LL = NA,UL=NA,catPoint=NA,pval=NA,courbe=vpan[3],panel=vpan[3]) ## table pour la figure / data.frame made to realize the graphical outputs + tab3$catPoint <- ifelse(tab3$val == 0,"0",ifelse(tab3$val < seuilAbond,"infSeuil",NA)) + + ## GLM pour calcul des tendances annuelles de l'evolution des populations / GLM to measure annual tendency of population evolution + formule <- as.formula("abond~as.factor(carre)+as.factor(annee)") #### specification du modèle = log lineaire / specifying the model = log linear + if(assessIC) {##### OPTION A RENTRER AU DEBUT PEUT ËTRE A METTRE DANS LES ARGUMENTS SI LAISSE LE CHOIX SINON L ARG PAR DEFAUT LORS DE LA DECLARATION DE LA FONCTION + glm1 <- glm(formule,data=d,family=quasipoisson) ##### fit model lineaire general avec intervalle de confiance disponible / fit linear and generalized model with confidence intervalle available + } else { + glm1 <- try(speedglm(formule,data=d,family=quasipoisson())) ##### fit modele lineaire et generaux pour les gros jeux de données / fit of linear and generalized model for large-medium dataset + if(class(glm1)[1]=="try-error") + glm1 <- glm(formule,data=d,family=quasipoisson) ##### comprends pas mais je pense que c'est speedglm qui marche pas avec toutes les données + } + sglm1 <- summary(glm1) #### sortie du modele / output of the model + sglm1 <- coefficients(sglm1) ### coefficient regression de chaque variable avec les résultats des tests statistiques / regression coefficient of each predictive variables with results of the statistical tests + sglm1 <- tail(sglm1,pasdetemps) #### recupére les derniers elements du modèle avec la taille de l'objet "pasdetemps" car le nombre de coef = nbre d'année et pas les coefficient de regression de la variable carre / retrieve only the coefficient regression of the variable year + coefan <- as.numeric(as.character(sglm1[,1]))#### coefficient de regression de la variable année (1 pour chaque année) + + coefannee <- c(1,exp(coefan))## coefannee vecteur des variation d'abondance par annee avec transformation inverse du log :exp() / regression coefficient of the year back transformed from log(abundance) : exp() + + erreuran <- as.numeric(as.character(sglm1[,2])) #### erreur standard sur le coefficient de regression de la variable annee / standard error on the regression coefficient of the year + erreurannee1 <- c(0,erreuran*exp(coefan))## erreur standard par année / the standard error per year ###### LA J AI UN DOUTE NORMALEMENT INTERVAL DE CONF C CI_lower <- coefficients(lin_mod)[2] - 1.96*summary(lin_mod)$coefficients[2,2] + ####CI_upper <- coefficients(lin_mod)[2] + 1.96*summary(lin_mod)$coefficients[2,2] + + pval <- c(1,as.numeric(as.character(sglm1[,4])))###### p value + + ## calcul des intervalle de confiance avec methode de bootstrap pour simuler des coef de regress sur lequel intervalle de conf sont mesurés/ calcul of the confidence interval using bootstrap method to simulate set regression coefficients and s.e.with uncertainty POURQUOI PAS UTILISE confint.glm() ou boot() ou ci.boot() + + if(assessIC) { + glm1.sim <- sim(glm1) + ic_inf_sim <- c(1,exp(tail(apply(coef(glm1.sim), 2, quantile,.025),pasdetemps))) + ic_sup_sim <- c(1,exp(tail(apply(coef(glm1.sim), 2, quantile,.975),pasdetemps))) + } else { + ic_inf_sim <- NA + ic_sup_sim <- NA + + } + + + + tab1 <- data.frame(annee,val=coefannee, ## tab1 table pour la realisation des figures / table for the graphical outputs ### 2EME POUR GRAPH ici ce sont le coef de regress annee en fonction des annéés alors que tab3 c'est les abondance en fct des années et tab2 nombre de carré total et avec presence + LL=ic_inf_sim,UL=ic_sup_sim, + catPoint=ifelse(pval<seuilSignif,"significatif",NA),pval, + courbe=vpan[1], + panel=vpan[1]) + ## netoyage des intervalle de confiance mal estimés et qd donnees pas suffisantes pour calcul d'IC /cleaning of wrong or biaised measures of the confidence interval + if(assessIC) { + tab1$UL <- ifelse( nb_carre_presence==0,NA,tab1$UL) + tab1$UL <- ifelse(tab1$UL == Inf, NA,tab1$UL) + tab1$UL <- ifelse(tab1$UL > 1.000000e+20, NA,tab1$UL) + tab1$UL[1] <- 1 + tab1$val <- ifelse(tab1$val > 1.000000e+20,1.000000e+20,tab1$val) + } + ## indice de surdispersion / overdispersion index + ## browser() + if(assessIC) dispAn <- glm1$deviance/glm1$null.deviance else dispAn <- glm1$deviance/glm1$nulldev + + + ## tabAn table de sauvegarde des resultats par année / table of the results per year ###### reprends bcp de tabl DIFFERENCE AVEC tab2 c les abondances relatives, alors que nb de carre, nb de carre presnce, p val sont aussi ds tab2 + tabAn <- data.frame(id,code_espece=sp, nom_espece = nomSp,indicateur = indic,annee = tab1$annee, + abondance_relative=round(tab1$val,3), + IC_inferieur = round(tab1$LL,3), IC_superieur = round(tab1$UL,3), + erreur_standard = round(erreurannee1,4), + p_value = round(tab1$pval,3),significatif = !is.na(tab1$catPoint), + nb_carre,nb_carre_presence,abondance=abond) + + ## GLM pour calcul des tendance generale sur la periode avec modele log lineaire / GLM to measure the tendency of population evolution on the studied period with log linear model + formule <- as.formula(paste("abond~ as.factor(carre) + annee",sep="")) ### + # browser() + + + if(assessIC) { + md2 <- glm(formule,data=d,family=quasipoisson) } + else { + md2 <- try(speedglm(formule,data=d,family=quasipoisson()),silent=TRUE) + + if(class(md2)[1]=="try-error") + md2 <- glm(formule,data=d,family=quasipoisson) + } + + + smd2 <- summary(md2) #### sortie du modele / output of the model + smd2 <- coefficients(smd2) ### coefficient regression de chaque variable avec les résultats des tests statistiques / regression coefficient of each predictive variables with results of the statistical tests + smd2 <- tail(smd2,1) ### coefficient regression de variable annee avec les résultats des tests statistiques / regression coefficient of the variable year with results of the statistical tests + + + coefan <- as.numeric(as.character(smd2[,1])) ## tendences sur la periode = coefficient regression de variable annee / tendency of population evolution on the studied period = regression coefficient of the variable year + trend <- round(exp(coefan),3) + + pourcentage <- round((exp(coefan*pasdetemps)-1)*100,2) ## pourcentage de variation sur la periode / percentage of population variation on the studied period + pval <- as.numeric(as.character(smd2[,4])) + + erreuran <- as.numeric(as.character(smd2[,2])) #### récuperer l'erreur standard / retrieve the error + ## erreur standard + erreurannee2 <- erreuran*exp(coefan) + + + ## calcul des intervalle de confiance avec methode de bootstrap pour simuler des coef de regress sur lequel intervalle de conf sont mesurés/ calculating the confidence interval based on bootstrap method to simulate set regression coefficients and s.e.with uncertainty + LL <- NA + UL <- NA + if(assessIC) { + md2.sim <- sim(md2) + LL <- round(exp(tail(apply(coef(md2.sim), 2, quantile,.025),1)),3) + UL <- round(exp(tail(apply(coef(md2.sim), 2, quantile,.975),1)),3) + } else { + LL <- NA + UL <- NA + } + + ## tab1t table utile pour la realisation des figures / table used for the figures + tab1t <- data.frame(Est=trend, + LL , UL, + pourcent=pourcentage,signif=pval<seuilSignif,pval) + + + trendsignif <- tab1t$signif + pourcent <- round((exp(coefan*pasdetemps)-1)*100,3) + ## mesure de la surdispersion / overdispersion measurment + + if(assessIC) dispTrend <- md2$deviance/md2$null.deviance else dispTrend <- md2$deviance/md2$nulldev + + + + ## classement en categorie incertain /classifying wrong or not reliable results + # browser() + if(assessIC) { + if(dispTrend > 2 | dispAn > 2 | median( nb_carre_presence)<seuilOccu) catIncert <- "Incertain" else catIncert <-"bon" ##### en fonction de l'indice de surdispersion et presence < à seuil occurence / based on the overdispersion index and the presence on a minimum number of plots + vecLib <- NULL + if(dispTrend > 2 | dispAn > 2 | median( nb_carre_presence)<seuilOccu) { + if(median( nb_carre_presence)<seuilOccu) { + vecLib <- c(vecLib,"espece trop rare") + } + if(dispTrend > 2 | dispAn > 2) { + vecLib <- c(vecLib,"deviance") + } + } + raisonIncert <- paste(vecLib,collapse=" et ") + } else { + catIncert <- NA + raisonIncert <- NA + } + + + + ## affectation des tendence EBCC / retrieve the trend of population evolution on the studied period + catEBCC <- NA + if(assessIC) catEBCC <- affectCatEBCC(trend = as.vector(trend),pVal = pval,ICinf=as.vector(LL),ICsup=as.vector(UL)) else catEBCC <- NA + ## table complete de resultats pour la periode etudiée / complete table with results for the studied period + # browser() + tabTrend <- data.frame( + id,code_espece=sp,nom_espece = nomSp,indicateur = indic, + nombre_annees = pasdetemps,premiere_annee = firstY,derniere_annee = lastY, + tendance = as.vector(trend) , IC_inferieur=as.vector(LL) , IC_superieur = as.vector(UL),pourcentage_variation=as.vector(pourcent), + erreur_standard = as.vector(round(erreurannee2,4)), p_value = round(pval,3), + significatif = trendsignif,categorie_tendance_EBCC=catEBCC,mediane_occurrence=median( nb_carre_presence) , + valide = catIncert,raison_incertitude = raisonIncert) + + + if(assessIC) listGLMsp <- list(list(glm1,glm1.sim,md2,md2.sim)) else listGLMsp <- list(list(glm1,md2)) + names(listGLMsp)[[1]] <-sp + fileSaveGLMsp <- paste(fileSaveGLMs,"_",sp,".Rdata",sep="") + + save(listGLMsp,file=fileSaveGLMsp) + cat("--->",fileSaveGLMsp,"\n") + flush.console() + + if(sp==listSp[1]) { + glmAn <- tabAn + glmTrend <- tabTrend + } else { + glmAn <- rbind(glmAn,tabAn) + glmTrend <- rbind(glmTrend,tabTrend) + } + ## les figures + if(figure) { + ## table complete pour la figure en panel par ggplot2 + ## table pour graphe en panel par ggplot2 + if(description) dgg <- rbind(tab1,tab2,tab3) else dgg <- tab1 + ## les figures + + ggplot.espece(dgg,tab1t,id,serie=NULL,sp,valide=catIncert,nomSp,description,tendanceSurFigure,seuilOccu=14,vpan = vpan,assessIC=assessIC) + + } + + + + + } + + write.table(glmAn,filesaveAn,row.names=FALSE,quote=FALSE,sep="\t",dec=".",fileEncoding="UTF-8") + cat("--->",filesaveAn,"\n") + write.table(glmTrend,filesaveTrend,row.names=FALSE,quote=FALSE,sep="\t",dec=".",fileEncoding="UTF-8") + cat("--->",filesaveTrend,"\n") + + + flush.console() + + + +} +########################################################################################################## Fin de la fonction main.glm / end of the function main.glm + + + + + + + + + + + + + + + +########################################################################################################### fonction appelée par main.glm renvoyant la categorie European Bird Census Council en fonction des resultats des modèles / function called by main.glm to classify results depending on the quality of the data and analyses +## renvoie la categorie EBCC de la tendance en fonction +## trend l'estimateur de la tendance / estimation of the trends +## pVal la p value +## ICinf ICsup l intervalle de confiance a 95 pourcent +affectCatEBCC <- function(trend,pVal,ICinf,ICsup){ + catEBCC <- ifelse(pVal>0.05, + ifelse(ICinf < 0.95 | ICsup > 1.05,"Incertain","Stable"), + ifelse(trend<1, + ifelse(ICsup<0.95,"Fort declin","Declin moderee"), + ifelse(ICinf>1.05,"Forte augmentation","Augmentation modere"))) + return(catEBCC) +} + +############################################################################################################ fin de la fonction renvoyant la categorie EBCC / end of the function main.glm + + + + + + + + +############################################################################################################ fonction graphique appelée par main.glm / function called by main.glm for graphical output +ggplot.espece <- function(dgg,tab1t,id,serie=NULL,sp,valide,nomSp=NULL,description=TRUE, + tendanceSurFigure=TRUE,seuilOccu=14, vpan,assessIC=TRUE) { + + # serie=NULL;nomSp=NULL;description=TRUE;valide=catIncert + # tendanceSurFigure=TRUE;seuilOccu=14 + require(ggplot2) + + figname<- paste("Output/",id,"/",ifelse(valide=="Incertain","Incertain/",""), + sp,"_",id,serie, ".png", + sep = "") + ## coordonnee des ligne horizontal de seuil pour les abondances et les occurences + hline.data1 <- data.frame(z = c(1), panel = c(vpan[1]),couleur = "variation abondance",type="variation abondance") + hline.data2 <- data.frame(z = c(0,seuilOccu), panel = c(vpan[2],vpan[2]),couleur = "seuil",type="seuil") + hline.data3 <- data.frame(z = 0, panel = vpan[3] ,couleur = "seuil",type="seuil") + hline.data <- rbind(hline.data1,hline.data2,hline.data3) + titre <- paste(nomSp)#,"\n",min(annee)," - ",max(annee),sep="") + + ## texte de la tendance / text for the population evolution trend + tab1 <- subset(dgg,panel =="Variation abondance") + pasdetemps <- max(dgg$annee) - min(dgg$annee) + 1 + if(assessIC){ + txtPente1 <- paste(tab1t$Est, + ifelse(tab1t$signif," *","")," [",tab1t$LL," , ",tab1t$UL,"]", + ifelse(tab1t$signif,paste("\n",ifelse(tab1t$pourcent>0,"+ ","- "), + abs(tab1t$pourcent)," % en ",pasdetemps," ans",sep=""),""),sep="") + }else{ + txtPente1 <- ifelse(tab1t$signif,paste("\n",ifelse(tab1t$pourcent>0,"+ ","- "), + abs(tab1t$pourcent)," % en ",pasdetemps," ans",sep=""),"") + + } + ## table du texte de la tendance / table of the text for the population evolution trend + tabTextPent <- data.frame(y=c(max(c(tab1$val,tab1$UL),na.rm=TRUE)*.9), + x=median(tab1$annee), + txt=ifelse(tendanceSurFigure,c(txtPente1),""), + courbe=c(vpan[1]),panel=c(vpan[1])) + ## les couleurs / the colors + vecColPoint <- c("#ffffff","#eeb40f","#ee0f59") + names(vecColPoint) <- c("significatif","infSeuil","0") + vecColCourbe <- c("#3c47e0","#5b754d","#55bb1d","#973ce0") + names(vecColCourbe) <- c(vpan[1],"carre","presence",vpan[3]) + vecColHline <- c("#ffffff","#e76060") + names(vecColHline) <- c("variation abondance","seuil") + + col <- c(vecColPoint,vecColCourbe,vecColHline) + names(col) <- c(names(vecColPoint),names(vecColCourbe),names(vecColHline)) + + ## si description graphique en 3 panels + if(description) { + p <- ggplot(data = dgg, mapping = aes(x = annee, y = val)) + ## Titre, axes ... + p <- p + facet_grid(panel ~ ., scale = "free") + + theme(legend.position="none", + panel.grid.minor=element_blank(), + panel.grid.major.y=element_blank()) + + ylab("") + xlab("Annee")+ ggtitle(titre) + + scale_colour_manual(values=col, name = "" , + breaks = names(col))+ + scale_x_continuous(breaks=min(dgg$annee):max(dgg$annee)) + p <- p + geom_hline(data =hline.data,mapping = aes(yintercept=z, colour = couleur,linetype=type ), + alpha=1,size=1.2) + if(assessIC){ ############# ONLY FOR THE CONFIDENCE INTERVAL + p <- p + geom_ribbon(mapping=aes(ymin=LL,ymax=UL),fill=col[vpan[1]],alpha=.2) + p <- p + geom_pointrange(mapping= aes(y=val,ymin=LL,ymax=UL),fill=col[vpan[1]],alpha=.2) + } + p <- p + geom_line(mapping=aes(colour=courbe),size = 1.5) + p <- p + geom_point(mapping=aes(colour=courbe),size = 3) + p <- p + geom_point(mapping=aes(colour=catPoint,alpha=ifelse(!is.na(catPoint),1,0)),size = 2) + p <- p + geom_text(data=tabTextPent, mapping=aes(x,y,label=txt),parse=FALSE,color=col[vpan[1]],fontface=2, size=4) + ggsave(figname, p,width=16,height=21, units="cm") + print (figname) ##### CAN BE REMOVED IF YOU DO NOT WANT THE GRAPH TO BE PLOTTED + } else { + + p <- ggplot(data = subset(dgg,panel=="Variation abondance"), mapping = aes(x = annee, y = val)) + ## Titre, axes ... + p <- p + facet_grid(panel ~ ., scale = "free") + + theme(legend.position="none", + panel.grid.minor=element_blank(), + panel.grid.major.y=element_blank()) + + ylab("") + xlab("Annee")+ ggtitle(titre) + + scale_colour_manual(values=col, name = "" , + breaks = names(col))+ + scale_x_continuous(breaks=min(dgg$annee):max(dgg$annee)) + p <- p + geom_hline(data =subset(hline.data,panel=="Variation abondance"),mapping = aes(yintercept=z, colour = couleur,linetype=type ), + alpha=1,size=1.2) + + if(assessIC){ ############# ONLY FOR THE CONFIDENCE INTERVAL + p <- p + geom_ribbon(mapping=aes(ymin=LL,ymax=UL),fill=col[vpan[1]],alpha=.2) + p <- p + geom_pointrange(mapping= aes(y=val,ymin=LL,ymax=UL),fill=col[vpan[1]],alpha=.2) + } + p <- p + geom_line(mapping=aes(colour=courbe),size = 1.5) + p <- p + geom_point(mapping=aes(colour=courbe),size = 3) + p <- p + geom_point(mapping=aes(colour=catPoint,alpha=ifelse(!is.na(catPoint),1,0)),size = 2) + p <- p + geom_text(data=tabTextPent, mapping=aes(x,y,label=txt),parse=FALSE,color=col[vpan[1]],fontface=2, size=4) + ggsave(figname, p,width=15,height=9,units="cm") + print (figname) ##### CAN BE REMOVED IF YOU DO NOT WANT THE GRAPH TO BE PLOTTED + } +} +############################################################################################################ fin fonction graphique / end of function for graphical output + + + + +#################################################################################################################### debut de la fonction de moyenne geometrique pondere / start of the geometric weighted mean function +geometriqueWeighted <- function(x,w=1) exp(sum(w*log(x))/sum(w)) +#################################################################################################################### fin de la fonction de moyenne geometrique pondere / end of the geometric weighted mean function + + + +##################################################################################################################### debut de la fonction analyseGroupe / start of the function analyseGroupe +## Analyse par groupe de specialisation a partir des resulats de variation d'abondance par especes / analysis by specialization group based on results of the analysis of population evolution trend +# + + +analyseGroupe <- function(id="france",tabsp=tabsp,donnees=donnees,donneesTrend=donneesTrend,ICfigureGroupeSp=TRUE,powerWeight=2, + correctionAbondanceNull = 0.000001, + groupeNom = c("generaliste","milieux batis","milieux forestiers","milieux agricoles"), + groupeCouleur = c("black","firebrick3","chartreuse4","orange")) { + + + + + + ## donnees tendances globales / results of the global trends + donneesTrend <- subset(donneesTrend, select = c(code_espece,valide,mediane_occurrence)) + + ## table de reference espece / reference table for species + tabsp <- subset(tabsp, select= c(sp,nom,indicateur, specialisation)) + donnees <- merge(donnees,donneesTrend,by="code_espece") + donnees <- merge(donnees,tabsp,by.x="code_espece",by.y="sp") + ## table de correspondance de biais en fonction des medianes des occuerences + + + nameFileSpe <- paste("Output/",id,"/variationsAnnuellesGroupes_",id, ############# Declare le fichier de sortie des variations annuelles par groupe / declare the name of the outputfile for annual population evolution trend by group + ".tabular",sep="" ) + nameFileSpepng <- paste("Output/",id,"/variationsAnnuellesGroupes_",id, ############# Declare le fichier de sortie graphique des variations annuelles par groupe / declare the name of the graphical output file for annual population evolution trend by group + ".png",sep="" ) + + grpe <- donnees$specialisation + + ####### valeur seuil sont obtenues à partir de simulations / threshold values are obtained from simulations + ff <- function(x,y) max(which(y<=x)) ## fonction pour recherche le poid associé à valeur max parmi valeur seuil d'occurence inferieur ou egale à occurence mediane obs / function to retrieve the weight associated with the max occurence threshold equal or smaller than the occurence mediane observed + + IncertW <- ifelse(donnees$valide=="Incertain",tBiais$biais[sapply(as.vector(donnees$mediane_occurrence),ff,y=tBiais$occurrenceMed)],1) ## pr verifier poids de l'espèce dans analyse, récupére seuil occurence minimum pour lequel tendance pas bonne, et compare avec mediane occurence des données / to check the weight of species in the analysis, this retrieve occurence threshold with wich real occurence measured on data are compared in order to verify the accuracy of the trend measurment + ## poids du a la qualite de l'estimation + # erreur_stW <- 1/((donnees$erreur_st+1)^powerWeight) + # erreur_stW <- ifelse( is.na(donnees$IC_superieur),0,erreur_stW) + erreur_stW <- ifelse(is.na(donnees$IC_superieur),0,1)##### si pas d'interval de confiance met 0 et donne un poid de 0 à l'esps (voir ci dessous) / if no confidence interval calculated give a weight of 0 for the sps + ## calcul du poids total de chaque espèce / calcul of the weight of each species + W <- IncertW * erreur_stW + + ## variable de regroupement pour les calculs par groupe de specialisation et par an / variables gathered to identify group for the calculation (per specialization and per year) + grAn <- paste(donnees$specialisation,donnees$annee,sep="_") + ## data frame pour le calcul / dataframe made for the calcul + dd <- data.frame(grAn,annee = donnees$annee, grpe,W,ab=donnees$abondance_relative,ICinf= donnees$IC_inferieur, ICsup= ifelse(is.na(donnees$IC_superieur),10000,donnees$IC_superieur)) + ## table resumer de tous les poids / table to sum up the weights of each species depending on the incertainty in the calcul of the poulation evolution trends + ddd <- data.frame(code_espece = donnees$code_espece,nom_espece = donnees$nom_espece,annee = donnees$annee, + groupe_indicateur = grpe, + poids_erreur_standard = round(erreur_stW,3), poids_incertitude = round(IncertW,3),poids_final = round(W,3), + abondance_relative=donnees$abondance_relative, + IC_inferieur= donnees$IC_inferieur, + IC_superieur= ifelse(is.na(donnees$IC_superieur),10000,donnees$IC_superieur), + valide = donnees$valide, mediane_occurrence = donnees$mediane_occurrence) + + nomFileResum <- paste("Output/",id,"/donneesGroupes_",id, ###### declaration du nom du repertoire et des fichiers de sortie / declaring the name of the output folder and files + ".tabular",sep="" ) + write.table(ddd,nomFileResum,row.names=FALSE,sep="\t",dec=".",fileEncoding="UTF-8") + cat("-->",nomFileResum,"\n") + + ## calcul des moyennes ponderees par groupe par an et pour les abondance et les IC / calcul of weighted means per specialization group and per year for the abundance and confidence interval + for(j in 5:7) dd[,j] <- ifelse(dd[,j]==0,correctionAbondanceNull,dd[,j]) + ag <- apply(dd[,5:7], 2, ######## sur les abondances relatives, les ICinf et ICsup + function(x) { + sapply(split(data.frame(dd[,1:4], x), dd$grAn), ###### fait les moyennes pondérés par groupe grAn / calculate the weighted mean by group grAn + function(y) round(geometriqueWeighted(y[,5], w = y$W),3)) + }) + ## gg <- subset(dd,as.character(dd$grAn)=="milieux forestier_2014") ############################################################# + + ag <- ifelse(is.na(ag),1,ag) + ag <- as.data.frame(ag) + ag$grAn <- rownames(ag) + dbon <- subset(donnees,valide=="bon") + dIncert <- subset(donnees,valide=="Incertain") + ## calcul nombre d'espece "bonne" pour le calcul / calculating the number of species with low level of incertainty, "good" species + bon <- tapply(dbon$nom,dbon$specialisation,FUN=function(X)length(unique(X)) ) + bon <- ifelse(is.na(bon),0,bon) + tbon <- data.frame(groupe=names(bon),bon) + ## calcul nombre d'especes "incertaines" pour le calcul / calculating the number of species with high level of incertainty, "bad" species + Incert <- tapply(dIncert$nom,dIncert$specialisation,FUN=function(X)length(unique(X)) ) + Incert <- ifelse(is.na(Incert),0,Incert) + tIncert <- data.frame(groupe=names(Incert),Incertain=Incert) + + tIncert <- merge(tIncert,tbon,by="groupe") + + ## table de données avec les moyennes ponderees par groupe / table of the data with the weighted mean by group + da <- merge(unique(dd[,1:3]),ag,by="grAn")[,-1] + colnames(da) <- c("annee","groupe","abondance_relative","IC_inferieur","IC_superieur") + + da$annee <- as.numeric(da$annee) + da <- merge(da,tIncert,by="groupe") #### ajoute le nombre d'espece "incertaines" et "bonne" aux resultats / add the number of "good" and "bad" species to the overall resutls + da <- subset(da, groupe != "non") + colnames(da)[6:7] <- c("nombre_especes_incertaines","nombre_espece_bonnes") + a <- data.frame(id,da) + write.table(da,file=nameFileSpe,row.names=FALSE,quote=FALSE,sep="\t",dec=".",fileEncoding="UTF-8") + + cat("-->",nameFileSpe,"\n") + yearsrange <- c(min(da$annee),max(da$annee)) + + ## figure par ggplot2 / plots with ggplot2 + titre <- paste("Variation de l'indicateur groupe de specialisation",sep="") + + vecCouleur <- setNames(groupeCouleur,groupeNom) + #browser() + p <- ggplot(data = da, mapping = aes(x = annee, y = abondance_relative, colour=groupe,fill=groupe)) + p <- p + geom_hline(aes(yintercept = 1), colour="white", alpha=1,size=1.2) + if(ICfigureGroupeSp) + p <- p + geom_ribbon(mapping=aes(ymin=IC_inferieur,ymax=IC_superieur),linetype=2,alpha=.1,size=0.1) + p <- p + geom_line(size=1.5) + p <- p + ylab("") + xlab("Annee")+ ggtitle(titre) + if(!is.null(groupeNom)) p <- p + scale_colour_manual(values=vecCouleur, name = "" )+ + scale_x_continuous(breaks=unique(da$annee)) + if(!is.null(groupeNom)) p <- p + scale_fill_manual(values=vecCouleur, name="") + p <- p + theme(panel.grid.minor=element_blank(), panel.grid.major.y=element_blank()) + ggsave(nameFileSpepng, p,width=17,height=10,units="cm") + + # cat(" <==",nameFileSpepng,"\n") + + ## calul pour chaque groupe une pente de regression d'evolution des abondances sur la periode étudiée / calculating for each group the regression slope for the abundance evolution on the studied period + vecSpe <- unique(da$groupe) + datasum <- data.frame(groupe=NULL,tendance=NULL,pourcentage_variation=NULL) + for(spe in 1:4){ + # print(spe) + subtab <- subset(da,groupe==vecSpe[spe]) + if(nrow(subtab)>1) { + sumlm <- summary(lm(abondance_relative~annee,data=subtab)) ##### recupère les resultats du modèle linéaire / retrieve the results of the linear model + subdatasum <- data.frame(groupe=vecSpe[spe], + tendance=round(sumlm$coefficients[2,1],3), + pourcentage_variation=round(sumlm$coefficients[2,1]*(nrow(subtab)-1)*100,3)) #### assemble les resultats pour en faire une sortie / bring together the results for an output file + datasum <- rbind(datasum,subdatasum) + + } + + } + datasum <- merge(datasum,tIncert,by="groupe") #### + datasum <- data.frame(id,datasum) + #datasum$cat_tendance_EBCC <- affectCatEBCC(trend,pVal,ICinf,ICsup + namefilesum <- paste("Output/",id,"/tendancesGlobalesGroupes_",id, + ".tabular",sep="" ) + write.table(datasum,file=namefilesum,row.names=FALSE,quote=FALSE,sep="\t",dec=".",fileEncoding="UTF-8") + cat("-->",namefilesum,"\n") +} + +################################################################################################################## fin de la fonction analyseGroupe / end of the function analyseGroupe + + + + + + + +################################################################################################################### debut de la fonction check_file / start of the function check_file +# Fonction pour verifier les données d'entrée / General function to check integrity of input file. Will check numbers and contents of variables(colnames). +#return an error message and exit if mismatch detected +#Faut rentrer le nom du jeu de données, le nbre et le nom des variables / Enter dataset name, expected number and names of variables. + an exit error message to guide user. + +check_file<-function(dataset,err_msg,vars,nb_vars){ + if(ncol(dataset)!=nb_vars){ #Verifiction de la présence du bon nb de colonnes, si c'est pas le cas= message d'erreur / checking for right number of columns in the file if not = error message + cat("\nerr nb var\n") + stop(err_msg, call.=FALSE) + } + + for(i in vars){ + if(!(i %in% names(dataset))){ + stop(err_msg,call.=FALSE) + } + } +} + +##################################################################################################################### +