##

school_rolls_from_1966 <- school_rolls_from_1966 %>%
    mutate_at(vars(year), as.ordered) %>%
    mutate_at(vars(secondary_schools, secondary_pupils, base_year_census), as.integer)

base_year <- 1996

##
# full dataset
##
sqa_qualifications_data <- bind_rows(dbGetQuery(dbConn, paste("SELECT A.*, B.NoOfStudents AS AllEntries",
                                                       "FROM sqa_data A, sqa_data B",
                                                       "WHERE (A.gender = 'female') AND (A.grade = 'Entries') AND",
                                                                 "(B.gender = 'all') AND (B.grade = 'Entries') AND",
                                                                 "(A.gender <> B.gender) AND (A.qualification = B.qualification) AND",
                                                                 "(A.year = B.year) AND (A.Subject = B.Subject)"
                                                      )),
                              dbGetQuery(dbConn, paste("SELECT A.*, B.NoOfStudents AS AllEntries",
                                                         "FROM sqa_data A, sqa_data B",
                                                         "WHERE (A.gender = 'male') AND (A.grade = 'Entries') AND",
                                                                 "(B.gender = 'all') AND (B.grade = 'Entries') AND",
                                                                 "(A.gender <> B.gender) AND (A.qualification = B.qualification) AND",
                                                                 "(A.year = B.year) AND (A.Subject = B.Subject)"
                                                      ))
          ) %>%

    arrange(qualification, year) %>%
    mutate_at(vars(Subject, gender, grade), as.factor) %>%
    mutate_at(vars(qualification), as.factor) %>%
    mutate_at(vars(year), as.ordered) %>%

    mutate(PercentageOfStudents = (NoOfStudents / AllEntries))

#head(sqa_qualifications_data, 15)

### ###

##
# order qualifications by SCQFLevel and start year
##
sqa_qualifications_ordering <- sqa_qualifications_data %>%
    distinct(qualification) %>%
    mutate_at(vars(qualification), as.character) %>%

    mutate(qualification_label = if_else(qualification == toupper(qualification),
                                         qualification,
                                         snakecase::to_title_case(qualification))) %>%

    left_join(sqa_qualification_list %>%

                select(QualificationId, SCQFLevel, DataStartYear) %>%
                mutate_at(vars(SCQFLevel, DataStartYear), as.integer),

              by = c("qualification" = "QualificationId")) %>%

    arrange(SCQFLevel, DataStartYear, qualification)

sqa_qualifications_ordering < sqa_qualifications_ordering %>%
    mutate(qualification_label = if_else(qualification == toupper(qualification),
                                         qualification,
                                         snakecase::to_title_case(qualification))) %>%
    relocate(qualification_label, .after = qualification)

#sqa_qualifications_ordering

sqa_qualifications_data <- sqa_qualifications_data %>%
    mutate_at(vars(qualification), ~ fct_relevel(., levels = sqa_qualifications_ordering$qualification))
#levels(sqa_qualifications_data$qualification)

### ###

##
# gender distribution
##
gender_distribution <- bind_rows(dbGetQuery(dbConn, paste("SELECT A.year, A.qualification, A.gender, SUM(A.NoOfStudents) AS NoOfStudents, SUM(B.NoOfStudents) AS AllEntries",
                                                                                "FROM sqa_data A, sqa_data B",
                                                             "WHERE ",
                                                                 "(A.gender = 'female') AND (A.grade = 'Entries') AND",
                                                                 "(B.gender = 'all') AND (B.grade = 'Entries') AND",
                                                                 "(A.gender <> B.gender) AND (A.qualification = B.qualification) AND",
                                                                 "(A.year = B.year) AND (A.Subject = B.Subject)",
                                                             "GROUP BY A.year, A.qualification",
                                                             "ORDER BY A.qualification, A.year"
                                                      )),

                                    dbGetQuery(dbConn, paste("SELECT A.year, A.qualification, A.gender, SUM(A.NoOfStudents) AS NoOfStudents, SUM(B.NoOfStudents) AS AllEntries",
                                                                                "FROM sqa_data A, sqa_data B",
                                                             "WHERE",
                                                                 "(A.gender = 'male') AND (A.grade = 'Entries') AND",
                                                                 "(B.gender = 'all') AND (B.grade = 'Entries') AND",
                                                                 "(A.gender <> B.gender) AND (A.qualification = B.qualification) AND",
                                                                 "(A.year = B.year) AND (A.Subject = B.Subject)",
                                                             "GROUP BY A.year, A.qualification",
                                                             "ORDER BY A.qualification, A.year"
                                                                                ))
                                 ) %>%

    arrange(qualification, year) %>%
    mutate_at(vars(qualification), ~ factor(., levels = sqa_qualifications_ordering$qualification)) %>%
    mutate_at(vars(gender), as.factor) %>%
    mutate_at(vars(year), as.ordered) %>%

    mutate(PercentageOfStudents = (NoOfStudents / AllEntries))

### ###

##
# and update gender_distribution ... and normalise using school rolls
##
gender_distribution <- gender_distribution %>%
    #mutate_at(vars(qualification), ~ fct_relevel(., sqa_qualifications_ordering$qualification)) %>%

    mutate_at(vars(year), as.character) %>%

    left_join(school_rolls_from_1966 %>%
                  select(year, secondary_pupils, index_factor)
              ) %>%
    relocate(index_factor, .after = qualification) %>%
    relocate(secondary_pupils, .after = qualification) %>%
    mutate_at(vars(year), as.ordered) %>%

    mutate(NoOfStudents_orig = NoOfStudents,
           AllEntries_orig = AllEntries) %>%
    mutate_at(vars(NoOfStudents, AllEntries), ~ as.integer(round(. / index_factor))) %>%

    relocate(NoOfStudents_orig, .before = NoOfStudents) %>%
    relocate(AllEntries_orig, .before = AllEntries)

#levels(gender_distribution$qualification)
#dim(gender_distribution)
#tail(gender_distribution, 15)

gender_column_labels <- levels(gender_distribution$gender)

### ###

##
# computing uptake across all qualifications
##
focus_subject <- "computing"

computing_uptake <- bind_rows(dbGetQuery(dbConn, paste("SELECT A.*, B.NoOfStudents AS AllEntries",
                                                       "FROM sqa_data A, sqa_data B",
                                                       "WHERE (A.Subject LIKE ", paste0("'%", focus_subject, "%'"), ") AND",
                                                                 "(A.gender = 'female') AND (A.grade = 'Entries') AND",
                                                                 "(B.gender = 'all') AND (B.grade = 'Entries') AND",
                                                                 "(A.gender <> B.gender) AND (A.qualification = B.qualification) AND",
                                                                 "(A.year = B.year) AND (A.Subject = B.Subject)"
                                                      )),
                              dbGetQuery(dbConn, paste("SELECT A.*, B.NoOfStudents AS AllEntries",
                                                         "FROM sqa_data A, sqa_data B",
                                                         "WHERE (A.Subject LIKE ", paste0("'%", focus_subject, "%'"), ") AND",
                                                                 "(A.gender = 'male') AND (A.grade = 'Entries') AND",
                                                                 "(B.gender = 'all') AND (B.grade = 'Entries') AND",
                                                                 "(A.gender <> B.gender) AND (A.qualification = B.qualification) AND",
                                                                 "(A.year = B.year) AND (A.Subject = B.Subject)"
                                                      ))
          ) %>%

    arrange(qualification, year) %>%
    mutate_at(vars(Subject, gender, grade), as.factor) %>%
    mutate_at(vars(qualification), ~ factor(., levels = sqa_qualifications_ordering$qualification))  %>%
    mutate_at(vars(year), as.ordered) %>%

    mutate(PercentageOfStudents = (NoOfStudents / AllEntries)) %>%
    mutate(Subject.label = eval(formatted_subject_labels_as_expr))

### ###

##
# computing across qualifications
##

computing_offering_all_qualifications <- dbGetQuery(dbConn, paste("SELECT year, qualification FROM sqa_data",
                         "GROUP BY year, qualification",
                         "ORDER BY qualification, year"
                        )
                   ) %>%

    left_join(dbGetQuery(dbConn, paste("SELECT year, qualification, Subject AS computing_offered FROM sqa_data ",
                                       "WHERE (Subject LIKE ", paste0("'%", focus_subject, "%'"), ")",
                                       "GROUP BY year, qualification ",
                                       "ORDER BY qualification, year"
                                      )
                   )
            ) %>%

    mutate_at(vars(computing_offered), ~ !is.na(.)) %>%

    mutate_at(vars(year), as.ordered) %>%
    mutate_at(vars(qualification), ~ factor(., levels = sqa_qualifications_ordering$qualification))

time_period_axis_breaks <-
    data.frame(year = levels(computing_offering_all_qualifications$year),
               tick_label = as.logical(seq_len(length(levels(computing_offering_all_qualifications$year))) %% 2)) %>%

        mutate_at(vars(year), as.character) %>%
        mutate_at(vars(tick_label), ~ if_else(., year, ""))

### ###

##
#
##


rm(list=ls())
load("HDIdata.rda")

y=array(NA,c(164,6,3))
nams=HDIdata[1:164,2]

u=unique(HDIdata[,1])
for(j in 1:6) {
for(h in 1:3) {
y[,j,h]=HDIdata[HDIdata[,1]==u[j],h+2]}}

source("codeKvariable.r")

library(snipEM)
library(mvtnorm)
set.seed(12345)

load("rl.rda")
Bs=c(10,50,100,200,500)
rlB=list()

for(iter in 1:5) {
    rlB[[iter]]=rlm(y,0,4,inits=inits0,hits=50,B=Bs[iter])
iter=iter+1
}

save.image(file="B.rda")


library(optparse, quietly = T)
library(pcalg, quietly = T)
library(ParallelPC, quietly = T)
source("/scripts/mpci_utils.r")

option_list_v <- list(
                    make_option(c("-j", "--job_id"), type="character",
                                help="Job ID", metavar=""),
                    make_option(c("--api_host"), type="character",
                                help="API Host/Port", metavar=""),
                    make_option(c("-d", "--dataset_id"), type="character",
                                help="Dataset ID", metavar=""),
                    make_option(c("-t", "--independence_test"), type="character", default="gaussCI",
                                help="Independence test used for ParallelPC", metavar=""),
                    make_option(c("-a", "--alpha"), type="double", default=0.05,
                                help="This is a hyperparameter", metavar=""),
                    make_option(c("-c", "--cores"), type="integer", default=2,
                                help="The number of cores to run ParallelPC on", metavar=""),
                    make_option(c("-s", "--subset_size"), type="integer", default=-1,
                                help="The maximal size of the conditioning sets that are considered", metavar=""),
                    make_option(c("--send_sepsets"), type="integer", default=0,
                                help="If 1, sepsets will be sent with the results", metavar=""),
                    make_option(c("-v", "--verbose"), type="integer", default=0,
                                help="More detailed output is provided (with impact on performance)", metavar=""),
                    make_option(c("--sampling_factor"), type="double", default=1.0,
                                help="Data sampling factor to select a random subset, between 0 and 1", metavar="")
                    # make_option(c("--fixed_gaps"), type="character", default=FALSE,
                    #             help="The connections that are removed via prior knowledge", metavar=""),
                    # make_option(c("--fixed_edges"), type="character", default=FALSE,
                    #             help="The connections that are fixed via prior knowledge", metavar="")
);

indepTestDict <- list(gaussCI=gaussCItest, binCI=binCItest, disCI=disCItest)

option_parser <- OptionParser(option_list=option_list_v)
opt <- parse_args(option_parser)

tmp_result <- get_dataset(opt$api_host, opt$dataset_id, opt$job_id, opt$sampling_factor)
df <- tmp_result[[1]]
dataset_loading_time <- tmp_result[[2]]

if (opt$independence_test == "gaussCI") {
    matrix_df <- data.matrix(df)
    sufficient_stats <- list(C=cor(matrix_df), n=nrow(matrix_df))
} else if (opt$independence_test == "binCI" || opt$independence_test == "disCI"){
    # Map categories to numbers if not done yet
    df[] <- lapply(df, factor)
    df <- df[sapply(df, function(x) !is.factor(x) | nlevels(x) > 1)]
    matrix_df <- data.matrix(df) - 1

    if (opt$independence_test == "binCI") {
        sufficient_stats <- list(dm=matrix_df, adaptDF=FALSE)
    } else {
        p <- ncol(matrix_df)
        nlev <- vapply(seq_len(p), function(j) length(levels(factor(matrix_df[,j]))), 1L)
        sufficient_stats <- list(dm=matrix_df, adaptDF=FALSE, nlev=nlev)
    }
} else{
    stop("No valid independence test specified")
}

subset_size <- if(opt$subset_size < 0) Inf else opt$subset_size
verbose <- opt$verbose > 0
start <- Sys.time()
result = pc_parallel(suffStat=sufficient_stats, verbose=verbose,
            indepTest=indepTestDict[[opt$independence_test]], m.max=subset_size,
            p=ncol(matrix_df), alpha=opt$alpha, num.cores=opt$cores, skel.method="parallel")
end <- Sys.time()
taken <- as.double(difftime(end,start,unit="s"))
colorize_log('\033[32m',taken)
graph_request <- store_graph_result(opt$api_host, result@'graph', result@'sepset', df, opt$job_id, opt$independence_test, opt$send_sepsets, opt, taken, dataset_loading_time)


vec=c(1:6)
print("Enter number to check in vector")
no=as.integer(readline())

'%findFun%'=function(vec,no)
{
  for (i in vec)
  {
    if(i==no)
      return(TRUE)
  }
  return(FALSE)

}

'%findFun%'(vec,no)


# context("Prediction functions")

# test_that("Prediction works", {

# Jmorr tree
tree  <- matrix(c(1, 2, 1, 3, 3, 4, 3, 5), ncol=2, byrow = TRUE)
tree  <- as.phylo(tree)
X     <- c(0, 0, 0)
atree <- new_aphylo(tip.annotation = X, tree = tree)

# Model parameters
Pi  <- .3
psi <- c(.01, .02)
mu  <- c(.2, .1)
eta <- c(1, 1)

# John's spreadsheet
ans0 <- c(
  0.009268032907,
  0.006404403815,
  0.006831065254,
  0.006041731783,
  0.006041731783
)[with(atree$tree, c(tip.label, node.label))]

# Computing brute-force and using the pre-order
# ans1 <- predict_brute_force(atree, psi, mu_d = mu, mu_s = mu, Pi)
# saveRDS(ans1, "inst/tinytest/test-predict-ans1.rds")
ans1 <- readRDS("test-predict-ans1.rds")
ans2 <- predict_pre_order(atree, psi, mu_d = mu, mu_s = mu, eta, Pi, loo = FALSE)

expect_equivalent(ans0, ans1$posterior)
expect_equivalent(ans1$posterior, ans2[,1])

# # Alternative take
# p_up <- matrix(ncol=2, nrow = length(ans0))
# p_pred <- double(nrow(p_up))
# l  <- LogLike(atree, psi = psi, mu_d = mu, mu_s = mu, eta = eta, Pi = Pi)
# for (i in rev(atree$pseq)) {
#
#   # If the root note
#   if (Ntip(atree) == (i - 1)) {
#
#     p_up[i, 1] = 1 - Pi
#     p_up[i, 2] = Pi
#
#   }
#
#   # Computing the offsprings
#   for (o in atree$offspring[[i]]) {
#     p_up[o, 1] = p_up[i, 1] * (1 - mu[1]) + p_up[i, 2] * mu[2]
#     p_up[o, 2] = p_up[i, 1] * mu[1]       + p_up[i, 2] * (1 - mu[2])
#   }
#
#   p_pred[i] <-  p_up[i, 2] * l$Pr[[1]][i, 2]/
#     (p_up[i, 1] * l$Pr[[1]][i, 1] + p_up[i, 2] * l$Pr[[1]][i, 2])
# }
#
# p_pred
# ans0

# Random test
set.seed(122331)
atree <- raphylo(4, psi = psi, mu_d = mu, mu_s = mu, eta = eta, Pi = Pi)

# ans0 <- predict_brute_force(atree, psi, mu_d = mu, mu_s = mu, Pi)
# saveRDS(ans0, file = "inst/tinytest/test-predict-ans0.rds")
ans0 <- readRDS("test-predict-ans0.rds")
ans1 <- predict_pre_order(atree, psi, mu_d = mu, mu_s = mu, eta, Pi, loo = FALSE)

expect_equivalent(ans0$posterior, ans1[,1])

# })

# test_that("Calling the prediction function works", {

set.seed(137245)

x <- raphylo(10)
x_obs <- rdrop_annotations(x, .5)
res   <- suppressWarnings({
  aphylo_mcmc(
    x_obs ~ psi + mu_d + Pi, priors = bprior(),
    control = list(nsteps = 2e3, burnin = 0)
    )
  })

ans0 <- predict_pre_order(
  x    = x_obs,
  psi  = res$par[c("psi0", "psi1")],
  mu_d = res$par[c("mu_d0", "mu_d1")],
  mu_s = res$par[c("mu_d0", "mu_d1")],
  eta  = c(1,1)/2, #res$par[c("eta0", "eta1")],
  Pi   = res$par["Pi"], loo = FALSE
  )

ans1 <- predict(res, ids = list(1:Nnode(x_obs, internal.only = FALSE)), loo = FALSE)

expect_silent(plot(prediction_score(res)))
expect_equivalent(ans0, ans1)

# Predictions on new data ------------------------------------------------------

set.seed(88)
res <- suppressMessages(
  suppressWarnings(
    aphylo_mcmc(
      x_obs ~ psi + mu_d + mu_s + eta + Pi, priors = bprior(),
      control = list(nsteps = 2e3, burnin = 0))
    )
  )
z <- raphylo(20, node.type = sample.int(2, 19, TRUE)-1)

ans0_a <- predict(res, loo = FALSE)
ans1_a <- predict_pre_order(
  res$dat,
  psi = res$par[c("psi0", "psi1")],
  eta = res$par[c("eta0", "eta1")],
  mu_s = res$par[c("mu_s0", "mu_s1")],
  mu_d = res$par[c("mu_d0", "mu_d1")],
  Pi  = res$par["Pi"], loo = FALSE
)

ans0_b <- predict(res, newdata = z, loo = FALSE)
ans1_b <- predict_pre_order(
  z,
  psi = res$par[c("psi0", "psi1")],
  eta = res$par[c("eta0", "eta1")],
  mu_s = res$par[c("mu_s0", "mu_s1")],
  mu_d = res$par[c("mu_d0", "mu_d1")],
  Pi  = res$par["Pi"], loo = FALSE
  )

expect_equivalent(ans0_a, ans1_a)
expect_equivalent(ans0_b, ans1_b)

expect_true(nrow(ans0_a) != nrow(ans0_b))

# Prediction score function ----------------------------------------------------

# test_that("Best vs Worse Prediction score", {

set.seed(123)
y <- sample(c(0,1), 20, replace = TRUE)

# Perfect prediction score
ans0 <- prediction_score(cbind(y), cbind(y))
expect_equivalent(ans0$obs[1], 1)

# Worse
ans1 <- prediction_score(cbind(y), 1 - cbind(y))
expect_equivalent(ans1$obs[1], 0)

# })

# test_that("Random prediction score", {

set.seed(123)
y <- cbind(sample(c(0,1), 20, replace = TRUE, prob = c(.8, .2)))
a <- .3

p0 <- mean(aphylo:::predict_random(1, y, diag(20), alpha0 = a, alpha1 = 1-a))
p1 <- aphylo:::prediction_score_rand(y, diag(20), alpha0 = a, alpha1 = 1-a)

expect_equivalent(p0, p1, tol = 1e-1)

# Mutliphylo -------------------------------------------------------------------
set.seed(192318)
net <- c(raphylo(20), raphylo(10))
ans <- aphylo_mcmc(net ~ mu_d + mu_s + Pi, control = list(nsteps = 2e3, burnin = 0))

pred <- prediction_score(ans)
expect_output(pred, "Prediction score")

# Prediction of multiple samples
set.seed(1123);p_all <- predict(ans, nsamples = 10)
set.seed(1123);p_1 <- predict(ans, which.tree = 1, nsamples = 10)
expect_equivalent(p_all[[1]], p_1[[1]])

# Predicting all, including interior nodes -------------------------------------
pred0 <- predict(ans, ids = lapply(Nnode(ans, internal.only = FALSE), seq_len))
pred1 <- predict(ans, ids = lapply(Nnode(ans, internal.only = FALSE), function(a) {
  seq_len(a - 5) + 5
  }))

expect_equivalent(rep(NA_real_, 10), unlist(lapply(pred1, "[", i = 1:5)))
expect_true(!any(is.na(unlist(pred0))))
expect_equal(
  lapply(pred0, "[", -c(1:5)),
  lapply(pred1, "[", -c(1:5))
)


library(Seurat)
library(rdist)

#functions

DE.list<-function(data,meta) {
        genes = c()
        for (t in unique(meta$time)) {
                condition=as.factor(meta$time==t)
                design = model.matrix(~0+condition)  # Create a design matrix containing time information
                fit=lmFit(data,design)  # Linear model fitting
                fit = eBayes(fit)  # Bayesian test
                top_table = topTable(fit,number=10000)  # Get the differentially expressed gene name
                genes = c(genes,row.names(top_table[top_table$adj.P.Val<0.05,]))  # combine into a list
                 }
        genes = unique(genes)
        return(genes)
}

get_form_data<-function(rdata,meta,type='NORM',hvg=6000,add=NULL) {#prefiltering and formalize the expression data,type='NORM' or 'COUNTS'
	form.data = c()
	if (type=='COUNTS') {
		obj <- CreateSeuratObject(counts = rdata, min.cells = 30, min.features = 200)
		obj[["percent.mt"]] <- PercentageFeatureSet(obj, pattern = "^MT-")
		obj <- subset(obj, subset = nFeature_RNA > 200 & nFeature_RNA < 2500 & percent.mt < 10)
		obj <- FindVariableFeatures(obj, selection.method = "vst", nfeatures = hvg)
		form.data <- as.matrix(RelativeCounts(data = obj[['RNA']]@data,scale.factor=1e6))
	} else if (type=='NORM') {
		form.data <- rdata
	}
	if (is.null(add)) {
		form.data = form.data[row.names(form.data) %in% VariableFeatures(obj),]
		form.meta = meta[row.names(meta) %in% colnames(form.data),]
	} else {
		form.data = form.data[row.names(form.data) %in% unique(unlist(c(VariableFeatures(obj),add))),]
		form.meta = meta[row.names(meta) %in% colnames(form.data),]
	}
	return(list(form.data,form.meta))
}

eu.dist<-function(p1,p2) { #given 2 vectors of positions, calculate  distance[e.g.eucleadian]
	return(sqrt(sum((p1-p2)^2)))
}

inn.dist<-function(p1,p2) { #normalized inner product
	p1=p1/norm(p1,type="2")
	p2=p2/norm(p2,type="2")
	return(p1 %*% p2)
}

get_pseudo_cells<-function(gex,keep.perc=.2,tag=null,pcn=20) {#form/average cells into pseudo cells---original sc exps too stochastic,input is the log-transformed matrix; keep.perc: percentage of pseudo cells VS original cells(%)
	n = dim(gex)[1]
	pca.res = prcomp(gex)
	pcs = gex %*% pca.res$rotation
	tpc = pcs[,1:pcn] #top PCs only
	d = rdist(tpc)
	psm = cutree(hclust(d),k=min(floor(n*keep.perc),n))  #membership of cell clusters

	#average expression of each cell cluster
	avg.gex = matrix(0,nrow=length(unique(psm)),ncol=dim(gex)[2])
	for (id in unique(psm)) {
		tmp = gex[psm==id,]
		if (!is.null(dim(tmp))) {
			avg.gex[id,] = colMeans(tmp)
		} else {
			avg.gex[id,] = tmp #need or not? throw singletons?
		}
	}
	tmp.tag = rep(tag,dim(avg.gex)[1])
	ps.names = paste(c(1:dim(avg.gex)[1]),tmp.tag,sep='-')
	row.names(avg.gex) = ps.names
	colnames(avg.gex) = colnames(gex)

	return(list(avg.gex,tmp.tag))
}

get_pseudo_cells2<-function(gex,keep.perc=.2,tag=null,pcn=20,ctp=null,ctp.collapse.thr=.8) {
#form/average cells into pseudo cells---original sc exps too stochastic,input is the log-transformed matrix; keep.perc: percentage of pseudo cells VS original cells(%)
#if cell types list provided, also collapse on the cell type of pseudocell
	n = dim(gex)[1]
	pca.res = prcomp(gex)
	ctp = as.character(ctp);ctp[is.na(ctp)]='NA'
	pcs = gex %*% pca.res$rotation
	tpc = pcs[,1:pcn] #top PCs only
	d = rdist(tpc)
	psm = cutree(hclust(d),k=min(floor(n*keep.perc),n))  #membership of cell clusters

	#average expression of each cell cluster
	avg.gex = matrix(0,nrow=length(unique(psm)),ncol=dim(gex)[2])
	ps.ctp = rep('NA',length(unique(psm)))
	for (id in unique(psm)) {
		tmp = gex[psm==id,]
		tmp.ctp = ctp[psm==id]
		if (!is.null(dim(tmp))) {
			avg.gex[id,] = colMeans(tmp)
			sorts = sort(table(tmp.ctp)/sum(table(tmp.ctp)),decreasing=T)
			if (sorts[1] >= ctp.collapse.thr) {
				ps.ctp[id] = names(sorts)[1]
			}
		} else {#need or not? throw singletons?
			avg.gex[id,] = tmp
			ps.ctp[id] = tmp.ctp
		}
	}
	tmp.tag = rep(tag,dim(avg.gex)[1])
	ps.names = paste(c(1:dim(avg.gex)[1]),tmp.tag,sep='-')
	row.names(avg.gex) = ps.names
	colnames(avg.gex) = colnames(gex)
	tmp.tag = data.frame('tag'=rep(tag,dim(avg.gex)[1]),'ctp'=ps.ctp)

	return(list(avg.gex,tmp.tag))
}

get_pseudo_cells3<-function(gex,keep.perc=.2,tag=null,pcn=20,ctp=null,ctp.collapse.thr=.8) {
#form/average cells into pseudo cells---original sc exps too stochastic,input is the log-transformed matrix; keep.perc: percentage of pseudo cells VS original cells(%)
#if cell types list provided, also collapse on the cell type of pseudocell
#record which cell belongs to which pseudocell
	n = dim(gex)[1]
	pca.res = prcomp(gex)
	ctp = as.character(ctp);ctp[is.na(ctp)]='NA'
	pcs = gex %*% pca.res$rotation
	tpc = pcs[,1:pcn] #top PCs only
	d = rdist(tpc)
	psm = cutree(hclust(d),k=min(floor(n*keep.perc),n))  #membership of cell clusters

	#average expression of each cell cluster
	avg.gex = matrix(0,nrow=length(unique(psm)),ncol=dim(gex)[2])
	ps.ctp = rep('NA',length(unique(psm)))
	for (id in unique(psm)) {
		tmp = gex[psm==id,]
		tmp.ctp = ctp[psm==id]
		if (!is.null(dim(tmp))) {
			avg.gex[id,] = colMeans(tmp)
			sorts = sort(table(tmp.ctp)/sum(table(tmp.ctp)),decreasing=T)
			if (sorts[1] >= ctp.collapse.thr) {
				ps.ctp[id] = names(sorts)[1]
			}
		} else {#need or not? throw singletons?
			avg.gex[id,] = tmp
			ps.ctp[id] = tmp.ctp
		}
	}
	tmp.tag = rep(tag,dim(avg.gex)[1])
	ps.names = paste(c(1:dim(avg.gex)[1]),tmp.tag,sep='-')
	row.names(avg.gex) = ps.names
	colnames(avg.gex) = colnames(gex)
	tmp.tag = data.frame('tag'=rep(tag,dim(avg.gex)[1]),'ctp'=ps.ctp)

	tmp.belong = paste(psm,tag,sep='-')

	return(list(avg.gex,tmp.tag,tmp.belong,gex))
}

runMSMA_cor<-function(mat1,mat2,k=5) {
#mat hasDE.list<-function(data,meta) {#find DE genes at any time and combine into a list
        genes = c()
        for (t in unique(meta$time)) {
                condition=as.factor(meta$time==t)
                design = model.matrix(~0+condition)
                fit=lmFit(data,design)
                fit = eBayes(fit)
                top_table = topTable(fit,number=10000)
                genes = c(genes,row.names(top_table[top_table$adj.P.Val<0.05,]))
        }
        genes = unique(genes)
        return(genes)
}
runMSMA_mw<-function(mat1,mat2,k=5){

#mat has genes on the column !!!!!!!!!!!!!!!!!
	sim_mat = c() #matrix to store the similarity results after 1st step
	knn_ini = c() #matrix to store the correspondence matrix after 1st step align
	df1 = NULL     #for validation

	sim_mat = cor(t(mat1),t(mat2))
	#knn
	knn_ini=t(matrix(0,nrow=dim(sim_mat)[2],ncol=dim(sim_mat)[1]))
	cm = apply(sim_mat,2,function(x) order(x,decreasing=T)[1:k])
	for (i in c(1:dim(cm)[2])) {
		knn_ini[cbind(cm[,i]),i] = 1
	}

	#after get the knn_ini, use it as correspondence matrix for 2nd align
	XY_corr=Correspondence(matrix=knn_ini)
	df2=ManiNetCluster(mat1,mat2,nameX='sample1',nameY='sample2',corr=XY_corr,d=3L,method='nonlinear manifold aln',k_NN=3L,k_medoids=6L) #NMA

	return(list(sim_mat,knn_ini,df2,df1))

}

runMSMA_mw<-function(mat1,mat2,k=5) {
#mat has genes on the column !!!!!!!!!!!!!!!!!
	sim_mat = c() #matrix to store the similarity results after 1st step
	knn_ini = c() #matrix to store the correspondence matrix after 1st step align
	df1 = NULL     #for validation

	df=ManiNetCluster(mat1,mat2,nameX='sample1',nameY='sample2',d=10L,method='manifold warping',k_NN=3L,k_medoids=3L)
	pair_dist = apply(df[df$data=='sample1',c(3:12)],1,function(x) {
			d = apply(df[df$data=='sample2',c(3:12)],1,function(y) eu.dist(x,y))
	})
	row.names(pair_dist)=row.names(mat2)
	colnames(pair_dist)=row.names(mat1)
	range01 <- function(x){(x-min(x))/(max(x)-min(x))}
	pair_dist = range01(pair_dist)
	sim_mat = 1/(1+pair_dist)
	df1 = df  #range01 OR NOT?
	#knn
	k1=k;k2=k
	knn_mat1 = matrix(0,nrow=dim(pair_dist)[1],ncol=dim(pair_dist)[2]) #for row
	knn_mat2 = matrix(0,nrow=dim(pair_dist)[1],ncol=dim(pair_dist)[2]) #for col
	for(i in 1:dim(knn_mat1)[1]) {#for row
		knn_mat1[i,order(pair_dist[i,])[1:k1]]=1
	}
	for(i in 1:dim(knn_mat2)[2]) {#for col
			knn_mat2[order(pair_dist[,i])[1:k2],i]=1
	}
	knn_ini = t(1*(knn_mat1 & knn_mat2))

	#after get the knn_ini, use it as correspondence matrix for 2nd align
	XY_corr=Correspondence(matrix=knn_ini)
	df2=ManiNetCluster(mat1,mat2,nameX='sample1',nameY='sample2',corr=XY_corr,d=3L,method='nonlinear manifold aln',k_NN=3L,k_medoids=6L) #NMA

	return(list(sim_mat,knn_ini,df2,df1))

}

runMSMA_dtw<-function(mat1,mat2) { #method can be 'cor','mw' or 'dtw'
#mat has genes on the column !!!!!!!!!!!!!!!!!
#1st step has 3 options:1)correlation;2)Manifod warping;3)Dynamic Time Warping
	sim_mat = c() #matrix to store the similarity results after 1st step
	knn_ini = c() #matrix to store the correspondence matrix after 1st step align
	df1 = NULL     #for validation

	library(dtw)
	cor_mat = cor(t(mat1),t(mat2))
	dist_mat = 1/(1+cor_mat)
	dtw_res=dtw(dist_mat,keep=TRUE,step=asymmetric,open.end=T,open.begin=T)  #open beginning and ending for flexibility
	knn_ini = matrix(0,nrow=nrow(dist_mat),ncol=ncol(dist_mat))
	knn_ini[cbind(dtw_res$index1,dtw_res$index2)]=1
	sim_mat=NULL #position holder

	#after get the knn_ini, use it as correspondence matrix for 2nd align
	XY_corr=Correspondence(matrix=knn_ini)
	df2=ManiNetCluster(mat1,mat2,nameX='sample1',nameY='sample2',corr=XY_corr,d=3L,method='nonlinear manifold aln',k_NN=3L,k_medoids=6L) #NMA

	return(list(sim_mat,knn_ini,df2,df1))

}

runMSMA_diag<-function(mat1,mat2) { #method can be 'cor','mw' or 'dtw'
#mat has genes on the column !!!!!!!!!!!!!!!!!
#1st step has 3 options:1)correlation;2)Manifod warping;3)Dynamic Time Warping
	sim_mat = c() #matrix to store the similarity results after 1st step
	knn_ini = c() #matrix to store the correspondence matrix after 1st step align
	df1 = NULL     #for validation

	if (nrow(mat1) != nrow(mat2)) {
		stop('for diag case---the numerb of samples need to be same')
	}else {
		knn_ini = diag(nrow(mat1))
	}

	#after get the knn_ini, use it as correspondence matrix for 2nd align
	XY_corr=Correspondence(matrix=knn_ini)
	df2=ManiNetCluster(mat1,mat2,nameX='sample1',nameY='sample2',corr=XY_corr,d=3L,method='nonlinear manifold aln',k_NN=3L,k_medoids=6L) #NMA

	return(list(sim_mat,knn_ini,df2,df1))

}

runMSMA<-function(mat1,mat2,method='cor',k=5) { #method can be 'cor','mw' or 'dtw'
#mat has genes on the column !!!!!!!!!!!!!!!!!
#1st step has 3 options:1)correlation;2)Manifod warping;3)Dynamic Time Warping
	sim_mat = c() #matrix to store the similarity results after 1st step
	knn_ini = c() #matrix to store the correspondence matrix after 1st step align
	df1 = NULL     #for validation
	if (method=='cor') {
		sim_mat = cor(t(mat1),t(mat2))

		#knn
		knn_ini=t(matrix(0,nrow=dim(sim_mat)[2],ncol=dim(sim_mat)[1]))
		cm = apply(sim_mat,2,function(x) order(x,decreasing=T)[1:k])
		for (i in c(1:dim(cm)[2])) {
			knn_ini[cbind(cm[,i]),i] = 1
		}
	}else if (method=='mw') {
		df=ManiNetCluster(mat1,mat2,nameX='sample1',nameY='sample2',d=10L,method='manifold warping',k_NN=3L,k_medoids=3L)
		pair_dist = apply(df[df$data=='sample1',c(3:12)],1,function(x) {
				d = apply(df[df$data=='sample2',c(3:12)],1,function(y) eu.dist(x,y))
		})
		row.names(pair_dist)=row.names(mat2)
		colnames(pair_dist)=row.names(mat1)
		range01 <- function(x){(x-min(x))/(max(x)-min(x))}
		pair_dist = range01(pair_dist)
		sim_mat = 1/(1+pair_dist)
		df1 = df  #range01 OR NOT?
		#knn
		k1=k;k2=k
		knn_mat1 = matrix(0,nrow=dim(pair_dist)[1],ncol=dim(pair_dist)[2]) #for row
		knn_mat2 = matrix(0,nrow=dim(pair_dist)[1],ncol=dim(pair_dist)[2]) #for col
		for(i in 1:dim(knn_mat1)[1]) {#for row
			knn_mat1[i,order(pair_dist[i,])[1:k1]]=1
		}
		for(i in 1:dim(knn_mat2)[2]) {#for col
				knn_mat2[order(pair_dist[,i])[1:k2],i]=1
		}
		knn_ini = t(1*(knn_mat1 & knn_mat2))

	}else if (method=='dtw') {
		library(dtw)
		cor_mat = cor(t(mat1),t(mat2))
		dist_mat = 1/(1+cor_mat)
		dtw_res=dtw(dist_mat,keep=TRUE,step=asymmetric,open.end=T,open.begin=T)  #open beginning and ending for flexibility
		knn_ini = matrix(0,nrow=nrow(dist_mat),ncol=ncol(dist_mat))
		knn_ini[cbind(dtw_res$index1,dtw_res$index2)]=1
		sim_mat=NULL #position holder
	}else if (method=='diag') {#use diagnal matrix as correspondence matrix---for 1-1 match
		if (nrow(mat1) != nrow(mat2)) {
			stop('for diag case---the numerb of samples need to be same')
		}else {
			knn_ini = diag(nrow(mat1))
		}
	}else {
		stop('not recognized method')
	}

	#after get the knn_ini, use it as correspondence matrix for 2nd align
	XY_corr=Correspondence(matrix=knn_ini)
	df2=ManiNetCluster(mat1,mat2,nameX='sample1',nameY='sample2',corr=XY_corr,d=3L,method='nonlinear manifold aln',k_NN=3L,k_medoids=6L) #NMA

	return(list(sim_mat,knn_ini,df2,df1))

}

##########FUNCTION that identifies DEGs across two separate experiments#########


library(dplyr)
library(htmltools)
library(dataui)
library(reactable)
data("diamonds", package="ggplot2")

hist_all <- hist(diamonds$price, breaks = 20, plot = FALSE)

dat <- diamonds %>%
  group_by(cut) %>%
  summarize(
    n = n(),
    mean_price = mean(price),
    hist = list(unclass(hist(price, breaks = hist_all$breaks, plot = FALSE)))
  )

topo <- topo.colors(10)

components <- lapply(dat$hist, function(h, i) {
  x <- hist_to_binned_data(h = h, density = FALSE)
  dui_densityseries(binnedData = x, fill = topo[i], stroke = topo[i], fillOpacity = 0.2)
}, i = seq_along(length(dat$hist)))
# add density for all
# components[[length(components) + 1]] <- dui_densityseries(
#   binnedData = hist_to_binned_data(hist_all),
#   stroke = "#ccc",
#   fill = "#ccc",
#   fillOpacity = 0.5
# )

dui_histogram(
  #cumulative = TRUE,
  normalized = TRUE,
  components = c(components, list(dui_xaxis(),dui_yaxis()))
)

max_pct <- max(unlist(lapply(dat$hist, function(x) {x$counts/sum(x$counts)})))
max_density <- max(unlist(lapply(dat$hist, function(x) {x$density})))

# standalone sparkline version
dat %>%
  reactable(
    style = "font-family: sans-serif;",
    rowStyle = "font-size:1.2rem; align-items: flex-end; border-bottom: 1px solid lightgray;",
    compact = TRUE,
    borderless = TRUE,
    striped = TRUE,
    defaultColDef = colDef(headerStyle = "text-transform: uppercase; align-self: flex-end; font-weight:normal;"),
    columns = list(
      cut = colDef(name = "Cut"),
      n = colDef(name = "Count", format = colFormat(separators = TRUE)),
      mean_price = colDef(name = "Avg. Price", format = colFormat(currency = "USD", separators = TRUE) ),
      hist = colDef(
        name = "Price Histogram",
        sortable = FALSE,
        cell = dui_for_reactable(
          dui_sparkline(
            data = htmlwidgets::JS("cellInfo.value.density"),
            max = max_density,
            height = 80,
            margin = list(top = 0, bottom = 0, left = 20, right = 0),
            components = list(
              dui_sparkbarseries(),
              dui_tooltip(
                list(
                  dui_sparkhorizontalrefline(
                    stroke = "#ccc",
                    strokeDasharray = "4,4"
                  ),
                  dui_sparkpointseries(
                    renderLabel = htmlwidgets::JS("(d) => d ? (d*100000).toFixed(2) + '%' : null"),
                    labelPosition = "right"
                  )
                )
              )
            )
          )
        )
      )
    )
  ) %>%
  dataui::dui_add_reactable_dep()

# htmlwidget version
dat %>%
  reactable(
    style = "font-family: sans-serif;",
    rowStyle = "font-size:1.2rem; align-items: flex-end; border-bottom: 1px solid lightgray;",
    compact = TRUE,
    borderless = TRUE,
    striped = TRUE,
    defaultColDef = colDef(headerStyle = "text-transform: uppercase; align-self: flex-end; font-weight:normal;"),
    columns = list(
      cut = colDef(name = "Cut"),
      n = colDef(name = "Count", format = colFormat(separators = TRUE)),
      mean_price = colDef(name = "Avg. Price", format = colFormat(currency = "USD", separators = TRUE) ),
      hist = colDef(
        minWidth = 200,
        name = "Price Histogram",
        sortable = FALSE,
        cell = function(value, info)  {
          dui_sparkline(
            data = value$density,
            max = max_density,
            height = 80,
            width = "100%",
            margin = list(top = 0, bottom = 0, left = 20, right = 0),
            components = list(
              dui_sparkbarseries(),
              dui_tooltip(
                list(
                  dui_sparkhorizontalrefline(
                    stroke = "#ccc",
                    strokeDasharray = "4,4"
                  ),
                  dui_sparkpointseries(
                    renderLabel = htmlwidgets::JS("(d) => d ? (d*100000).toFixed(2) + '%' : null"),
                    labelPosition = "right"
                  )
                )
              )
            )
          )
        }
      )
    )
  )


##
##  Java Information Dynamics Toolkit (JIDT)
##  Copyright (C) 2012, Joseph T. Lizier
##
##  This program is free software: you can redistribute it and/or modify
##  it under the terms of the GNU General Public License as published by
##  the Free Software Foundation, either version 3 of the License, or
##  (at your option) any later version.
##
##  This program is distributed in the hope that it will be useful,
##  but WITHOUT ANY WARRANTY; without even the implied warranty of
##  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
##  GNU General Public License for more details.
##
##  You should have received a copy of the GNU General Public License
##  along with this program.  If not, see <http://www.gnu.org/licenses/>.
##

# Example 6 - Mutual information calculation with dynamic specification of calculator

# This example shows how to write R code to take advantage of the
#  common interfaces defined for various information-theoretic calculators.
# Here, we use the common form of the infodynamics.measures.continuous.MutualInfoCalculatorMultiVariate
#  interface (which is never named here) to write common code into which we can plug
#  one of three concrete implementations (kernel estimator, Kraskov estimator or
#  linear-Gaussian estimator) by dynamically supplying the class name of
#  the concrete implementation.

# Load the rJava library and start the JVM
library("rJava")
.jinit()

# Change location of jar to match yours:
#  IMPORTANT -- If using the default below, make sure you have set the working directory
#   in R (e.g. with setwd()) to the location of this file (i.e. demos/r) !!
.jaddClassPath("../../infodynamics.jar")

#---------------------
# 1. Properties for the calculation (these are dynamically changeable, you could
#    load them in from another properties file):
# The name of the data file (relative to this directory)
datafile <- "../data/4ColsPairedNoisyDependence-1.txt"
# List of column numbers for variables 1 and 2:
#  (you can select any columns you wish to be contained in each variable)
variable1Columns <- c(1,2) # array indices start from 1 in R
variable2Columns <- c(3,4)
# The name of the concrete implementation of the interface
#  infodynamics.measures.continuous.MutualInfoCalculatorMultiVariate
#  which we wish to use for the calculation.
# Note that one could use any of the following calculators (try them all!):
#  implementingClass <- "infodynamics/measures/continuous/kraskov/MutualInfoCalculatorMultiVariateKraskov1" # MI([1,2], [3,4]) = 0.36353
#  implementingClass <- "infodynamics/measures/continuous/kernel/MutualInfoCalculatorMultiVariateKernel"
#  implementingClass <- "infodynamics/measures/continuous/gaussian/MutualInfoCalculatorMultiVariateGaussian"
implementingClass <- "infodynamics/measures/continuous/kraskov/MutualInfoCalculatorMultiVariateKraskov1"

#---------------------
# 2. Load in the data
data <- read.csv(datafile, header=FALSE, sep="")
# Pull out the columns from the data set which correspond to each of variable 1 and 2:
variable1 <- data[, variable1Columns]
variable2 <- data[, variable2Columns]
# Extra step to extract the raw values from these data.frame objects:
variable1 <- apply(variable1, 2, function(x) as.numeric(x))
variable2 <- apply(variable2, 2, function(x) as.numeric(x))

#---------------------
# 3. Dynamically instantiate an object of the given class:
# (in fact, all java object creation in octave/matlab is dynamic - it has to be,
#  since the languages are interpreted. This makes our life slightly easier at this
#  point than it is in demos/java/example6LateBindingMutualInfo where we have to handle this manually)
miCalc<-.jnew(implementingClass)

#---------------------
# 4. Start using the MI calculator, paying attention to only
#  call common methods defined in the interface type
#  infodynamics.measures.continuous.MutualInfoCalculatorMultiVariate
#  not methods only defined in a given implementation class.
# a. Initialise the calculator to use the required number of
#   dimensions for each variable:
.jcall(miCalc,"V","initialise", length(variable1Columns), length(variable2Columns))
# b. Supply the observations to compute the PDFs from:
.jcall(miCalc,"V","setObservations",
	.jarray(variable1, "[D", dispatch=TRUE),
	.jarray(variable2, "[D", dispatch=TRUE))
# c. Make the MI calculation:
miValue <- .jcall(miCalc,"D","computeAverageLocalOfObservations")

cat("MI calculator", implementingClass, "\n computed the joint MI as ",
	miValue, "\n")


SIreg <- uvozi.zemljevid("https://biogeo.ucdavis.edu/data/gadm3.6/shp/gadm36_SVN_shp.zip",
                              "gadm36_SVN_1", encoding="UTF-8")

koordinate <- coordinates(SIreg) %>% as_tibble()

# uporabim fortify, da lahko uporabljam ggplot2
SIreg_fort <- SIreg %>%
 fortify()

SIreg_fort <- SIreg_fort %>%
  mutate(
    NAME_1=str_replace(NAME_1, "Notranjsko-kraška", "Primorsko-notranjska"),
    NAME_1=str_replace(NAME_1, "Spodnjeposavska", "Posavska"))

SIreg_fort <- SIreg_fort %>%
  rename(regija=NAME_1)

regije <- regije %>% mutate(
  rojeni=gsub("\\.", "", rojeni),
  rojeni=as.numeric(rojeni))

SIreg_zdr <- inner_join(regije, SIreg_fort, by="regija")

brez.ozadja <- theme_bw() +
  theme(
    axis.line=element_blank(),
    axis.text.x=element_blank(),
    axis.text.y=element_blank(),
    axis.ticks=element_blank(),
    axis.title.x=element_blank(),
    axis.title.y=element_blank(),
    panel.background=element_blank(),
    panel.border=element_blank(),
    panel.grid.major=element_blank(),
    panel.grid.minor=element_blank(),
    plot.background=element_blank()
  )

regije.imena <- c("Gorenjska", "Goriška", "Jugovzhodna Slovenija", "Koroška", "Primorsko-notranjska","Obalno-kraška","Osrednjeslovenska","Podravska","Pomurska","Savinjska","Posavska","Zasavska")

koord <- koordinate %>%
  mutate(regija=regije.imena) %>%
  .[c(3,1,2)]

# zemljevid števila živorojenih otrok v regijah za leto 2018

SIreg_zdr2018 <- SIreg_zdr %>% filter(leto=="2018") %>%
  mutate(rojeni=as.numeric(rojeni))
brks <- quantile(SIreg_zdr2018$rojeni, seq(0,1,1/8))

legendaLabele <- paste(as.integer(brks[1:8]), as.integer(brks[2:9]), sep="-")
legendaNaslov <- "Število rojenih otrok"

zem.reg <- SIreg_zdr2018 %>%
  mutate(
    kvantil=factor(findInterval(SIreg_zdr2018$rojeni, brks, all.inside=TRUE))
    ) %>%
  ggplot() +
  geom_polygon(aes(x=long, y=lat, group=group, fill=kvantil), color="black", size=0.001) +
  scale_fill_brewer(
    type=9, palette="Reds",
    labels=legendaLabele,
    name=legendaNaslov
    ) +
  labs(title="Število rojenih otrok v letu 2018 za posamezne slovenske regije") +
  geom_text(data=koord, aes(x=V1, y=V2, label=regija), size=6) +
  brez.ozadja +
  theme(plot.title=element_text(size=20),
        legend.title=element_text(size=20),
        legend.text=element_text(size=20))

# primerjava števila živorojenih otrok v regijah z najvišjo in najnižjo vrednostjo

v <- c("Zasavska", "Primorsko-notranjska", "Osrednjeslovenska", "Podravska")

graf.reg <- ggplot(data=regije %>%
                     filter(regija %in% v),
                   aes(x=leto, y=rojeni, color=regija)) +
  geom_line(size=1) +
  xlab("Leto") +
  ylab("Število rojenih otrok") +
  scale_x_continuous(breaks=2009:2018) +
  labs(title="Število rojenih otrok v štirih slovenskih regijah") +
  guides(color=guide_legend(title="Regija")) +
  theme_bw(base_size=20)

# primerjava števila živorojenih otrok v nekaterih evropskih državah

EUpovrs <- inner_join(evropa, povrsine, by="drzava")

slovar <- c("Belgium"="Belgija",
            "Bulgaria"="Bolgarija",
            "Czechia"="Češka",
            "Denmark"="Danska",
            "Germany "="Nemčija",
            "Estonia"="Estonija",
            "Ireland"="Irska",
            "Greece"="Grčija",
            "Spain"="Španija",
            "France"="Francija",
            "Croatia"="Hrvaška",
            "Italy"="Italija",
            "Cyprus"="Ciper",
            "Latvia"="Latvija",
            "Lithuania"="Litva",
            "Luxembourg"="Luksemburg",
            "Hungary"="Madžarska",
            "Malta"="Malta",
            "Netherlands"="Nizozemska",
            "Austria"="Avstrija",
            "Poland"="Poljska",
            "Portugal"="Portugalska",
            "Romania"="Romunija",
            "Slovenia"="Slovenija",
            "Slovakia"="Slovaška",
            "Finland"="Finska",
            "Sweden"="Švedska",
            "United Kingdom"="Velika Britanija",
            "Iceland"="Islandija",
            "Liechtenstein"="Lihtenštajn",
            "Norway"="Norveška",
            "Switzerland"="Švica",
            "Montenegro"="Črna gora",
            "North Macedonia"="Severna Makedonija",
            "Albania"="Albanija",
            "Serbia"="Srbija",
            "Turkey"="Turčija",
            "Andorra"="Andora",
            "Belarus"="Belorusija",
            "Bosnia and Herzegovina"="Bosna in Hercegovina",
            "Kosovo "="Kosovo",
            "Moldova"="Moldavija",
            "Russia"="Rusija",
            "San Marino"="San Marino",
            "Ukraine"="Ukrajina",
            "Armenia"="Armenija",
            "Azerbaijan"="Azerbajdžan",
            "Georgia"="Gruzija")

u <- c("Malta", "Iceland", "Netherlands", "Finland", "France", "Slovenia", "Luxembourg", "United Kingdom")
EUpovrs$leto <- as.numeric(EUpovrs$leto)
EUpovrs <- EUpovrs %>% mutate(gostota=rojeni/povrsina)

graf.evr <- ggplot(data=EUpovrs %>%
                     filter(drzava %in% u),
                   aes(x=leto, y=gostota, color=slovar[drzava])) +
  geom_line(size=1) +
  xlab("Leto") +
  ylab("Število rojenih otrok na km\u00B2") +
  scale_x_continuous(breaks=2009:2018) +
  labs(title="Število rojenih otrok na km\u00B2 v osmih evropskih državah") +
  guides(color=guide_legend(title="Država")) +
  theme_bw(base_size=20)

# primerjava števila rojstev po mesecih

meseci$mesec <- factor(meseci$mesec, levels = unique(meseci$mesec))

graf.mes <- ggplot(data=meseci,
                   aes(x=leto, y=rojeni, color=mesec)) +
  geom_line(size=1) +
  xlab("Leto") +
  ylab("Število rojenih otrok") +
  scale_x_continuous(breaks=2009:2018) +
  labs(title="Število rojenih otrok v posameznih mesecih") +
  guides(color=guide_legend(title="Mesec")) +
  theme_bw(base_size=20)

# število rojstev v Evropi za leti 2009 in 2018

w <- c("Ukraine", "San Marino", "Russia", "Moldova", "Kosovo ", "Bosnia and Herzegovina", "Albania", "Liechtenstein", "Andorra")

graf.evr2 <- ggplot(EUpovrs %>%
                      filter(leto %in% c("2009", "2018")) %>%
                      filter(!(drzava %in% w)),
                    aes(x=gostota, y=reorder(slovar[drzava], -gostota), fill=factor(leto))) +
  geom_col(position="dodge") +
  labs(title="Število rojenih otrok na km\u00B2 v evropskih državah za leti 2009 in 2018") +
  xlab("Število otrok na km\u00B2") +
  ylab("Država") +
  guides(fill=guide_legend(title="Leto")) +
  geom_vline(mapping=aes(xintercept=mean(EUpovrs %>% filter(leto==2018) %>% filter(!(drzava %in% w)) %>% .$gostota)),
             col="indianred2") +
  geom_vline(mapping=aes(xintercept=mean(EUpovrs %>% filter(leto==2009) %>% filter(!(drzava %in% w)) %>% .$gostota)),
             col="cadetblue3") +
  scale_fill_manual(values=c("cadetblue3", "indianred2")) +
  theme_bw(base_size=20)

# napoved števila rojstev za Slovenijo

quadratic <- lm(data=EUpovrs %>% filter(drzava=="Slovenia"), gostota ~ I(leto))
leta <- data.frame(leto=seq(2019, 2025, 1))
prediction <- mutate(leta, gostota=predict(quadratic, leta))

graf.napoved <- ggplot(EUpovrs %>%
         filter(drzava == "Slovenia")) +
  aes(x=leto, y=gostota) +
  geom_smooth(method="lm", fullrange=TRUE, color="red4", formula=y ~ x) +
  geom_point(size=2, color="royalblue4") +
  geom_point(data=prediction %>% filter(leto >= 2019), color="green4", size=3) +
  scale_x_continuous('Leto', breaks=seq(2009, 2025, 1), limits=c(2009, 2025)) +
  labs(title="Napoved števila rojenih otrok na km\u00B2 v Sloveniji do leta 2025") +
  ylab("Število rojenih otrok na km\u00B2") +
  theme_bw(base_size=20) +
  theme(axis.text.x=element_text(angle=45, hjust=1),
        axis.title.x = element_text(vjust=-4),
        axis.title.y = element_text(vjust=5))


library(ggplot2)
theme_set(theme_gray(base_family ='Migu 1M'))

# 散布図(sample of qplot)
qplot(
  carat,
  price,
  colour = cut,
  data = diamonds,
  main ='ダイヤモンドのカラットと価格の関係',
  xlab='カラット',
  ylab='価格[$]'
)

g <- ggplot(diamonds, aes(cut))

g_bar <- g + geom_bar(aes(fill = clarity))
print(g_bar)

g2 <- ggplot(diamonds, aes(cut))
g_bar_dodge <- g2 + geom_bar(position='dodge', aes(fill =clarity))

print(g_bar_dodge)


#===============================================================
# Validate ideology estimates of our model by comparing them to
# the political parties of members of Congress.
#
# We note that not every member of Congress was included in our
# model, because collecting the followers of some of them was
# infeasible.
#
# This should theoretically show a correlation between the
# members' political party and our ideological estimate. We draw
# paired boxplots to view this qualitatively.
#
# This script assumes:
#  - ideology estimates stored in estimates.Rdata
#  - republicans list stored in congress_republicans.csv
#  - democrats list stored in congress_democrats.csv
#===============================================================

library(ggplot2)

#===============================================================
# APPLY ESTIMATES
#===============================================================

load("estimates.Rdata")  # loads matrix estimates

# Load lists of congresspeople from saved files
reps <- read.csv("congress_republicans.csv", header = FALSE,
                 col.names = c("id", "name", "followers", "party"))

dems <- read.csv("congress_democrats.csv", header = FALSE,
                 col.names = c("id", "name", "followers", "party"))

reps <- data.frame(reps)
dems <- data.frame(dems)

politicians <- rbind(dems, reps)

# Apply estimates; keep non-null ideology estimates
p <- merge(x = politicians, y = estimates[c("id", "ideology")], by = "id")

#===============================================================
# CHECK ACCURACY
#===============================================================

# Check how well an ideology threshold of 0.5 works; that is,
# if we classify everyone below 0.5 as a Democrat, and
# everyone above it as a Republican, how well do we do?

t <- table(p$ideology > 0.5, p$party == "R")
(t[1,1] + t[2,2]) / sum(t)  # 0.991

# Apparently, 99% accuracy. Remember that we never used party
# affiliation when constructing the estimates; we only used
# the structure of the followers network.

# Next, perform a t-test to see if the estimates differ
# significantly for Democrats and Republicans in Congress.
t.test(p[p$party == "R",]$ideology, p[p$party == "D",]$ideology, var.equal = TRUE)

# t = 53.7
# There is clearly a difference in our estimates, which is reassuring.

#===============================================================
# PLOTS
#===============================================================

# Boxplot
plt <- ggplot(p, aes(x = party, y = ideology)) +
       geom_boxplot(fill="lightblue") +
       labs(title="Ideology Estimates of Members of Congress",
            x="Party Affiliation", y="Ideology Estimate") +
       coord_flip()

ggsave(f = "plots/congress_boxplot.png", plot = plt, height = 3, width = 8)

# Jitter plot
plt <- ggplot(p, aes(x = party, y = ideology)) +
       geom_jitter(aes(color=party)) +
       labs(title="Ideology Estimates of Members of Congress",
            x="Party Affiliation", y="Ideology Estimate") +
       theme(legend.position="none") +
       scale_color_manual(values=c("slateblue1", "firebrick1")) +
       coord_flip()

ggsave(f = "plots/congress_jitter.png", plot = plt, height = 3, width = 8)


ships.2018 <- x$IMO.Number[x$reporting.period == 2018]
ships.2019 <- x$IMO.Number[x$reporting.period == 2019]
ships.2020 <- x$IMO.Number[x$reporting.period == 2020]

# a matrix of T/F whether a ship has data in a given year
ships.by.year <- matrix(FALSE,nrow=length(unique(x$IMO.Number)),ncol=3)
rownames(ships.by.year) <- sort(unique(x$IMO.Number))
colnames(ships.by.year) <- c('2018','2019','2020')
ships.by.year[,'2018'] <- rownames(ships.by.year) %in% ships.2018
ships.by.year[,'2019'] <- rownames(ships.by.year) %in% ships.2019
ships.by.year[,'2020'] <- rownames(ships.by.year) %in% ships.2020

is.ship.with.prior.year <- ships.by.year[,'2020'] & (ships.by.year[,'2019'] | ships.by.year[,'2018'])
ships.with.prior.year <- rownames(ships.by.year)[is.ship.with.prior.year]
y2020 <- x[x$reporting.period == 2020 & (x$IMO.Number %in% ships.with.prior.year),'kg.CO2.per.nm']
names(y2020) <- x$IMO.Number[x$reporting.period == 2020 & (x$IMO.Number %in% ships.with.prior.year)]
yhat <- y2020
for(i in 1:length(y2020)){
    ship.id <- names(y2020)[i]
    if((ship.id %in% ships.2018) && (ship.id %in% ships.2019)){
      yhat[i] <- mean(x[x$IMO.Number == ship.id & x$reporting.period != 2020,'kg.CO2.per.nm'])
    } else if(ship.id %in% ships.2018) {
      yhat[i] <- x[x$IMO.Number == ship.id & x$reporting.period == 2018,'kg.CO2.per.nm']
    } else if(ship.id %in% ships.2019) {
      yhat[i] <- x[x$IMO.Number == ship.id & x$reporting.period == 2019,'kg.CO2.per.nm']
    }
}


library(RColorBrewer)
png("#40_colorRampPalette_and_RcolorBrewer.png" , width = 480, height = 480)
par(mar=c(0,0,0,0))
coul = brewer.pal(4, "BuPu")
coul = colorRampPalette(coul)(25)
pie(rep(1, length(coul)), col = coul , main="")
dev.off()


#' fRH
#'
#' Return relative humidity from air temperature (Celsius) and Dew point (Celsius);
#'
#' @param t numeric Vector or value of air temperature in Celsius degree.
#' @param td numeric Vector or value of dew point temperature in Celsius degree.
#' @return relative humidity value
#'
#'
#' @author  Istituto per la Bioeconomia CNR Firenze Italy  Alfonso Crisci \email{alfonso.crisci@@ibe.cnr.it}
#' @keywords  Relative humidity
#'
#' @export
#'
#'
#'
#'

fRH=function(t,td) {
                         ct$assign("t", as.array(t))
                         ct$assign("td", as.array(td))
                         ct$eval("var res=[]; for(var i=0, len=t.length; i < len; i++){ res[i]=fRH(t[i],td[i])};")
                         res=ct$get("res")
                         return(ifelse(res==9999,NA,res))
}


#Rscript

#####################################################################################################################
#####################################################################################################################
###################################### Create a plot from your community data #######################################
#####################################################################################################################
#####################################################################################################################

###################### Packages
suppressMessages(library(ggplot2))
suppressMessages(library(boot))

###################### Load arguments and declaring variables

args <- commandArgs(trailingOnly = TRUE)

if (length(args) < 2) {
    stop("At least 3 arguments must be supplied input dataset file with GLM results (.tabular)", call. = FALSE) #if no args -> error and exit1

} else {
    import_data <- args[1] ###### file name : glm results table
    data_tab <- args[2] ###### file name : Metrics table
    unitobs_tab <- args[3] ###### file name : Unitobs table
    source(args[4]) ###### Import functions

}

#Import data
glmtable <- read.table(import_data, sep = "\t", dec = ".", header = TRUE, encoding = "UTF-8") #
datatable <- read.table(data_tab, sep = "\t", dec = ".", header = TRUE, encoding = "UTF-8") #
unitobs <- read.table(unitobs_tab, sep = "\t", dec = ".", header = TRUE, encoding = "UTF-8") #

#Check files

vars_data1 <- c("analysis", "Interest.var", "distribution")
err_msg_data1 <- "The input GLM results dataset doesn't have the right format. It needs to have at least the following 3 fields :\n- analysis\n- Interest.var\n- distribution\n"
check_file(glmtable, err_msg_data1, vars_data1, 4)

if (length(grep("[0-2][0|9][0-9][0-9].[Estimate|Pvalue]", colnames(glmtable))) == 0) {
    stop("The input GLM results dataset doesn't have the right format or informations. This tool is to represent temporal trends, if your GLM doesn't take the year variable as a fixed effect this tool is not proper to make any representation of it. It needs to have at least estimates and p-value for every year from your time series GLM as columns with name formated as : yyyy Estimate (example : 2020 Estimate) and  yyyy Pvalue (example : 2020 Pvalue).")
}

if (length(grep("[0-2][0|9][0-9][0-9].IC_[up|inf]", colnames(glmtable))) == 0) {
    assess_ic <- FALSE
}else{
    assess_ic <- TRUE
}

metric <- as.character(glmtable[1, "Interest.var"])

vars_data2 <- c("observation.unit", "location", metric)
err_msg_data2 <- "The input metrics dataset doesn't have the right format. It needs to have at least the following 3 fields :\n- observation.unit\n- location\n- the name of the interest metric\n"
check_file(datatable, err_msg_data2, vars_data2, 4)

vars_data3 <- c("observation.unit", "year")
err_msg_data3 <- "The input unitobs dataset doesn't have the right format. It needs to have at least the following 2 fields :\n- observation.unit\n- year\n"
check_file(unitobs, err_msg_data3, vars_data3, 2)
if (length(grep("[0-2][0|9][0-9][0-9]", unitobs$year)) == 0) {
    stop("The year column in the input unitobs dataset doesn't have the right format. Years must be fully written as : yyyy (example : 2020).")
}

if (all(is.na(match(datatable[, "observation.unit"], unitobs[, "observation.unit"])))) {
    stop("Observation units doesn't match in the inputs metrics dataset and unitobs dataset")
}

####################################################################################################################
######################### Creating plot from time series GLM data ## Function : ggplot_glm #########################
####################################################################################################################
ggplot_glm <- function(glmtable, datatable, unitobs, metric = metric, sp, description = TRUE,
                       trend_on_graph = TRUE, assess_ic = TRUE) {
    ## Purpose: Creating plot from time series GLM data
    ## ----------------------------------------------------------------------
    ## Arguments: glmtable : GLM(s) results table
    ##            datatable : Metrics table
    ##            unitobs : Unitobs table
    ##            metric : Interest variable in GLM(s)
    ##            sp : name of processed GLM
    ##            description : Two graphs ?
    ##            trend_on_graph : Write global trend of the time series on graph ?
    ##            assess_ic : Assess confidence intervals ?
    ## ----------------------------------------------------------------------
    ## Author: Coline ROYAUX 13 october 2020

    s_signif <- 0.05 ## threshold when pvalue is considered significant
    distrib <- as.character(glmtable[1, "distribution"]) ## extract GLM distribution

    col <- c("observation.unit", "location", metric) ## names of needed columns in metrics table to construct the 2nd panel of the graph

    if (colnames(glmtable)[length(glmtable)] == "separation") { ## if GLM is a community analysis
        cut <- as.character(glmtable[1, "separation"])
        if (cut != "None") { ## if there is plural GLM analysis performed
            if (! is.element(as.character(cut), colnames(unitobs))) {
                stop("The input unitobs dataset doesn't have the right format. If plural GLM analysis have been performed it needs to have the field used as separation factor.")
            }
            datatable <- cbind(datatable[, col], unitobs[match(datatable[, "observation.unit"], unitobs[, "observation.unit"]), c("year", cut)]) ## extracting 'year' and analysis separation factor columns from unitobs table to merge with metrics table /// Matching lines with 'observation.unit' column
            colnames(datatable) <- c(col, "year", cut)
        }else{
            datatable <- cbind(datatable[, col], unitobs[match(datatable[, "observation.unit"], unitobs[, "observation.unit"]), "year"]) ## extracting 'year' column from unitobs table to merge with metrics table /// Matching lines with 'observation.unit' column
            colnames(datatable) <- c(col, "year")
        }

    }else{ ## GLM is a population analysis
        cut <- "species.code"
        if (! is.element("species.code", colnames(datatable))) {
            stop("The input metrics dataset or the GLM results dataset doesn't have the right format. If the GLM is a population analysis, the field species.code needs to be informed in the metrics dataset. If the GLM is a community analysis the field separation (None if only one analysis and name of the separation factor if several analysis) needs to be informed in the last column of the GLM results dataset.")
        }
        col <- c(col, cut)
        datatable <- cbind(datatable[, col], unitobs[match(datatable[, "observation.unit"], unitobs[, "observation.unit"]), "year"]) ## extracting 'year' column from unitobs table to merge with metrics table /// Matching lines with 'observation.unit' column
        colnames(datatable) <- c(col, "year")
    }

    ##vpan vector of names of the two panels in the ggplot

    switch(as.character(metric),
           "number" = vpan <- c("Abundance variation", "Raw abundance"),
           "presence_absence" = vpan <- c("Presence-absence variation", "% presence in location"),
           vpan <- c(paste(metric, " variation"), paste("Mean ", metric)))

    ##Cut table for 1 analysis
    glmtab <- glmtable[glmtable[, "analysis"] == sp, ]

    glmtab <- glmtab[, grep("FALSE", is.na(glmtab[1, ]))] ## Supress columns with NA only

    ## specification of temporal variable necessary for the analyses
    an <- as.numeric(unlist(strsplit(gsub("X", "", paste(colnames(glmtab)[grep("[0-2][0|9][0-9][0-9].Estimate", colnames(glmtab))], collapse = " ")), split = ".Estimate"))) ## Extract list of years studied in the GLM

    year <- sort(c(min(an) - 1, an)) ## Add the first level, "reference" in the GLM
    nbans <- length(year)
    pasdetemps <- nbans - 1

    ##### Table 1

    coefan <- unlist(lapply(an, FUN = function(x) {
                                          if (length(glmtab[glmtab[, 1] == sp, grep(paste0("X", x, ".Estimate"), colnames(glmtab))]) > 0) {
                                              glmtab[glmtab[, 1] == sp, grep(paste0("X", x, ".Estimate"), colnames(glmtab))]
                                          }else{
                                              NA
                                          }
                                                 }))  ## extract estimates for each years to contruct graph 1

    ic_inf <- unlist(lapply(an, FUN = function(x) {
                                          if (length(glmtab[glmtab[, 1] == sp, grep(paste0("X", x, ".IC_inf"), colnames(glmtab))]) > 0) {
                                              glmtab[glmtab[, 1] == sp, grep(paste0("X", x, ".IC_inf"), colnames(glmtab))]
                                          }else{
                                               NA
                                          }
                                                  }))

    ic_up <- unlist(lapply(an, FUN = function(x) {
                                         if (length(glmtab[glmtab[, 1] == sp, grep(paste0("X", x, ".IC_up"), colnames(glmtab))]) > 0) {
                                             glmtab[glmtab[, 1] == sp, grep(paste0("X", x, ".IC_up"), colnames(glmtab))]
                                         }else{
                                             NA
                                         }
                                                }))

    switch(distrib,  ## Applying the reciprocal of the link function to coefficients and confidence intervals depending on distribution law
           "poisson" = {
                            coefyear <- c(1, exp(as.numeric(coefan))) ## link function : log
                            if (assess_ic) {
                                ic_inf_sim <- c(1, exp(as.numeric(ic_inf)))
                                ic_sup_sim <- c(1, exp(as.numeric(ic_up)))
                            } else {
                                ic_inf_sim <- NA
                                ic_sup_sim <- NA
                      }},
           "quasipoisson" = {
                                 coefyear <- c(1, exp(as.numeric(coefan))) ## link function : log
                                 if (assess_ic) {
                                     ic_inf_sim <- c(1, exp(as.numeric(ic_inf)))
                                     ic_sup_sim <- c(1, exp(as.numeric(ic_up)))
                                 } else {
                                     ic_inf_sim <- NA
                                     ic_sup_sim <- NA
                           }},
           "inverse.gaussian" = {
                                     coefyear <- c(0, as.numeric(coefan) ^ (- 1 / 2)) ## link function : x^ - 2
                                     if (assess_ic) {
                                         ic_inf_sim <- c(0, as.numeric(ic_inf) ^ (- 1 / 2))
                                         ic_sup_sim <- c(0, as.numeric(ic_up) ^ (- 1 / 2))
                                     } else {
                                         ic_inf_sim <- NA
                                         ic_sup_sim <- NA
                               }},
           "binomial" = {
                             coefyear <- c(1, boot::inv.logit(as.numeric(coefan))) ## link function : logit
                             if (assess_ic) {
                                 ic_inf_sim <- c(1, boot::inv.logit(as.numeric(ic_inf)))
                                 ic_sup_sim <- c(1, boot::inv.logit(as.numeric(ic_up)))
                             } else {
                                 ic_inf_sim <- NA
                                 ic_sup_sim <- NA
                       }},
           "quasibinomial" = {
                                  coefyear <- c(1, boot::inv.logit(as.numeric(coefan))) ## link function : logit
                                  if (assess_ic) {
                                      ic_inf_sim <- c(1, boot::inv.logit(as.numeric(ic_inf)))
                                      ic_sup_sim <- c(1, boot::inv.logit(as.numeric(ic_up)))
                                  } else {
                                      ic_inf_sim <- NA
                                      ic_sup_sim <- NA
                            }},
           "Gamma" = {
                          coefyear <- c(1, as.numeric(coefan) ^ (- 1)) ## link function : -x^ - 1
                          if (assess_ic) {
                              ic_inf_sim <- c(1, as.numeric(ic_inf) ^ (- 1))
                              ic_sup_sim <- c(1, as.numeric(ic_up) ^ (- 1))
                          } else {
                              ic_inf_sim <- NA
                              ic_sup_sim <- NA
                    }}
         , {
                coefyear <- c(0, as.numeric(coefan))
                if (assess_ic) {
                    ic_inf_sim <- c(0, as.numeric(ic_inf))
                    ic_sup_sim <- c(0, as.numeric(ic_up))
                } else {
                    ic_inf_sim <- NA
                    ic_sup_sim <- NA
            }})

    pval <- c(1, unlist(lapply(an, FUN = function(x) {
                                             if (length(glmtab[glmtab[, 1] == sp, grep(paste0("X", x, ".Pvalue"), colnames(glmtab))]) > 0) {
                                                 glmtab[glmtab[, 1] == sp, grep(paste0("X", x, ".Pvalue"), colnames(glmtab))]
                                              }else{
                                                  NA
                                              }
                                                    }))) ## extract p value for each year

    tab1 <- data.frame(year, val = coefyear,  ## table for the graphical output 1
                       ll = unlist(ic_inf_sim), ul = unlist(ic_sup_sim),
                       catPoint = ifelse(pval < s_signif, "significatif", NA), pval,
                       courbe = vpan[1],
                       panel = vpan[1])
    ## cleaning of wrong or biaised measures of the confidence interval
    if (assess_ic) {
        tab1$ul <-  ifelse(tab1$ul == Inf, NA, tab1$ul)
        tab1$ul <-  ifelse(tab1$ul > 1.000000e+20, NA, tab1$ul)
        tab1$val <-  ifelse(tab1$val > 1.000000e+20, 1.000000e+20, tab1$val)
    }

    coefancontinu <- as.numeric(as.character(glmtab[glmtab[, 1] == sp, grep("year.Estimate", colnames(glmtab))])) ##  tendency of population evolution on the studied period = regression coefficient of the variable year as a continuous variable in the GLM
    switch(distrib, ## Applying the reciprocal of the link function to coefficients and confidence intervals depending on distribution law
           "poisson" = {
                           trend <- round(exp(as.numeric(coefancontinu)), 3) ## link function : log
                            pourcentage <- round((exp(as.numeric(coefancontinu) * as.numeric(pasdetemps)) - 1) * 100, 2)
                       },
           "quasipoisson" = {
                                 trend <- round(exp(as.numeric(coefancontinu)), 3) ## link function : log
                                 pourcentage <- round((exp(as.numeric(coefancontinu) * as.numeric(pasdetemps)) - 1) * 100, 2)
                            },
           "inverse.gaussian" = {
                                     trend <- round(as.numeric(coefancontinu) ^ (- 1 / 2), 3) ## link function : x^ - 2
                                     pourcentage <- round((((as.numeric(coefancontinu) * as.numeric(pasdetemps)) ^ (- 1 / 2)) - 1) * 100, 2)
                                },
           "binomial" = {
                             trend <- round(boot::inv.logit(as.numeric(coefancontinu)), 3) ## link function : logit
                             pourcentage <- round((boot::inv.logit(as.numeric(coefancontinu) * as.numeric(pasdetemps)) - 1) * 100, 2)
                        },
           "quasibinomial" = {
                                  trend <- round(boot::inv.logit(as.numeric(coefancontinu)), 3) ## link function : logit
                                  pourcentage <- round((boot::inv.logit(as.numeric(coefancontinu) * as.numeric(pasdetemps)) - 1) * 100, 2)
                             },
           "Gamma" = {
                          trend <- round(as.numeric(coefancontinu) ^ (- 1), 3) ## link function : -x^ - 1
                          pourcentage <- round((((as.numeric(coefancontinu) * as.numeric(pasdetemps)) ^ (- 1)) - 1) * 100, 2)
                     }
         , {
                trend <- round(as.numeric(coefancontinu), 3)
                pourcentage <-  round((((as.numeric(coefancontinu) * as.numeric(pasdetemps))) - 1) * 100, 2)
           })

    pval <- as.numeric(as.character(glmtab[glmtab[, 1] == sp, grep("year.Pvalue", colnames(glmtab))])) ## Extract p value

    ## table for global trend on the whole time series
    tab1t <- NULL
    if (length(pval) > 0) {
        tab1t <- data.frame(Est = trend, pourcent = pourcentage, signif = pval < s_signif, pval)
    }

    ##### Table 2

    if (sp == "global") { ## prepare metrics table to extract variables used in graph 2
        datatablecut <- datatable[grep("FALSE", is.na(datatable[, as.character(metric)])), ]

    }else{

        datatablecut <- datatable[datatable[, as.character(cut)] == sp, ]
        datatablecut <- datatablecut[grep("FALSE", is.na(datatablecut[, as.character(metric)])), ]
    }

    switch(as.character(metric), ## Different value represented graph 2 depending on the nature of the metric
           "number" = {
                           valplot <- lapply(sort(year), FUN = function(x) {
                                                                   sum(na.omit(as.numeric(subset(datatablecut, year == x)[, as.character(metric)])))
                                                                           })
                      }, ## sum if abundance
           "presence_absence" = {
                                     nb_loc <- lapply(sort(year), FUN = function(x) {
                                                                            length(unique(subset(datatablecut, year == x)[, "location"]))
                                                                                }) ## number of plots per year
                                     nb_loc_presence <- lapply(sort(year), FUN = function(x) {
                                                                                length(unique(subset(datatablecut[datatablecut[, metric] > 0, ], year == x)[, "location"]))
                                                                                }) ##  number of plots where the species were observed
                                     valplot <- (na.omit(as.numeric(nb_loc_presence)) / na.omit(as.numeric(nb_loc))) * 100
                                } ## % of presence in observered plots if presence / absence
         , {
                valplot <- lapply(sort(year), FUN = function(x) {
                                                        mean(na.omit(as.numeric(subset(datatablecut, year == x)[, as.character(metric)])))
                                                                })
           } ## mean if any other metric
          )

    tab2 <- data.frame(year, val = round(as.numeric(valplot), 2), ll = NA, ul = NA, catPoint = NA, pval = NA,
                       courbe = vpan[2], panel = vpan[2])

    ## Creating ggplots

    dgg <- tab1

    figname <- paste(sp, ".png", sep = "")

    ## coord for horizontal lines in graphs
    hline_data1 <- data.frame(z = tab1$val[1], panel = c(vpan[1]), couleur = "var estimates", type = "var estimates")
    hline_data3 <- data.frame(z = 0, panel = vpan[2], couleur = "seuil", type = "seuil")
    hline_data <- rbind(hline_data1, hline_data3)
    titre <- paste(sp)

    ## text for the population evolution trend

    pasdetemps <- max(dgg$year) - min(dgg$year) + 1
    if (! is.null(tab1t)) {
        if (assess_ic) {
            txt_pente1 <- paste("Global trend : ", tab1t$Est,
                               ifelse(tab1t$signif, " *", ""),
                               ifelse(tab1t$signif, paste("\n", ifelse(tab1t$pourcent > 0, "+ ", "- "),
                                                         abs(tab1t$pourcent), " % in ", pasdetemps, " years", sep = ""), ""), sep = "")
        }else{
            txt_pente1 <- ifelse(tab1t$signif, paste("\n", ifelse(tab1t$pourcent > 0, "+ ", "- "),
                                                   abs(tab1t$pourcent), " % in ", pasdetemps, " years", sep = ""), "")
        }
    }else{
        trend_on_graph <- FALSE
    }

    ## table of the text for the population evolution trend
    tab_text_pent <- data.frame(y = c(max(c(dgg$val, dgg$ul), na.rm = TRUE) * .9),
                              x = median(dgg$year),
                              txt = ifelse(trend_on_graph, c(txt_pente1), ""),
                              courbe = c(vpan[1]), panel = c(vpan[1]))

    dgg <- rbind(tab1, tab2)

    ## colors for plots
    vec_col_point <- c("#ffffff", "#eeb40f", "#ee0f59")
    names(vec_col_point) <- c("significatif", "infSeuil", "0")
    vec_col_courbe <- c("#3c47e0", "#5b754d", "#55bb1d", "#973ce0")
    names(vec_col_courbe) <- c(vpan[1], "loc", "presence", vpan[2])
    vec_col_hline <- c("#ffffff", "#e76060")
    names(vec_col_hline) <- c("var estimates", "seuil")

    col <- c(vec_col_point, vec_col_courbe, vec_col_hline)
    names(col) <- c(names(vec_col_point), names(vec_col_courbe), names(vec_col_hline))

    p <- ggplot2::ggplot(data = dgg, mapping = ggplot2::aes_string(x = "year", y = "val"))
    ## Titles and scales
    p <- p + facet_grid(panel ~ ., scale = "free") +
    theme(legend.position = "none",
          panel.grid.minor = element_blank(),
          panel.grid.major.y = element_blank(),
          axis.text.x = element_text(angle = 90, vjust = 0.5, hjust = 1))  +
    ylab("") + xlab("year") + ggtitle(titre) +
    scale_colour_manual(values = col, name = "",
                             breaks = names(col)) +
    scale_x_continuous(breaks = min(dgg$year):max(dgg$year))
    p <- p + ggplot2::geom_hline(data = hline_data, mapping = ggplot2::aes_string(yintercept = "z", colour = "couleur", linetype = "type"),
                    alpha = 1, size = 1.2)
    if (assess_ic) { ############# ONLY FOR THE CONFIDENCE INTERVAL
        p <- p + ggplot2::geom_ribbon(mapping = ggplot2::aes_string(ymin = "ll", ymax = "ul"), fill = col[vpan[1]], alpha = .2)
        p <- p + ggplot2::geom_pointrange(mapping = ggplot2::aes_string(y = "val", ymin = "ll", ymax = "ul"), fill = col[vpan[1]], alpha = .2)
    }

    p <- p + ggplot2::geom_line(mapping = ggplot2::aes_string(colour = "courbe"), size = 1.5)
    p <- p + ggplot2::geom_point(mapping = ggplot2::aes_string(colour = "courbe"), size = 3)
    alph <- ifelse(!is.na(dgg$catPoint), 1, 0)
    p <- p + ggplot2::geom_point(mapping = ggplot2::aes_string(colour = "catPoint", alpha = alph), size = 2)
    p <- p + ggplot2::geom_text(data = tab_text_pent, mapping = ggplot2::aes_string("x", "y", label = "txt"), parse = FALSE, color = col[vpan[1]], fontface = 2, size = 4)
    ggplot2::ggsave(figname, p, width = 16, height = 15, units = "cm")
}
############################################################################################################ fin fonction graphique / end of function for graphical output

################# Analysis

for (sp in glmtable[, 1]) {

    if (!all(is.na(glmtable[glmtable[, 1] == sp, 4:(length(glmtable) - 1)]))) { ##ignore lines with only NA
        ggplot_glm(glmtable = glmtable, datatable = datatable, unitobs = unitobs, metric = metric, sp = sp, description = TRUE, trend_on_graph = TRUE, assess_ic = assess_ic)
    }
}

sink("stdout.txt", split = TRUE)


# Generate grid of test data

v = seq(-2,2,length=200)
z = expand.grid(v,v)
colnames(z) <- c('d1','d2')
write.table(z, 'test.csv',row.names=F, col.names=F,sep=',')


# Read in towers
towers <- read.csv("../data/tower_sites/Sites_all_BAMS_15march2019_v2.csv", stringsAsFactors = F)

# FILTER
towers <- towers %>%

  filter(IGBP %in% c("WET","CRO - Rice")) %>%
  # Could turn this filtering off to see a 'what if we had all towers scenario?"
  filter(Data_acquired == "yes") %>%
  filter(SITE_ID != "--*") %>%
  # Count Nb. of data years
  mutate(FLUX_MEASUREMENTS_DATE_END = ifelse(FLUX_MEASUREMENTS_DATE_END=="Present", 2019, FLUX_MEASUREMENTS_DATE_END)) %>%
  mutate(FLUX_MEASUREMENTS_DATE_END = as.numeric(FLUX_MEASUREMENTS_DATE_END),
         FLUX_MEASUREMENTS_DATE_START= as.numeric(FLUX_MEASUREMENTS_DATE_START))

towers <- towers[,1:10]

#-------------------------------------------------------------------------------
### CALCULATE THE NUMBER OF TOWERS PER YEAR

# create empty dataframe
output = data.frame()

# loop through rows (each row = a site)
for (i in 1:nrow(towers_pts_df)){

  # Make temp variables
  site = towers_pts_df[i,]
  id = site[1,'SITE_ID']
  start = site[1,'FLUX_MEASUREMENTS_DATE_START']
  end = site[1,'FLUX_MEASUREMENTS_DATE_END']

  # Make table of tower x year  for each row
  e <- expand.grid(c(id), seq(start, end))

  # append rows to output
  output <- bind_rows(output, e)

  }

# Rename columns
names(output) <- c("SITE_ID", "YEAR")

# Get tower count per year
count_towers_per_years <- output %>%
                          group_by(YEAR) %>%
                          summarise(n = n())

# Make lineplot of tower count
ggplot(count_towers_per_years) +
          geom_line(aes(x=YEAR, y=n)) +
          geom_point(aes(x=YEAR, y=n))