#!/usr/bin/env Rscript

########################################################################################################################################################################
############## FUNCTION TO CALCULATE AND PLOT VARIATION IN TIME OF INDICATOR OR MEAN TRAIT VALUE OF COMMUNITIES  function:csi_cti_ctri    ##############################
########################################################################################################################################################################

#### Based on Romain Lorrillière R script
#### Modified by Alan Amosse and Benjamin Yguel for integrating within Galaxy-E

### made with R version 3.5.1

suppressMessages(library(RODBC))  ##Version: 1.3-15
suppressMessages(library(reshape))  ##Version: 0.8.8
suppressMessages(library(data.table))  ##Version: 1.12.0
suppressMessages(library(rgdal))  ##Version: 1.3-4
suppressMessages(library(lubridate))  ##Version: 1.7.4
suppressMessages(library(RPostgreSQL))  ##Version: 0.6-2
suppressMessages(library(doBy))  ##Version: 4.6-2
suppressMessages(library(arm))  ##Version: 1.10-1
suppressMessages(library(ggplot2))  ##Version: 3.1.0
suppressMessages(library(scales))  ##Version: 1.0.0
suppressMessages(library(mgcv))  ##Version: 1.8-24
suppressMessages(library(visreg))  ##Version: 2.5-0
suppressMessages(library(plyr))  ##Version: 1.8.4
suppressMessages(library(lme4))  ##Version: 1.1-18-1
suppressMessages(library(lmerTest))  ##Version: 3.1-0
suppressMessages(library(glmmTMB)) ###Version: 0.2.3

###########
#delcaration des arguments et variables/ declaring some variables and load arguments

args = commandArgs(trailingOnly=TRUE)

if (length(args)!=12) {
    stop("At least 12 arguments must be supplied :\n- An input dataset filtered (.tabular). May come from the filter rare species tool.\n- A species detail table (.tabular)\n- A species ssi/sti table.\n- A table with plots coordinates.\n- table with csi calculated before 2001.\n\n", call.=FALSE) #si pas d'arguments -> affiche erreur et quitte / if no args -> error and exit1
} else {
Datafiltered<-args[1] ###### Nom du fichier avec extension ".typedefichier", peut provenir de la fonction "FiltreEspeceRare" / file name without the file type ".filetype", may result from the function "FiltreEspeceRare"
tabSpecies<-args[2] ###### Nom du fichier avec extension ".typedefichier", fichier mis à disposition dans Galaxy-E avec specialisation à l'habitat des especes et si espece considérée comme indicatrice / file name without the file type ".filetype", file available in Galaxy-E containing habitat specialization for each species and whether or not they are considered as indicator
tabtrait<-args[3] ##### Nom du fichier avec extension ".typedefichier", fichier mis à disposition dans Galaxy-E avec degre de specialisation de l espece et affinite thermique /file name without the file type ".filetype", file available in Galaxy-E containing specilalization degree as well as thermic preferences
coordCarre<-args[4] #### Nom du fichier avec extension ".typedefichier", fichier mis à disposition dans Galaxy-E avec les coordonnees gps des carres /file name without the file type ".filetype", file available in Galaxy-E containing gps coordinates of the plots
Var <- args[5] #### Nom du trait dans fichier de traits "nomdutrait" exemple: "ssi" pour l'indice de specialisation par sps / Name of the trait in the file containing trait data
indicator <- args[6] #### Nom de l'indicateur ou du trait par communauté ex pour ssi c'est csi calculé au niveau communauté / Name of the indicator or the trait per community ex: for the ssi, it is the csi measured at the community level
methode <- args[7] #### Methode d'analyse de l'evolution du trait ou de l'indicateur, lmer pour modèloe mixte seul ou gam pour generalized additive model / name of the models used to analyze evolution of mean trait or indicator
dd <- args[8] ##### Nom du fichier si déjà un fichier avec trait moyen par communauté, avec une colonne annee appelé "year" et une colonne plot appelé "carre" correspondant à l'echelle des communautés etudiées / name of the file if a file with the mean trait value per community is already prepared with one column named "year" for the year, one column named "carre" for the plots (the scale of the community measurment)
csibefore2001<-args[9] #### Nom du fichier avec extension ".typedefichier", fichier mis à disposition dans Galaxy-E avec les calcul de csi avant 2001 sur base de données différentes / file name without the file type ".filetype", file available in Galaxy-E containing csi calculated for years before 2001
id<-args[10]#Id name for output res repo
plot_smooth<-args[11]#TRUE or FALSE
ic<-args[12]#TRUE or FALSE
}

#Import des données / Import data
tabCLEAN <- read.table(Datafiltered,sep="\t",dec=".",header=TRUE) #### charge le fichier de données d abondance / load abundance of species
tabsp <- read.table(tabSpecies,sep="\t",dec=".",header=TRUE)   #### charge le fichier de donnees sur nom latin, vernaculaire et abbreviation, espece indicatrice ou non / load the file with information on species specialization and if species are indicators

vars_tabCLEAN<-c("carre","annee","espece","abond")
err_msg_tabCLEAN<-"The input dataset filtered doesn't have the right format. It need to have the following 4 variables :\n- carre\n- annee\n- espece\n- abond\n"

vars_tabsp<-c("espece","nom","nomscientific","indicateur","specialisation")
err_msg_tabsp<-"\nThe species dataset filtered doesn't have the right format. It need to have the following 4 variables :\n- espece\n- nom\n- nomscientific\n- indicateur\n- specialisation\n"

check_file(tabCLEAN,err_msg_tabCLEAN,vars_tabCLEAN,4)
check_file(tabsp,err_msg_tabsp,vars_tabsp,5)

if(!dd==""){
    vars_dd<-c("carre","year","longitude_grid_wgs84","latitude_grid_wgs84","indic")  #### si vous avez déjà votre tableau d'analyse indic correspond au trait moyen par communauté ou au calcul de l'indicateur
    err_msg_dd<-"\nThe dataset for analysis doesn't have the right format. It need to have the following 5 variables :\n- carre\n- year\n- longitude_grid_wgs84\n- latitude_grid_wgs84\n- indic\n"
    check_file(dd,err_msg_dd,vars_dd,5)
    dd <- read.table(dd,sep="\t",dec=".",header=TRUE) #### charge le fichier pour analyse si déjà construit (voir ci dessus pour les détails ) / load the required file for the analysis if already prepared (see above for details)
}else{
    dd<-NULL
}

spTrait=read.table(tabtrait,sep="\t",dec=".",header=TRUE) ############# species_indicateur_fonctionnel.csv pour le STOC sinon fichier avec traits pour calcul du trait moyen par communauté / file with the trait for the community weighted mean calculation
coordCarre=read.table(coordCarre,sep="\t",dec=".",header=TRUE) ######## carre.csv  charge les coordonnées des carrés qui sont utilisés comme covariable  / load the gps coordinates of the plots, is used as covariable in the models
csibefore2001=read.csv2(csibefore2001)##### csi_init.csv

dd <- read.table(dd,sep="\t",dec=".",header=TRUE) #### charge le fichier pour analyse si déjà construit (voir ci dessus pour les détails ) / load the required file for the analysis if already prepared (see above for details)

dir.create(paste("Output/",sep=""),recursive=TRUE,showWarnings=FALSE)##### Creation du dossier de sortie
cat(paste("Create Output/","\n",sep=""))

############################# The function

csi_cti_ctri <- function(tabCLEAN=tabCLEAN,coordCarre=coordCarre,spTrait=spTrait,dd=NULL,ic=TRUE, Var="ssi",indicator="csi", methode="gam", ####### Var= nom du trait dans le fichier de trait (pour le calcul du csi, le trait est ssi par exemple); Indicator= nom de l'indicateur ou du trait moyen par communauté ; methode: choisir modele "gam" ou "lmer" ; ic pour calcul de l'interval de confiance plus rapide sans mais moins fiable / Var=name of the trait in the trait file; Indicator= name of the indicator or of the community weighted mean trait used in graphical output and output files; methode is the statistical model use for the analysis "gam" or "lmer" ; ic is for the calculation of confidence interval faster without but less reliable
                          firstYear=NULL,lastYear=NULL,altitude=800,departement=NULL,onf=TRUE,distance_contact=NULL, #### altitude, departement onf, distance de contact = Argument non utilise, se trouvait dans requete sql / altitude, departement onf, distance de contact = not use anymore was in a postgres request
                         spExcluPassage1=c("MOTFLA","SAXRUB","ANTPRA","OENOEN","PHYTRO"),# (Prince et al. 2013 Env. Sc. and Pol.) + "OENOEN","PHYTRO" avis d'expert F. Jiguet, #### Argument non utilise, se trouvait dans requete sql / not use anymore was in a postgres request
                         seuilAbondance=.99,init_1989 = FALSE,plot_smooth=TRUE, ###### init_1989 si TRUE, option que pour csi et besoin du fichier des csi calculés sur les données avant 2001 (pas forcement fiable car protocole un peu different) / init_1989 if TRUE, only working for csi, and use calculation of csi based on data before 2001 (protocol was bit different, not totally reliable)
                          champSp = "code_sp", sp=NULL,champsHabitat=FALSE, #### Argument non utilise, se trouvait dans requete sql / not use anymore was in a postgres request
                          anglais=FALSE,seuilSignif=0.05,##### #### anglais=FALSE Argument non utilise, se trouvait dans requete sql / not use anymore was in a postgres request
                          couleur="#4444c3",
                          titreY=indicator,titreX="Années",titre=indicator,
                          savePostgres=FALSE,output=FALSE,   ##### OPTION "output" pour afficher le resultat dans R  / OPTION "output" is only to show the result in the R window
                          operateur=c("Lorrilliere Romain","lorrilliere@mnhn.fr"), encodingSave="ISO-8859-1",fileName="dataCSI",id="France"){ ####### nom des fichiers de sorties et de l'operateur / name of the output files and of the operator

start <- Sys.time()
            dateExport <- format(start,"%Y-%m-%d")

if(is.null(firstYear)) firstYear <- 2001
if(is.null(lastYear)) lastYear <- 9999
if(is.null(altitude)) altitude <- 10000

#############################################  calcul de l'indicateur ou du trait moyen pondéré par communauté / Calculation of the weighted mean trait or of the indicator per community i.e. calculation of the csi, cti, ctri (corresponds to Community weighted mean or CWM for traits)
if (is.null(dd)){

colnames(spTrait)[colnames(spTrait) == Var] <- "trait"
spTrait$trait <- spTrait$trait
###browser()
tabCLEAN$trait <- spTrait$trait[match(tabCLEAN$espece,spTrait$pk_species)] ### recupere donnee du trait par espece calcule  / retrieve trait data for each species

tabCLEAN=na.omit(tabCLEAN) ##### pour faire les moyennes pondérées sur les espèces avec des données de trait (donc pas de prise en compte des sps sans traits dans l'abondance totale par carré)

traitcarre <- aggregate(trait*abond~annee+carre,tabCLEAN,sum) ### somme des traits par annee et carre pondere par les abondances / sum of the trait per year and per plots weighted by abundances
abcarre <- aggregate(abond~annee+carre,tabCLEAN,sum) ### somme des abondances totales par annee et carre / sum of total abundance per year and plots
indic <- traitcarre[,3]/abcarre[,3]  #### le trait moyen par carre = indicateur par carre et annee / mean trait per plots = indicator per year and plots

dd <- data.frame(indic,traitcarre$carre,traitcarre$annee)
names(dd)[2] <- "carre"
names(dd)[3] <- "year"

dd$longitude_grid_wgs84 <- coordCarre$longitude_grid_wgs84[match(dd$carre,coordCarre$pk_carre)] #### recupere coordonnées gps / retrieve gps coordinates
dd$latitude_grid_wgs84 <- coordCarre$latitude_grid_wgs84[match(dd$carre,coordCarre$pk_carre)]  #### recupere coordonnées gps / retrieve gps coordinates
dd$id_plot <- dd$carre  ### id_plot nom données aux carrés dans le script /id_plot is use as the name of the plot in the following script

}
else{

colnames(dd)[colnames == "indicator"] <- "indic"
}

############################################ fin du calcul de l'indicateur ou du trait moyen pondéré par communauté / end of the calculation of the indicator or the mean trait value per community

 annee <- sort(unique(dd$year))
            nban <- length(annee)
            pasdetemps <-nban-1

if(methode == "gam") {

            cat("Methode: gam\n")

##browser()
            ## Utilisation des modèles GAMM pour obtenir les tendances d evolution par an du csi cti ou ctri !!!! Marche pas si peu de données !!!!  / Use of GAMM model for the estimation of the annual variations of the csi cti or ctri  !!! does not work with few data !!!
            cat("\nEstimation de la variation annuelle ",indicator,"~ factor(year)+s(longitude_grid_wgs84,latitude_grid_wgs84,bs='sos')\n",sep="")

        gammf <- gamm(indic ~ factor(year)+s(longitude_grid_wgs84,latitude_grid_wgs84,bs="sos"), data=dd,random=reStruct(object = ~ 1| id_plot, pdClass="pdDiag"),correlation=corAR1(form=~year)) #### spline sur les coordonnées, effet aleatoire sur les carres, methode autoregressive sur l'année N-1  / spline on the gps coordinates, random effect on the plots, autoregressive method on the year-1

            sgammf<-summary(gammf$gam)
            coefdata=coefficients(gammf$gam) ### recupere les coefficient de regression de la variable "annee" / retrieve the regression coefficient of the variable "year"
            coefannee <- c(0,sgammf$p.coeff[2:nban])  ### meme chose que au dessus / same as before
            erreuran <- c(0,sgammf$se[2:nban])### recupere les erreurs standard des coefficient de regression de la variable "annee" / retrieve the standard errors of the regression coefficient of the variable "year"
            pval <-  c(1,sgammf$p.pv[2:nban])### recupere les p value de la variable "annee" / retrieve the p value of the variable year

			## calcul des intervalles de confiance  / confidence interval calculation

        if(ic) {
            # gammf.sim <- sim(gammf)  ######################  VERSION ROMAIN mais fct sim() ne marche pas avec GAMM / old version using function sim() but did not work with Gamm models
            # ic_inf_sim <- c(0,tail(apply(coef(gammf.sim), 2, quantile,.025),pasdetemps))
            # ic_sup_sim <- c(0,tail(apply(coef(gammf.sim), 2, quantile,.975),pasdetemps))
			icalpha05 <- as.data.frame(confint(gammf$gam))[2:nban,1:2]  ########## VERSION BENJ
			ic_inf_sim <- icalpha05[,1]
			ic_inf_sim <- c("NA",ic_inf_sim[1:nban-1])
			ic_sup_sim <- icalpha05[,2]
			ic_sup_sim <- c("NA",ic_sup_sim[1:nban-1])
        } else
        {
            ic_inf <- "not assessed"
            ic_sup <- "not assessed"
        }

            tabfgamm <- data.frame(model = "gamm factor(year) plot",annee,coef=coefannee,se = erreuran,pval,signif=pval<seuilSignif,Lower_ci=ic_inf_sim,upper_ci=ic_sup_sim,indicator=indicator) #### recupère les resultats des modèles avec interval de confiance / retrieve results of the models used with confidence interval

     write.csv(tabfgamm,paste("Output/",indicator,"_gammParannee_",id,".csv",sep=""),row.names=FALSE)

        gg <- ggplot(data=tabfgamm,aes(x=annee,y=coef))
        gg <- gg + geom_errorbar(aes(ymin=coef-se, ymax=coef+se), width=0,colour=couleur,alpha=0.5) + geom_line(size=1.5,colour=couleur)
        gg <- gg + geom_ribbon(aes(ymin=coef-se, ymax=coef+se),fill = couleur,alpha=.2)+ geom_point(size=3,colour=couleur)+ geom_point(size=1.5,colour="white")
        gg <- gg + labs(y=indicator,x="")+scale_x_continuous(breaks=pretty_breaks())

        ggsave(paste("Output/fig",indicator,"_carre_",id,".png"),gg)

if(plot_smooth) {   #### Representation graphique de l'evolution annuelle des indicateurs  / Graphical representation of the annual evolution of the indicators
            cat("\nGam pour la figure ",indicator,"~s(year)\n",sep="")
            ## create a sequence of temperature that spans your temperature  #####not use anymore
            ## http://zevross.com/blog/2014/09/15/recreate-the-gam-partial-regression-smooth-plots-from-r-package-mgcv-with-a-little-style/  #### method for the plot

        ####dd$yearf=factor(dd$year) PAS BON j'ai modifié la ligne suivante en mettant s(year) et plus s(yearsf)
            gammgg <- gamm(indic ~ s(year), data=dd,random=reStruct(object = ~ 1| id_plot, pdClass="pdDiag"),correlation=corAR1(form=~year))  #### spline sur l'année, effet aleatoire des carres sur ordonnée à l'origine, methode autoregressive sur l'année N-1  / spline on the year, random effect of the plots on the intercept, autoregressive method on the year-1

###browser()
            maxyear<-max(dd$year)
            minyear<-min(dd$year)
            year.seq<-sort(unique(c(minyear:maxyear,(seq(minyear, maxyear,length=1000)))))
            year.seq<-data.frame(year=year.seq)

                                        # predict only the temperature term (the sum of the   ########### ???? not use anymore
                                        # term predictions and the intercept gives you the overall########### ???? not use anymore
                                        # prediction)########### ???? not use anymore

            preds<-predict(gammgg$gam, newdata=year.seq, type="terms", se.fit=TRUE)  #### Utilise model pour predire les valeurs de indic sur sequence d'années defini au dessus \ Use of the model to predict value of the indicator in the year sequence define above

                                        # set up the temperature, the fit and the upper and lower########### ???? not use anymore
                                        # confidence interval########### ???? not use anymore

            year <-year.seq$year
            realYear <- sort(unique(dd$year))
            fit<-as.vector(preds$fit)
            init <- fit[1]

            fit.up95 <- fit-1.96*as.vector(preds$se.fit)

            fit.low95 <- fit+1.96*as.vector(preds$se.fit)

           # ggGamData <- data.frame(year=year, csi=fit,ic_low95 = fit.low95, ic_up95 = fit.up95)

        fit <- fit - init ### Réechelonne les predictions du modèle sur la 1ère valeure de la prediction  ? ne sait pas pourquoi
        fit.up95 <- fit.up95 - init  ### Réechelonne IC superieur sur la 1ère valeure de la prediction  ? ne sait pas pourquoi
        fit.low95 <- fit.low95 - init  ### Réechelonne IC inferieur sur la 1ère valeure de la prediction  ? ne sait pas pourquoi

        ggGamData <- data.frame(year=year, indic=fit,ic_low95 = fit.low95, ic_up95 = fit.up95)  ####### Recupère les resultats des modèles / retrieve the results of the models

 ## The ggplot:
#browser()
            gg <- ggplot(data=ggGamData,aes(x=year,y=indic))

		   gg <- gg + geom_ribbon(aes(ymin=ic_low95, ymax=ic_up95),fill = couleur,alpha=.2)+ geom_line(size=1,colour=couleur)
            gg <- gg +  geom_point(data = subset(ggGamData,year %in% realYear),size=3,colour=couleur) + geom_point(data = subset(ggGamData,year %in% realYear),size=1.5,colour="white")
            gg <- gg + labs(y=titreY,x=titreX,title=titre)+scale_x_continuous(breaks=pretty_breaks())

            ggsave(paste("Output/fig",indicator,"_plot",id,".png",sep=""),gg)
            cat("\n--> Output/fig",indicator,"_plot",id,".png\n",sep="")

            tabPredict <- subset(ggGamData,year %in% realYear)########### Tableau des resultats pour ne prendre que les valeurs d'IC pour l'année pas entre les années (spline sur annee) !!!plus utilisé!! / Table of the results not taking confidence interval between year but at each year (because of the spline of year)
            colnames(tabPredict)[1:2] <- c("annee",paste(indicator,"_predict",sep=""))
            tabgamm <- merge(tabfgamm,tabPredict,by="annee") #### Desactivation car merge sortie de modèles différents (le modèle dont on tire les coef de regression pour année, avec spline sur les coordonnées geo vs celui pour faire la figure avec splin sur année uniquement)  / not use anymore (as before) because use the results of the restricted model with the spline on the year while the better analysis is on full model with the spline on gps coordinates
			##tabgamm <-  tabfgamm  #### remplace la ligne au dessus  / replace the line above

} else {
    if(init_1989) { ########### Pour utiliser les données csi avant 2001 / in order to use csi data from before 2001
        histo <- read.csv2("csi_init.csv")  ###############   Csi calculé avant 2001 / Data of the csi calculated before 2001
        init <- subset(histo,annee == 2001)$csi

        tabgamm <-  tabfgamm
        tabgamm$coef <-  tabgamm$coef+init
        histo <- subset(histo,annee<=2001)
        tabgamm <- subset(tabgamm,annee>2001)
        tabHisto <- data.frame(model= tabgamm$model[1],annee = histo$annee,
                               coef = histo$csi,se=histo$se,pval=NA,signif=NA)
        tabgamm <- rbind(tabgamm,tabHisto)
        tabgamm <- tabgamm[order(tabgamm$annee),]

        tabgamm$ic_up95<-tabgamm$coef-1.96*as.vector(tabgamm$se)

           tabgamm$ic_low95<-tabgamm$coef+1.96*as.vector(tabgamm$se)

#    browser()
         ## The ggplot:
            gg <- ggplot(data=tabgamm,aes(x=annee,y=coef))
           gg <- gg + geom_ribbon(aes(ymin=ic_low95, ymax=ic_up95),fill = couleur,alpha=.2)+ geom_line(size=1,colour=couleur)
            gg <- gg +  geom_point(size=3,colour=couleur)
            gg <- gg + labs(y=titreY,x=titreX,title=titre)+scale_x_continuous(breaks=pretty_breaks())

            ggsave(paste("Output/fig",indicator,"_plot",id,".png",sep=""),gg)
        cat("\n--> Output/fig",indicator,"_plot",id,".png\n",sep="")

    write.csv(tabgamm,paste("Output/",indicator,"_gammPlot_",id,".csv",sep=""),row.names=FALSE) ####
        cat("\n  --> Output/",indicator,"_gammPlot_",id,".csv\n",sep="")

}###### CROCHET deplacer apres le dernier ggplot ici mais dans version Romain CROCHET placé AVANT le dernier ggplot qui n'était pas dans la condition if(init_1989)

}

            cat("\nEstimation de la tendence  ",indicator,"~ year+s(longitude_grid_wgs84,latitude_grid_wgs84,bs='sos')\n")

            gammc <- gamm(indic~year+s(longitude_grid_wgs84,latitude_grid_wgs84,bs="sos"), data=dd,random=reStruct(object = ~ 1| id_plot, pdClass="pdDiag"),correlation=corAR1(form=~year))### spline sur les coordonnées, effet aleatoire des carres sur ordonnée à l'origine, methode autoregressive sur l'année N-1  / spline on the gps coordinates, random effect of the plots on intercept, autoregressive method on the year-1

			sgammc=summary(gammc$gam)
            coefannee <- sgammc$p.coeff[2]  #### coefficient de regression de la variable année / regression coefficient of the variable "year"
            ## erreur standard / standard error
            erreuran <- sgammc$se[2]
            ## p value
            pval <-  sgammc$p.pv[2]

			#### Calcul des intervalles de confiances / calculation of the confidence intervals

        if(ic) {
            # gammc.sim <- sim(gammc)######################  VERSION ROMAIN mais fct sim() marche pas avec Gamm / old version using function sim() but did not work with Gamm models
            # ic_inf_sim <- c(0,tail(apply(coef(gammc.sim), 2, quantile,.025),pasdetemps))
            # ic_sup_sim <- c(0,tail(apply(coef(gammc.sim), 2, quantile,.975),pasdetemps))
			icalpha052 <- as.data.frame(confint(gammc$gam))[2,1:2]  ########## VERSION BENJ
			ic_inf_sim2 <- icalpha052[,1]
			ic_sup_sim2 <- icalpha052[,2]
        } else
        {
            ic_inf_sim2 <- "not assessed"
            ic_sup_sim2 <- "not assessed"
        }

            tabcgamm <- data.frame(model = "gamm numeric(year) plot",annee = NA,coef = coefannee,se = erreuran,pval,signif = pval<seuilSignif, indicator= indicator , Lower_ci = as.factor(ic_inf_sim2), upper_ci = as.factor(ic_sup_sim2), csi_predict =NA ,ic_low95 =NA,ic_up95=NA)#### recupère les resultats des modèles avec interval de confiance / retrieve results of the models used with confidence interval
    ########### MODIF tabcgamm en remplacant ic_low95 ic_up95 par Lower_ci et upper_ci pour coller avec les sorties des modèles "pour les stats" et non celui utilisé pour le graphe uniquement, et rajout des colonnes spécifique a model ggsmooth pour les garder
#### ai rajouté aussi as.factor(ic) car ne savait pas pourquoi mais tabfgamm sont en facteur et besoin de la meme class pour rbind() ci dessous
            tabgamm <- tabgamm[,colnames(tabcgamm)]  #### recupère que les colonnes de tabcgamm donc perds les infos du modèle du ggsmooth si pas declarer dans le tableau tabcgamm (maintenant c fait)

            tabgamm <- rbind(tabgamm,tabcgamm)

            write.csv(tabgamm,paste("Output/",indicator,"_gammCOMPLET_",id,".csv",sep=""),row.names=FALSE)
        cat("\n  --> Output/",indicator,"_gammPlot_",id,".csv\n",sep="")

		}

if (methode == "lmer") {
            cat("Method : lmer \n")

###################
 ##browser()
   ### Utilisation des modèles mixtes pour obtenir les tendances d evolution par an du csi cti ou ctri / Use of mixte model for the estimation of the annual variations of the csi cti or ctri
            cat("\nEstimation de la variation annuelle lmer(",indicator,"~ factor(year)+(1|id_plot)\n",sep="")

			#md.f <- lmer(indic~ factor(year)+(1|id_plot),data=dd)  ##### effet aleatoire liés aux carrés sur l'ordonnée à l'origine / random effects of plots on intercept
			md.f <- glmmTMB(indic~ factor(year)+(1|id_plot),data=dd)

            smd.f <- summary(md.f)
            # coefdata.f <-  as.data.frame(smd.f$coefficients)  ### version pour sortie lmer()
			coefdata.f <-  as.data.frame(smd.f$coefficients$cond)
            coefdata.f <- data.frame(model="Annual fluctuation", variable = rownames(coefdata.f),coefdata.f)

            # ggdata <<- data.frame(year=c(1989,as.numeric(substr(coefdata.f$variable[-1],13,16))),##### version pour sortie lmer()
             ggdata <- data.frame(year=c(1989,as.numeric(substr(coefdata.f$variable[-1],13,17))),
			 estimate=c(0,coefdata.f$Estimate[-1]),
                                 se=c(0,coefdata.f$Std..Error[-1]))   #####################  resultat du modèle / results of the models
            #ggdata$estimate <-  ggdata$estimate
             #ggdata$se.supR <- ggdata$estimate +  ggdata$se ############################################################################## METHODE ROMAIN
             #ggdata$se.infR <- ggdata$estimate -  ggdata$se
            # ggdata$estimate2 <- c(coefdata.f$Estimate[1],coefdata.f$Estimate[1] + coefdata.f$Estimate[-1])
			# ggdata$se.sup2 <- ggdata$estimate2 +  ggdata$se
            # ggdata$se.inf2 <- ggdata$estimate2 -  ggdata$se

		#prof <- profile(md.f)  #### Nouvel interval de confiance avec utilisation du logarithme des ecarts types / logarithms of standard deviations are used, while varianceProf converts from the standard-deviation to the variance scale
		MODconfint <- confint(md.f) #### plus rapide de ne pas passer par la fonction profile et pas indispensable fonctionne aussi directement sur modele mixte md.f  / more rapid using both function profile and confint but works also directly on output of the model
		se.sup <- MODconfint[2:nban,2]#### [2:nban+2,2] version pour sortie lmer()
		ggdata$se.sup <- c(0,se.sup)
		se.inf <- MODconfint[2:nban,1]#### [2:nban+2,2] version pour sortie lmer()
        ggdata$se.inf <- c(0,se.inf)
coefdata.f$se.inf <- ggdata$se.inf
coefdata.f$se.sup <- ggdata$se.sup
#browser()
            #gg <<- ggplot(ggdata,aes(x=year,y=estimate))+ geom_ribbon(ymin=ggdata$se.infR,ymax=ggdata$se.supR,alpha=.25)+geom_errorbar(ymin=ggdata$se.infR,ymax=ggdata$se.supR,width=0,alpha=.25)+ geom_point() + geom_line() + ylim(min(ggdata$se.infR),max(ggdata$se.supR)) + labs(x="Years",y=paste(indic," variation",sep="")) #####  AVEC INTERVAL ROMAIN
			gg <- ggplot(ggdata,aes(x=year,y=estimate))+ geom_ribbon(ymin=ggdata$se.inf,ymax=ggdata$se.sup,alpha=.25)+geom_errorbar(ymin=ggdata$se.inf,ymax=ggdata$se.sup,width=0,alpha=.25)+ geom_point() + geom_line() + ylim(min(ggdata$se.inf),max(ggdata$se.sup)) + labs(x="Years",y=paste(indicator," variation",sep="")) #####

            ggfile <- paste("Output/",indicator,"_glmmTMB_",id,".png",sep="")
            ggsave(ggfile,gg)

############ Estimation de la tendance sur la periode étudiée  / Trends estimation on the time period studied
			cat("\nEstimation de la tendance lmer(",indicator,"~ year+(1|id_plot)\n",sep="")
           ## browser()
			#md.c <- lmer(indic~ year+(1|id_plot),data=dd)##### effet aleatoire liés aux carrés sur l'ordonnée à l'origine / random effects of plots on intercept ### version lmer
			md.c <- glmmTMB(indic~ year+(1|id_plot),data=dd)
            smd.c<-summary(md.c)
            # coefdata.c <-  as.data.frame(smd.c$coefficients) #### pour la version lmer
            coefdata.c <-  as.data.frame(smd.c$coefficients$cond)[2,]
#profc=profile(md.c) ######### Ajout des intervalles de confiances / addition of the confidence intervals
MODconfint=confint(md.c) ### plus rapide de ne pas passer par profile
se.inf=MODconfint[2,1]### [4,1] pour la version lmer
se.sup=MODconfint[2,2]### [4,2] pour la version lmer
			coefdata.c <- data.frame(model = "Linear trend", variable = rownames(coefdata.c),coefdata.c,se.inf,se.sup)

            coefdata <- rbind(coefdata.c,coefdata.f)

write.csv(coefdata,paste("Output/GlmmTMB_coefficient_",indicator,id,".csv",sep=""),row.names=FALSE)
write.csv(ggdata,paste("Output/ggdata_",indicator,id,".csv",sep=""),row.names=FALSE)

            smd.file <- paste("Output/summary_lmer_",indicator,"_",id,".txt",sep="")

#####################

        }

		}

##################
###  Do your analysis

csi_cti_ctri(tabCLEAN=tabCLEAN,coordCarre=coordCarre,spTrait=spTrait,dd=NULL,Var=Var,indicator=indicator,ic=ic,plot_smooth = plot_smooth,methode=methode,init_1989 = FALSE)  ##### exemple pour l'indicateur csi sans csi déjà calculé donc à partir du ssi avec interval de confiance et utilisant modele mixte / example for the csi index which is not already calculated from the ssi with confidence interval using the mixte model


library(reshape)
library(lme4)
library(sandwich)

intermedia.organizeData <- function(hits, meta, variable='hits', codes=c(), split_hours=c(), skip_weekdays=c(), mediameta=data.frame()){
  if(length(codes) == 0) codes = unique(hits$code)
  h = hits[hits$code %in% codes & hits$id %in% meta$id,]

  meta$day = as.Date(format(meta$date))
  meta$hour = intermedia.getPublicationHour(meta, mediameta=mediameta)

  alldayparts = c()
  for(i in 1:length(c(0,split_hours))) alldayparts = c(alldayparts,paste(c(0,split_hours)[i],'h-',c(0,split_hours,24)[i+1],'h',sep=''))
  meta$daypart = alldayparts[1]
  for(i in 1:length(split_hours)) meta$daypart[meta$hour >= split_hours[i]] = alldayparts[i+1]
  meta$daypart = as.factor(meta$daypart)

  if(nrow(mediameta) == 0) mediameta = data.frame(medium_id=unique(meta$medium), medium_string=amcat.getMediumString(unique(meta$medium)))
  meta = merge(meta, mediameta[,c('medium_id','medium_string')], by.x='medium', by.y='medium_id',all.x=T)

  d = merge(data.frame(id=h$id, hits=h[,variable], code=h$code), meta, by='id', all.x=T)
  d = aggregate(hits ~ medium_string + code + day + daypart, data=d, FUN='length')
  d = reshape(d[,c('medium_string','code','day','hits','daypart')], timevar=c('medium_string'), idvar=c('code','day','daypart'), direction='wide')

  alldays = seq(min(d$day), max(d$day), by='day')
  dayXdaypart = data.frame(day=rep(alldays, each=length(alldayparts)),daypart=rep(alldayparts, times=length(alldays)))

  dayXdaypart$weekday = as.numeric(format(dayXdaypart$day, '%w'))
  dayXdaypart$weekday[dayXdaypart$weekday == 0] = 7
  dayXdaypart = dayXdaypart[!dayXdaypart$weekday %in% skip_weekdays,]

  dayXdaypart$t = 1:nrow(dayXdaypart)

  allcodes = unique(d$code)
  allcases = NULL
  for(code in unique(d$code)) allcases = rbind(allcases, cbind(dayXdaypart, code=rep(code, nrow(dayXdaypart))))

  d = d[d$day %in% allcases$day,]
  d = merge(allcases, d, by=c('day','daypart','code'), all.x=T)
  narts = aggregate(cbind(total=meta$id) ~ medium_string + day + daypart, meta, FUN='length')
  narts = reshape(narts, timevar=c('medium_string'), idvar=c('day','daypart'), direction='wide')
  d = merge(d, narts, by=c('day','daypart'), all.x=T)

  d[is.na(d)] = 0
  d = d[order(d$code,d$t),]

  d
}

intermedia.mediumXweekday <- function(meta) {
  meta$weekday = as.numeric(format(meta$date, '%w'))
  meta$weekday[meta$weekday == 0] = 7
  reshape(aggregate(id ~ weekday + medium, meta, FUN='length'), timevar='medium',idvar=c('weekday'), direction='wide')
}

intermedia.prepareData <- function(hits, meta, day_lag=1, split_hours=c(), skip_weekdays=c(), skip_missingdays=TRUE, mediameta=mediameta){
  d = intermedia.organizeData(hits, meta, split_hours=split_hours, skip_weekdays=skip_weekdays, mediameta=mediameta)
  lagscores = intermedia.getLag(d, day_lag=day_lag)
  d = d[d$t %in% lagscores$t,]
  d = merge(d, lagscores, by=c('t','code'), all.x=T)
  if(skip_missingdays == TRUE) {
    missingdays = intermedia.missingDays(d, skip_weekdays)
    if(length(missingdays) > 0){
      d = intermedia.deleteMissingDays(d, missingdays, day_lag=day_lag)
      print('Deleted missing days (and consecutive days to account for lag)')
    }
  }
  d[order(d$code,d$day,d$daypart),]
}

intermedia.missingDays <- function(d, skip_weekdays=c()) {
  d = d[d$code == d$code[1] & !d$weekday %in% skip_weekdays,]
  agg = aggregate(d[,colnames(d)[grep('total.',colnames(d))]], by=list(day=d$day), FUN='sum')
  allmissingdays = c()
  for(column in colnames(d)[grep('total.',colnames(d))]) {
    missingdays = as.character(agg$day[agg[,column] == 0])
    print(paste(column,': ', length(missingdays), ' days missing',sep=''))
    allmissingdays = unique(c(allmissingdays, missingdays))
  }
  print(paste("Total of unique days missing:", length(allmissingdays)))
  as.Date(allmissingdays)
}

intermedia.deleteMissingDays <- function(d, missingdays, day_lag=1){
  missingdays = missingdays[order(missingdays, decreasing=T)]
  for(mis in missingdays){
    ts = unique(d$t[d$day == mis])
    maxts = max(ts) + day_lag*length(ts)
    d = d[!d$t %in% (min(ts):maxts),]
  }
  d
}

intermedia.getLag <- function(d, day_lag=1) {
  ndayparts = length(unique(d$daypart)) #(max(d$t) / length(unique(d$day)) for dubbelcheck
  lag = day_lag * ndayparts

  media = unique(as.character(sapply(colnames(d)[grep('hits', colnames(d))],intermedia.getMediumName)))
  hitsvars = paste('hits',media,sep='.')
  lagvars = paste('lag',media,sep='.')

  codes = unique(d$code)
  for(lagvar in lagvars) d[,lagvar] = NA
  first_t = min(d$t)

  d = reshape(d[,c('code','t',hitsvars,lagvars)], timevar=c('code'), idvar=c('t'), direction='wide')
  N = nrow(d)
  sufficient_lag_cases = rep(0,nrow(d))

  hitsvarsXcodes = paste(rep(as.character(hitsvars),each=length(codes)),codes,sep='.')
  lagvarsXcodes = paste(rep(lagvars,each=length(codes)),codes,sep='.')

  print('Calculating lag:')
  for(i in 1:N){
    if(i %% 100 == 0) print(paste(i, ' / ', N))
    r = d[i,]
    min_t = r$t - lag
    if(min_t < first_t) next # als de lag niet helemaal berekend kan worden, dan blijft lagscore NA
    sufficient_lag_cases[i] = 1
    d[i,lagvarsXcodes] = colSums(d[d$t >= min_t & d$t < r$t, hitsvarsXcodes])
  }
  d = d[sufficient_lag_cases == 1,]
  d = reshape(d[,c('t',lagvarsXcodes)], idvar='t', ids=d$t, times=lagvarsXcodes, varying=list(lag=lagvarsXcodes), v.names='lag',direction='long')
  d$medium = sapply(d$time, function(txt) strsplit(as.character(txt), fixed=T, '.')[[1]][2])
  d$code = sapply(d$time, function(txt) strsplit(as.character(txt), fixed=T, '.')[[1]][3])
  d = reshape(d[,c('t','lag','medium','code')], timevar='medium', idvar=c('t','code'), direction='wide')
  d = data.frame(t=d$t,code=d$code,d[,lagvars],row.names=NULL)
  colnames(d) = c('t','code',lagvars)
  d
}

intermedia.runAnalysis <- function(d, b_digits=2, se_digits=2, randomintercepts=F, binomial=F, control_for_daytotal=F, use_ar=T){
  modelindex = intermedia.getModelIndex(d)
  media = unique(modelindex$medium)
  models_output = NULL
  #if(randomintercepts==TRUE) print('Using random intercepts for codes') else print("Using pooled issues. Robuse SE's are used")
  for(i in 1:nrow(modelindex)){
    medium = modelindex$medium[i]
    daypart = modelindex$daypart[i]
    print(paste('Analyzing model for', medium,'at daypart', daypart))

    d$autoregression = d[,paste('lag',medium,sep='.')]
    d$hits = d[,paste('hits',medium,sep='.')]

    fullformula = 'hits ~ '
    if(control_for_daytotal == TRUE) {
      d$daytotal = d[,paste('total',medium,sep='.')]
      fullformula = paste(fullformula, 'daytotal + ', sep='')
    }
    if(use_ar == TRUE) fullformula = paste(fullformula, 'autoregression +', sep='')
    independent_media = paste('lag',media[!media == medium],sep='.')
    fullformula = paste(fullformula, paste(independent_media, collapse=' + '), sep='')

    if(binomial == T) {
      d$hits[d$hits > 1] = 1
      family = 'binomial'
    } else family = 'poisson'

    if(randomintercepts==TRUE) {
      fullformula = paste(fullformula, '+ (1|code)')
      m_base = glmer(hits ~ (1|code), family=family,data=d[d$daypart == daypart,])
      m = glmer(as.formula(fullformula), family=family,data=d[d$daypart == daypart,])
      mo = intermedia.getLmerOutput(m, b_digits=b_digits, se_digits=se_digits)
      modelindex$delta.loglik[i] = intermedia.getGlmerFit(m, m_base)

    } else {
      m_base = glm(hits ~ 1, family=family,data=d[d$daypart == daypart,])
      m = glm(as.formula(fullformula), family=family,data=d[d$daypart == daypart,])

      # having fun with intercepts
      #base_intercept = as.numeric((coef(m_base)['(Intercept)']))
      #full_intercept = as.numeric((coef(m)['(Intercept)']))
      # if(binomial == T){
      #  p_base = 1 / (1 + exp(-base_intercept))
      #  p_controlled = 1 / (1 + exp(-full_intercept))
      #} else{
      #  p_base = exp(base_intercept)
      #  p_controlled = exp(full_intercept)
      #}
      #print(paste(medium, ': ', p_base, ' - ', p_controlled, sep=''))

      if(binomial == T){
        mo = intermedia.getGlmOutput(m, b_digits=b_digits, se_digits=se_digits)
      } else mo = intermedia.getRobustSePoissonOutput(m, b_digits=b_digits, se_digits=se_digits)
      modelindex$delta.deviance[i] = intermedia.getGlmFit(m, m_base)
    }
    mo$model = paste(medium,daypart)
    mo$medium = medium
    mo$daypart = daypart
    models_output = rbind(models_output, mo)
  }
  list(coefficients=models_output,models=modelindex)
}

intermedia.getLmerOutput <- function(m, b_digits=2, se_digits=3){
  vc <- vcov(m, useScale = FALSE)
  b <- fixef(m)
  se <- sqrt(diag(vc))
  z <- b / sqrt(diag(vc))
  P <- 2 * (1 - pnorm(abs(z)))
  P[is.na(P)] = 1
  fe = format(round(b,b_digits), digits=b_digits)
  fe[P < 0.05] = paste(fe[P < 0.05], '*', sep='') ; fe[P >= 0.05] = paste(fe[P >= 0.05], ' ', sep='')
  fe[P < 0.01] = paste(fe[P < 0.01], '*', sep='') ; fe[P >= 0.01] = paste(fe[P >= 0.01], ' ', sep='')
  fe[P < 0.001] = paste(fe[P < 0.001], '*', sep='') ; fe[P >= 0.001] = paste(fe[P >= 0.001], ' ', sep='')
  fe_se = paste(fe, ' (',format(round(se,se_digits),digits=se_digits), ')', sep='')
  data.frame(variable = names(b), b=b, se=se, p=P, label=fe, label_se=fe_se)
}

intermedia.getRobustSePoissonOutput <- function (model, b_digits=2, se_digits=2) {
  output = intermedia.getRobustSe(model)
  varnames = rownames(summary(model)$coef)
  b = output[,'Estimate']
  P = output[,'Pr(>|z|)']
  P[is.na(P)] = 1
  se = output[,'Robust SE']
  fe = format(round(b,b_digits), digits=b_digits)
  fe[P < 0.05] = paste(fe[P < 0.05], '*', sep='') ; fe[P >= 0.05] = paste(fe[P >= 0.05], ' ', sep='')
  fe[P < 0.01] = paste(fe[P < 0.01], '*', sep='') ; fe[P >= 0.01] = paste(fe[P >= 0.01], ' ', sep='')
  fe[P < 0.001] = paste(fe[P < 0.001], '*', sep='') ; fe[P >= 0.001] = paste(fe[P >= 0.001], ' ', sep='')
  fe_se = paste(fe, ' (',format(round(se,se_digits),digits=se_digits), ')', sep='')
  data.frame(variable = rownames(output), label_se = fe_se, label=fe, b=b, p=P)
}

intermedia.getGlmOutput <- function (model, b_digits=2, se_digits=2) {
  b = coef(model)
  vc <- vcov(model, useScale = FALSE)
  se <- sqrt(diag(vc))
  P = 2 * pnorm(abs(b/se), lower.tail = FALSE)
  P[is.na(P)] = 1
  varnames = rownames(summary(model)$coef)
  fe = format(round(b,b_digits), digits=b_digits)
  fe[P < 0.05] = paste(fe[P < 0.05], '*', sep='') ; fe[P >= 0.05] = paste(fe[P >= 0.05], ' ', sep='')
  fe[P < 0.01] = paste(fe[P < 0.01], '*', sep='') ; fe[P >= 0.01] = paste(fe[P >= 0.01], ' ', sep='')
  fe[P < 0.001] = paste(fe[P < 0.001], '*', sep='') ; fe[P >= 0.001] = paste(fe[P >= 0.001], ' ', sep='')
  fe_se = paste(fe, ' (',format(round(se,se_digits),digits=se_digits), ')', sep='')

  data.frame(variable = varnames, label_se = fe_se, label=fe, b=b, p=P)
}

intermedia.getRobustSe <-function(model){
  ##http://www.ats.ucla.edu/stat/r/dae/poissonreg.htm
  cov.model <- vcovHC(model, type = "HC0")
  std.err <- sqrt(diag(cov.model))
  coef.model = coef(model)
  #class(coef.model)
  coef.model[is.na(coef.model)] = 0
  missing = names(coef.model[!names(coef.model) %in% names(std.err)])
  coef.model = coef.model[!names(coef.model) %in% missing]
  r.est <- cbind(Estimate = coef.model, `Robust SE` = std.err, `Pr(>|z|)` = 2 *
                   pnorm(abs(coef.model/std.err), lower.tail = FALSE), LL = coef.model - 1.96 *
                   std.err, UL = coef.model + 1.96 * std.err)
  if(length(missing) > 0){
    missing_line = data.frame(dit=rep(0,length(missing)),is=0,mega=1,stom=NA,hoor=NA)
    rownames(missing_line) = missing
    colnames(missing_line) = colnames(r.est)
    r.est = rbind(r.est, missing_line)
  }
  r.est
}

intermedia.getGlmerFit <- function(m, m_base){
  comp=anova(m, m_base, test = "Chisq")
  dll = round((comp$logLik[1] - comp$logLik[2]),1)
  P = comp[,"Pr(>Chisq)"][2]
  P[is.na(P)] = 1
  for(star_thres in c(0.05,0.01,0.001)) if(P < star_thres) dll = paste(dll,'*',sep='')
  dll
}

intermedia.getGlmFit <- function(m, m_base){
  comp=anova(m, m_base, test = "Chisq")
  dev = round(comp$Deviance[2],1)
  P = comp[,'Pr(>Chi)'][2]
  P[is.na(P)] = 1
  for(star_thres in c(0.05,0.01,0.001)) if(P < star_thres) dev = paste(dev,'*',sep='')
  dev
}

intermedia.getRegressionTable <- function(results, dayparts=NA, media=NA, values='label'){
  if(is.na(dayparts)) dayparts = unique(results$daypart)
  if(is.na(media)) media = unique(results$medium)
  rtable = reshape(results[results$daypart %in% dayparts & results$medium %in% media,c('variable',values,'model')], timevar='model', idvar='variable', direction='wide')
  colnames(rtable) = sapply(names(rtable),intermedia.cleanName)
  rtable
}

intermedia.cleanName <- function(txt) strsplit(as.character(txt), fixed=T, '.')[[1]][2]

intermedia.getPublicationHour <- function(d, mediameta=data.frame()){
  #print("Getting hour for available timestamps")
  d$hour = as.numeric(format(d$date, '%H'))
  #format(as.POSIXct(d$date), '%H')
  if(!nrow(mediameta) == 0){
    #print("Getting preset hours from mediafile:")
    #mediameta$pub_hour = as.numeric(format(as.POSIXct(mediameta$publication_time, format='%H:%M:%S'), '%H'))
    for(m in mediameta$medium_id[!is.na(mediameta$pub_hour)]){
      #print(paste('    ', m))
      d$hour[d$medium == m] = as.numeric(mediameta$pub_hour[mediameta$medium_id == m])
    }
  }
  d$hour
}

intermedia.getMediumName <- function(txt) strsplit(as.character(txt), fixed=T, '.')[[1]][2]

intermedia.getModelIndex <- function(d){
  media = as.character(sapply(colnames(d)[grep('hits', colnames(d))],intermedia.getMediumName))
  models = NULL
  for(medium in media){
    agg = aggregate(cbind(N=d[,paste('total',medium,sep='.')]), by=list(daypart=d$daypart), FUN='sum')
    agg$medium = medium
    models = rbind(models, agg)
  }
  models[models$N > 0,c('medium','daypart','N')]
}

intermedia.prepareSlData <- function(codings, meta, attribute, mediameta, attrib_values=c(), lag_hours=24, variable='hits', codes=c(), timesplit='hours', skip_weekdays=c()){
  if(length(codes) == 0) codes = unique(codings$code) # if not codes are specified, use all codes

  h = codings[codings$code %in% codes & codings$id %in% meta$id,c('id','code',attribute)] # make basis for results table
  colnames(h) = c('id','code','attrib')

  # transform date to day-hour format
  meta$day = as.Date(format(meta$date))
  meta$time = intermedia.getPublicationHour(meta, mediameta=mediameta)
  meta$date = as.POSIXct(paste(format(meta$day), ' ', meta$time, ':00:00',sep=''))
  timerange = date=seq(min(meta$date), max(meta$date), "hour")
  meta$t = match(meta$date, timerange) # change day-hour format to integer (t)

  h = unique(merge(h, meta[,c('id','medium','t')], by='id', all.x=T)) # match metadata
  h$medium = mediameta$medium_string[match(h$medium, mediameta$medium_id)] # change medium_id to medium_string

  r = intermedia.getSlLag(h, lag_hours) # get lag

  r$hit = 1 # dependent variable. All cases are 1 (hit)
  r = intermedia.addzeros(r, attrib_values) # dependent variable, add no-hit cases (using alternative attributes)
  r
}

intermedia.getSlLag <- function(h, lag_hours){
  media = NULL
  for(m in unique(h$medium)) media = c(media, m)

  r = h[,c('id','code','attrib','medium','t')] # make results table
  for(m in media) r[,paste('lag',m,sep='.')] = NA # make empty values to fill with calculated lag values
  for(code in unique(h$code)){ # loop through codes
    print(code)
    hs = h[h$code == code,] # select subset of h, containing only the code in the loop
    hs$hit = 1 # set value to 1 (since each case is a hit)
    hs = cast(hs, id + code + attrib + t ~ medium, value='hit') # transform dataframe to wide format with media as columns
    for(m in media[!media %in% colnames(hs)]) hs[,m] = NA # if certain media do not occur in hs, add these as NA (required for matching later on)
    hs[is.na(hs)] = 0 # set all NA values to 0

    all_t = unique(hs$t) # get unique points in time (t) for hs
    all_t = all_t[all_t > lag_hours] # only calculate lag for t with sufficient history
    for(t in all_t){
      hs_lag = hs[hs$t < t & hs$t > (t-lag_hours),] # select cases in hs that represent the lag for time t
      if(nrow(hs_lag) == 0) next # if no lag, continue
      agg = aggregate(hs_lag[,media], by=list(hss$attrib), FUN='sum') # aggregate lag scores, break by attributes
      for(i in 1:nrow(agg)){
        l = agg[i,media] # get lag scores seperately for each attribute
        attrib = agg$Group.1[i] # get attribute name
        r[r$code == code & r$attrib == attrib & r$t == t,paste('lag',media,sep='.')] = l # fill lag values in results table for matching code, attribute and t
      }
    }
  }
  r[is.na(r)] = 0 # set NA values to 0
  r = r[r$t > lag_hours,] # delete cases whith insufficient history for indicated lag time
  r
}

intermedia.addzeros <- function(r, attribs=c()){
  ## Adds not-coded alternative attributes to results, in order to compare to coded attributes.
  ## The attribs parameter is optional. If given, only these attributes are used as alternatives. Otherwise, all code attributes that have a least been used once, by any medium, are used.

  r = r[!r$attrib == '',] # ignore non-coded attributes
  attribs = attribs[!attribs == '']
  all_codes = unique(r[,c('code','attrib')])
  for(i in 1:nrow(r)){
    l = r[i,]
    if(length(attribs) == 0) {
      missing_attrib = all_codes$attrib[all_codes$code == l$code & !all_codes$attrib == l$attrib]
    } else missing_attrib = attribs[!attibs == l$attrib]
    addlines = NULL
    for(attrib in missing_attrib){
      new_l = l
      new_l$attrib = attrib
      new_l$hit = 0
      addlines = rbind(addlines, new_l)
    }
    r = rbind(r, addlines)
  }
  r
}

x = data.frame(a = c(1,2,3),b=c(4,5,6))

getPseudoR <- function(m, m_intercept){
  llm=logLik(m)
  ll0=logLik(m_intercept)
  n = length(m$residuals)
  CoxSnell.R2 <- 1 - exp(-2/n * (llm[1]-ll0[1]))
  Nagelkerke.R2 <- CoxSnell.R2/(1-exp(2/n * ll0[1]))
  R2fit <-rbind(CoxSnell.R2, Nagelkerke.R2)
  R2fit
}


make.OP.dat<-function(my.area='North Sea',my.last.year=2000,first.year.output=2000,do.indicators=F,stochastic.recruitment=0,recruit.adjust.CV=0) {
  SMS<-read.FLSMS.control(file='SMS.dat',dir=data.path)
  nsp<-SMS@no.species
  n.other.pred<-sum(SMS@species.info[,'predator']==2)
  n.pred<-n.other.pred+sum(SMS@species.info[,'predator']==1)
  n.vpa<-nsp-n.other.pred
  n.vpa.pred<-sum(SMS@species.info[,'predator']==1)
  #if (n.other.pred==0) n.other.pred<-1

  #OP<-read.FLOP.control(file=file.path(data.path,'OP.dat'),n.VPA=n.vpa,n.other.pred=n.other.pred,n.pred=n.pred)
  OP<-FLOP.control(
        first.year=SMS@last.year.model+1,
        last.year=SMS@last.year.model+5,
        no.species=SMS@no.species,
        no.VPA.predators=n.vpa.pred,
        no.other.predators= n.other.pred,
        species.names=SMS@species.names
    )

      OP@last.year<-my.last.year
      OP@first.year.out<-first.year.output

      if (do.indicators) OP@indicator<-1 else OP@indicator<-0

      y.end<-2013
      y.first<-2004
      OP@years.wsea['first-year',]<-y.first; OP@years.M['first-year',]<-y.first; OP@years.propmat['first-year',]<-y.first; OP@years.weca['first-year',]<-y.first; OP@years.ration['first-year',]<-y.first;
      OP@years.wsea['last-year',] <-y.end;   OP@years.M['last-year',] <-y.end;   OP@years.propmat['last-year',] <-y.end;   OP@years.weca['last-year',] <-y.end;   OP@years.ration['last-year',] <-y.end;

      OP@years.stock.distrib['first-year',] <-y.end;
      OP@years.stock.distrib['last-year',]  <-y.end;

      OP@years.F['first-year',] <-y.end;
      OP@years.F['last-year',]  <-y.end;

      OP@years.prop.landed['first-year',] <-y.end;
      OP@years.prop.landed['last-year',]  <-y.end;

      OP@years.other['first-year',] <-2008;
      OP@years.other['last-year',]  <-y.end;

      if (my.area=='North Sea') {
                                      #Cod  Whiting     Haddock    Saithe  Herring  Sandeel   Nor. pout Sprat  Plaice  Sole
 #         OP@rec.noise['lower',]<-c(  -2,      -2.0,    -2.5,     -2.5,    -2.5,      -3,      -2.5,    -2.5,     -2,   -2)
#          OP@rec.noise['upper',]<-c(   2.0,     2.0,     2.0,      2.5,       2,       2,         2,     2.5,      2.5,    2)

                                     #Cod  Whiting     Haddock    Saithe  Herring  n Sandeel  Ssa   Nor. pout Sprat  Plaice  Sole
 #         OP@rec.noise['lower',]<-c(  -2,      -2.0,    -2.5,     -2.5,    -2.5,      -2,     -2,    -2.5,    -2.5,     -2,   -2)
        OP@rec.noise['lower',]<- -2
 #         OP@rec.noise['upper',]<-c(   2.0,     2.0,     2.0,      2.5,       2,       2,     2 ,   2,     2.5,      2.5,    2)
        OP@rec.noise['upper',]<- 2

       }    # end North Sea
      if (my.area=='Baltic Sea') {
                                     #Cod    Herring   Sprat
          OP@rec.noise['lower',]<-c(  -2,      -2.5,    -1.5 )
          OP@rec.noise['upper',]<-c(   2.0,     2.0,     2.0 )

       }    # end Baltic Sea

    OP@recruit.adjust.CV[1,]<-recruit.adjust.CV     #adjust recruitment with half of the variance (factor exp(-(CV^2)/2).  0=no adjustment, 1=do adjustment,

    OP@stochastic.recruitment[]<-stochastic.recruitment

  OP@first.year<-SMS@last.year.model+1
  OP@M2.iterations<- 4    ## Maximum M2 iterations (option M2.iterations) in case of use.Nbar=1
  OP@max.M2.sum2<-1e-6    ## convergence criteria (option max.M2.sum2) in case of use.Nbar=1

  return(list(OP=OP,SMS=SMS))
}

calc.high5.yield<-function() {
  a<-read.table(file=file.path(data.path,"summary_table_raw.out"),header=T)
  a<-subset(a,!is.na(Yield))
  y.lag<-2

  yrange<-seq(SMS@first.year.model+y.lag,SMS@last.year-y.lag,1)
  bb<-NULL
  for (y in yrange) {
    b<-subset(a,Year>=y+y.lag & Year<=y+y.lag)
    b<-aggregate(Yield~Species.n,data=a,mean)
    b$Year<-y
    bb<-rbind(b,bb)
  }

  head(bb)

  b<-aggregate(Yield~Species.n,data=bb,max)
  b$Species<-sp.names[b$Species.n]
  b
}


library("future")
future::plan(future.batchtools::batchtools_slurm,
             template = ".batchtools.slurm.tmpl",
             label     = "sim_test_2",
             resources = list(
                job.name = "sim_test_2",
                walltime = 1,
                memory = "2G",
                ncpus  = 4,
                output   = "/work/%u/%j-%x.log",
                email  = "alban.sagouis@idiv.de"
             )
)

### Community
source("./analysis/parameters/community_v1.r")
res <- listenv::listenv()
for (param_i in 1:4)  res[[param_i]] %<-% {

   comm <- mobsim::sim_thomas_community(100, 100000, fix_s_sim = TRUE)
   comm <- sRealm::jitter_species(comm = comm, sd = 0.01)
   comm <- sRealm::torusify(comm)

   x0 <- y0 <- 0.45
   xsize <- ysize <-  0.1

   mobsim::abund_rect(comm = comm, x0 = x0, y0 = y0, xsize = xsize, ysize = ysize)
}
res <- as.list(res)
saveRDS(object = res, file = "~/simRealm/data/simulations/sim_test_2.rds")


library(dplyr)
library(data.table)
library(stringr)
library(glue)
library(pagoda2)
library(conos)

con = readRDS(glue('~/paper_data/conos_objects/conos_ATC.rds'))

cell_annot = fread(glue('~/paper_data/cell_annotations/cell_annot_MDA.tsv')) %>%
    mutate(annot = copykat.pred) %>%
    split(.$sample)

set.seed(0)
tumor_cells = cell_annot[['ATC2']] %>% filter(annot == 'T') %>% pull(cell)
normal_cells = cell_annot[['ATC2']] %>% filter(annot == 'N') %>% pull(cell) %>% sample(50)
cells = c(tumor_cells, normal_cells)

count_mat = as.matrix(t(con$samples[['ATC2']]$misc$rawCounts))
df = fread(glue('~/paper_data/processed/ATC2_allele_counts.tsv.gz'), sep = '\t')

count_mat_ATC2 = count_mat[,cells]
df_allele_ATC2 = df %>% filter(cell %in% cells)

# use_data(df_allele_ATC2, overwrite = T)
# use_data(count_mat_ATC2, overwrite = T)


#' Score Performance Indicators
#'
#' @param df site MSD file
#'
#' @export
#' @importFrom magrittr %>%

score_prfm <- function(df){

  prfm_ind <- df %>%
    dplyr::filter(indicator %in% c("HTS_TST_POS", "TX_NEW", "PMTCT_STAT", "OVC_SERV", "KP_PREV", "VMMC_CIRC"),
                  standardizeddisaggregate == "Total Numerator",
                  typemilitary == "N") %>%
    ICPIutilities::add_cumulative() %>%
    dplyr::group_by(operatingunit, psnu,sitename, orgunituid, indicator) %>%
    dplyr::summarise_at(dplyr::vars(fy2018cum, fy2018_targets), ~ sum(., na.rm = TRUE)) %>%
    dplyr::ungroup() %>%
    dplyr::filter(fy2018_targets !=0) %>%
    dplyr::mutate(achievement = round(fy2018cum/fy2018_targets, 3)) %>%
    dplyr::select(-fy2018cum) %>%
    dplyr::mutate(indicator = paste0("prfm.", stringr::str_to_lower(indicator)))

  thres_med <- addthresholds(df) %>% .["med"]

  prfm_ind <- prfm_ind %>%
    dplyr::group_by(indicator) %>%
    dplyr::mutate(score = dplyr::case_when(achievement < thres_med &
                               fy2018_targets > median(fy2018_targets, na.rm = TRUE) ~ 2,
                             achievement < thres_med                                 ~ 1,
                             TRUE                                                    ~ 0)) %>%
    dplyr::ungroup() %>%
    dplyr::rename(value = achievement) %>%
    dplyr::select(-fy2018_targets) %>%
    tidyr::gather(type, val, value, score, na.rm = TRUE) %>%
    tidyr::unite(ind, indicator, type, sep = ".") %>%
    tidyr::spread(ind, val)

  return(prfm_ind)

}


# Scripts to include more biomerker (remove the  10% NA biomarker selection)
# 30 Oct to generate documentation for project conclusion
# module load R/3.4.3
# module load R_packages/3.4.3

library(data.table)
library(dplyr)

setwd("/proj/sens2016007/nobackup/Zhiwei/BAManalyses/Manta1_5Main/FormatPopulation/BinVariants/WinSize10/Association_folder_moreBiomarker")
Pdf <- data.frame()
for(i in 1:10) {
  fil <- paste(i, ".rds", sep = "")
  print(paste0("Reading chromosome:", i))
  temp <- readRDS(fil)
  Pdf <- rbind(Pdf, temp)
}
fil <- "AllPvalues1_10.rds"
saveRDS(Pdf,fil)

Pdf <- data.frame()
for(i in 11:22) {
  fil <- paste(i, ".rds", sep = "")
  print(paste0("Reading chromosome:", i))
  temp <- readRDS(fil)
  Pdf <- rbind(Pdf, temp)
}
fil <- "AllPvalues11_22.rds"
saveRDS(Pdf,fil)

Pdf <- data.frame()
temp <- readRDS("AllPvalues1_10.rds")
Pdf <- rbind(Pdf, temp)
temp <- readRDS("AllPvalues11_22.rds")
Pdf <- rbind(Pdf, temp)
# > dim(Pdf)
# [1] 108745    438
fil <- "AllPvalues.rds" #"
saveRDS(Pdf,fil)
T_Pdf <- t(Pdf)
fil <- "T_AllPvalues.rds"
saveRDS(T_Pdf,fil)

# select p value:
rm(list=ls())
T_Pdf <- readRDS("T_AllPvalues.rds")
#GET the last value of: Estimate/Std.Error/t-value/Pr(>|t|)
T_Pdf <- apply(T_Pdf, MARGIN = c(1,2), function(x) as.numeric(gsub("^.*/", "", x)) )
fil <- "T_All_P_only.rds"
saveRDS(T_Pdf,fil)
T_Pdf <- readRDS("T_All_P_only.rds")
# dim(T_Pdf) :438 108745
# number of regions? need for adjusted P-value threshold
#NOTE: wc -l /proj/sens2016007/nobackup/Zhiwei/BAManalyses/Manta1_5Main/FormatPopulation/BinVariants/WinSize10/All.tmp.sort.merge.bed #=> 30598
#TODO: fix the NA for indexing and searching for lowest value
#Best_T_Pdf <- data.frame(P_value=apply(T_Pdf,1,min),Coor=colnames(T_Pdf)[apply(T_Pdf,1,which.min)])
#Best_T_Pdf <- data.frame(P_value=apply(T_Pdf,1,function(x){min(x, na.rm = TRUE)}),Coor=colnames(T_Pdf)[apply(T_Pdf,1,function(x){which (x == min(x, na.rm = TRUE))})])
Best_T_Pdf <- data.frame(P_value=apply(T_Pdf,1,min,na.rm=TRUE),Coor=colnames(T_Pdf)[apply(T_Pdf,1,which.min)])
library(stringr)
Best_T_Pdf <- data.frame(Best_T_Pdf, Panel=str_split_fixed(rownames(Best_T_Pdf), "_", 3)[,1], BioMarker_name=str_split_fixed(rownames(Best_T_Pdf), "_", 3)[,3], BioMarker_fullname=rownames(Best_T_Pdf))
Coor <- Best_T_Pdf$Coor
Coor <- str_split_fixed(Coor, "[.]", 3)
Coor[,1] <- substring(Coor[,1], 2)
Coor <- apply(Coor, MARGIN = c(1,2), function(x) as.numeric(x) )
colnames(Coor) <- c("Chr", "Start", "End")
histData <- data.frame(Coor, Best_T_Pdf)
# Sort by Chr and Start:
histData_sort <- histData[order( histData$Chr, histData$Start), ]
histData_sort <- data.frame(number = c(1:nrow(histData_sort)),Best_T_Pdf)
library(ggplot2)
# Manhattan plot for the highest values fo each biomarker: adapted from Nima Rafati nimarafati@gmail.com
ggplot(data = histData_sort, aes(x = number, y = -log10(P_value), fill = factor(Panel))) +
    geom_bar(stat = "identity") +
    facet_grid(~Chr, scales = 'free_x', space = 'free_x', switch = 'x') +
    theme_classic() +
    theme(plot.title = element_text(size=22), axis.text.x = element_blank(),axis.ticks.x = element_blank(),
          strip.background = element_rect(colour = "white", fill = "grey"),panel.spacing = unit(0, "lines"), axis.text = element_text(size=12), axis.title=element_text(size=14), legend.text=element_text(size=12)) + scale_x_continuous(expand = c(0.1, 0.1)) +
    xlab("Chromosome") +
    ylim(0,60) +
    ggtitle("Max -log10(P) for each biomarker") +
    theme(plot.title = element_text(hjust = 0.5)) +
    labs(fill="Panel")

aspect_ratio <- 2
height <- 7
ggsave("Manha_not_anno_Manta.png", height = height , width = height * aspect_ratio)
#
AllValues <- readRDS("T_AllPvalues.rds")
Pfilter <- 0.05/438/29205 #0.05/397/20598 #update 30Oct
histData_sort_filter <- histData_sort[histData_sort$P_value <= 0.05/438/29205,] #dim 23*6 Old 0.05/397/30598; 25*9: 0.05/397/20598
significantBio <- data.frame()
library(stringr)
WholeGenome_filter <- T_Pdf[rownames(histData_sort_filter),] #[1]     23biomarkers 108745Pos
for(i in 1:nrow(WholeGenome_filter)) {
  OneBioMarker <- data.frame(P_value=WholeGenome_filter[i,][WholeGenome_filter[i,] <= Pfilter & !is.na(WholeGenome_filter[i,])], Stat=AllValues[rownames(WholeGenome_filter)[i],][WholeGenome_filter[i,] <= Pfilter & !is.na(WholeGenome_filter[i,])], Coor=colnames(WholeGenome_filter)[WholeGenome_filter[i,] <= Pfilter & !is.na(WholeGenome_filter[i,])], Biomarker= rep(rownames(WholeGenome_filter)[i],sum(WholeGenome_filter[i,] <= Pfilter, na.rm = TRUE)))
  Coor <- OneBioMarker$Coor
  Coor <- str_split_fixed(Coor, "[.]", 3)
  Coor[,1] <- substring(Coor[,1], 2)
  Coor <- apply(Coor, MARGIN = c(1,2), function(x) as.numeric(x) )
  colnames(Coor) <- c("Chr", "Start", "End")
  OneBioMarker<- data.frame(Coor, OneBioMarker)
  significantBio <- rbind(significantBio, OneBioMarker)
}
write.csv(significantBio, file = "List_significantBiomarkers_withStat_Manta.csv")
fil <- "List_significantBiomarkers_withStat_Manta.rds"
saveRDS(significantBio,fil)
write.table(significantBio, "List_significantBiomarkers_withStat_Manta.txt", sep="\t", col.names = F, row.names = F)

# in bash:
module load bioinfo-tools BEDTools/2.27.1
awk '{OFS="\t"; print $1,$2,$3,$3-$2,$4,$7}' List_significantBiomarkers_withStat_Manta.txt > List_significantBiomarkers_withStat_Manta_size.bed
# the SigCNVR for selecting individual:
bedtools sort -i List_significantBiomarkers_withStat_Manta_size.bed | bedtools merge -i stdin | awk '{OFS="\t";print $0,$3-$2}' > SigCNVR_size.bed
bedtools intersect -wao -a SigCNVR_size.bed -b List_significantBiomarkers_withStat_Manta_size.bed | bedtools groupby -g 1-4 -c 10 -o freqdesc > SigCNVR_size_withBiomarker_Manta.bed
#Manhattan plot:
# in R:

library(stringr)
AllValues <- readRDS("T_AllPvalues.rds")
#WholeGenome_filter <- T_Pdf[rownames(histData_sort_filter),] #size: 23biomarkers 108745Pos
# each of the 23 biomarkers, extract whole-genome wide CNVR results
Manha23 <- data.frame()
for(i in 1:nrow(WholeGenome_filter)) {
  OneBioMarker <- data.frame(P_value=WholeGenome_filter[i,], Stat=AllValues[rownames(WholeGenome_filter)[i],], Coor=colnames(WholeGenome_filter), Biomarker= rep(rownames(WholeGenome_filter)[i],length(WholeGenome_filter[i,]) ))
  Coor <- OneBioMarker$Coor
  Coor <- str_split_fixed(Coor, "[.]", 3)
  Coor[,1] <- substring(Coor[,1], 2)
  Coor <- apply(Coor, MARGIN = c(1,2), function(x) as.numeric(x) )
  colnames(Coor) <- c("Chr", "Start", "End")
  OneBioMarker<- data.frame(Coor, OneBioMarker)
  Manha23 <- rbind(Manha23, OneBioMarker)
}

# make plot:
#colnames(Manha23) <- c("Coor", "CHR", "BP", "BP_end", "P", "Stat", "SNP", "Biomarker")
fil <- "Manha23_Manta.rds"
saveRDS(Manha23,fil)
colnames(Manha23) <- c("CHR", "BP", "BP_end", "P", "Stat", "SNP", "Biomarker")
sum(Manha23$P < 0.05/438/29205, na.rm = TRUE) #[1] 130
#remove rows with NA P values:
Manha23_rmNA <- Manha23[!is.na(Manha23[,"P"]),]
dim(Manha23)
#[1] 2501135       7
dim(Manha23_rmNA)
#[1] 2328112       7

library(qqman)
png("Manha23_manta.png", width=1080, height=720, res=120)
manhattan(Manha23_rmNA, genomewideline = FALSE, suggestiveline = FALSE, highlight = Manha23_rmNA$SNP[Manha23_rmNA$P < 0.05/397/29205] )
dev.off()

#25Oct, QQplot
#Manha23 <- readRDS(Manha23_Manta.rds)
png("QQplot23_manta.png", width=1080, height=720, res=120)
qq(Manha23_rmNA$P)
dev.off()


NULL

is.hcl <- function(color_space) {
	return(is.list(color_space) && length(color_space) == 3
	&& all(sapply(color_space, function(pair) {is.numeric(pair) && length(pair) == 2}))
	&& color_space[[1]][1] < color_space[[1]][2] && color_space[[1]][1] >= 0 && color_space[[1]][2] <= 360
	&& color_space[[2]][1] < color_space[[2]][2] && color_space[[2]][1] >= 0 && color_space[[2]][2] <= 100
	&& color_space[[3]][1] < color_space[[3]][2] && color_space[[3]][1] >= 0 && color_space[[3]][2] <= 100)
}

#' A list of color space presets as defined in \url{http://tools.medialab.sciences-po.fr/iwanthue/js/presets.js}.
#'
#' @export
hcl_presets = list(
	full = list(c(0,360), c(0,100), c(0,100)),
	default = list(c(0,360), c(30, 80), c(35, 80)),
	colorblind_friendly = list(c(0,360), c(40, 70), c(15, 85)),
	fancy_light = list(c(0,360), c(15, 40), c(70,100)),
	fancy_dark = list(c(0,360), c(8, 40), c(7, 40)),
	shades = list(c(0,240), c(0, 15), c(0,100)),
	tarnish = list(c(0,360), c(0, 15), c(30, 70)),
	pastel = list(c(0,360), c(0, 30), c(70,100)),
	pimp = list(c(0,360), c(30, 100), c(25, 70)),
	intense = list(c(0,360), c(20, 100), c(15, 80)),
	fluo = list(c(0,300), c(35, 100), c(75,100)),
	red_roses = list(c(20, 330), c(10, 100), c(35,100)),
	ochre_sand = list(c(20, 60), c(20, 50), c(35,100)),
	yellow_lime = list(c(60, 90), c(10, 100), c(35,100)),
	green_mint = list(c(90, 150), c(10, 100), c(35,100)),
	ice_cube = list(c(150, 200), c(0,100), c(35,100)),
	blue_ocean = list(c(220, 260), c(8, 80), c(0, 50)),
	indigo_night = list(c(260, 290), c(40, 100), c(35,100)),
	purple_wine = list(c(290, 330), c(0,100), c(0, 40))
)


#NEON functional group tables.
#clear environment, source paths, packages and functions.
rm(list=ls())
library(data.table)
source('paths.r')

#set output paths.----
output.path <- NEON_cosmo_genera.path

#load data.----
sv <- readRDS(NEON_SV.table_clean.path)
map <- readRDS(hierarch_filled.path)
map <- map$core.obs
fun <- readRDS(NEON_fun_clean.path)
cosmo_ref <- readRDS(tedersoo_ITS_cosmo_genera_list.path)
cosmo_ref <- colnames(cosmo_ref$abundances)
cosmo_ref <- cosmo_ref[!cosmo_ref %in% c('other')]

#check that things are properly ordered.----
if(sum(rownames(fun) == colnames(sv)) != ncol(sv)){
  cat('Stop. rownames of tax-fun table do not match column names of SV table.\n')
}

#aggregate cosmopolitan genera.----
test <- data.table(cbind(fun, t(sv)))
seq.out <- list()
cosmo.out <- list()
for(i in 1:length(cosmo_ref)){
      z <- test[genus == cosmo_ref[i],]
  start <- ncol(fun) + 1
    out <- colSums(z[,start:ncol(z)])
  cosmo <- length(out[out > 0]) / length(out)
    seq.out[[i]] <- out
  cosmo.out[[i]] <- cosmo
}
  seq.out <- do.call('cbind',seq.out)
cosmo.out <- do.call('rbind',cosmo.out)
colnames(seq.out) <- cosmo_ref

#get a handle on most abundant and most cosmopolitan genera.----
j <- data.table(cbind(cosmo_ref,cosmo.out))
colnames(j)[2] <- 'cosmo'
j$cosmo <- as.numeric(j$cosmo)
j <- j[order(-cosmo),]
counts <- rowSums(seq.out)
k <- data.table(cbind(cosmo_ref,counts))
k$counts <- as.numeric(as.character(k$counts))
k <- k[order(-counts),]
k <- k[!(cosmo %in% c('unidentified'))] #remove the genus "unidentified".
j <- j[!(cosmo %in% c('unidentified'))] #remove the genus "unidentified".
#head(cbind(j,k), 30)

#Get together abundances and seq_total.----
seq_total <- rowSums(sv)
seq_total <- seq_total[order(match(names(seq_total),rownames(seq.out)))]
other <- seq_total - rowSums(seq.out)
abundances <- data.frame(other,seq.out)
rel.abundances <- abundances / seq_total

#get other IDs in here. deprecatedVialID does not match all products.----
    abundances$deprecatedVialID <- rownames(    abundances)
rel.abundances$deprecatedVialID <- rownames(rel.abundances)

abundances <-     merge(    abundances, map[,c('deprecatedVialID','geneticSampleID')],
                        by.x = 'deprecatedVialID', by.y = 'deprecatedVialID', all.x = T)
rel.abundances <- merge(rel.abundances, map[,c('deprecatedVialID','geneticSampleID')],
                        by.x = 'deprecatedVialID', by.y = 'deprecatedVialID', all.x = T)

#save output.----
dat.out <- list(abundances,rel.abundances,seq_total)
names(dat.out) <- c('abundances','rel.abundances','seq_total')
saveRDS(dat.out, output.path)


core_sets <- read.csv("core_sets.csv")
expansions <- read.csv("expansions.csv")
#Import CSV data generated by scryfall.js
cs <- sample(1:nrow(core_sets),1)
#Randomly sample one core set.
ex <-sample(2:nrow(expansions),5)
#Randomly sample five expansions
ex <- c(1,ex)
#Include the newest expansion.
format <- rbind(core_sets[cs,], expansions[ex,])
#Create one dataframe for all sets in the format.
names(format) <- c("Set Name","Expansion Code","Link")
#Make the column names pretty.
filename <-paste("Random Standard ",Sys.Date(),".csv",sep="")
#Name the file Random Standard {date}.csv.
write.csv(format,filename,row.names=FALSE,quote=FALSE)
#Export the format data to csv.


# shocktitles.r
#               RBLandau 20190204
# The guts of making the titles and legend for shock plots.
# Extracted from previous working code, to be slid back in.
#
# Requires that the following constants be defined by the caller:
#
# nServerDefaultLife  server default half-life in years.  (Recall that this
#                      must be nonzero for all shock scenarios.)
# nShockspan          span of shocks when they occur: 0,1,2,3,4.
# nShockImpactMin     minimum percent value of shock impact for this picture;
#                      the interval is closed (inclusive) at both ends.
# nShockImpactMax     maximum percent value of shock impact.
#                      (To consider only fatal shocks, e.g., set both min
#                      and max to 100.)
# nSegments           number of audit segments per year: 1,2,4,10,50.
#                      (Audit cycles are always annual.)
# sPlotFile           (string) name of the file to write plots into.
#
# Uses trows$simlength to calculate simulation duration.
# Also uses the fngettime() function from PlotUtil,
#  which must be included first.
#

sLegendLabel <- "  Number of \nAudited Copies"
lLegendItemLabels <- levels(factor(trows$copies))

sCopiesList <- paste0(lLegendItemLabels, sep=",", collapse="")
sTitleLine <-   (   ""
                %+% sprintf("Shocks: span=%d", nShockspan)
                %+% sprintf(", impacts [%d%%,%d%%]",
                            nShockImpactMin, nShockImpactMax)
                %+% sprintf(", ServerDefaultHalflife=%dyrs", nServerDefaultLife)
                %+% sprintf(", Duration=%dyrs", as.integer(min(trows$simlength)/10000))
                %+% " "
                %+% "\n"
                %+% sprintf("\n(Copies=%s ", sCopiesList)
                %+% "annual systematic auditing in "
                %+% sprintf("%d segment(s))", nSegments)
                )

sTimestamp <- fngettime()
sSamples <- sprintf("samples=%d ", min(trows$n))
sXLabel <- ("Shock Frequency (half-life) in hours "
            %+% "      (one metric year = 10,000 hours) "
            %+% "                           (less frequent shocks =====>)"
            )
sXLabel <- sXLabel %+% ("\n\n                                  " # cheapo rjust.
            %+% sprintf("          %s   %s   %s", sPlotFile,sTimestamp,sSamples)
            )

sYLabel <- ("probability of losing the entire collection (%)")


#' @export
agelenPlot <-function(x,by="spp",level="all",fraction=c("DIS","LAN"),title=TRUE,supsmu=FALSE,jitter=FALSE,...)
{
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
# agelenPlot
# function that plots age given length
# of the ca table of csData objects
# Borrows heavily from MM's lenDisPlot code
# AP 22/04/09
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

# library(COSTeda)
# data(ASFIS)

if(class(x)%in%c("csPi","csData","csDataVal")==FALSE)stop("x is not csPi, csData")

spp <-ifelse(length(table(x@ca$spp))==1,x@ca$spp[1],"multiple species")

dots <-list(...)
if(class(x) %in%c("csPi"))
{

data(ASFIS)
object <-suppressWarnings(mergecsPi(x))@ca

}
if(class(x) %in%c("csData","csDataVal"))
{
data(code.list)
ASFIS <-code.list$spp
object <-suppressWarnings(mergecsData(x))@ca
}

if((by %in% names(object))!=TRUE)stop("by not a recognised grouping variable")

if(all(names(table(object$catchCat))=="DIS"))
{
fraction <-"DIS"
warning("Only DIS fraction present in data")
}
if(all(names(table(object$catchCat))=="LAN"))
{
fraction <-"LAN"
warning("Only LAN fraction present in data")
}
if(all(fraction %in% names(table(object$catchCat)))==FALSE)
{
stop(paste(fraction,"fraction not in the data"))
}

lgthCode <- as.character(x@sl[,"lenCode"][1])
stepp <- c(1,5,10,25)
names(stepp) <- c("mm","scm","cm","25mm")
ste <- stepp[lgthCode]
varlevs <-as.character(level)
if(level[1]=="all")varlevs <-levels(factor(object[[by]]))
if(any(as.character(varlevs) %in% as.character(object[[by]])==FALSE))
{
stop("level not present in the variable")
}

df <-object
# running through the levels to get the ylimits
allcounts <-allages <-NULL
for(i in 1:length(varlevs))
{
df <- object[(as.character(object[[by]])%in%as.character(varlevs[i]))&(object$catchCat %in% fraction),]
if(dim(df)[1]==0)next
alllengths <-df$lenCls
strataage <-df$age

allcounts <-append(allcounts,alllengths)
allages <-append(allages,strataage)

}
# doing some defaults for the dots argument
addtitle <-FALSE
if(is.null(dots$add))dots$add <-FALSE
if(dots$add==TRUE&&is.null(dots$main)) dots$main <-""
if(is.null(dots$main))addtitle <-TRUE
if(is.null(dots$xlab))dots$xlab <-"Age"
if(is.null(dots$ylab))dots$ylab <-"Length class (mm)"
if(is.null(dots$axes))dots$axes <-TRUE
if(is.null(dots$col))dots$col <-rep(1,length(varlevs))
if(is.null(dots$col.line))dots$col.line <-dots$col
if(!is.null(dots$col)&length(dots$col==1))dots$col <-rep(dots$col,length(varlevs))
if(!is.null(dots$col.line)&length(dots$col.line==1))dots$col.line <-rep(dots$col.line,length(varlevs))

if(is.null(dots$pch))dots$pch <-rep(1,length(varlevs))
if(!is.null(dots$pch)&length(dots$pch==1))dots$pch <-rep(dots$pch,length(varlevs))
if(is.null(dots$lwd))dots$lwd <-rep(1,length(varlevs))
if(!is.null(dots$lwd)&length(dots$lwd==1))dots$lwd <-rep(dots$lwd,length(varlevs))
if(is.null(dots$lty))dots$lty <-rep(1,length(varlevs))
if(!is.null(dots$lty)&length(dots$lty==1))dots$lty <-rep(dots$lty,length(varlevs))

if(is.null(dots$ylim))dots$ylim <-c(min(allcounts,na.rm=T),max(allcounts,na.rm=T))
if(is.null(dots$xlim))dots$xlim <-c(min(allages,na.rm=T),max(allages,na.rm=T))
if(is.null(dots$span))dots$span <-"cv"
out <-NULL
# and finally plotting out the levels
for(i in 1:length(varlevs))
{

if(addtitle)dots$main <-paste(by,varlevs[i],sep=" ")
if(addtitle&&by=="month")dots$main <-month.abb[as.numeric(varlevs)][i]
df <- object[(as.character(object[[by]])%in%as.character(varlevs[i]))&(object$catchCat %in% fraction),]
if(jitter)jitterage <-jitter(df$age)
#alllengths <-df$lenCls
if(i==1|dots$add==FALSE)
{
plot(df$age,df$lenCls,ylim=dots$ylim,xlim=dots$xlim,main=dots$main,sub=dots$sub,col=dots$col[i],
pch=dots$pch[i],cex.main=dots$cex.main,cex.axis=dots$cex.axis,cex.lab=dots$cex.lab,
axes=dots$axes,xlab=dots$xlab,ylab=dots$ylab,cex=dots$cex)
if(jitter)points(jitterage,df$lenCls,col=dots$col[i],pch=dots$pch[i],cex=dots$cex)
if(supsmu)suppressWarnings(lines(out[[i]] <-supsmu(df$age,df$lenCls,span=dots$span)
,col=dots$col.line[i],lwd=dots$lwd[i],lty=dots$lty[i]))
}

if(i>=2&dots$add==TRUE)
{
points(df$age,df$lenCls,col=dots$col[i],pch=dots$pch[i],cex=dots$cex)
if(jitter)points(jitterage,df$lenCls,col=dots$col[i],pch=dots$pch[i],cex=dots$cex)
if(supsmu)suppressWarnings(lines(out[[i]] <-supsmu(df$age,df$lenCls,span=dots$span)
,col=dots$col.line[i],lwd=dots$lwd[i],lty=dots$lty[i]))

}

}

# adding the outer margin title

fishname <-spp
if(fishname!="multiple species")
{
fishname <- as.character(ASFIS$English_name[ASFIS$Scientific_name == spp])
}
if(title)
{
title(paste("Length given Age for ",fishname," by ",by,

sep=""),outer=TRUE,line=-1,cex.main=dots$cex.main)
}
if(!is.null(out))names(out) <-varlevs
invisible(out)
}

#--------------end of agelenPlot--------------------------------------------


source("utils/rtools.r");

list.packages = c("VennDiagram", "ComplexHeatmap", "circlize", "RColorBrewer", "measurements", "svglite", "stringr", "jsonlite", "base64enc", "Rcpp")
install_missing(list.packages, github=c("ComplexHeatmap"="jokergoo/ComplexHeatmap"))

sourceCpp('utils/parseParams.cpp')

mm2in <- 0.0393701;

params <- list(
	wantedCol="x_OfSpectra",
	vennImgSize = 2800,
	heatmapcount = 64,
	linespacing = 1.5,
	heatmapcolors = list("blue", "white", "red"),
	vennCutoff = 0.05 # the proportion of the max in the test groups at which it cuts off including the other rows; threshold between counted/not in venn
)

params <- mergeList(parseParams('vennclustermap.r'), params);
# print(params)

colors <- colorRamp2(c(0, params$heatmapcount/2, params$heatmapcount), params$heatmapcolors)(seq(0, params$heatmapcount));

futile.logger::flog.threshold(futile.logger::ERROR, name = "VennDiagramLogger");

if (!('name' %in% names(params))) {
	params$name <- readInput("dataset name:");
}

homedir <- fileExists(file.path("Results",params$name), paste("Dataset", params$name, "cannot be found. Please run combinedHM to generate HeatMap data before this program is run."));

setwd(homedir);

fids <- read.csv("fileIDs.csv");

dataset.groupids <- unique(fids$Test_Group) #unique test groups
if (length(dataset.groupids) <= 8) {
	palette <- brewer.pal(8, "Pastel2")[1:length(dataset.groupids)]
}
# if (length(dataset.groupids) == 1){
# 	print("Not enough test groups to compare!")
# 	stopQuietly();
# }

hms <- list.files(path="HeatMap/Files"); #All heatmaps generated

# Disable Rplots.pdf from generating;
pdf(NULL)

jsonData <- list(VennDiagram = list(), ClusterHeatMap = list())

parsedHM <- str_match(hms, "(.+)\\.csv")[,2]

# Function to autogen heatmap

genHM.rowgp <- gpar(fontsize = 7);
genHM.colgp <-gpar(fontsize = 7);

genHM.minwidth <- unit(6, "cm");
genHM.minheight <- unit(10, "cm");

# Helper function to generate a heatmap given name
genHM <- function(loc, name, data, fnum){

	message(paste('Generating Heatmap', name))
	# use percentilism

	rankdata <- apply(data,2,rank, na.last = "keep", ties.method = "max")

	hmheight <- max(max_text_height(
	    rownames(rankdata),
	    gp = genHM.colgp
	  )*params$heatmapcount*params$linespacing, genHM.minheight)
	rowhmheight <- max_text_height(
	    rownames(rankdata),
	    gp = genHM.rowgp
	  )

	hm2 <- Heatmap(
		rankdata[,1:fnum],
		name="File Id",
		column_title="File Id",
		row_title="Peptide Rank",
		col=colors,
		row_names_gp = genHM.rowgp,
		column_names_gp = genHM.colgp,
		width = max(rowhmheight*fnum*params$linespacing, genHM.minwidth),
		height=hmheight
	)+Heatmap(
		rankdata[,(fnum+1):NCOL(rankdata)],
		name="Test Group",
		column_title="Test Group",
		col=colors,
		row_names_gp = genHM.rowgp,
		column_names_gp = genHM.colgp,
		width = max(rowhmheight*(NCOL(rankdata)-fnum)*params$linespacing, genHM.minwidth),
		height=hmheight
	)
	hm2plot <- draw(hm2)

	hm.colOrder <- column_order(hm2);
	names(hm.colOrder) <- NULL
	hm.colOrder <- c(hm.colOrder[[1]], sapply(hm.colOrder[[2]], function(x) x+length(dataset.groupids)))

	outfname <- file.path("ClusterHeatMap", paste(loc, name, sep='_'));
	write.csv(data[row_order(hm2),hm.colOrder], file=paste(outfname, 'csv', sep='.'), na="")
	# attr(plot, "layout")$page_size[1] <- attr(plot, "ht_list_param")$width

	hmw <- as.double(ComplexHeatmap:::width(hm2plot))*mm2in
	hmh <- as.double(ComplexHeatmap:::height(hm2plot))*mm2in
	# print(hmw)
	# print(conv_unit(303.1907, "mm", "inch"))
	outsvg <- stringSVG(print(hm2plot),
		width=hmw,
		height=hmh)
	write(outsvg, file= paste(outfname, "svg", sep="."))

	return(list(name=name, data=as.character(outsvg)))
}

for(hmid in 1:length(hms)){
	hm <- hms[hmid]
	f <- read.csv(file.path("HeatMap", "Files", hm));

	f <- f[Reduce("&", list(f$Row_Type==1, f$Contaminant == 0)), ]; #take only uncontamiated classes
	# f <- f[f$contaminant==0,]

	groups <- getGroups(f, fids, dataset.groupids);

	# groups <- matrix(0L, nrow=NROW(f),ncol=length(dataset.groupids)); # get final test groups averaged
	# for(x in 1:length(dataset.groupids)){
	# 	fnames <- fids$ID[fids$Test_Group==dataset.groupids[x]] # get file ids in this group
	# 	colnames <- paste("x_OfSpectra", fnames, sep="_");
	# 	selected <- f[,colnames];
	# 	if (NCOL(selected) > 1){
	# 		selected <- rowMeans(selected, na.rm=TRUE);
	# 	}
	# 	groups[,x] = selected;
	# }

	if (length(dataset.groupids) > 1){
		maxgroup <- apply(groups, 1, function(x) max(x, na.rm=TRUE));
	}else{
		maxgroup <- groups;
	}

	dir.create("VennDiagram", showWarnings = FALSE)
	dir.create("ClusterHeatMap", showWarnings = FALSE)

	rownames(f) <- f$Rank_Number #save ranks of each
	f.geneNames <- f[,c("Rank_Number", "Gene_Name")] #save gene names
	f <- f[,paste(params$wantedCol, fids$ID, sep="_")]
	colnames(f) <- fids$ID;

	colnames(groups) <- dataset.groupids;

	combinedf <- data.matrix(cbind(f, groups))

	# Return TRUE if include, FALSE if not (or any other truthy/falsey value)
	hm.prefunctions <- list(
		"ranks"=function(i, data) TRUE, # just include all
		"stdev"=function(i, data) i<NROW(data)/10, # top 10% by rank
		"coeffvar"=function(i, data) i<NROW(data)/10 # same as above
	)

	# Return a value by which to sort the list (low->high)
	hm.functions <- list(
		"ranks"=function(i, data) i, # sort by rank
		"stdev"=function(i, data) -sd(data[i,], na.rm=TRUE), # negative is used because rank() puts low number with the highest rank (lowest # rank)
		"coeffvar"=function(i, data) -cv(data[i,], na.rm=TRUE) # same as above but with coeff of variation
	)

	hm.list <- list()

	for(hm.name in names(hm.functions)){
		hm.func <- function(i, data){
			if(hm.prefunctions[[hm.name]](i, data)){ # if prefunction says to include, return parsed value
				return(hm.functions[[hm.name]](i, data))
			}
			return(NA) # return NA if it shouldnt be included (will be put last)
		}
		data <- sapply(1:NROW(combinedf), hm.func, combinedf) # get sort order first
		data <- data[!is.na(data)] # remove NAs (things that we dont want to include)
		data <- combinedf[rank(data, ties.method = "first"),] # convert list of sorted to actual data
		data <- data[1:min(NROW(data), params$heatmapcount),] # take the first <params$heatmapcount> so the table isnt too big

		hm.list[[length(hm.list)+1]] <- genHM(parsedHM[hmid], paste(hm.name, 'ids', sep='_'), data, NCOL(f))
		rownames(data) <- sapply(rownames(data), function(v) f.geneNames[f.geneNames$Rank_Number==as.numeric(v),"Gene_Name"])
		hm.list[[length(hm.list)+1]] <- genHM(parsedHM[hmid], paste(hm.name, 'names', sep='_'), data, NCOL(f))
	}

	jsonData[['ClusterHeatMap']][[hmid]] <- list(name=parsedHM[hmid], sheets=hm.list);

	# for sets of >10, generating overlap data will not only take too long but also be virtually useless due to 2^n possible overlap configs
	if (length(dataset.groupids) > 10){
		message("Number of test groups exceeds 10. Overlap data and Venn Diagram images will not be calculated.")
		next
	}

	# create sets for venn diagram later usage
	sets <- sapply(1:length(dataset.groupids), function(x) which(compareNA(groups[,x]>params$vennCutoff*maxgroup)));

	# calculate overlap sections of the venn diagram
	cnames <- recursiveBinary(length(dataset.groupids));
	overlap <- replicate(length(cnames), c())
	names(overlap) <- cnames;

	# loop through each protein and assign it to the right section
	for(prot in 1:NROW(combinedf)){
		p.x <- paste(sapply(sets, function(set) as.numeric(is.element(prot, set))), collapse="")
		overlap[[p.x]][[length(overlap[[p.x]])+1]] <- prot
	}

	# convert list of vectors with different lengthsto a dataframe
	max_l <- max(lengths(overlap));
	# overlap <- as.data.frame(matrix(unlist(lapply(overlap, 'length<-', max_l)), nrow=max_l))
	overlap <- do.call(cbind, lapply(overlap, 'length<-', max_l))

	# Replace NA values with empty
	overlap <- data.frame(apply(overlap, c(1, 2), function(x) ifelse(is.na(x), "", x)));

	# ifelse(v=="", "", f.geneNames[f.geneNames$Rank_Number==v,"Gene_Name"])

	# convert list of IDs to names
	overlapnames <- data.frame(apply(overlap, c(1,2), function(v) ifelse(v=="", "", as.character(f.geneNames[f.geneNames$Rank_Number==as.numeric(v),"Gene_Name"]))))

	# add venn diagram data to json
	jsonData[['VennDiagram']][[hmid]] <- list(
		Name=parsedHM[hmid],
		raw = list(
			Id=overlap,
			Name=overlapnames
		)
	)

	#maximum length of any of the venn diagram areas (used to equalize for saving to csv)

	# save id and name csv files
	message("Saving Venn Diagram Raws")
	write.csv(overlap, file=file.path("VennDiagram", paste(parsedHM[hmid], "_ids.csv", sep="")), na = "");
	write.csv(overlapnames, file=file.path("VennDiagram", paste(parsedHM[hmid], "_names.csv", sep="")), na = "");

	# too many datasets to generate venn diagram
	if (length(sets) > 5){
		message("Number of test groups exceeds 5, the maximum number for the venn diagram. As a result, no venn diagram image will be generated.")
		next
	}

	outfname <- paste(unlist(strsplit(hm, ".", fixed=TRUE))[1], "png", sep=".");

	venn.diagram(
		x = sets,
		category.names = paste("Testgroup_", dataset.groupids, sep=""),
		filename = file.path("VennDiagram", outfname),
		output=TRUE,

		# Output features
		imagetype="png",
		height = params$vennImgSize,
		width = params$vennImgSize,
		resolution = 300,
		compression = "lzw",
		units = 'px',

		# Circles
    lwd = 2,
    lty = 'solid',
    fill = palette,

    # Numbers
    cex = 0.6,
    fontface = "bold",
    fontfamily = "sans",

    # Set names
    cat.cex = 0.6,
    cat.fontface = "bold",
    cat.fontfamily = "sans",
    cat.default.pos = "outer"
	)
	message("Saving Venn Diagram Image")
	jsonData[['VennDiagram']][[hmid]][['img']] <- paste("<img src=\"",
							dataURI(mime = "image/png", encoding = "base64", file = file.path("VennDiagram", outfname)),
							"\" class=\"vennImg\" alt=\"Venn Diagram\"/>", sep="")
}

# save json raw file
message("Saving Final JSON Raw")
write(toJSON(jsonData, auto_unbox=TRUE), file=file.path("Raws", "vennclustermap.json"));