library(rstan)
library(data.table)
library(lubridate)
library(gdata)
library(dplyr)
library(tidyr)
library(EnvStats)
library(scales)
library(stringr)

process_covariates <- function(states, mobility, intervention = NULL,
                               interventions_lifted  = readRDS('usa/data/covariates_ended.RDS'),
                               death_data, ifr_by_state,
                               num_days_sim, interventions, formula,
                               formula_partial_regional, formula_partial_state){
  # Read in serial interval
  serial_interval = read.csv("data/serial_interval.csv")

  pad_serial.interval <- data.frame(
    "X"=(length(serial_interval$fit)+1):200,
    "fit"=rep(1e-17, 200)
  )
  serial_interval = rbind(serial_interval, pad_serial.interval)

  ## read population
  df_pop <- readRDS("usa/data/us_population.rds")
  df_pop <- df_pop[which(!is.na(df_pop$code)),]

  # various distributions required for modelling
  mean1 <- 5.1; cv1 <- 0.86; # infection to onset
  mean2 <- 17.8; cv2 <- 0.45 # onset to death
  x1 <- rgammaAlt(1e6,mean1,cv1) # infection-to-onset distribution
  x2 <- rgammaAlt(1e6,mean2,cv2) # onset-to-death distribution
  f_cached <- ecdf(x1+x2) # empirical cumulative distribtion function

  dates <- list()
  reported_cases <- list()
  reported_deaths <- list()
  stan_data <- list(M = length(states), # Number of states
                    N0 = 6, # Number of days in seeding
                    N = NULL, # Number of time points with data
                    N2 = NULL, # Number of time points with data plus forecast
                    cases = NULL, # daily cases
                    deaths =  NULL, # daily deaths
                    f = NULL, # Hazard times survival
                    X = NULL, # Covariates
                    P = NULL, # Number of covariates
                    SI = serial_interval$fit[1:num_days_sim], # Serial interval fit
                    EpidemicStart = NULL, # Date to start epidemic in each state
                    pop = NULL,
                    Q = NULL,
                    Region = NULL,
                    Pop_density = NULL) # state population

  covariate_list <- list()
  covariate_list_partial_regional <- list()
  covariate_list_partial_state <- list()

  k=1
  # same_mobility_states <- c('ME','VT','CT','NJ','MA','RI','NH','PA')
  same_mobility_states <- c('CT')
  # states for transit
  transit_states <- c('NY', 'DC', 'MA', 'CA', 'WA', 'IL', 'MD', 'NJ')
  colnames(interventions_lifted) <- c("StatePostal_lif", "EmergDec_lif", "GathRecomAny_lif", "GathRestrictAny_lif",
                                      "OtherBuisnessClose_lif", "Quarantine_lif", "RestaurantRestrict_lif", "SchoolClose_lif", "StayAtHome_lif")
  interventions_lifted$April1 = as.Date("2020-04-01")
  for(State in states) {
    # Selects correct IFR for each country
    ifr_state <- ifr_by_state$ifr[ifr_by_state$code == State]
    # Selects correct Interventions for each region
    intervention_state <- interventions[interventions$StatePostal == State, c(2:9)]
    # Selects correct Interventions Lifted for each region
    intervention_lifted_state <- interventions_lifted[interventions_lifted$StatePostal == State, c(2:10)]
    # Selects mobility data for each state
    covariates_state <- mobility[which(mobility$code == State),]
    # checking if states part of same mobility
    # if (State %in% same_mobility_states){
    #   # covariates_state <- mobility[which(mobility$code == 'NY'),]
    #   intervention_state <- interventions[interventions$StatePostal == 'NY', c(2:7)]
    # }
    # Selects population for each state
    pop_state <-  df_pop[df_pop$code==State, names(df_pop) == "Total"][[1]]
    # Subsets data by state
    data_state <- death_data[death_data$code == State,]
    # Maks dates numeric
    data_state$t <- decimal_date(data_state$date)
    # Sorts data into time order
    data_state <- data_state[order(data_state$t),]

    # Selects index when first case
    index <- which(data_state$daily_cases > 0)[1]
    index1 <-  which(data_state$cumulative_deaths >= 10)[1] # also 5
    if(is.na(index1)) {
      index1 <-  which(data_state$cumulative_deaths >= 5)[1]
    }
    index2 <- index1 - 30 # was 30. need more thought on this
    print(sprintf("First non-zero cases is on day %d, and 30 days before 10 deaths is day %d",
                  index, index2))

    # Works out state start point
    data_state <- data_state[index2:nrow(data_state),]
    # Work out how much padding need at end
    N <- length(data_state$daily_cases)
    forecast_length <- num_days_sim - N[[1]]
    print(sprintf("%s has %d days of data. Forecasting %d days", State, N, forecast_length))
    if(forecast_length < 0) {
      stop('num_days_sim is not long enough to model all data.  Increase forecast')
    }

    # IFR is the overall probability of dying given infection
    convolution = function(u) (ifr_state * f_cached(u))

    f = rep(0,num_days_sim) # f is the probability of dying on day i given infection
    f[1] = (convolution(1.5) - convolution(0))
    for(i in 2:num_days_sim) {
      f[i] = (convolution(i+.5) - convolution(i-.5))
    }

    deaths <- c(data_state$daily_deaths, rep(-1,forecast_length))
    cases <- c(data_state$daily_cases, rep(-1,forecast_length))

    # Format the interventions
    # Find minimum date for the data
    min_date <- min(data_state$date)
    num_pad <- (min(covariates_state$date) - min_date[[1]])[[1]]
    len_mobility <- ncol(covariates_state)
    padded_covariates <- pad_mobility(len_mobility, num_pad, min_date, covariates_state, forecast_length, data_state, State)
    # Indexes 1 or 0 if intervention has occured
    for (ii in 1:ncol(intervention_state)) {
      covariate <- names(intervention_state)[ii]
      data_state[covariate] <- (data_state$date >= intervention_state[1,covariate])*1  # should this be > or >=?
    }
    # Indexes 1 or 0 if intervention lifted
    for (ii in 1:ncol(intervention_lifted_state)) {
      covariate <- names(intervention_lifted_state)[ii]
      data_state[covariate] <- (data_state$date >= intervention_lifted_state[1,covariate])*1  # should this be > or >=?
    }
    # Extend covariates to cover forecast
    covariates_forecast <- as.data.frame(data_state[, colnames(intervention_state)])
    covariates_forecast[N:(N + forecast_length),] <- covariates_forecast[N,]
    covariates_forecast[is.na(covariates_forecast)] <- 0
    # Extend covariates_lifted to cover forecast
    covariates_lifted_forecast <- as.data.frame(data_state[, colnames(intervention_lifted_state)])
    covariates_lifted_forecast[N:(N + forecast_length),] <- covariates_lifted_forecast[N,]
    covariates_lifted_forecast[is.na(covariates_lifted_forecast)] <- 0
    # Transit covariate
    if(State %in% transit_states){
      transit_usage <- rep(1, (N + forecast_length) )
    } else{
      transit_usage <- rep(0, (N + forecast_length) )
    }
    # creating features
    df_features <- create_features(len_mobility, padded_covariates, covariates_forecast, covariates_lifted_forecast, transit_usage)
    features <- model.matrix(formula, df_features)
    features_partial_regional <- model.matrix(formula_partial_regional, df_features)
    features_partial_state <- model.matrix(formula_partial_state, df_features)

    covariate_list[[k]] <- features
    covariate_list_partial_regional[[k]] <- features_partial_regional
    covariate_list_partial_state[[k]] <- features_partial_state
    k <- k+1

    ## Append data to stan data
    stan_data$y <- c(stan_data$y, data_state$daily_cases[1]) # just the index case!
    stan_data$EpidemicStart <- c(stan_data$EpidemicStart, index1 + 1 - index2)
    stan_data$pop <- c(stan_data$pop, pop_state)
    stan_data$f <- cbind(stan_data$f,f)
    stan_data$deaths <- cbind(stan_data$deaths, deaths)
    stan_data$cases <- cbind(stan_data$cases, cases)
    stan_data$N2 <- num_days_sim
    stan_data$N <- c(stan_data$N, N)
    stan_data$Region <- c(stan_data$Region, data_state$region_code[1])
    stan_data$Pop_density <- c(stan_data$Pop_density, log(data_state$pop_density[1]))

    # Saves other data for each state
    dates[[State]] <- data_state$date
    reported_cases[[State]] <- data_state$daily_cases
    reported_deaths[[State]] <- data_state$daily_deaths
  }

  stan_data$P = dim(features)[2]
  stan_data$X = array(NA, dim = c(stan_data$M , stan_data$N2 ,stan_data$P ))
  stan_data$P_partial_regional = dim(features_partial_regional)[2]
  stan_data$P_partial_state = dim(features_partial_state)[2]
  if(stan_data$P_partial_regional==0){
    stan_data$X_partial_regional = array(0, dim = c(stan_data$M , stan_data$N2, 1))
  }
  else{
    stan_data$X_partial_regional = array(NA, dim = c(stan_data$M , stan_data$N2 ,stan_data$P_partial_regional))
  }
  if(stan_data$P_partial_state==0){
    stan_data$X_partial_state = array(0, dim = c(stan_data$M , stan_data$N2, 1))
  }
  else{
    stan_data$X_partial_state = array(NA, dim = c(stan_data$M , stan_data$N2 ,stan_data$P_partial_state))
  }

  for (i in 1:stan_data$M){
    stan_data$X[i,,] = covariate_list[[i]]
    if(stan_data$P_partial_regional != 0)
      stan_data$X_partial_regional[i,,] = covariate_list_partial_regional[[i]]
    if(stan_data$P_partial_state != 0)
      stan_data$X_partial_state[i,,] = covariate_list_partial_state[[i]]
  }
  if(stan_data$P_partial_regional == 0)
    stan_data$P_partial_regional = 1
  if(stan_data$P_partial_state == 0)
    stan_data$P_partial_state = 1
  stan_data$Pop_density <- scale(stan_data$Pop_density )[,1]
  stan_data$Q <- max(stan_data$Region)
  stan_data$W <- ceiling(stan_data$N2/7)
  stan_data$week_index <- matrix(1,stan_data$M,stan_data$N2)
  for(state.i in 1:stan_data$M) {
    stan_data$week_index[state.i,] <- rep(2:(stan_data$W+1),each=7)[1:stan_data$N2]
    last_ar_week = which(dates[[state.i]]==max(death_data$date) -28)
    stan_data$week_index[state.i,last_ar_week:ncol(stan_data$week_index)] <-  stan_data$week_index[state.i,last_ar_week]
  }
  return(list("stan_data" = stan_data, "dates" = dates, "reported_cases" = reported_cases,
              "reported_deaths" = reported_deaths))
}

pad_mobility <- function(len_mobility, num_pad, min_date, covariates_state, forecast_length, data_state, State){
  if (num_pad <= 0){
    covariates_state <- covariates_state[covariates_state$date >=min_date, ]
    pad_dates_end <- max(covariates_state$date) +
      days(1:(forecast_length - (min(data_state$date) - min(covariates_state$date)) +
                (max(data_state$date) - max(covariates_state$date))))
    for_length <- length(pad_dates_end)

    len_covariates <- length(covariates_state$grocery.pharmacy)
    padded_covariates <- data.frame("code" = rep(State, length(covariates_state$date) + for_length),
                                    "date" = c(covariates_state$date, pad_dates_end),
                                    "grocery.pharmacy" = c(covariates_state$grocery.pharmacy,
                                                           rep(median(covariates_state$grocery.pharmacy[(len_covariates-7):len_covariates],na.rm = TRUE),
                                                               for_length)),
                                    "parks" = c(covariates_state$parks,
                                                rep(median(covariates_state$parks[(len_covariates-7):len_covariates],na.rm = TRUE), for_length)),
                                    "residential" = c(covariates_state$residential,
                                                      rep(median(covariates_state$residential[(len_covariates-7):len_covariates], na.rm = TRUE), for_length)),
                                    "retail.recreation" = c(covariates_state$retail.recreation,
                                                            rep(median(covariates_state$retail.recreation[(len_covariates-7):len_covariates],na.rm = TRUE),
                                                                for_length)),
                                    "transitstations" = c(covariates_state$transitstations,
                                                          rep(median(covariates_state$transitstations[(len_covariates-7):len_covariates], na.rm = TRUE),
                                                              for_length)),
                                    "workplace" = c(covariates_state$workplace,
                                                    rep(median(covariates_state$workplace[(len_covariates-7):len_covariates], na.rm = TRUE), for_length)))

  } else {
    pad_dates_front <- min_date + days(1:num_pad-1)
    pad_dates_end <- max(covariates_state$date) +
      days(1:(forecast_length + (max(data_state$date) - max(covariates_state$date))))
    for_length <- length(pad_dates_end)

    len_covariates <- length(covariates_state$grocery.pharmacy)
    padded_covariates <- data.frame("code" = rep(State, num_pad + length(covariates_state$date) + for_length),
                                    "date" = c(pad_dates_front, covariates_state$date, pad_dates_end),
                                    "grocery.pharmacy" = c(as.integer(rep(0, num_pad)), covariates_state$grocery.pharmacy,
                                                           rep(median(covariates_state$grocery.pharmacy[(len_covariates-7):len_covariates], na.rm = TRUE),
                                                               for_length)),
                                    "parks" = c(as.integer(rep(0, num_pad)), covariates_state$parks,
                                                rep(median(covariates_state$parks[(len_covariates-7):len_covariates],na.rm = TRUE), for_length)),
                                    "residential" = c(as.integer(rep(0, num_pad)), covariates_state$residential,
                                                      rep(median(covariates_state$residential[(len_covariates-7):len_covariates], na.rm = TRUE),
                                                          for_length)),
                                    "retail.recreation" = c(as.integer(rep(0, num_pad)), covariates_state$retail.recreation,
                                                            rep(median(covariates_state$retail.recreation[(len_covariates-7):len_covariates], na.rm = TRUE),
                                                                for_length)),
                                    "transitstations" = c(as.integer(rep(0, num_pad)), covariates_state$transitstations,
                                                          rep(median(covariates_state$transitstations[(len_covariates-7):len_covariates], na.rm = TRUE),
                                                              for_length)),
                                    "workplace" = c(as.integer(rep(0, num_pad)), covariates_state$workplace,
                                                    rep(median(covariates_state$workplace[(len_covariates-7):len_covariates], na.rm = TRUE),
                                                        for_length)))

  }

  return(padded_covariates)
}

create_features <- function(len_mobility, padded_covariates, covariates_forecast, covariates_lifted_forecast, transit_usage){
    return (data.frame('school' = covariates_forecast$SchoolClose, 'emergency' = covariates_forecast$EmergDec,
               'stayHome' = covariates_forecast$StayAtHome, 'quarantine' = covariates_forecast$Quarantine,
               'gatherRestrict' = covariates_forecast$GathRestrictAny,
               'business' = covariates_forecast$OtherBusinessClose, "restaurant" = covariates_forecast$RestaurantRestrict,
               'firstIntervention' = 1*((covariates_forecast$SchoolClose+
                                           covariates_forecast$StayAtHome+
                                           covariates_forecast$GathRestrictAny+
                                           covariates_forecast$StayAtHome+
                                           covariates_forecast$OtherBusinessClose+
                                           covariates_forecast$RestaurantRestrict) >= 1),
               'school_lifted' = covariates_lifted_forecast$SchoolClose_lif, 'emergency_lifted' = covariates_lifted_forecast$EmergDec_lif,
               'stayHome_lifted' = covariates_lifted_forecast$StayAtHome_lif, 'quarantine_lifted' = covariates_lifted_forecast$Quarantine_lif,
               'gatherRestrict_lifted' = covariates_lifted_forecast$GathRestrictAny_lif,
               'business_lifted' = covariates_lifted_forecast$OtherBuisnessClose_lif,
               "restaurant_lifted" = covariates_lifted_forecast$RestaurantRestrict_lif,
               "April1" = covariates_lifted_forecast$April1,
               'firstIntervention_lifted' = 1*((covariates_lifted_forecast$SchoolClose_lif+
                                                  covariates_lifted_forecast$EmergDec_lif+
                                                  covariates_lifted_forecast$StayAtHome_lif+
                                                  covariates_lifted_forecast$Quarantine_lif+
                                                  covariates_lifted_forecast$GathRestrictAny_lif+
                                                  covariates_lifted_forecast$OtherBuisnessClose_lif+
                                                  covariates_lifted_forecast$RestaurantRestrict_lif) >= 1),
               'transit_use' = transit_usage,
               'residential' = padded_covariates$residential,
               'transit' = padded_covariates$transitstations,
               'grocery' = padded_covariates$grocery.pharmacy,
               'parks' = padded_covariates$parks,
               'retail' =padded_covariates$retail.recreation,
               'workplace' = padded_covariates$workplace,
               'averageMobility' = rowMeans(padded_covariates[,c("grocery.pharmacy", "retail.recreation", "workplace")],
                                            na.rm=TRUE))
            )
}


#######DESCRIPTION###############################
#processes area, prcp, et, qavg table for use as weights in
#rating curve fits
#outputs rdata object and csv
#################################################
##load libraries
library(dplyr)
library(data.table)
library(stringr)
library(tidyr)
library(readr)

##user inputs
#processed data location
dir_dat = '/Volumes/gonggong/flood forecasting/data/'
#reference table location
dir_ref = '/Volumes/gonggong/flood forecasting/data/reference tables/'

##read in data
stage_weight = fread(file.path(dir_ref, 'qavg_normalizing_coef.csv'))
stage_topology = readRDS(file.path(dir_ref, 'stage_topology_tbl.rda'))

##process data
stage_weight = stage_weight %>% dplyr::rename(sta_id = gage_names) %>% dplyr::select(sta_id, area, prcp, et, Qavg)
stage_weight_us = stage_weight %>% dplyr::rename(sta_id_us = sta_id, area_us = area, prcp_us = prcp, et_us = et, Qavg_us = Qavg)
stage_weight = stage_topology %>% left_join(stage_weight)
stage_weight = stage_weight %>% left_join(stage_weight_us)
stage_weight = stage_weight %>% dplyr::mutate(scale = Qavg_us / Qavg)

##save processed tables
saveRDS(stage_weight, paste0(dir_ref, 'stage_weight_tbl.rda'))
write.csv(stage_weight, paste0(dir_ref, 'stage_weight_tbl.csv'), row.names = F)


#' @useDynLib kazaam R_add1
add1 = function(x) .Call(R_add1, x)

#' @useDynLib kazaam R_memcpy
memcpy = function(dest, src) .Call(R_memcpy, dest, src)

get_numbefore = function(x)
{
  allm.local = unlist(pbdMPI::allgather(nrow(DATA(x))))
  numbefore = c(0, cumsum(allm.local)[1:(length(allm.local)-1)])
  numbefore[comm.rank() + 1L]
}

get_random_seed = function()
{
  if (comm.rank() == 0)
    seed = bitwXor(Sys.getpid(), as.integer(Sys.time()))
  else
    seed = 0L

  MPI_Allreduce(seed)
}

#' @useDynLib kazaam R_km_assign
km.assign = function(x, centers, labels)
{
  .Call(R_km_assign, DATA(x), centers, labels)
}

#' @useDynLib kazaam R_km_update
km.update = function(x, centers, labels)
{
  comm_ptr = pbdMPI::get.mpi.comm.ptr(.pbd_env$SPMD.CT$comm)
  .Call(R_km_update, DATA(x), centers, labels, comm_ptr)
}

# take random points from x
km.init = function(x, k, numbefore)
{
  m = nrow(x)
  m.local = nrow(DATA(x))

  rows = sort(sample(1:m, size=k, replace=FALSE))
  centers.rows.local = numbefore < rows & rows <= numbefore+m.local

  x.local.ind = rows[which(centers.rows.local)] - numbefore
  centers.local = t(DATA(x)[x.local.ind, ])

  centers = matrix(0, ncol(x), k)
  centers[, centers.rows.local] = centers.local
  MPI_Allreduce(centers)
}

#' km
#'
#' k-means via Lloyd's Algorithm.
#'
#' Note that the function does not respect \code{set.seed()} or
#' \code{comm.set.seed()}.  For managing random seeds, use the \code{seed}
#' parameter.
#'
#' @details
#' The iterations stop either when the maximum number of iterations have been
#' achieved, or when the centers in the current iteration are basically the same
#' (within \code{1e-8}) as the centers from the previous iteration.
#'
#' For best performance, the data should be as balanced as possible across all
#' MPI ranks.
#'
#' @section Communication:
#' Most of the computation is local. However, at each iteration there is a
#' length \code{n*k} and a length \code{k} allreduce call to update the centers.
#' There is also a check at the beginning of the call to find out how many
#' observations come before the current process's data, which is an allgather
#' operation.
#'
#' @param x
#' A shaq.
#' @param k
#' The 'k' in k-means.
#' @param maxiter
#' The maximum number of iterations possible.
#' @param seed
#' A seed for determining the (random) initial centroids.  Each process has to
#' use the same seed or very strange things may happen.  If you do not provide
#' a seed, a good initial seed will be chosen.
#'
#' @return
#' A list containing the cluster centers (global), the observation labels i.e.
#' the assignments to clusters (distributed shaq), and the total number of
#' iterations (global).
#'
#' @examples
#' \dontrun{
#' suppressMessages(library(kazaam))
#' set.seed(1234)
#'
#' m.local = 10
#' n = 2
#' k = comm.size()
#' data = matrix(rnorm(m.local*n, mean=10*comm.rank()), m.local, n)
#' x = shaq(data)
#'
#' cl = km(x, k=k)
#' cl
#'
#' finalize()
#' }
#'
#' @references
#' Phillips, J.. Data Mining: Algorithms, Geometry, and Probability.
#' https://www.cs.utah.edu/~jeffp/DMBook/DM-AGP.html
#'
#' @export
km = function(x, k=2, maxiter=100, seed=get_random_seed())
{
  pbdMPI::comm.set.seed(seed, diff=FALSE)

  if (!is.double(DATA(x)))
    storage.mode(DATA(x)) = "double"

  numbefore = get_numbefore(x)

  centers = km.init(x, k, numbefore)
  centers.old = matrix(0.0, nrow(centers), ncol(centers))
  memcpy(centers.old, centers)

  labels = integer(nrow(DATA(x)))
  km.assign(x, centers, labels)

  for (iter in 1:maxiter)
  {
    km.update(x, centers, labels)
    km.assign(x, centers, labels)

    if (isTRUE(all.equal(centers, centers.old)))
      break

    memcpy(centers.old, centers)
  }

  add1(labels)

  labels.shaq = shaq(matrix(labels), ncols=1L, checks=FALSE)
  list(centers=centers, labels=labels.shaq, iterations=iter)
}


# Bilan hydrique d'une vigne enherb?e
# X.Delpuech (IFV) d'apres F.Celette, A. Ripoche, 2009
# S.Roux : quelques modifications pour param?trage, lisibilit?
#######################

###############################
# DEFINITION DES SOUS-FONCTIONS

#######
#  Fonction Somme de temp?rature base  cumsumb(vecteur temp?rature, base, ligne de d?but, ligne de fin)
#  base : definit la valeur de base pour la somme des temp?ratures, par d?faut = 10
#  x : definit le vecteur d'entr?e
#  debut : definit la ligne de debut du calcul, par d?faut = 1
#  fin : definit la ligne de fin du calcul, par d?faut la derni?re ligne de x

cumsumb<-function(x,base=10,debut=1,fin=length(x))
{
	somTb<-vector(mode="numeric",length = length(x)) #cree un vecteur vide du m?me nombre de ligne que le vecteur d'entr?e x
	ifelse (x[debut]>base,somTb[debut]<-(x[debut]-base),somTb[debut]<-0)  # Calcul la premi?re valeur de la somme de Temp en base
	for (i in (debut+1):fin)
	{
		ifelse (x[i]>base, somTb[i]<-(somTb[i-1]+x[i]-base), somTb[i]<-somTb[i-1])
	}   # Calcul des SomTb de la ligne 2 ? la fin des donn?es m?t?o
	return(somTb)
}

########
# Fonctions calcul du seuil de ruissellement  Sr(CN)

# Fonction calcul du seuil de ruissellement (p5j,cn2,p5j1,p5j2)
SeuilR<-function(p5j,cn2,p5j1,p5j2)
{
	cn1 = (4.2*cn2)/(10-0.058*cn2)
	cn3 = (23*cn2)/(10+0.13*cn2)

	#calcul du seuil de ruissellement
	if (p5j<p5j1)
		res = 254*(100/cn1-1)
	else {
		if (p5j>p5j2)
			res = 254*(100/cn3-1)
		else
			res = 254*(100/cn2-1)
	}
	return(res)

}

# Fonction calcul du ruissellement Rs(pluie,seuil ruissellement)
Ruiss<-function(P,sr) # P = pluie en mm , sr = seuil de ruissellement
{
	if (P<0.2*sr) y<-0
	else y<-((P-0.2*sr)^2/(P+0.8*sr))
	return (y)
}
###############################
# param?trage par defaut

nominal=list(p=0.6,
		Tonte="N", 							# caractere {O,N} d'activation des tontes aux dates prevues (renint LAI)(si "N", tontes automatique /LAI)
		nbtonte=c(2,2,2,0,0,0,0), 			# D?finit le nombre de tonte chaque ann?e de simulation
		inn=0.3, 							# D?finit l?INN de l?herbe
		irri="N", 							# caractere {O,N} d'activation de l?irrigation qui branche la colonne "IR" du fichier meteo
		dtonte=rep("29/03",10), 			# date des tontes activ? par le parametre "Tonte"
		dbr=rep("26/03",10), 				# dates de d?marrage de la v?g?tation de la vigne (en nombre >=sup?rieur ou ?gal au nombre d?ann?es simul?es)
		arretTr="01/11", 					# date d?arr?t de transpiration de la vigne
		ddkmax=600, 						# nombre de degr? jour pour atteindre le Kmax
		reinit="N",							# caractere {O,N} pour reinitialiser les stocks d'eau en debut d'ann?e
		pir=0, 								# Permet d?attribuer un CN diff?rent (donn? par CN_Ruiss2)  ? l?inter-rang m?me en absence d?enherbement.
		seuilpeff=2,						# seuil de pluie efficace
		kmax=rep(0.43,10),					# coefficient d?interception du rayonnement de la vigne
		levee="01/01",						# date de lev?e de l?enherbement
		flagRuiss="O",						# utilisation du module de ruissellement "O" active
		CN_Ruiss=94,						# CN (ruissellement) sous le rang
		CN_Ruiss2=84,						# CN (ruissellement) dans l?inter-rang
		herblairate=0.9,					# LAI rate de l?enherbement
		LAIinit=0.5,						# LAI initial de l?enherbement
		LAIres=0.3,							# LAI r?siduel de l?enherbement apr?s une tonte
		LLSmin=700,							# LLSmin de l?herbe
		LAItonte=3,							# LAI ? partir duquel on d?clenche une tonte automatiquement
		U=2.7,								# param?tre U d??vaporation du sol
		b1_evap=14,							# param?tre b1_evap d??vaporation du sol
		b2_evap=0.15,						# param?tre b2_evap d??vaporation du sol
		FTSWhregultr=0.6,					# FTSW du compartiment herbe ? partir de laquelle l?herbe r?gule sa transpiration
		FTSWhregulLAI=0.9,					# FTSW du compartiment herbe ? partir de laquelle l?herbe r?gule son LAI
		TTSWh=129,							# TTSW du compartiment herbe
		TTSWv=224,							# TTSW du compartiment vigne
		FTSWvregulTR=0.4,					# FTSW du compartiment vigne ? partir de laquelle la vigne r?gule sa transpiration
		ASWhinit=70.92,						# quantit? d?eau dans le compartiment vigne en d?but de simulation
		ASWvinit=178.18,						# quantit? d?eau dans le compartiment herbe  en d?but de simulation
		format_date="%d/%m/%Y"    # format des dates dans le fichier m?t?o d'entr?e
		)

###############################
# FONCTION BH
walis.model.single<-function( param, meteo)
{

	###############################
	## FONCTION DE BILAN HYDRIQUE

	if(param$p!=0) param$pir<-param$p

	# DEFINITION PARAMETRE DU MODELE

	dat<-as.POSIXlt(strptime(meteo$Date,param$format_date))
	#
	# Nombre d'ann?e : "an" donne le nombre d'ann?es dans le fichier
  ans<-unique(dat$year)  # donne le vecteur des ann?es du fichier
  an<-length(ans)        # donne le nombre d'ann?e dans le fichier

	# jdeb donne les lignes de d?but de chaque ann?e
  jj<-as.POSIXlt(dat)$yday # vecteur des jours julien
  ll<-c(1:dim(meteo)[1]) # vecteur indice des lignes
  jdeb<-ll[jj==0]
  if (an>1 & jj[1]>1) jdeb=c(1,jdeb)
  jdeb[1]<-1  # au cas ou l'anne ne commence pas au 01/01
  jdeb[an+1]<-(dim(meteo)[1]+1)

	# Calcul des lignes correspondant aux dates du BH (avec cette m?thode, il y a un d?calage d'un jour les ann?es non bisextiles,
	#il faudrait rajouter les ann?es...)
	# la fonction as.POSIXlt()$yday donne le jour julien de la date
	leveejj		<-as.POSIXlt(as.Date(param$levee,"%d/%m"))$yday
	dbrjj		<-as.POSIXlt(as.Date(param$dbr,"%d/%m"))$yday
	arretTrjj	<-as.POSIXlt(as.Date(param$arretTr,"%d/%m"))$yday
	tontejj		<-as.POSIXlt(as.Date(param$dtonte,"%d/%m"))$yday
	Ldbr		<-c(1:an)
	Ltonte		<-c(1:sum(param$nbtonte[1:an]))

# Calcul des indices d?bourrement
# pour la premiere annee, si la date de debourrement est anterieure au premier jour du fichier
if ((dbrjj[1]-jj[1])<0)
{
dbrjj[1]<-jj[1] # for?age au premier jour
print ("Attention : date de dbr pour l'annee 1 forcee au 1er jour")
}
# au cas ou la date de debourrement est posterieure a la fin du fichier
for (i in 1:an)
{
if (max(jj[dat$year==ans[i]])-dbrjj[i]<0)   # si la date de dbr est posterieur a la fin du fichier
{
dbrjj[i]<-max(jj[dat$year==ans[i]])
print("Attention : date de dbr de la derniere annee forcee au dernier jour")
}
Ldbr[i]<-ll[dat$year==ans[i]&jj==dbrjj[i]]
}
# Calcul des indices levee de l'herbe
Llevee<-ll[jj==leveejj]
if (an>1 & jj[1]>leveejj) Llevee=c(1,Llevee)

# pour l'annee 1, il se peut que la date de lev?e soit ant?rieure au 1er jour de donn?es
# par exemple si le fichier ne d?marre pas au 01/01
	Llevee[1] <- leveejj[1]-strptime(meteo$Date[1],param$format_date)$yday
	if (Llevee[1]<0)
	{
		Llevee[1]<-1
		print("Attention : date de levee de l'herbe pour l'annee 1 forcee au premier jour")
	}

## pour l'arret de transpiration
# si le fichier meteo se termine avant la date d'arret
LarretTr<-c(1:an)
for (i in 1:an)
{
if (max(jj[dat$year==ans[i]])-arretTrjj<0)   # si la date d'arret Transpiration est posterieur a la fin du fichier
{
LarretTr[i]<-length(ll)
print("Attention : date d'arret de transpiration de la derniere annee forcee au dernier jour")
}
if (max(jj[dat$year==ans[i]])-arretTrjj>=0)
{
LarretTr[i]<-ll[dat$year==ans[i]&jj==arretTrjj]
}
}

# pour la premiere annee, si la date de tonte est anterieure au premier jour du fichier
for (i in 1:param$nbtonte[1])
{
if ((tontejj[i]-jj[1])<0)
{
tontejj[i]<-jj[1] # for?age au premier jour
print (paste("Attention : date de tonte n?",i," pour l'annee 1 forcee au 1er jour"))
}
}
i<-1
tt<-1
repeat
{
if (tt>an) break()
if (i>sum(param$nbtonte)) break()
if (max(jj[dat$year==ans[tt]])-tontejj[i]<0)
{
Ltonte[i]<-length(ll)
print(paste("Attention : forcage date de tonte n?",i," au dernier jour"))
}
if (max(jj[dat$year==ans[tt]])-tontejj[i]>0)
{
Ltonte[i]<-ll[dat$year==ans[tt]&jj==tontejj[i]]
}
i<-i+1
if (i>cumsum(param$nbtonte)[tt]) tt<-tt+1
}

	# Calcul des vecteurs somme de T?C
	somTb10	<-vector(mode="numeric",length = dim(meteo)[1])
	for (a in 1:an)
		somTb10<-(somTb10+cumsumb(meteo$Temp,debut=Ldbr[a], fin=(jdeb[a+1]-1)))

	#   Calcul de la Pluie efficace
	Peff<-vector(mode="numeric",length=dim(meteo)[1]) #creer un vecteur vide du meme nombre de ligne que meteo
	for (i in 1:dim(meteo)[1])
			ifelse (meteo$Pluie[i]>param$seuilpeff, Peff[i]<-meteo$Pluie[i],Peff[i]<-0) # si pluie >2mm, alors Peff = pluie, sinon =0

	# Calcul de la Peff pour l'enherbement et la vigne
	Peffh<-(Peff*param$p)
	Peffv<-(Peff*(1-param$p))

	#
	# Somme des pluies des 5 derniers jours
	P5j		<-vector(mode="numeric",length=dim(meteo)[1]) #vecteur vide
	P5j[1]	<-0
	for (i in 2:5)
	  P5j[i]	<-P5j[i-1] + meteo$Pluie[i-1]
	for (i in 6:dim(meteo)[1])
	  P5j[i]<-(meteo$Pluie[i-5]+meteo$Pluie[i-4]+meteo$Pluie[i-3]+meteo$Pluie[i-2]+meteo$Pluie[i-1])

	#
	# Calcul du ruissellement herbe (inter rang)
	Seuilrui<-vector(mode="numeric",length=dim(meteo)[1]) # vecteur vide
	Ruissh<-vector(mode="numeric",length=dim(meteo)[1])   #vecteur vide
	for (i in 1:dim(meteo)[1])  # attribution de la valeur de ruissellement en fonction de la pluie des 5 derniers jours
	{
		Seuilrui[i]<-SeuilR(P5j[i],param$CN_Ruiss2,35.6,53.3)
		Ruissh[i]<-Ruiss(meteo$Pluie[i],Seuilrui[i])*param$pir
		if (param$flagRuiss=="N") Ruissh[i]=0
	}

	# Calcul du seuil ruissellement vigne (rang)
	Seuilruiv<-vector(mode="numeric",length=dim(meteo)[1]) # vecteur vide
	Ruissv<-vector(mode="numeric",length=dim(meteo)[1]) #vecteur vide
	for (i in 1:dim(meteo)[1])  # attribution de la valeur de ruissellement en fonction de la pluie des 5 derniers jours
	{
		Seuilruiv[i]<-SeuilR(P5j[i],param$CN_Ruiss,12.7,28)
		Ruissv[i]<-Ruiss(meteo$Pluie[i],Seuilruiv[i])*(1-param$pir)
		if (param$flagRuiss=="N") Ruissv[i]=0
	}

	#
	# Calcul de la pluie efficace - le ruissellement inter-rang (herbe) et rang (vigne)
	Peffh_Ruiss<-(Peffh-Ruissh)
	Peffv_Ruiss<-(Peffv-Ruissv)

	# Part de l'ETP enherbement
	ETPh<-(meteo$ETP*param$p)

	#
	# Calcul de Temp base 0 ? partir de la lev?e de l'enherbement
	Tb0<-rep(0,dim(meteo)[1])
	for (a in 1:an)
		for (i in Llevee[a]:(jdeb[a+1]-1))
			ifelse(meteo$Temp[i]>0,Tb0[i]<-meteo$Temp[i],Tb0[i]<-0)

	# Calcul du kvigne estim?
	kv<-rep(0,dim(meteo)[1]) #vecteur vide
	for (a in 1:an)
		for (i in Ldbr[a]:LarretTr[a])
		{
			kv[i]<-param$kmax[a]
			if (somTb10[i]<param$ddkmax)#
				kv[i]<-(param$kmax[a]*(somTb10[i]/param$ddkmax))  # croissance lin?aire du Kv du dbr jusqu'? somTb10=ddkmax
			if (i>(LarretTr[a]-15) & i<(length(ll)-15))  #
				kv[i]<-(param$kmax[a]-param$kmax[a]*min(1,1-(LarretTr[a]-i)/15))      # decroissance lineaire ? partir de 15j avant l'arr?t de transpiration
		}

	#
	# Calcul de INN
	INN<-rep(0,dim(meteo)[1])
	INN<-INN+param$inn # ? ce stade de d?veloppement, la valeur de INN est fix? par d?faut ? 0.3

	#
	# Calcul de Es0
	Es0<-(meteo$ETP*(1-kv)*(1-param$p))
	#
	# CALCUL du groupe evaporation du sol
	b_evap	<-(0.5*param$b1_evap*param$b2_evap)

	BHSn	<-rep(0,dim(meteo)[1])
	ESn1	<-rep(0,dim(meteo)[1])
	SES0	<-rep(0,dim(meteo)[1])
	ESn2	<-rep(0,dim(meteo)[1])
	ESn		<-rep(0,dim(meteo)[1])

	BHSn[1]	<-(param$U*(1-param$p))
	ESn1[1]	<-Es0[1]
	ESn[1]	<-(ESn1[1]+ESn2[1])
	j<-1
	repeat
	{
		j<-(j+1)
		if (j>dim(meteo)[1]) break()
		ESn1[j]<-(min(Es0[j],BHSn[j-1]))
		if (ESn1[j]<Es0[j]) SES0[j]<-(Es0[j]-ESn1[j]+SES0[j-1]) else SES0[j]<-0
		ESn2[j]	<-(max(0,(2*b_evap*SES0[j]+b_evap^2)^0.5-(2*b_evap*SES0[j-1]+b_evap^2)^0.5))
		ESn[j]	<-(ESn1[j]+ESn2[j])
		BHSn[j]	<-(min(param$U*(1-param$p),max(0,(BHSn[j-1]+meteo$Pluie[j]*(1-param$p)-ESn[j]))))
	}

	# Allocations
	crherbe<-vector(mode="numeric",length=dim(meteo)[1])
	STb0<-vector(mode="numeric",length=dim(meteo)[1])
	seneherbe<-vector(mode="numeric",length=dim(meteo)[1])
	LAIsen<-vector(mode="numeric",length=dim(meteo)[1])
	KLAI<-vector(mode="numeric",length=dim(meteo)[1])
	LAI<-vector(mode="numeric",length=dim(meteo)[1])
	Kh<-vector(mode="numeric",length=dim(meteo)[1])
	Ktransp<-vector(mode="numeric",length=dim(meteo)[1])
	ETRh<-vector(mode="numeric",length=dim(meteo)[1])
	ASWh<-vector(mode="numeric",length=dim(meteo)[1])
	FTSWh<-vector(mode="numeric",length=dim(meteo)[1])
	Dh<-vector(mode="numeric",length=dim(meteo)[1])
	Shv<-vector(mode="numeric",length=dim(meteo)[1])
	Tv<-vector(mode="numeric",length=dim(meteo)[1])
	Dv<-vector(mode="numeric",length=dim(meteo)[1])
	ASWv<-vector(mode="numeric",length=dim(meteo)[1])
	FTSWv<-vector(mode="numeric",length=dim(meteo)[1])
	ASWtot<-vector(mode="numeric",length=dim(meteo)[1])
	FTSWtot<-vector(mode="numeric",length=dim(meteo)[1])

	#######################
	# INITIALISATIONS
	LAI[1]<-param$LAIinit
	STb0[1]<-Tb0[1]
	LAIsen[1]<-param$LAIinit
	ASWv[1]<-param$ASWvinit
	ASWh[1]<-param$ASWhinit
	FTSWh[1]<-param$ASWhinit/param$TTSWh
	TTSWtot<-(param$TTSWh+param$TTSWv)
	FTSWv[1]<-param$ASWvinit/param$TTSWv
	ASWtot[1]<-(ASWv[1]+ASWh[1])
	FTSWtot[1]<-(ASWtot[1]/TTSWtot)
	Shv[1]<-min(1,FTSWtot[1]/param$FTSWvregulTR) # Effet Stress hydrique sur vigne
	KLAI[1]<-(min(1,max((FTSWh[1]/(param$FTSWhregulLAI-0.1)-0.1/param$FTSWhregulLAI),0)))
	Ktransp[1]<-min(1,FTSWh[1]/param$FTSWhregultr)  # Effet stress hydrique sur la transpiration
	Kh[1]<-0.5
	ETRh[1]<-(ETPh[1]*(1-kv[1])*Kh[1]*Ktransp[1])
	j<-1
	a<-1
	if (param$Tonte=="O") param$LAItonte<-100 # cette valeur d?sactive LAItonte si les dates de tontes sont actives
	tont<-1 # compteur de date de tonte

	#######################
	# BOUCLE JOURNALIERE
	repeat
	{

		j<-j+1
		if (j>dim(meteo)[1]) break()

		# Calcul de la s?nescence folaire de l'herbe
		crherbe[j]	<-(param$herblairate*1.71*0.001*min(18,Tb0[j])^2*KLAI[j-1]*INN[j-1])
		STb0[j]		<-STb0[j-1]+Tb0[j]
		if (STb0[j-1]>param$LLSmin | LAI[j-1]==param$LAIres) LAIsen[j]<-LAI[j-1] else LAIsen[j]<-LAIsen[j-1]
		if (STb0[j-1]>param$LLSmin) STb0[j]<-0
		seneherbe[j]<-(LAIsen[j]*max(0,Tb0[j]/param$LLSmin))

		#gestion de la dynamique du LAI incluant les eventuelles tontes
		if (LAI[j-1]>param$LAItonte)
			LAI[j]<-param$LAIres
		else
			LAI[j]<-max(0,LAI[j-1]+crherbe[j]-seneherbe[j])
		if (j==Ltonte[tont] & param$Tonte=="O")
		{
			LAI[j]<-param$LAIres
			STb0[j]<-0
			tont<-(tont+1)
		}
		if (tont>sum(param$nbtonte))
			tont<-sum(param$nbtonte)

		Kh[j]	<-(0.95*(1-exp(-0.6*LAI[j])))
		ETRh[j]	<-(ETPh[j]*(1-kv[j])*Kh[j]*Ktransp[j-1])
		Shv[j]	<-min(1,FTSWtot[j-1]/param$FTSWvregulTR) # Effet Stress hydrique sur vigne
		if (j<LarretTr[a]) Tv[j]<-(kv[j]*meteo$ETP[j]*Shv[j])
		ASWh[j]<-max(0.000001,min(param$TTSWh,ASWh[j-1]+Peffh_Ruiss[j]-ETRh[j]-(ASWh[j-1]/ASWtot[j-1])*Tv[j]))
		FTSWh[j]<-(ASWh[j]/param$TTSWh)
		Ktransp[j]	<-min(1,max(FTSWh[j]/param$FTSWhregultr,0))  # Effet stress hydrique sur la transpiration
		KLAI[j]		<-(min(1,max((FTSWh[j]/(param$FTSWhregulLAI-0.1)-0.1/param$FTSWhregulLAI-0.1),0))) # Effet stress hydrique sur LAI
		Dh[j]		<-max(0,ASWh[j-1]+Peffh_Ruiss[j]-param$TTSWh)
		Dv[j]		<-max(0,ASWv[j-1]+Peffv_Ruiss[j]-param$TTSWv)
		ASWv[j]		<-max(0,min(param$TTSWv,ASWv[j-1]+Peffv_Ruiss[j]-(ASWv[j-1]/ASWtot[j-1])*Tv[j]-ESn[j]+Dh[j]))
		if (param$irri=="O") ASWv[j]<-ASWv[j]+meteo$IR[j] # s'il  a de l'irrigation, on la rajoute directement ? l'ASWv
		FTSWv[j]<-(ASWv[j]/param$TTSWv)
		ASWtot[j]<-(ASWv[j]+ASWh[j])
		FTSWtot[j]<-(ASWtot[j]/TTSWtot)
		if (param$reinit=="O" & j==(jdeb[a+1]-1)) ASWv[j]<-param$TTSWv
		if (param$reinit=="O" & j==(jdeb[a+1]-1)) ASWh[j]<-param$TTSWh
		if (j==(jdeb[a+1]-1)) a<-(a+1)
	}
	# FIN DE LA BOUCLE SUR LES JOURS DE SIMULATION

	#
	#BHr<-data.frame(meteo,Peff,
	BHr<-list(meteo,Peff, Kh,ETRh,crherbe,seneherbe,KLAI,Tb0,LAI,kv,Tv,Shv,BHSn,Es0,ESn1,ESn2,SES0,ESn,ETPh,Dh,Dv,Ruissv,Ruissh,ASWv,ASWh,ASWtot=ASWtot,FTSWh,FTSWv,FTSWtot,Peffh_Ruiss,Peffv_Ruiss,P5j)
	names(BHr)<-c("meteo","Peff", "Kh","ETRh","crherbe","seneherbe","KLAI","Tb0","LAI","kv","Tv","Shv","BHSn","Es0","ESn1","ESn2","SES0","ESn","ETPh","Dh","Dv","Ruissv","Ruissh","ASWv","ASWh","ASWtot","FTSWh","FTSWv","FTSWtot","Peffh_Ruiss","Peffv_Ruiss","P5j")
  return(BHr)
} # FIN de la fonction Bilan hydrique
#

#######################################################
# application du mod?le sur des matrices de param?tres

walis.model <- function(param, clim_data)
return(apply(param,walis.model.single,clim_data))

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


#!/usr/bin/env Rscript
library(data.table)
library("optparse")
library("qqman")
t_col <- function(color, percent = 50, name = NULL) {
  #      color = color name
  #    percent = % transparency
  #       name = an optional name for the color

## Get RGB values for named color
rgb.val <- col2rgb(color)

## Make new color using input color as base and alpha set by transparency
t.col <- rgb(rgb.val[1], rgb.val[2], rgb.val[3],
             max = 255,
             alpha = (100 - percent) * 255 / 100,
             names = name)

## Save the color
invisible(t.col)
}

computedher<-function(beta, se, af,N){
#https://journals.plos.org/plosone/article/file?type=supplementary&id=info:doi/10.1371/journal.pone.0120758.s001
maf<-af
maf[!is.na(af) & af>0.5]<- 1 - maf[!is.na(af) & af>0.5]
ba<-!is.na(beta) & !is.na(se) & !is.na(maf) & !is.na(N)
a<-rep(NA, length(beta))
b<-rep(NA, length(beta))
a<-2*(beta[ba]**2)*(maf[ba]*(1-maf[ba]))
b<-2*(se[ba]**2)*N[ba]*maf[ba]*(1-maf[ba])
res<-rep(NA, length(beta))
res[ba]<-a[ba]/(a[ba]+b[ba])
res
}

option_list = list(
  make_option(c( "--gwascat"), type="character", default=NULL,
              help="dataset file name", metavar="character"),
  make_option(c( "--gwas"), type="character", default=NULL,
              help="dataset file name", metavar="character"),
  make_option(c( "--ldblock_file"), type="character", default=NULL,
              help="dataset file name", metavar="character"),
  make_option(c( "--pheno"), type="character", default=NULL,
              help="dataset file name", metavar="character"),
  make_option(c("--chr_gwas"), type="character", default=NULL,
              help="dataset file name", metavar="character"),
  make_option(c("--bp_gwascat"), type="character", default=NULL,
              help="dataset file name", metavar="character"),
  make_option(c("--ps_gwas"), type="character", default=NULL,
              help="dataset file name", metavar="character"),
  make_option(c("--a1_gwas"), type="character", default=NULL,
              help="dataset file name", metavar="character"),
  make_option(c("--a2_gwas"), type="character", default=NULL,
              help="dataset file name", metavar="character"),
  make_option(c("--beta_gwas"), type="character", default=NULL,
              help="dataset file name", metavar="character"),
  make_option(c("--se_gwas"), type="character", default=NULL,
              help="dataset file name", metavar="character"),
  make_option(c("--af_gwas"), type="character", default=NULL,
              help="dataset file name", metavar="character"),
  make_option(c("--N_gwas"), type="character", default=NULL,
              help="dataset file name", metavar="character"),
  make_option(c("--ps_gwascat"), type="character", default=NULL,
              help="dataset file name", metavar="character"),
  make_option(c("--chr_gwascat"), type="character", default=NULL,
              help="dataset file name", metavar="character"),
  make_option(c("--p_gwas"), type="character", default=NULL,
              help="dataset file name", metavar="character"),
  make_option(c("--min_pvalue"), type="numeric", default=NULL,
              help="dataset file name", metavar="character"),
  make_option(c("--min_r2"), type="numeric", default=NULL,
              help="dataset file name", metavar="character"),
  make_option(c("--info_gwascat"), type="character", default=NULL,
              help="dataset file name", metavar="character"),
  make_option(c("--out"), type="character", default="out.txt",
              help="output file name [default= %default]", metavar="character")
);

checkhead<-function(head,Data, type){
if(length(which(head %in% names(Data)))==0){
print(names(Data))
print(paste('not found ', head,'for',type ,'data'))
q(2)
}
}
Test=F
#--chr_gwas ${params.head_chr} --ps_gwas ${params.head_bp} --a1_gwas ${params.head_A1} --a2_gwas ${params.head_A2
opt_parser = OptionParser(option_list=option_list);
opt = parse_args(opt_parser)
if(Test)opt = parse_args(opt_parser, strsplit('--gwascat DBP_AwigenLD_all.csv --gwas DBP_AwigenLD_range.init --chr_gwas CHR --ps_gwas BP --a1_gwas ALLELE1 --a2_gwas ALLELE0 --beta_gwas BETA --se_gwas SE --chr_gwascat chrom --bp_gwascat chromEnd --p_gwas P_BOLT_LMM --ps_gwascat chromEnd --chr_gwascat chrom --out DBP_AwigenLD_wind --ldblock_file tmpout --min_pvalue 0.01 --min_r2 0.5 --info_gwascat "pubMedID;author;trait;initSample', split=' ')[[1]])

#/home/jeantristan/Travail/git/h3agwas/replication/gwascat/bin/computestat_ldv2.r  --gwascat meanMaxcIMT_eurld_all.csv --gwas meanMaxcIMT_eurld_range.init --chr_gwas CHR --ps_gwas BP --a1_gwas ALLELE1 --a2_gwas ALLELE0  --beta_gwas BETA --se_gwas SE  --chr_gwascat chrom --bp_gwascat chromEnd --p_gwas P_BOLT_LMM --ps_gwascat chromEnd --chr_gwascat chrom --out meanMaxcIMT_eurld_noext --ldblock_file meanMaxcIMT_eurld_ldinfo_ld.out --min_pvalue 1 --min_r2  0.5 --info_gwascat "pubMedID;author;trait;initSample"
#if(Test)opt=list(gwascat='meanMaxcIMT_eurld_all.csv',gwas='meanMaxcIMT_eurld_range.init',chr_gwas='CHR',ps_gwas='BP',a1_gwas='ALLELE1',a2_gwas='ALLELE0',beta_gwas='BETA',se_gwas='SE',af_gwas='A1FREQ',chr_gwascat='chrom',bp_gwascat='chromEnd',p_gwas='P_BOLT_LMM',ps_gwascat='chromEnd',chr_gwascat='chrom',out='out',ldblock_file='meanMaxcIMT_eurld_ldinfo_ld.out',min_pvalue='0.0001',min_r2=0.5,info_gwascat="pubMedID;author;trait;initSample")
#n/computestat_ldv2.r  --gwascat meanMaxcIMT_eurld_AwigenLD_all.csv --gwas meanMaxcIMT_eurld_AwigenLD_range.init --chr_gwas CHR --ps_gwas BP --a1_gwas ALLELE1 --a2_gwas ALLELE0  --beta_gwas BETA --se_gwas SE  --chr_gwascat chrom --bp_gwascat chromEnd --p_gwas P_BOLT_LMM --ps_gwascat chromEnd --chr_gwascat chrom --out meanMaxcIMT_eurld_AwigenLD_ld2 --ldblock_file meanMaxcIMT_eurld_AwigenLD_ld2.tmp_pos --min_pvalue 1.0E-4 --min_r2  0.5 --info_gwascat "pubMedID;author;trait;initSample"

headse=opt[['se_gwas']];headbp=opt[['ps_gwas']];headchr=opt[['chr_gwas']];headbeta=opt[['beta_gwas']];heada1=opt[['a1_gwas']];heada2=opt[['a2_gwas']];headpval=opt[['p_gwas']];headaf<-opt[['af_gwas']];headbeta=opt[['beta_gwas']]
headchrcat=opt[['chr_gwascat']];headbpcat=opt[['ps_gwascat']];heada1catrs<-"riskAllele";headzcat="z.cat";headafcat<-'risk.allele.af';heada1cat<-'risk.allele.cat'
outhead=opt[['out']]

version<-2

datagwascat=read.csv(opt[['gwascat']])
#datagwascat[,heada1cat]<-sapply(strsplit(as.character(datagwascat[,heada1catrs]),split='-'),function(x)x[2])
datagwas<-fread(opt[['gwas']], header=T)
if(!is.null(headaf))checkhead(headaf, datagwas,'af')
checkhead(headpval, datagwas,'pval');checkhead(headse, datagwas,'se');checkhead(headbp, datagwas,'bp');checkhead(headchr, datagwas, 'chr');checkhead(headbeta, datagwas, 'beta')

checkhead(headbpcat,datagwascat,'bp cat');checkhead(headchrcat,datagwascat,'chro cat');

# CHR_A         BP_A         SNP_A  CHR_B         BP_B         SNP_B           R2
data_resumld<-fread(opt[['ldblock_file']])
if(version==1)names(data_resumld)<-c('block', 'CHR', 'BP', 'TYPE') else names(data_resumld)<-c('block', 'CHR', 'BP')
data_resumld$block<-paste(data_resumld$CHR,data_resumld$block, sep='_')

#tmpa<-unique(datald[,c('CHR_A','BP_A','SNP_A')]);names(tmpa)<-c('CHR','BP','SNP');
#tmpb<-unique(datald[,c('CHR_B','BP_B','SNP_B')]);names(tmpb)<-c('CHR','BP','SNP');
#tmp<-rbind(tmpa,tmpb)
#tmpall<-unique(rbind(tmpa,tmpb))
#tmpall<-tmpall[,c('CHR','BP','SNP','CHR','BP','SNP')]
#tmpall$R2<-1
#names(tmpall)<-names(datald)
#datald<-rbind(datald,tmpall)

#   CHR_A     BP_A     SNP_A CHR_B     BP_B      SNP_B       R2
#1:    18 48132646 rs1437649    18 48133241 rs61148001 0.896039

headN<-opt[['N_value']]
if(is.null(opt[['N_gwas']])){
if(is.null(opt[['N_value']]))Nval<-10000 else Nval=opt[['N_value']]
datagwas[['N_gwas']]<-Nval
headN<-'N_gwas'
}
if(!is.null(headaf)){
 datagwas$h2.gwas<-computedher(datagwas[[headbeta]], datagwas[[headse]], datagwas[[headaf]],datagwas[[headN]])
 datagwas$z.gwas<-datagwas[[headbeta]]/datagwas[[headse]]
}else{
datagwas$h2.gwas<-NA
datagwas$z.gwas<-NA

}

#datalda1<-merge(datagwascat, datald, by.x=c(headchrcat,headbpcat), by.y=c("CHR_A", "BP_A"));names(datalda1)[names(datalda1)=="CHR_B"]<-headchr;names(datalda1)[names(datalda1)=="BP_B"]<-headbp;names(datalda1)[names(datalda1)=="SNP_B"]<-'rs_gwas';names(datalda1)[names(datalda1)=="SNP_A"]<-'rs_cat'
#datalda2<-merge(datagwascat, datald, by.x=c(headchrcat,headbpcat), by.y=c("CHR_B", "BP_B"));names(datalda2)[names(datalda2)=="CHR_A"]<-headchr;names(datalda2)[names(datalda2)=="BP_A"]<-headbp;names(datalda2)[names(datalda2)=="SNP_A"]<-'rs_gwas';names(datalda2)[names(datalda2)=="SNP_B"]<-'rs_cat'

#dataldallcat<-rbind(datalda1,datalda2)

dataresall<-merge(data_resumld,datagwascat, all.x=T, by.x=c('CHR', 'BP'), by.y=c(headchrcat,headbpcat),allow.cartesian=TRUE)
dataresall<-as.data.frame(merge(dataresall, datagwas, all.x=T, by.x=c('CHR', 'BP'), by.y=c(headchr, headbp), allow.cartesian=TRUE))

write.table(dataresall, file=paste(opt[['out']],'_all.txt',sep=''), row.names=F, col.names=T,quote=F, sep='\t')

infocatI=strsplit(opt[['info_gwascat']],split=';')[[1]]

dataresall$info_gwas<-paste(dataresall[,'CHR'],':',dataresall[,'BP'],'-beta:',dataresall[,headbeta], ',se:',dataresall[,headse],',pval:',dataresall[,headpval])
dataresall$info_gwascat<-""
balise<-!apply(dataresall[,infocatI], 1, function(x)all(is.na(x)))
infocat<-c('CHR','BP',infocatI)
for(cat in infocat)dataresall$info_gwascat[balise]<-paste(dataresall$info_gwascat[balise],cat,':',dataresall[balise,cat],',',sep='')
write.csv(dataresall, file=paste(opt[['out']],'_all.csv',sep=''),row.names=F)

infocatdata<-aggregate(info_gwascat~block, data=dataresall[,],function(x)paste(unique(x), collapse=';'))
infodata<-aggregate(info_gwas~block, data=dataresall,function(x)paste(unique(x), collapse=';'))
chro<-aggregate(as.formula(paste("CHR~block")), data=dataresall, unique)
bpmin<-aggregate(as.formula(paste("BP~block")), data=dataresall, min)
bpmax<-aggregate(as.formula(paste("BP~block")), data=dataresall, max)
#wh.minpvaldata<-aggregate(as.formula(paste('cbind(',headbp,',',headpval,')',"~block")), data=dataresall,function(x)print(x))

infobloc<-merge(merge(chro, bpmin, by='block',allow.cartesian=TRUE),bpmax, by='block',allow.cartesian=TRUE)

minpvaldata<-aggregate(as.formula(paste(headpval,"~block")), data=dataresall, min);names(minpvaldata)<-c('block', 'min_pval')
dataresalltmp<-merge(dataresall,minpvaldata, by='block')
minpvalbp<-dataresalltmp[dataresalltmp$min_pval==dataresalltmp[,headpval],]
minpos<-aggregate(BP~block ,data=minpvalbp,function(x)paste(x,collapse=';'))
names(minpos)<-c('block', 'best_pos')

print(head(infobloc))
names(infobloc)<-c('block', 'chro','min_bp', 'max_bp')

ndata<-aggregate(as.formula(paste(headpval,"~block")), data=dataresall, length)
names(ndata)<-c('block', 'n_total')

allmerge<-merge(merge(infobloc,merge(merge(merge(infocatdata,infodata,by='block',all=T),minpvaldata,by='block',all=T), ndata, by='block',all=T),by='block',all=T), minpos, by='block',all=T)
print(is.data.frame(allmerge))
write.csv(allmerge, file=paste(opt[['out']],'_allresume.csv',sep=''),row.names=F)

minpval<-as.numeric(opt[['min_pvalue']])
dataresallsig<-dataresall[!is.na(dataresall[,headpval]) & dataresall[,headpval]<minpval,]
if(nrow(dataresallsig)>0){
dataresallsig$info_gwas<-paste(dataresallsig[,'CHR'],':',dataresallsig[,'BP'],'-beta:',dataresallsig[,headbeta], ',se:',dataresallsig[,headse],',pval:',dataresallsig[,headpval])

chro<-aggregate(as.formula(paste("CHR~block")), data=dataresallsig, unique)

ndata<-aggregate(as.formula(paste(headpval,"~block")), data=dataresallsig, length)
names(ndata)<-c('block', 'n_total')

infodata<-aggregate(info_gwas~block, data=dataresallsig,function(x)paste(unique(x), collapse=';'))
minpvaldata<-aggregate(as.formula(paste(headpval,"~block")), data=dataresallsig, min)
ndataSig<-aggregate(as.formula(paste(headpval,"~block")), data=dataresallsig, length)

infobloc<-merge(merge(chro, bpmin, by='block'),bpmax, by='block')
names(infobloc)<-c('block', 'chro','min_bp', 'max_bp')

minpvaldata<-aggregate(as.formula(paste(headpval,"~block")), data=dataresallsig, min);names(minpvaldata)<-c('block', 'min_pval')
dataresalltmp<-merge(dataresallsig,minpvaldata, by='block')
minpvalbp<-dataresalltmp[dataresalltmp$min_pval==dataresalltmp[,headpval],]
minpos<-aggregate(BP~block ,data=minpvalbp,function(x)paste(x,collapse=';'))
names(minpos)<-c('block', 'best_pos')

names(ndataSig)<-c('block', 'n_sig')

allmergesig<-merge(merge(infobloc,merge(merge(merge(merge(infocatdata,infodata,by='block',all=F),minpvaldata,by='block',all=F), ndata, by='block',all=F), ndataSig, by='block', all=F),by='block',all=F), minpos,by='block',all=F)
write.csv(allmergesig, file=paste(opt[['out']],'_resumesig.csv',sep=''),row.names=F)
}else{
head=paste(c("block","chro","min_bp","max_bp","info_gwascat","info_gwas","min_pval","n_total","best_pos"), collapse=',')
writeLines(head, con=paste(opt[['out']],'_resumesig.csv',sep=''))

}


# Quick test to see if it's possible to get a map of total NDVI observations
library(raster)
library(probaV)
library(tools)
source("utils/set-temp-path.r")

CleanDir = "../../userdata/semicleaned/ndvi/"
OutputDir = "../../userdata/observations/"
TempDir = "../../userdata/temp/"
TileOfInterest = "X20Y01"

BandPattern = "NDVI_sm.tif$"
VrtFilename = paste0(TempDir, "harmonics.vrt")

# Create virtual stack
Vrt = timeVrtProbaV(CleanDir, pattern = BandPattern, vrt_name = VrtFilename, tile = TileOfInterest,
    return_raster = TRUE)

Obs = sum(!is.na(Vrt))
writeRaster(Obs, datatype="INT1U", filename=paste0(OutputDir, "observations-semicleaned.tif"))