########################### BayesKin ###########################
## Bayesian estimates of rigid body kinematics
## Andy Pohl
## UofC - Faculty of Kinesiology

## Written by: Andy Pohl
## UofC - Faculty of Kinesiology
## June-Dec 2020
## Revision 1: April 2021
################################################################

##################### generate_results.r  ###################
## processes_results table for a batch of simulations
#############################################################

# preliminaries
rm(list = ls()) # clear workspace

library('dplyr')
library('latex2exp')
library('xtable')
library('coda')
WORKING_DIR = "" # Replace with the location of the BayesKin/src directory on the local PC.
setwd(WORKING_DIR)
RESULTS_DIR = paste0(WORKING_DIR, "/src/") # location of results directory

setwd(RESULTS_DIR)
# Load results file

FILENAME = "" # Filename of .rda result file produced by process_results.r
results = readRDS(FILENAME)
results = data.frame(results, stringsAsFactors = F)
results$model = factor(results$model, levels = c('LS', "Bayes_p1", "Bayes_p2", "Bayes_p3", "Bayes_p4", "Bayes_p5"))
results$parameter = factor(results$parameter, levels = c('r1', "r2", "theta1", "theta2", "theta3", "sigma"))
# Convert r/sigma to mm
results[results$parameter %in% c('r1', 'r2', 'sigma'),c('est', 'quantile.1', 'quantile.2', 'quantile.3', 'quantile.4', 'quantile.5')] = results[results$parameter %in% c('r1', 'r2', 'sigma'),c('est', 'quantile.1', 'quantile.2', 'quantile.3', 'quantile.4', 'quantile.5')]*1000

# Set constants
POSES = c("SingleLink", "DoubleLink", "TripleLink")
MODELS = c("LS", "Bayes_p1", "Bayes_p2", "Bayes_p3", "Bayes_p4", "Bayes_p5")
PARMS = c("r1", "r2", "theta1", "theta2", "theta3", "sigma")
PARMLABS = list(r1=TeX("$r_1 \\,  (mm)$"), r2=TeX("$r_2  \\, (mm)$"), theta1=TeX("$\\theta_1 \\, (^o)$"),
                theta2=TeX("$\\theta_2 \\, (^o)$"), theta3=TeX("$\\theta_3\\, (^o) "), sigma=TeX("$\\sigma \\, (mm)$"))
MODELLABS = c("LS", "Bayes P1", "Bayes P2", "Bayes P3", "Bayes P4", "Bayes P5")

TRUEVALS = list(r1 = 0.07*1000, r2 = 0.03*1000,
                theta1 = -55, theta2 = -110, theta3 = -10, sigma = 1.5/1000 *1000)

################################################################################
## FILTERING Poor MCMC convergence
################################################################################
# identify poor MCMC convergence
bad_seeds = results %>% group_by(pose) %>% filter(rhat>1.1) %>% select(pose, model, seed) %>% distinct()
bad_seeds %>% summarise(n_distinct(seed))

results = results[!((results$seed %in% bad_seeds$seed[bad_seeds$pose == 'SingleLink']) & (results$pose == 'SingleLink')),]
results = results[!((results$seed %in% bad_seeds$seed[bad_seeds$pose == 'DoubleLink']) & (results$pose == 'DoubleLink')),]
results = results[!((results$seed %in% bad_seeds$seed[bad_seeds$pose == 'TripleLink']) & (results$pose == 'TripleLink')),]

# filter to only 1000 iterations per pose
results_temps = results[results$pose =='SingleLink',]
temp_seeds = unique(results_temps$seed)
results_temps = results_temps[results_temps$seed %in% temp_seeds[1:1000],]

results_tempd = results[results$pose =='DoubleLink',]
temp_seeds = unique(results_tempd$seed)
results_tempd = results_tempd[results_tempd$seed %in% temp_seeds[1:1000],]

results_tempt = results[results$pose =='TripleLink',]
temp_seeds = unique(results_tempt$seed)
results_tempt = results_tempt[results_tempt$seed %in% temp_seeds[1:1000],]

results = rbind(results_temps, results_tempd, results_tempt)

results %>% group_by(pose) %>% summarise(n_distinct(seed))

################################################################################
## MCMC convergence summary
################################################################################

MCMC_summary = results %>% filter(model != "LS") %>%
    group_by(pose, model, parameter) %>%
    summarise( mean_neff = mean(rhat), sd_neff = sd(rhat))

xtable(MCMC_summary)

################################################################################
## Table 1: Bias, variance, mse and RMSE
################################################################################

tab1 = results %>% group_by(pose, model, parameter) %>% summarize(bias = mean(est), var = sd(est)^2)

parms = c("r1", "r2", "theta1", "theta2", "theta3", "sigma")
for(i in 1:length(parms)){
    tab1$bias[tab1$parameter == parms[i]] = tab1$bias[tab1$parameter == parms[i]] - TRUEVALS[[parms[i]]]
}
tab1$bias[tab1$parameter %in% c('r1', 'r2', 'sigma')] = tab1$bias[tab1$parameter %in% c('r1', 'r2', 'sigma')]
tab1$mse = tab1$bias^2 + tab1$var
tab1$rmse = sqrt(tab1$mse)

print(xtable(tab1[,c('pose', 'model', 'parameter', 'rmse')], digits = 3), include.rowname=F)

################################################################################
## FIGURE 1 strip charts
################################################################################
deltadeg = 2
deltar = .02 *1000
axislimits = list(r1 = TRUEVALS[[1]] +  c(-deltar, deltar),
                  r2 = TRUEVALS[[2]] +  c(-deltar, deltar),
                  theta1 = TRUEVALS[[3]] + c(-deltadeg, deltadeg),
                  theta2 = TRUEVALS[[4]] + c(-deltadeg, deltadeg),
                  theta3 = TRUEVALS[[5]] + c(-deltadeg, deltadeg),
                  sigma = c(0, 0.01))
axislimits$sigma = axislimits$sigma*1000

colors = list(grey = rgb(97/255, 97/255,97/255, 0.2),
              orange = rgb(241/255, 136/255,5/255, 1),
              blue = rgb(18/255, 78/255,120/255,  0.2),
              red = rgb(162/255, 0/255,33/255, 0.2),
              green = rgb(76/255, 159/255, 112/255, 0.2),
              purple = rgb(217/255, 187/255, 249/255, 0.2),
              pink = rgb(217/255, 3/255, 104/255, 0.2))

point_cols = list(colors$pink, colors$blue, colors$green, colors$purple)

# Adjust the following to choose what is plotted in the nparmsx4 grid of plots.
MODELS = c("LS", "Bayes_p1", "Bayes_p2", "Bayes_p3")
MODELLABS = c("LS", "Bayes P1", "Bayes P2", "Bayes P3")
################################################################################
## Single Link
################################################################################
sl_results = results %>% filter(pose == 'SingleLink')
par(mfcol = c(4,4), mar = c(3, 1, 1,1), mgp = c(2,0.5,0), cex.lab = 1.2, cex.main = 1.2)
for(i in 1:length(MODELS)){
    m_results = sl_results %>% filter(model == MODELS[i])
    ps = unique(m_results$parameter)
    for(j in 1:length(ps)){
        est = m_results %>% filter(parameter == ps[j]) %>% select(est)
        if(j ==1){
            plot(x = est[,1], y = runif(length(est[,1]), 0, 0.1),
                 xlim = get(as.character(ps[j]),axislimits), ylim = c(-0.03,0.25),
                 pch = 16, col = point_cols[[i]],
                 xlab = get(as.character(ps[j]),PARMLABS),
                 ylab =NA, yaxt='n', bty = 'n',
                 main = MODELLABS[i])
        }else{
            plot(x = est[,1], y = runif(length(est[,1]), 0, 0.1),
                 xlim = get(as.character(ps[j]),axislimits), ylim = c(-0.03,0.25),
                 pch = 16, col =  point_cols[[i]],
                 xlab = get(as.character(ps[j]),PARMLABS),  bty = 'n',
                 ylab =NA, yaxt='n')
        }

        segments(x0=TRUEVALS[[ps[j]]], y0=-0.02, x1=TRUEVALS[[ps[j]]], y1=0.12, col = colors$orange, lwd=1.5)
    }
}

################################################################################
## Double Link
################################################################################
sl_results = results %>% filter(pose == 'DoubleLink')
par(mfcol = c(5,4), mar = c(3, 1, 1,1), mgp = c(2,0.5,0), cex.lab = 1.2, cex.main = 1.2)
for(i in 1:length(MODELS)){
    m_results = sl_results %>% filter(model == MODELS[i])
    ps = unique(m_results$parameter)
    for(j in 1:length(ps)){
        est = m_results %>% filter(parameter == ps[j]) %>% select(est)
        if(j ==1){
            plot(x = est[,1], y = runif(length(est[,1]), 0, 0.1),
                 xlim = get(as.character(ps[j]),axislimits), ylim = c(-0.03,0.25),
                 pch = 16, col = point_cols[[i]],
                 xlab = get(as.character(ps[j]),PARMLABS), ylab =NA, yaxt='n', bty = 'n',
                 main = MODELLABS[i])
        }else{
            plot(x = est[,1], y = runif(length(est[,1]), 0, 0.1),
                 xlim = get(as.character(ps[j]),axislimits),ylim = c(-0.03,0.25),
                 pch = 16, col = point_cols[[i]],
                 xlab = get(as.character(ps[j]),PARMLABS), ylab =NA, yaxt='n', bty = 'n')
        }

        segments(x0=TRUEVALS[[ps[j]]], y0=-0.02, x1=TRUEVALS[[ps[j]]], y1=0.12, col = colors$orange, lwd=1.5)
    }
}

################################################################################
## Triple Link
################################################################################
sl_results = results %>% filter(pose == 'TripleLink')
par(mfcol = c(6,4), mar = c(3, 1, 1,1), mgp = c(2,0.5,0), cex.lab = 1.2, cex.main = 1.2)
for(i in 1:length(MODELS)){
    m_results = sl_results %>% filter(model == MODELS[i])
    ps = unique(m_results$parameter)
    for(j in 1:length(ps)){
        est = m_results %>% filter(parameter == ps[j]) %>% select(est)
        if(j ==1){
            plot(x = est[,1], y = runif(length(est[,1]), 0, 0.1),
                 xlim = get(as.character(ps[j]),axislimits), ylim = c(-0.03,0.25),
                 pch = 16, col = point_cols[[i]],
                 xlab = get(as.character(ps[j]),PARMLABS), ylab =NA, yaxt='n', bty = 'n',
                 main = MODELLABS[i])
        }else{
            plot(x = est[,1], y = runif(length(est[,1]), 0, 0.1),
                 xlim = get(as.character(ps[j]),axislimits), ylim = c(-0.03,0.25),
                 pch = 16, col = point_cols[[i]],
                 xlab = get(as.character(ps[j]),PARMLABS), ylab =NA, yaxt='n', bty = 'n')
        }
        segments(x0=TRUEVALS[[ps[j]]], y0=-0.02, x1=TRUEVALS[[ps[j]]], y1=0.12, col = colors$orange, lwd=1.5)
    }
}

################################################################################
## Table 2: EQULIIVANCE
################################################################################

## Prior 1
p1 = results %>% filter(model =='Bayes_p1' )
Bayes_perf = data.frame(seed = numeric(), pose = character(), model = character(), parameter = character(),
                        equilivance_ls = numeric(), equilivance_true = numeric(),outperformed = numeric())
for(i in 1:length(POSES)){
    temp = p1 %>% filter(pose == POSES[i])
    ps = unique(temp$parameter)
    for(j in 1:length(ps)){
        print(sprintf("Computing Pose %s, parameter: %s", POSES[i], ps[j]))
        temp1 = temp %>% filter(parameter == ps[j])
        seeds = unique(temp1$seed)
        for(k in 1:length(seeds)){
            tmpseed = seeds[k]
            print(sprintf("    seed: %s", as.character(tmpseed)))

            ls_est = results %>% filter(seed == tmpseed, parameter == ps[j], pose == POSES[i], model == 'LS') %>% select(est)
            bayes_est = results %>% filter(seed == tmpseed, parameter == ps[j], pose == POSES[i], model == 'Bayes_p1') %>% select(est)

            # Equilivance of Bayes and LS
            if((temp$est[k] - (2* temp1$ts_se[k]) < ls_est)  &(temp1$est[k] + (2* temp1$ts_se[k]) > ls_est)){
                tmpcvgls = 1
            } else{
                tmpcvgls =0
            }

            # equilivance of Bayes and True Val
            if((temp$est[k] - (2* temp1$ts_se[k]) < TRUEVALS[[ps[j]]])  &(temp1$est[k] + (2* temp1$ts_se[k]) > TRUEVALS[[ps[j]]])){
                tmpcvgtrue = 1
            } else{
                tmpcvgtrue =0
            }

            tmpimprv = as.numeric((abs(bayes_est - TRUEVALS[[ps[j]]])) < (abs(ls_est  - TRUEVALS[[ps[j]]])))

            toappend = data.frame(seed = tmpseed, pose = POSES[i], model = "Bayes_p1", parameter = ps[j],
                                  equilivance_ls = tmpcvgls, equilivance_true = tmpcvgtrue, outperformed = tmpimprv)
            Bayes_perf = rbind(Bayes_perf, toappend)

        }

    }
}

Bayes_perf_p1 = Bayes_perf %>% group_by(pose, model, parameter) %>% summarize(equilivance_ls = mean(equilivance_ls), equilivance_true = mean(equilivance_true),
                                                                              perf = mean(outperformed))

## Prior 2
p2 = results %>% filter(model =='Bayes_p2' )
Bayes_perf = data.frame(seed = numeric(), pose = character(), model = character(), parameter = character(),
                        equilivance_ls = numeric(), equilivance_true = numeric(),outperformed = numeric())
for(i in 1:length(POSES)){
    temp = p2 %>% filter(pose == POSES[i])
    ps = unique(temp$parameter)
    for(j in 1:length(ps)){
        print(sprintf("Computing Pose %s, parameter: %s", POSES[i], ps[j]))
        temp1 = temp %>% filter(parameter == ps[j])
        seeds = unique(temp1$seed)
        for(k in 1:length(seeds)){
            tmpseed = seeds[k]
            print(sprintf("    seed: %s", as.character(tmpseed)))

            ls_est = results %>% filter(seed == tmpseed, parameter == ps[j], pose == POSES[i], model == 'LS') %>% select(est)
            bayes_est = results %>% filter(seed == tmpseed, parameter == ps[j], pose == POSES[i], model == 'Bayes_p2') %>% select(est)

            # Equilivance of Bayes and LS
            if((temp$est[k] - (2* temp1$ts_se[k]) < ls_est)  &(temp1$est[k] + (2* temp1$ts_se[k]) > ls_est)){
                tmpcvgls = 1
            } else{
                tmpcvgls =0
            }

            # equilivance of Bayes and True Val
            if((temp$est[k] - (2* temp1$ts_se[k]) < TRUEVALS[[ps[j]]])  &(temp1$est[k] + (2* temp1$ts_se[k]) > TRUEVALS[[ps[j]]])){
                tmpcvgtrue = 1
            } else{
                tmpcvgtrue =0
            }

            tmpimprv = as.numeric((abs(bayes_est - TRUEVALS[[ps[j]]])) < (abs(ls_est  - TRUEVALS[[ps[j]]])))

            toappend = data.frame(seed = tmpseed, pose = POSES[i], model = "Bayes_p2", parameter = ps[j],
                                  equilivance_ls = tmpcvgls, equilivance_true = tmpcvgtrue, outperformed = tmpimprv)
            Bayes_perf = rbind(Bayes_perf, toappend)

        }

    }
}

Bayes_perf_p2 = Bayes_perf %>% group_by(pose, model, parameter) %>% summarize(equilivance_ls = mean(equilivance_ls), equilivance_true = mean(equilivance_true),
                                                                              perf = mean(outperformed))

## Prior 3
p3 = results %>% filter(model =='Bayes_p3' )
Bayes_perf = data.frame(seed = numeric(), pose = character(), model = character(), parameter = character(),
                        equilivance_ls = numeric(), equilivance_true = numeric(),outperformed = numeric())
for(i in 1:length(POSES)){
    temp = p3 %>% filter(pose == POSES[i])
    ps = unique(temp$parameter)
    for(j in 1:length(ps)){
        print(sprintf("Computing Pose %s, parameter: %s", POSES[i], ps[j]))
        temp1 = temp %>% filter(parameter == ps[j])
        seeds = unique(temp1$seed)
        for(k in 1:length(seeds)){
            tmpseed = seeds[k]
            print(sprintf("    seed: %s", as.character(tmpseed)))

            ls_est = results %>% filter(seed == tmpseed, parameter == ps[j], pose == POSES[i], model == 'LS') %>% select(est)
            bayes_est = results %>% filter(seed == tmpseed, parameter == ps[j], pose == POSES[i], model == 'Bayes_p3') %>% select(est)

            # Equilivance of Bayes and LS
            if((temp$est[k] - (2* temp1$ts_se[k]) < ls_est)  &(temp1$est[k] + (2* temp1$ts_se[k]) > ls_est)){
                tmpcvgls = 1
            } else{
                tmpcvgls =0
            }

            # equilivance of Bayes and True Val
            if((temp$est[k] - (2* temp1$ts_se[k]) < TRUEVALS[[ps[j]]])  &(temp1$est[k] + (2* temp1$ts_se[k]) > TRUEVALS[[ps[j]]])){
                tmpcvgtrue = 1
            } else{
                tmpcvgtrue =0
            }

            tmpimprv = as.numeric((abs(bayes_est - TRUEVALS[[ps[j]]])) < (abs(ls_est  - TRUEVALS[[ps[j]]])))

            toappend = data.frame(seed = tmpseed, pose = POSES[i], model = "Bayes_p3", parameter = ps[j],
                                  equilivance_ls = tmpcvgls, equilivance_true = tmpcvgtrue, outperformed = tmpimprv)
            Bayes_perf = rbind(Bayes_perf, toappend)

        }

    }
}

Bayes_perf_p3 = Bayes_perf %>% group_by(pose, model, parameter) %>% summarize(equilivance_ls = mean(equilivance_ls), equilivance_true = mean(equilivance_true),
                                                                              perf = mean(outperformed))

## Prior 4
p4 = results %>% filter(model =='Bayes_p4' )
Bayes_perf = data.frame(seed = numeric(), pose = character(), model = character(), parameter = character(),
                        equilivance_ls = numeric(), equilivance_true = numeric(),outperformed = numeric())
for(i in 1:length(POSES)){
    temp = p4 %>% filter(pose == POSES[i])
    ps = unique(temp$parameter)
    for(j in 1:length(ps)){
        print(sprintf("Computing Pose %s, parameter: %s", POSES[i], ps[j]))
        temp1 = temp %>% filter(parameter == ps[j])
        seeds = unique(temp1$seed)
        for(k in 1:length(seeds)){
            tmpseed = seeds[k]
            print(sprintf("    seed: %s", as.character(tmpseed)))

            ls_est = results %>% filter(seed == tmpseed, parameter == ps[j], pose == POSES[i], model == 'LS') %>% select(est)
            bayes_est = results %>% filter(seed == tmpseed, parameter == ps[j], pose == POSES[i], model == 'Bayes_p4') %>% select(est)

            # Equilivance of Bayes and LS
            if((temp$est[k] - (2* temp1$ts_se[k]) < ls_est)  &(temp1$est[k] + (2* temp1$ts_se[k]) > ls_est)){
                tmpcvgls = 1
            } else{
                tmpcvgls =0
            }

            # equilivance of Bayes and True Val
            if((temp$est[k] - (2* temp1$ts_se[k]) < TRUEVALS[[ps[j]]])  &(temp1$est[k] + (2* temp1$ts_se[k]) > TRUEVALS[[ps[j]]])){
                tmpcvgtrue = 1
            } else{
                tmpcvgtrue =0
            }

            tmpimprv = as.numeric((abs(bayes_est - TRUEVALS[[ps[j]]])) < (abs(ls_est  - TRUEVALS[[ps[j]]])))

            toappend = data.frame(seed = tmpseed, pose = POSES[i], model = "Bayes_p4", parameter = ps[j],
                                  equilivance_ls = tmpcvgls, equilivance_true = tmpcvgtrue, outperformed = tmpimprv)
            Bayes_perf = rbind(Bayes_perf, toappend)

        }

    }
}

Bayes_perf_p4 = Bayes_perf %>% group_by(pose, model, parameter) %>% summarize(equilivance_ls = mean(equilivance_ls), equilivance_true = mean(equilivance_true),
                                                                              perf = mean(outperformed))

## Prior 5
p5 = results %>% filter(model =='Bayes_p5' )
Bayes_perf = data.frame(seed = numeric(), pose = character(), model = character(), parameter = character(),
                        equilivance_ls = numeric(), equilivance_true = numeric(),outperformed = numeric())
for(i in 1:length(POSES)){
    temp = p5 %>% filter(pose == POSES[i])
    ps = unique(temp$parameter)
    for(j in 1:length(ps)){
        print(sprintf("Computing Pose %s, parameter: %s", POSES[i], ps[j]))
        temp1 = temp %>% filter(parameter == ps[j])
        seeds = unique(temp1$seed)
        for(k in 1:length(seeds)){
            tmpseed = seeds[k]
            print(sprintf("    seed: %s", as.character(tmpseed)))

            ls_est = results %>% filter(seed == tmpseed, parameter == ps[j], pose == POSES[i], model == 'LS') %>% select(est)
            bayes_est = results %>% filter(seed == tmpseed, parameter == ps[j], pose == POSES[i], model == 'Bayes_p5') %>% select(est)

            # Equilivance of Bayes and LS
            if((temp$est[k] - (2* temp1$ts_se[k]) < ls_est)  &(temp1$est[k] + (2* temp1$ts_se[k]) > ls_est)){
                tmpcvgls = 1
            } else{
                tmpcvgls =0
            }

            # equilivance of Bayes and True Val
            if((temp$est[k] - (2* temp1$ts_se[k]) < TRUEVALS[[ps[j]]])  &(temp1$est[k] + (2* temp1$ts_se[k]) > TRUEVALS[[ps[j]]])){
                tmpcvgtrue = 1
            } else{
                tmpcvgtrue =0
            }

            tmpimprv = as.numeric((abs(bayes_est - TRUEVALS[[ps[j]]])) < (abs(ls_est  - TRUEVALS[[ps[j]]])))

            toappend = data.frame(seed = tmpseed, pose = POSES[i], model = "Bayes_p5", parameter = ps[j],
                                  equilivance_ls = tmpcvgls, equilivance_true = tmpcvgtrue, outperformed = tmpimprv)
            Bayes_perf = rbind(Bayes_perf, toappend)

        }

    }
}

Bayes_perf_p5 = Bayes_perf %>% group_by(pose, model, parameter) %>% summarize(equilivance_ls = mean(equilivance_ls), equilivance_true = mean(equilivance_true),
                                                                              perf = mean(outperformed))
Bayes_perf = rbind(Bayes_perf_p1, Bayes_perf_p2, Bayes_perf_p3, Bayes_perf_p4, Bayes_perf_p5)

Bayes_perf

################################################################################
## Computational time.
################################################################################
comp_time = results %>% select(pose, seed, model, run_time) %>% group_by(pose, model)
comp_time = unique(comp_time)
comp_time = comp_time %>% summarise(run_time_mean = mean(run_time), run_time_sd = sd(run_time))

#   temp = Bayes_perf %>% group_by(pose, model, parameter) %>% summarise(equilivance = mean(coverage), perf = mean(outperformed))
xtable(comp_time, digits = 2)

#####################################################################################
## Plot likelihoods
#####################################################################################
source('./library.r')

set.seed(4)

## 1) Specify parameters
n.links = 3               # Number of links.
seg.length = c(0.45, 0.35, 0.25)         # Length of segment specified in m. NB: Pataky pg 2.
r_true = c(0.07, 0.03)      # Origin location in m.
theta_true = c(-55, -110, -10)          # Rotation angle in deg. NB: specified to avoid 0/360 issue
# and mirroring solutions.
sigma_true = 1.5/1000       # Measurement noise in m. NB Noise specified as 1.5mm
# midpoint of range explored by Pataky et al.
true_vals = c(r_true = r_true, theta_true = theta_true, sigma_true = sigma_true)

# Generate posture
links = list(gen_link(seg.length = seg.length[1],
                      plate.center = 0.7*seg.length[1]),
             gen_link(seg.length = seg.length[2],
                      plate.center = 0.5*seg.length[2]),
             gen_link(seg.length = seg.length[3],
                      plate.center = 0.5*seg.length[3]))
posture = gen_posture(links, r = r_true, theta = theta_true)
y = gen_obs(posture, sigma_true)

LS_result = LS_soln(y, links,
                    inits = true_vals,
                    init_type = 'random' )
inits = c(0.0446749866008758, 0.012961977859959, -40.1004006620497, 88.534386176616, 142.351554371417)
# lik for r
rs = seq(-1, 1, by = 0.01)
costs = matrix(NA, nrow = length(rs), ncol = length(rs))
for(i in 1:length(rs)){
    for(j in 1:length(rs)){
        costs[i,j] = cost(params = c(rs[i], rs[j], true_vals[3:5]), y =y, links = links)
    }
}

filled.contour(x=rs, y = rs, z=costs,
               color = function(n) rev(hcl.colors(n, "Spectral")),
               main = 'Cost for R', xlab = 'r1', ylab = 'r2', nlevels = 30,
               plot.axes={points(true_vals[1], true_vals[2], pch = 3, col = 'green')
                   points(LS_result$r.hat[1], LS_result$r.hat[2], pch = 3, col = 'blue')
                   points(inits[1], inits[2], pch = 3, col = 'black')
                   axis(1, seq(-1, 1, by = 0.1))
                   axis(2, seq(-1, 1, by = 0.1))})

# lik for theta 1 vs 2
thetas = seq(-360, 360, by = 1)
costs = matrix(NA, nrow = length(thetas), ncol = length(thetas))
for(i in 1:length(thetas)){
    for(j in 1:length(thetas)){
        costs[i,j] = cost(params = c(true_vals[1:2], thetas[i], thetas[j], true_vals[5]), y =y, links = links)
    }
}

filled.contour(x=thetas, y = thetas, z=costs,
               color = function(n) rev(hcl.colors(n, "Spectral")),
               main = 'Cost for theta', xlab = 'theta1', ylab = 'theta2', nlevels = 30,
               plot.axes={points(true_vals[3], true_vals[4], pch = 3, col = 'green')
                   points(LS_result$theta.hat[1], LS_result$theta.hat[2], pch = 3, col = 'blue')
                   points(inits[3], inits[4], pch = 3, col = 'black')
                   axis(1, seq(-360, 360, by = 45))
                   axis(2, seq(-360, 360, by = 45))})

# lik for theta 2 vs 3
thetasi = seq(-135, 135, length.out = 500)
thetasj = seq(-45, 270, length.out = 500)

costs = matrix(NA, nrow = length(thetasi), ncol = length(thetasj))
for(i in 1:length(thetasi)){
    for(j in 1:length(thetasj)){
        costs[i,j] = cost(params = c(true_vals[1:3], thetasi[i], thetasj[j]), y=y, links = links)
    }
}

filled.contour(x=thetasi, y = thetasj, z=costs,
               color = function(n) rev(hcl.colors(n, "Spectral")),
               main = "LS Cost", xlab = TeX('$\\theta_2$'), ylab = TeX('$\\theta_3$'), nlevels = 30,
               plot.axes={points(true_vals[4], true_vals[5], pch = 19, col = rgb(241/255, 136/255,5/255, 1))
                   points(LS_result$theta.hat[2], LS_result$theta.hat[3], pch = 19, col = rgb(217/255, 3/255, 104/255, 1))
                   points(inits[4], inits[5], pch = 19, col = 'black')
                   axis(1, seq(-135, 135, by = 45))
                   axis(2, seq(-45, 270, by = 45))})

## lik for sigma
sigmas = seq(1e-3, 1, length.out = 10000)
lls = rep(NA, length(sigmas))
for(i in 1:length(sigmas)){
    lls[i] = loglikelihood(hat = c(true_vals[1:5], log(sigmas[i])), y=y, links = links)
}

plot(x = log(sigmas), y=lls, type = 'l', main = 'LL for sigma', xlab = 'log(sigma)')
abline(v=log(true_vals[6]), col = 'red')

plot_system(posture, y)
posture_hat = gen_posture(links = links, r = LS_result$r.hat, theta = LS_result$theta.hat)
plot_system(posture_hat, y, add=T)


rebol []

if error? try [
	ui32-struct: make struct! [value [integer!]] none
	ui16-struct: make struct! [value [short]] none
	int-to-ui32: func[i][ui32-struct/value: to integer! i copy third ui32-struct]
	int-to-ui16: func[i][ui16-struct/value: to integer! i copy third ui16-struct]
	int-to-ui8: func[i][ui16-struct/value: to integer! i copy/part third ui16-struct 1]
	int-to-bits: func[i [number!] bits][skip enbase/base reverse int-to-ui32 i 2 32 - bits]
][
	;for Rebol versions where the struct! datatype is not available
	int-to-ui32: func[i [number!]][reverse load rejoin ["#{" to-hex to-integer i "}"]]
	int-to-ui16: func[i [number!]][reverse load rejoin ["#{" skip mold to-hex to integer! i 5 "}"]]
	int-to-ui8:  func[i [number!]][load rejoin ["#{" skip mold to-hex to integer! i 7 "}"]]
	int-to-bits: func[i [number!] bits][skip enbase/base load rejoin ["#{" to-hex to integer! i "}"] 2 32 - bits]
]

issue-to-binary: func[clr] [debase/base clr 16]
issue-to-decimal: func[i [issue!] /local e d][
	i: reverse issue-to-binary i
	e: 0 d: 0
	forall i [
		d: d + (i/1 * (2 ** e))
		e: e + 8
	]
	d
]
tuple-to-decimal: func[t [tuple!] /local e d][
	t: reverse to-binary t
	e: 0 d: 0
	forall t [
		d: d + (t/1 * (2 ** e))
		e: e + 8
	]
	d
]


library(qdapTools)
library(tidyverse)
library(dplyr)

#if (!requireNamespace("BiocManager", quietly=TRUE))
#  install.packages("BiocManager")
#BiocManager::install("ComplexHeatmap")
#library(ComplexHeatmap)
#install.packages("FactoMineR")

rm(list=ls())

cat("\014")

# Import all hits of all devices with dependent issue

setwd("D:/nils/projects/dissertation")

dependent_issue <- 'long_cpu_hog_prod126'

file_in <- paste('./', dependent_issue, '.csv', sep = '')
file_out <- './dataset_cpu_hog-exp1.csv'

df0 <- read_csv(file_in)

df <- head(df0, 10000000)

# keeps hits of the same issue where the severity changes (so removes duplicates)
#df <- df0 %>% arrange(hit_issue_id, hit_date) %>%
#              filter(hit_issue_id != lag(hit_issue_id, default = 0) |
#              hit_severity != lag(hit_severity) &
#              hit_issue_id == lag(hit_issue_id))

# add dependent variable y
df <- df %>% mutate(y = ifelse(hit_module == 'long_cpu_hog_Prod126' &
                        hit_severity >= 2, 1, 0))

# Sort by device_id and hit_date - make y an integer
df <- arrange(df, device_id, hit_date)

df$y <- as.numeric(df$y)

summary(df$y)

sum(df$y)

# remove leading colon from hit_labels (otherwise next command gets messed up)
df$hit_labels <- sub('.', '', df$hit_labels)

head(df)

# Create dummy variables from hit_labels with colon separator
xy0 <- mtabulate(strsplit(df$hit_labels, ':'))

head(xy0)

View(xy0)

#xy1 <- as.data.frame(colSums(xy0))
#View(xy1)
#names(xy1)
#colnames(xy1) <- c("x")
#xy1 <- tibble::rownames_to_column(xy1, "Label")
#xy1 <- xy1[order(-xy1$x),]
#write_csv(xy1, 'labels.csv')

#Removing labels/features with less than 200 hits
#xy <- xy[, colSums(xy) > 200]

xy <- xy0 %>% select(Automation,
                    Access_List,
                    Bugs,
                    Configuration,
                    CPU_1,
                    Crash,
                    Device_Hardening,
                    Diagnostic_Signature,
                    Diagnosis,
                    Failover,
                    Hardware,
                    Hardware_Failure,
                    Hardware_Limitation,
                    Healthcheck,
                    Incident1,
                    Management_1,
                    Memory,
                    Memory_Depletion,
                    Memory_Leak,
                    Optimization_Opportunity,
                    Performance,
                    Prod6028,
                    Prod6044_Prod6027_Prod6009_Series_Adaptive_Security_Appliances,
                    Prod6052_FW_Appliance,
                    Software,
                    Software_Failure,
                    Software_Limitation,
                    System,
                    System_Resource,
                    Temperature,
                    Traffic,
                    troubleshooting
                    )

xy

xy <- xy %>%
  #add_column(df$device_id, .before = 1) %>%
  add_column(df$hit_severity) %>%
  add_column(df$y)

xy <- xy %>% rename(
                    #device_id = 'df$device_id',
                    hit_severity = 'df$hit_severity',
                    y = 'df$y'
                    )

#Removing 00000 rows

zero_rows <- xy %>%
  select(-hit_severity) %>%
  rowSums() > 0

xy <- xy %>%
  filter(zero_rows)

# Remove hit_severity=0
xy <- xy  %>% filter(hit_severity!=0)

xy <- xy %>%
  select(y, everything()) # %>% # move the Y variable to the "front"
  #rename_at(vars(2:ncol(.)), ~ paste("X", 1:length(.), sep = ""))

names(xy)
colSums(xy)
summary(xy)
head(xy)

write_csv(xy, file_out)


#Code for Figure 4D: Compares neoantigen depletion ratio between subclonal and clonal neoantigens
#Also performs statistical tests between groups (no differences)
#Query at the top joins analysis.neoantigen_depletion_clonality materialized view with other tables to get timepoint, hypermutator, and subtype information
#-----------------------------------------------------

library(DBI)
library(ggplot2)

con <- DBI::dbConnect(odbc::odbc(), "VerhaakDB")

q <- "SELECT gs.* , nd1c.rneo AS nd_a_c, nd1s.rneo AS nd_a_s, nd2c.rneo AS nd_b_c, nd2s.rneo AS nd_b_s, clin.idh_codel_subtype AS subtype,
CASE WHEN mf1.coverage_adj_mut_freq >= 10 THEN 1 WHEN mf1.coverage_adj_mut_freq < 10 THEN 0 END AS hm_a,
CASE WHEN mf2.coverage_adj_mut_freq >= 10 THEN 1 WHEN mf2.coverage_adj_mut_freq < 10 THEN 0 END AS hm_b
FROM analysis.gold_set gs
LEFT JOIN analysis.neoantigen_depletion_clonality nd1c ON gs.tumor_barcode_a = nd1c.aliquot_barcode AND nd1c.clonality= 'C'
LEFT JOIN analysis.neoantigen_depletion_clonality nd1s ON gs.tumor_barcode_a = nd1s.aliquot_barcode AND nd1s.clonality= 'S'
LEFT JOIN analysis.neoantigen_depletion_clonality nd2c ON gs.tumor_barcode_b = nd2c.aliquot_barcode AND nd2c.clonality= 'C'
LEFT JOIN analysis.neoantigen_depletion_clonality nd2s ON gs.tumor_barcode_b = nd2s.aliquot_barcode AND nd2s.clonality= 'S'
LEFT JOIN analysis.mut_freq mf1 ON mf1.aliquot_barcode = gs.tumor_barcode_a
LEFT JOIN analysis.mut_freq mf2 ON mf2.aliquot_barcode = gs.tumor_barcode_b
LEFT JOIN clinical.subtypes clin ON clin.case_barcode = gs.case_barcode
WHERE nd1c.rneo IS NOT NULL AND nd1s.rneo IS NOT NULL AND nd2c.rneo IS NOT NULL AND nd2s.rneo IS NOT NULL AND
(nd1c.nobs >= 3 AND nd1s.nobs >= 3 AND nd2c.nobs >= 3 AND nd2s.nobs >= 3)
ORDER BY gs.tumor_pair_barcode"

res <- dbGetQuery(con, q)

#Get sample sizes
tmp <- res[,"subtype"]
tmp <- tmp[order(tmp)]
rle(tmp)

#Clonal vs subclonal in each tumor
t.test(res[,"nd_a_c"],res[,"nd_a_s"],paired=TRUE)		#0.59
t.test(res[,"nd_b_c"],res[,"nd_b_s"],paired=TRUE)		#0.55

#Clonality status by timepoint
t.test(res[,"nd_a_c"],res[,"nd_b_c"],paired=TRUE)		#0.52
t.test(res[,"nd_a_s"],res[,"nd_b_s"],paired=TRUE)		#0.75

subtypes <- unique(res[,"subtype"])
pvals <- matrix(0, ncol=4,nrow=3)
colnames(pvals) <- c("Primary_CS","Recurrent_CS","Clonal_PR","Subclonal_PR")
rownames(pvals) = subtypes
for(i in 1:length(subtypes))
{
	sub_res <- res[which(res[,"subtype"]==subtypes[i]),]

	#Clonal vs subclonal in each tumor
	pvals[i,1] <- t.test(sub_res[,"nd_a_c"],sub_res[,"nd_a_s"],paired=TRUE)$p.value
	pvals[i,2] <- t.test(sub_res[,"nd_b_c"],sub_res[,"nd_b_s"],paired=TRUE)$p.value

	#Clonality status by timepoint
	pvals[i,3] <- t.test(sub_res[,"nd_a_c"],sub_res[,"nd_b_c"],paired=TRUE)$p.value
	pvals[i,4] <- t.test(sub_res[,"nd_a_s"],sub_res[,"nd_b_s"],paired=TRUE)$p.value

}

pair <- c(rep(res[,"tumor_pair_barcode"],4))
samp <- rep(c(res[,"tumor_barcode_a"],res[,"tumor_barcode_b"]),2)
rneo <- c(res[,"nd_a_c"],res[,"nd_b_c"],res[,"nd_a_s"],res[,"nd_b_s"])
subtype <- rep(res[,"subtype"],4)
timepoint <- rep(c(rep("Initial",nrow(res)),rep("Recurrent",nrow(res))),2)
clonality <- c(rep("Clonal",nrow(res)*2),rep("Subclonal",nrow(res)*2))
plot_res <- data.frame(pair,samp,rneo,subtype,timepoint,clonality)

pval <- rep("",nrow(plot_res))
pval[which(plot_res[,"timepoint"]=="Initial")] <- "P = 0.59"
pval[which(plot_res[,"timepoint"]=="Recurrent")] <- "P = 0.55"
p_text <- cbind(plot_res,pval)

gtsize = 7/(14/5)

pdf("/projects/varnf/GLASS/Figures/resubmission/Figure4D.pdf",width=3.25,height=2)
ggplot(plot_res, aes(y = rneo, x = clonality, group=pair, colour=subtype)) +
	geom_line(size=0.45,alpha=0.4) +
	geom_point(size=1,colour="black") +
	facet_grid(.~timepoint) +
	labs(y="Observed/expected neoantigens") +
 	geom_text(data=p_text, aes(x=1.5, y=2, label = pval), size=gtsize, color = "black") +
	theme_classic() +
	theme(strip.text.x = element_text(size=7),strip.background = element_blank(),
	axis.title.y=element_text(size=7),axis.title.x=element_blank(),
	axis.text=element_text(colour="black",size=7), axis.text.x=element_text(hjust=0.5,size=7),
	legend.position="none")
dev.off()


# compare WFS null model simulations (s=0) to observations
## examine how much drift to expect for large Ne
# to run on my mac

require(data.table)
require(bit)
require(ff)
require(RColorBrewer)

########################################################################
# plot histogram of diff vs. initial observed frequency (25k or 150k)
########################################################################
	# observations
	dat <- fread('data/data_29.06.17/Frequency_table_Lof07_Lof14_25k.txt', header=TRUE); setnames(dat, 3:7, c('N_CHR_1', 'Freq_1', 'N_CHR_2', 'Freq_2', 'ABS_DIFF')); kmer='25k'; yrs='07-14' # the name and observed frequencies of all the loci, from output by Bastiaan Star
	dat <- fread('data/data_29.06.17/Frequency_table_Lof07_Lof14_150k.txt', header=TRUE); setnames(dat, 3:7, c('N_CHR_1', 'Freq_1', 'N_CHR_2', 'Freq_2', 'ABS_DIFF')); kmer='150k'; yrs='07-14' # the name and observed frequencies of all the loci, from output by Bastiaan Star
	dat[,summary(N_CHR_1)] # 44
	dat[,summary(N_CHR_2)] # 44

	# simulations
	ffload('analysis/temp/wfs_simsnull_ff44,44', overwrite=TRUE) # loads thisout.ff. quick on my mac

	xlims <- range(c(dat[,Freq_2-Freq_1], thisout.ff['f2samp',]-thisout.ff['f1samp',]))
	cols <- c('black', '#7fcdbb', '#edf8b1', '#2c7fb8') # sims, obs 44, low obs, high obs

	quartz(width=7, height=6)
	# png(width=7, height=7, filename=paste('analysis/figures/wfs_nullmodel_hist_obsdiff_by_obsf1_with_data', yrs, ',', kmer, '.png', sep=''), units='in', res=300)
	f1s <- c(seq(0,1,by=0.1), 1.01)
	bks <- seq(-1,1,by=0.05)
	par(mfrow=c(3,4), las=1, tcl=-0.3, mgp=c(2.4,0.6,0), mai=c(0.5, 0.5, 0.3, 0.05), cex.axis=0.8)
	for(i in 2:length(f1s)){
		inds <- (thisout.ff['f1samp',] >= f1s[i-1]) & (thisout.ff['f1samp',] < f1s[i])
		hst <- hist(thisout.ff['f2samp',inds] - thisout.ff['f1samp',inds], plot=FALSE, breaks=bks) # returns some 0 values that get eliminated, but appear as holes in the histogram: doesn't change our interpretation
		j <- which(hst$density>0)
		plot(hst$mids[j], hst$density[j], type='o', xlab='Sample ∆freq', ylab='log(density)', main=paste('initial ', f1s[i-1], '-', f1s[i], sep=''), pch=16, xlim=xlims, log='y', ylim=c(0.0001,20), col=cols[1])
		abline(v=c(-0.06, 0.06), col='grey', lty=3) # genome-wide allele frequency change

			# low sample size
#		inds3 <- dat[,Freq_1 >= f1s[i-1] & Freq_1 < f1s[i] & (N_CHR_1<44 | N_CHR_2<44)]
#		hst3 <- hist(dat[inds3,Freq_2 - Freq_1], plot=FALSE, breaks=bks) # returns some 0 values that get eliminated, but appear as holes in the histogram: doesn't change our interpretation
#		j3 <- which(hst3$density>0)
#		lines(hst3$mids[j3], hst3$density[j3], type='o', pch=16, col=cols[3])

			# high sample size
#		inds4 <- dat[,Freq_1 >= f1s[i-1] & Freq_1 < f1s[i] & (N_CHR_1>44 & N_CHR_2>44)]
#		hst4 <- hist(dat[inds4,Freq_2 - Freq_1], plot=FALSE, breaks=bks) # returns some 0 values that get eliminated, but appear as holes in the histogram: doesn't change our interpretation
#		j4 <- which(hst4$density>0)
#		lines(hst4$mids[j4], hst4$density[j4], type='o', pch=16, col=cols[4])

			# sample size 44
		inds2 <- dat[,Freq_1 >= f1s[i-1] & Freq_1 < f1s[i] & N_CHR_1==44 & N_CHR_2==44]
		hst2 <- hist(dat[inds2,Freq_2 - Freq_1], plot=FALSE, breaks=bks) # returns some 0 values that get eliminated, but appear as holes in the histogram: doesn't change our interpretation
		j2 <- which(hst2$density>0)
		lines(hst2$mids[j2], hst2$density[j2], type='o', pch=16, col=cols[2])

	}

	legend('bottomright', col=cols[1:2], lty=1, legend=c('Sims n=44', 'Obs n=44'), cex=0.7, bty='n')
#	legend('bottomright', col=cols, lty=1, legend=c('Sims n=44', 'Obs n=44', 'Obs low n', 'Obs high n'), cex=0.7, bty='n')

	dev.off()

#########################################################################
# plot histogram of diff vs. initial observed frequency
# 25k AND 150k
#########################################################################
	# load data
		# for 1907-2014
	dat25 <- fread('data/data_29.06.17/Frequency_table_Lof07_Lof14_25k.txt', header=TRUE); setnames(dat25, 3:7, c('N_CHR_1', 'Freq_1', 'N_CHR_2', 'Freq_2', 'ABS_DIFF')) # the name and observed frequencies of all the loci, from output by Bastiaan Star
	dat150 <- fread('data/data_29.06.17/Frequency_table_Lof07_Lof14_150k.txt', header=TRUE); setnames(dat150, 3:7, c('N_CHR_1', 'Freq_1', 'N_CHR_2', 'Freq_2', 'ABS_DIFF')) # the name and observed frequencies of all the loci, from output by Bastiaan Star
	yrs='07-14'

		# for 1907-2011
	dat25 <- fread('data/data_29.06.17/Frequency_table_Lof07_Lof11_25k.txt', header=TRUE); setnames(dat25, 3:7, c('N_CHR_1', 'Freq_1', 'N_CHR_2', 'Freq_2', 'ABS_DIFF')) # the name and observed frequencies of all the loci, from output by Bastiaan Star
	dat150 <- fread('data/data_29.06.17/Frequency_table_Lof07_Lof11_150k.txt', header=TRUE); setnames(dat150, 3:7, c('N_CHR_1', 'Freq_1', 'N_CHR_2', 'Freq_2', 'ABS_DIFF')) # the name and observed frequencies of all the loci, from output by Bastiaan Star
	yrs='07-11'

		# for 2011-2014
	dat25 <- fread('data/data_29.06.17/Frequency_table_Lof11_Lof14_25k.txt', header=TRUE); setnames(dat25, 3:7, c('N_CHR_1', 'Freq_1', 'N_CHR_2', 'Freq_2', 'ABS_DIFF')) # the name and observed frequencies of all the loci, from output by Bastiaan Star
	dat150 <- fread('data/data_29.06.17/Frequency_table_Lof11_Lof14_150k.txt', header=TRUE); setnames(dat150, 3:7, c('N_CHR_1', 'Freq_1', 'N_CHR_2', 'Freq_2', 'ABS_DIFF')) # the name and observed frequencies of all the loci, from output by Bastiaan Star
	yrs='11-14'

	xlims <- range(c(dat25[,Freq_2-Freq_1], dat150[,Freq_2-Freq_1], thisout.ff['f2samp',]-thisout.ff['f1samp',]))
	cols <- c('black', brewer.pal(6, 'PRGn')[c(3:1,4:6)]) # sims, obs 25k n<44, n=44, n>44, obs150k n<44, n=44, n>44

	quartz(width=7, height=6)
	# png(width=7, height=7, filename=paste('analysis/figures/wfs_nullmodel_hist_obsdiff_by_obsf1_with_data', yrs, ',25k&150k.png', sep=''), units='in', res=300)
	f1s <- c(seq(0,1,by=0.1), 1.01)
	bks <- seq(-1,1,by=0.05)
	par(mfrow=c(3,4), las=1, tcl=-0.3, mgp=c(2.4,0.6,0), mai=c(0.5, 0.5, 0.3, 0.05), cex.axis=0.8)

	# add panel not divided by initial freq
		hst <- hist(thisout.ff['f2samp',] - thisout.ff['f1samp',], plot=FALSE, breaks=bks) # returns some 0 values that get eliminated, but appear as holes in the histogram: doesn't change our interpretation
		j <- which(hst$density>0)
		plot(hst$mids[j], hst$density[j], type='o', xlab='Sample ∆freq', ylab='log(density)', main=paste('All loci', yrs), pch=16, xlim=xlims, log='y', ylim=c(0.00001,20), col=cols[1])
		abline(v=c(-0.06, 0.06), col='grey', lty=3) # genome-wide allele frequency change

			# 25kmer n<44
		inds2 <- dat25[, N_CHR_1<44 | N_CHR_2<44]
		hst2 <- hist(dat25[inds2,Freq_2 - Freq_1], plot=FALSE, breaks=bks) # returns some 0 values that get eliminated, but appear as holes in the histogram: doesn't change our interpretation
		j2 <- which(hst2$density>0)
		lines(hst2$mids[j2], hst2$density[j2], type='o', pch=16, col=cols[2])

			# 25kmer n=44
		inds2 <- dat25[, N_CHR_1==44 & N_CHR_2==44]
		hst2 <- hist(dat25[inds2,Freq_2 - Freq_1], plot=FALSE, breaks=bks) # returns some 0 values that get eliminated, but appear as holes in the histogram: doesn't change our interpretation
		j2 <- which(hst2$density>0)
		lines(hst2$mids[j2], hst2$density[j2], type='o', pch=16, col=cols[3])

			# 25kmer n>44
		inds2 <- dat25[, N_CHR_1>44 | N_CHR_2>44]
		hst2 <- hist(dat25[inds2,Freq_2 - Freq_1], plot=FALSE, breaks=bks) # returns some 0 values that get eliminated, but appear as holes in the histogram: doesn't change our interpretation
		j2 <- which(hst2$density>0)
		lines(hst2$mids[j2], hst2$density[j2], type='o', pch=16, col=cols[4])

			# 150kmer n<44
		inds2 <- dat150[, N_CHR_1<44 | N_CHR_2<44]
		hst2 <- hist(dat150[inds2,Freq_2 - Freq_1], plot=FALSE, breaks=bks) # returns some 0 values that get eliminated, but appear as holes in the histogram: doesn't change our interpretation
		j2 <- which(hst2$density>0)
		lines(hst2$mids[j2], hst2$density[j2], type='o', pch=16, col=cols[5])

			# 150kmer n=44
		inds2 <- dat150[, N_CHR_1==44 & N_CHR_2==44]
		hst2 <- hist(dat150[inds2,Freq_2 - Freq_1], plot=FALSE, breaks=bks) # returns some 0 values that get eliminated, but appear as holes in the histogram: doesn't change our interpretation
		j2 <- which(hst2$density>0)
		lines(hst2$mids[j2], hst2$density[j2], type='o', pch=16, col=cols[6])

			# 150kmer n>44
		inds2 <- dat150[, N_CHR_1>44 | N_CHR_2>44]
		hst2 <- hist(dat150[inds2,Freq_2 - Freq_1], plot=FALSE, breaks=bks) # returns some 0 values that get eliminated, but appear as holes in the histogram: doesn't change our interpretation
		j2 <- which(hst2$density>0)
		lines(hst2$mids[j2], hst2$density[j2], type='o', pch=16, col=cols[7])

	# panels for each bin of initial frequencies
	for(i in 2:length(f1s)){
		print(i)

		inds <- (thisout.ff['f1samp',] >= f1s[i-1]) & (thisout.ff['f1samp',] < f1s[i])
		hst <- hist(thisout.ff['f2samp',inds] - thisout.ff['f1samp',inds], plot=FALSE, breaks=bks) # returns some 0 values that get eliminated, but appear as holes in the histogram: doesn't change our interpretation
		j <- which(hst$density>0)
		plot(hst$mids[j], hst$density[j], type='o', xlab='Sample ∆freq', ylab='log(density)', main=paste('initial ', f1s[i-1], '-', f1s[i], sep=''), pch=16, xlim=xlims, log='y', ylim=c(0.0001,20), col=cols[1])
		abline(v=c(-0.06, 0.06), col='grey', lty=3) # genome-wide allele frequency change

			# 25kmer n<44
		inds2 <- dat25[,Freq_1 >= f1s[i-1] & Freq_1 < f1s[i] & (N_CHR_1<44 | N_CHR_2<44)]
		hst2 <- hist(dat25[inds2,Freq_2 - Freq_1], plot=FALSE, breaks=bks) # returns some 0 values that get eliminated, but appear as holes in the histogram: doesn't change our interpretation
		j2 <- which(hst2$density>0)
		lines(hst2$mids[j2], hst2$density[j2], type='o', pch=16, col=cols[2])

			# 25kmer n=44
		inds2 <- dat25[,Freq_1 >= f1s[i-1] & Freq_1 < f1s[i] & N_CHR_1==44 & N_CHR_2==44]
		hst2 <- hist(dat25[inds2,Freq_2 - Freq_1], plot=FALSE, breaks=bks) # returns some 0 values that get eliminated, but appear as holes in the histogram: doesn't change our interpretation
		j2 <- which(hst2$density>0)
		lines(hst2$mids[j2], hst2$density[j2], type='o', pch=16, col=cols[3])

			# 25kmer n>44
		inds2 <- dat25[,Freq_1 >= f1s[i-1] & Freq_1 < f1s[i] & (N_CHR_1>44 | N_CHR_2>44)]
		hst2 <- hist(dat25[inds2,Freq_2 - Freq_1], plot=FALSE, breaks=bks) # returns some 0 values that get eliminated, but appear as holes in the histogram: doesn't change our interpretation
		j2 <- which(hst2$density>0)
		lines(hst2$mids[j2], hst2$density[j2], type='o', pch=16, col=cols[4])

			# 150kmer n<44
		inds2 <- dat150[,Freq_1 >= f1s[i-1] & Freq_1 < f1s[i] & (N_CHR_1<44 | N_CHR_2<44)]
		hst2 <- hist(dat150[inds2,Freq_2 - Freq_1], plot=FALSE, breaks=bks) # returns some 0 values that get eliminated, but appear as holes in the histogram: doesn't change our interpretation
		j2 <- which(hst2$density>0)
		lines(hst2$mids[j2], hst2$density[j2], type='o', pch=16, col=cols[5])

			# 150kmer n=44
		inds2 <- dat150[,Freq_1 >= f1s[i-1] & Freq_1 < f1s[i] & N_CHR_1==44 & N_CHR_2==44]
		hst2 <- hist(dat150[inds2,Freq_2 - Freq_1], plot=FALSE, breaks=bks) # returns some 0 values that get eliminated, but appear as holes in the histogram: doesn't change our interpretation
		j2 <- which(hst2$density>0)
		lines(hst2$mids[j2], hst2$density[j2], type='o', pch=16, col=cols[6])

			# 150kmer n>44
		inds2 <- dat150[,Freq_1 >= f1s[i-1] & Freq_1 < f1s[i] & (N_CHR_1>44 | N_CHR_2>44)]
		hst2 <- hist(dat150[inds2,Freq_2 - Freq_1], plot=FALSE, breaks=bks) # returns some 0 values that get eliminated, but appear as holes in the histogram: doesn't change our interpretation
		j2 <- which(hst2$density>0)
		lines(hst2$mids[j2], hst2$density[j2], type='o', pch=16, col=cols[7])

	}

	legend('bottomright', col=cols, lty=1, legend=c('Sims n=44', 'Obs 25k n<44', 'Obs 25k n=44', 'Obs 25k n>44', 'Obs 150k n<44', 'Obs 150k n=44', 'Obs 150k n>44'), cex=0.7, bty='n')
#	legend('bottomright', col=cols, lty=1, legend=c('Sims n=44', 'Obs n=44', 'Obs low n', 'Obs high n'), cex=0.7, bty='n')

	dev.off()


#' read_h5df
#'
#' TODO
#'
#' @param h5in
#' Input file.
#' @param dataset
#' Dataset in input file to read or \code{NULL}. In the latter case, TODO
#' @param indices
#' TODO
#'
#' @export
read_shff = function(h5in, dataset=NULL, indices=NULL)
{
  check.is.string(h5in)
  if (!is.null(dataset))
    check.is.string(dataset)
  if (!is.null(indices))
  {
    if (length(indices) == 0 || !all(is.inty(indices)) || any(indices < 1))
      stop("argument 'indices' must be a vector of positive integers")
  }

  fp = h5file(h5in, mode="r")
  dataset = h5_get_dataset(fp, dataset)

  x = read_shff_mm(fp, dataset, indices)

  h5close(fp)

  x
}

extract = function(fp, dataset, indices)
{
  if (is.null(indices))
    fp[[dataset]][]
  else
    fp[[dataset]][indices]
}

read_shff_mm = function(fp, dataset, indices)
{
  attrs = glue(dataset, ATTR_PATH)
  format = h5attr(fp[[attrs]], "format")
  M = h5attr(fp[[attrs]], "nrows")
  N = h5attr(fp[[attrs]], "ncols")
  nz = h5attr(fp[[attrs]], "nz")
  matcode = mm_matcode_int2char(h5attr(fp[[attrs]], "matcode"))
  indexing = h5attr(fp[[attrs]], "indexing")

  I = extract(fp, glue(dataset, "I"), indices)
  J = extract(fp, glue(dataset, "J"), indices)

  if (mm_is_pattern(matcode))
    val = NULL
  else
    val = extract(fp, glue(dataset, "val"), indices)

  mm = list(M=M, N=N, nz=nz, I=I, J=J, val=val, matcode=matcode, indexing=indexing)
}


#' Iterator that filters elements not satisfying a predicate function
#'
#' Constructs an iterator that filters elements from iterable returning only
#' those for which the predicate is \code{TRUE}.
#'
#' @importFrom iterators iter nextElem
#' @export
#' @param predicate a function that determines whether an element is \code{TRUE}
#' or \code{FALSE}. The function is assumed to take only one argument.
#' @param iterable an iterable object
#' @return iterator object
#'
#' @examples
#' # Filters out odd numbers and retains only even numbers
#' is_even <- function(x) {
#'   x %% 2 == 0
#' }
#' it <- ifilter(is_even, 1:10)
#' as.list(it)
#'
#' # Similar idea here but anonymous function is used to filter out even
#' # numbers
#' it2 <- ifilter(function(x) x %% 2 == 1, 1:10)
#' iterators::nextElem(it2) # 1
#' iterators::nextElem(it2) # 3
#' iterators::nextElem(it2) # 5
#' iterators::nextElem(it2) # 7
#' iterators::nextElem(it2) # 9
#'
#' is_vowel <- function(x) {
#'   x %in% c('a', 'e', 'i', 'o', 'u')
#' }
#' it3 <- ifilter(is_vowel, letters)
#' as.list(it3)
ifilter <- function(predicate, iterable) {
  if (!is.function(predicate)) {
    stop("The 'predicate' must a function that returns TRUE or FALSE.")
  }

  iter_obj <- iterators::iter(iterable)

  nextElem <- function() {
    repeat {
      next_elem <- iterators::nextElem(iter_obj)
      if (predicate(next_elem)) {
        return(next_elem)
      }
    }
  }

  it <- list(nextElem=nextElem)
  class(it) <- c("abstractiter", "iter")
  it
}

#' Iterator that filters elements not satisfying a predicate function
#'
#' Constructs an iterator that filters elements from iterable returning only
#' those for which the predicate is \code{FALSE}.
#'
#' @export
#' @examples
#' # Filters out even numbers and retains only odd numbers
#' is_even <- function(x) {
#'   x %% 2 == 0
#' }
#' it <- ifilterfalse(is_even, 1:10)
#' as.list(it)
#'
#' # Similar idea here but anonymous function is used to filter out odd
#' # numbers
#' it2 <- ifilter(function(x) x %% 2 == 1, 1:10)
#' as.list(it2)
#'
#' is_vowel <- function(x) {
#'   x %in% c('a', 'e', 'i', 'o', 'u')
#' }
#' it3 <- ifilterfalse(is_vowel, letters)
#' iterators::nextElem(it3) # b
#' iterators::nextElem(it3) # c
#' iterators::nextElem(it3) # d
#' iterators::nextElem(it3) # f
#' iterators::nextElem(it3) # g
#' # iterators::nextElem(it) continues through the rest of the consonants
#'
#' @rdname ifilter
ifilterfalse <- function(predicate, iterable) {
  if (!is.function(predicate)) {
    stop("The 'predicate' must a function that returns TRUE or FALSE.")
  }

  iter_obj <- iterators::iter(iterable)

  nextElem <- function() {
    repeat {
      next_elem <- iterators::nextElem(iter_obj)
      if (!predicate(next_elem)) {
        return(next_elem)
      }
    }
  }

  it <- list(nextElem=nextElem)
  class(it) <- c("abstractiter", "iter")
  it
}


model_updatephase <- function (cumulTT = 354.582294511779,
         leafNumber_t1 = 4.620511621863958,
         cumulTTFromZC_39 = 0.0,
         isMomentRegistredZC_39 = 0,
         gAI = 0.3255196285135,
         grainCumulTT = 0.0,
         dayLength = 12.7433275303389,
         vernaprog = 1.0532526829571554,
         minFinalNumber = 6.879410413987549,
         fixPhyll = 91.2,
         isVernalizable = 1,
         dse = 105.0,
         pFLLAnth = 2.22,
         dcd = 100.0,
         dgf = 450.0,
         degfm = 0.0,
         maxDL = 15.0,
         sLDL = 0.85,
         ignoreGrainMaturation = FALSE,
         pHEADANTH = 1.0,
         choosePhyllUse = 'Default',
         p = 120.0,
         phase_t1 = 1.0,
         cumulTTFromZC_91 = 0.0,
         phyllochron = 91.2,
         hasLastPrimordiumAppeared_t1 = 0,
         finalLeafNumber_t1 = 0.0){
    #'- Name: UpdatePhase -Version: 1.0, -Time step: 1
    #'- Description:
    #'            * Title: UpdatePhase Model
    #'            * Author: Pierre MARTRE
    #'            * Reference: Modeling development phase in the
    #'                Wheat Simulation Model SiriusQuality.
    #'                See documentation at http://www1.clermont.inra.fr/siriusquality/?page_id=427
    #'            * Institution: INRA Montpellier
    #'            * Abstract: This strategy advances the phase and calculate the final leaf number
    #'
    #'- inputs:
    #'            * name: cumulTT
    #'                          ** description : cumul thermal times at current date
    #'                          ** variablecategory : auxiliary
    #'                          ** datatype : DOUBLE
    #'                          ** min : -200
    #'                          ** max : 10000
    #'                          ** default : 354.582294511779
    #'                          ** unit : °C d
    #'                          ** inputtype : variable
    #'            * name: leafNumber_t1
    #'                          ** description : Actual number of phytomers
    #'                          ** variablecategory : state
    #'                          ** datatype : DOUBLE
    #'                          ** min : 0
    #'                          ** max : 25
    #'                          ** default :  4.620511621863958
    #'                          ** unit : leaf
    #'                          ** inputtype : variable
    #'            * name: cumulTTFromZC_39
    #'                          ** description : cumul of the thermal time ( DeltaTT) since the moment ZC_39
    #'                          ** variablecategory : auxiliary
    #'                          ** datatype : DOUBLE
    #'                          ** min : 0
    #'                          ** max : 10000
    #'                          ** default : 0
    #'                          ** unit : °C d-1
    #'                          ** inputtype : variable
    #'            * name: isMomentRegistredZC_39
    #'                          ** description : true if ZC_39 is registered in the calendar
    #'                          ** variablecategory : state
    #'                          ** datatype : INT
    #'                          ** min : 0
    #'                          ** max : 1
    #'                          ** default : 0
    #'                          ** unit :
    #'                          ** inputtype : variable
    #'            * name: gAI
    #'                          ** description : used to calculate Terminal spikelet
    #'                          ** variablecategory : auxiliary
    #'                          ** datatype : DOUBLE
    #'                          ** min : 0
    #'                          ** max : 10000
    #'                          ** default : 0.3255196285135
    #'                          ** unit :
    #'                          ** inputtype : variable
    #'            * name: grainCumulTT
    #'                          ** description : cumulTT used for the grain developpment
    #'                          ** variablecategory : auxiliary
    #'                          ** datatype : DOUBLE
    #'                          ** min : 0
    #'                          ** max : 10000
    #'                          ** default : 0
    #'                          ** unit : °C d
    #'                          ** inputtype : variable
    #'            * name: dayLength
    #'                          ** description : length of the day
    #'                          ** datatype : DOUBLE
    #'                          ** variablecategory : auxiliary
    #'                          ** min : 0
    #'                          ** max : 24
    #'                          ** unit : h
    #'                          ** default : 12.7433275303389
    #'                          ** inputtype : variable
    #'            * name: vernaprog
    #'                          ** description : progression on a 0  to 1 scale of the vernalization
    #'                          ** variablecategory : state
    #'                          ** datatype : DOUBLE
    #'                          ** min : 0
    #'                          ** max : 10
    #'                          ** default :  1.0532526829571554
    #'                          ** unit :
    #'                          ** inputtype : variable
    #'            * name: minFinalNumber
    #'                          ** description : minimum final leaf number
    #'                          ** variablecategory : state
    #'                          ** datatype : DOUBLE
    #'                          ** min : 0
    #'                          ** max : 25
    #'                          ** default : 6.879410413987549
    #'                          ** unit : leaf
    #'                          ** inputtype : variable
    #'            * name: fixPhyll
    #'                          ** description : Phyllochron with sowing date fix
    #'                          ** variablecategory : auxiliary
    #'                          ** datatype : DOUBLE
    #'                          ** min : 0
    #'                          ** max : 10000
    #'                          ** default : 91.2
    #'                          ** unit : °C d
    #'                          ** inputtype : variable
    #'            * name: isVernalizable
    #'                          ** description : true if the plant is vernalizable
    #'                          ** parametercategory : species
    #'                          ** datatype : INT
    #'                          ** min : 0
    #'                          ** max : 1
    #'                          ** unit :
    #'                          ** default : 1
    #'                          ** inputtype : parameter
    #'            * name: dse
    #'                          ** description : Thermal time from sowing to emergence
    #'                          ** parametercategory : genotypic
    #'                          ** datatype : DOUBLE
    #'                          ** min : 0
    #'                          ** max : 1000
    #'                          ** default : 105
    #'                          ** unit : °C d
    #'                          ** inputtype : parameter
    #'            * name: pFLLAnth
    #'                          ** description : Phyllochronic duration of the period between flag leaf ligule appearance and anthesis
    #'                          ** parametercategory : species
    #'                          ** datatype : DOUBLE
    #'                          ** min : 0
    #'                          ** max : 1000
    #'                          ** unit :
    #'                          ** default : 2.22
    #'                          ** inputtype : parameter
    #'            * name: dcd
    #'                          ** description : Duration of the endosperm cell division phase
    #'                          ** parametercategory : species
    #'                          ** datatype : DOUBLE
    #'                          ** min : 0
    #'                          ** max : 10000
    #'                          ** default : 100
    #'                          ** unit : °C d
    #'                          ** inputtype : parameter
    #'            * name: dgf
    #'                          ** description : Grain filling duration (from anthesis to physiological maturity)
    #'                          ** parametercategory : species
    #'                          ** datatype : DOUBLE
    #'                          ** min : 0
    #'                          ** max : 10000
    #'                          ** default : 450
    #'                          ** unit : °C d
    #'                          ** inputtype : parameter
    #'            * name: degfm
    #'                          ** description : Grain maturation duration (from physiological maturity to harvest ripeness)
    #'                          ** parametercategory : species
    #'                          ** datatype : DOUBLE
    #'                          ** min : 0
    #'                          ** max : 50
    #'                          ** default : 0
    #'                          ** unit : °C d
    #'                          ** inputtype : parameter
    #'            * name: maxDL
    #'                          ** description : Saturating photoperiod above which final leaf number is not influenced by daylength
    #'                          ** parametercategory : species
    #'                          ** datatype : DOUBLE
    #'                          ** min : 0
    #'                          ** max : 24
    #'                          ** default : 15
    #'                          ** unit : h
    #'                          ** inputtype : parameter
    #'            * name: sLDL
    #'                          ** description : Daylength response of leaf production
    #'                          ** parametercategory : species
    #'                          ** datatype : DOUBLE
    #'                          ** min : 0
    #'                          ** max : 1
    #'                          ** default : 0.85
    #'                          ** unit : leaf h-1
    #'                          ** inputtype : parameter
    #'            * name: ignoreGrainMaturation
    #'                          ** description : true to ignore grain maturation
    #'                          ** parametercategory : species
    #'                          ** datatype : BOOLEAN
    #'                          ** default : FALSE
    #'                          ** unit :
    #'                          ** inputtype : parameter
    #'            * name: pHEADANTH
    #'                          ** description : Number of phyllochron between heading and anthesiss
    #'                          ** parametercategory : species
    #'                          ** datatype : DOUBLE
    #'                          ** min : 0
    #'                          ** max : 1000
    #'                          ** default : 1
    #'                          ** unit :
    #'                          ** inputtype : parameter
    #'            * name: choosePhyllUse
    #'                          ** description : Switch to choose the type of phyllochron calculation to be used
    #'                          ** parametercategory : species
    #'                          ** datatype : STRING
    #'                          ** unit :
    #'                          ** default : Default
    #'                          ** inputtype : parameter
    #'            * name: p
    #'                          ** description : Phyllochron (Varietal parameter)
    #'                          ** parametercategory : species
    #'                          ** datatype : DOUBLE
    #'                          ** min : 0
    #'                          ** max : 1000
    #'                          ** default : 120
    #'                          ** unit : °C d leaf-1
    #'                          ** inputtype : parameter
    #'            * name: phase_t1
    #'                          ** description :  the name of the phase
    #'                          ** variablecategory : state
    #'                          ** datatype : DOUBLE
    #'                          ** min : 0
    #'                          ** max : 7
    #'                          ** default : 1
    #'                          ** unit :
    #'                          ** inputtype : variable
    #'            * name: cumulTTFromZC_91
    #'                          ** description : cumul of the thermal time (DeltaTT) since the moment ZC_91
    #'                          ** variablecategory : auxiliary
    #'                          ** datatype : DOUBLE
    #'                          ** min : 0
    #'                          ** max : 5000
    #'                          ** default : 0
    #'                          ** unit : °C d-1
    #'                          ** inputtype : variable
    #'            * name: phyllochron
    #'                          ** description : Phyllochron
    #'                          ** variablecategory : state
    #'                          ** datatype : DOUBLE
    #'                          ** min : 0
    #'                          ** max : 1000
    #'                          ** default : 91.2
    #'                          ** unit : °C d leaf-1
    #'                          ** inputtype : variable
    #'            * name: hasLastPrimordiumAppeared_t1
    #'                          ** description : if Last Primordium has Appeared
    #'                          ** variablecategory : state
    #'                          ** datatype : INT
    #'                          ** min : 0
    #'                          ** max : 1
    #'                          ** default : 0
    #'                          ** unit :
    #'                          ** inputtype : variable
    #'            * name: finalLeafNumber_t1
    #'                          ** description : final leaf number
    #'                          ** variablecategory : state
    #'                          ** datatype : DOUBLE
    #'                          ** min : 0
    #'                          ** max : 25
    #'                          ** default : 0
    #'                          ** unit : leaf
    #'                          ** inputtype : variable
    #'- outputs:
    #'            * name: finalLeafNumber
    #'                          ** description : final leaf number
    #'                          ** variablecategory : state
    #'                          ** datatype : DOUBLE
    #'                          ** min : 0
    #'                          ** max : 25
    #'                          ** unit : leaf
    #'            * name: phase
    #'                          ** description : the name of the phase
    #'                          ** variablecategory : state
    #'                          ** datatype : DOUBLE
    #'                          ** min : 0
    #'                          ** max : 7
    #'                          ** unit :
    #'            * name: hasLastPrimordiumAppeared
    #'                          ** description : if Last Primordium has Appeared
    #'                          ** variablecategory : state
    #'                          ** datatype : INT
    #'                          ** min : 0
    #'                          ** max : 1
    #'                          ** unit :
    hasLastPrimordiumAppeared <- hasLastPrimordiumAppeared_t1
    finalLeafNumber <- finalLeafNumber_t1
    phase <- phase_t1
    if (phase_t1 >= 0.0 && phase_t1 < 1.0)
    {
        if (cumulTT >= dse)
        {
            phase <- 1.0
        }
        else
        {
            phase <- phase_t1
        }
    }
    else if ( phase_t1 >= 1.0 && phase_t1 < 2.0)
    {
        if (isVernalizable == 1 && vernaprog >= 1.0 || isVernalizable == 0)
        {
            if (dayLength > maxDL)
            {
                finalLeafNumber <- minFinalNumber
                hasLastPrimordiumAppeared <- 1
            }
            else
            {
                appFLN <- minFinalNumber + (sLDL * (maxDL - dayLength))
                if (appFLN / 2.0 <= leafNumber_t1)
                {
                    finalLeafNumber <- appFLN
                    hasLastPrimordiumAppeared <- 1
                }
                else
                {
                    phase <- phase_t1
                }
            }
            if (hasLastPrimordiumAppeared == 1)
            {
                phase <- 2.0
            }
        }
        else
        {
            phase <- phase_t1
        }
    }
    else if ( phase_t1 >= 2.0 && phase_t1 < 4.0)
    {
        if (isMomentRegistredZC_39 == 1)
        {
            if (phase_t1 < 3.0)
            {
                ttFromLastLeafToHeading <- 0.0
                if (choosePhyllUse == 'Default')
                {
                    ttFromLastLeafToHeading <- (pFLLAnth - pHEADANTH) * fixPhyll
                }
                else if ( choosePhyllUse == 'PTQ')
                {
                    ttFromLastLeafToHeading <- (pFLLAnth - pHEADANTH) * phyllochron
                }
                else if ( choosePhyllUse == 'Test')
                {
                    ttFromLastLeafToHeading <- (pFLLAnth - pHEADANTH) * p
                }
                if (cumulTTFromZC_39 >= ttFromLastLeafToHeading)
                {
                    phase <- 3.0
                }
                else
                {
                    phase <- phase_t1
                }
            }
            else
            {
                phase <- phase_t1
            }
            ttFromLastLeafToAnthesis <- 0.0
            if (choosePhyllUse == 'Default')
            {
                ttFromLastLeafToAnthesis <- pFLLAnth * fixPhyll
            }
            else if ( choosePhyllUse == 'PTQ')
            {
                ttFromLastLeafToAnthesis <- pFLLAnth * phyllochron
            }
            else if ( choosePhyllUse == 'Test')
            {
                ttFromLastLeafToAnthesis <- pFLLAnth * p
            }
            if (cumulTTFromZC_39 >= ttFromLastLeafToAnthesis)
            {
                phase <- 4.0
            }
        }
        else
        {
            phase <- phase_t1
        }
    }
    else if ( phase_t1 == 4.0)
    {
        if (grainCumulTT >= dcd)
        {
            phase <- 4.5
        }
        else
        {
            phase <- phase_t1
        }
    }
    else if ( phase_t1 == 4.5)
    {
        if (grainCumulTT >= dgf || gAI <= 0.0)
        {
            phase <- 5.0
        }
        else
        {
            phase <- phase_t1
        }
    }
    else if ( phase_t1 >= 5.0 && phase_t1 < 6.0)
    {
        localDegfm <- degfm
        if (ignoreGrainMaturation)
        {
            localDegfm <- -1.0
        }
        if (cumulTTFromZC_91 >= localDegfm)
        {
            phase <- 6.0
        }
        else
        {
            phase <- phase_t1
        }
    }
    else if ( phase_t1 >= 6.0 && phase_t1 < 7.0)
    {
        phase <- phase_t1
    }
    return (list ("finalLeafNumber" = finalLeafNumber,"phase" = phase,"hasLastPrimordiumAppeared" = hasLastPrimordiumAppeared))
}


#' Convert to methylated/unmethylated signal
#'
#' Converts Cy5/Cy3 signals to methylated/unmethylated signals from a
#' Infinium HumanMethylation450 BeadChip.
#'
#' @param rg Cy5/Cy3 signal generated by \code{\link{read.rg}()}.
#'
#' @return List containing methylated and unmethylated signals.
rg.to.mu <- function(rg, probes) {
    stopifnot(is.rg(rg))

    probes.M.R <- probes[which(probes$target == "M" & probes$dye == "R"),]
    probes.M.G <- probes[which(probes$target == "M" & probes$dye == "G"),]
    probes.U.R <- probes[which(probes$target == "U" & probes$dye == "R"),]
    probes.U.G <- probes[which(probes$target == "U" & probes$dye == "G"),]

    stopifnot(all(c(probes.M.R$address, probes.U.R$address) %in% rownames(rg$R)))
    stopifnot(all(c(probes.M.G$address, probes.U.G$address) %in% rownames(rg$G)))

    M <- c(rg$R[probes.M.R$address,"Mean"],
           rg$G[probes.M.G$address,"Mean"])
    U <- c(rg$R[probes.U.R$address,"Mean"],
           rg$G[probes.U.G$address,"Mean"])

    names(M) <- c(probes.M.R$name, probes.M.G$name)
    names(U) <- c(probes.U.R$name, probes.U.G$name)

    list(class="mu",
         version=packageVersion("meffil"),
         M=M,
         U=U[names(M)])
}

is.mu <- function(object)
    is.list(object) && "class" %in% names(object) && object$class == "mu"


setwd("~/Maestria/Visualizacion de la informacion/TP3/git/visualization-d3/data/")
library(geosphere)
library("dplyr")
# Se setea para que R trabaje con 22 decimales
options("digits" = 22)

cities = read.csv(file = "cities.csv", encoding = "UTF-8")
lines = read.csv(file = "lines.csv", encoding = "UTF-8")
stations = read.csv(file = "stations.csv", encoding = "UTF-8")
systems = read.csv(file = "systems.csv", encoding = "UTF-8")
pbi = read.csv(file = "pbi.csv", encoding = "UTF-8", stringsAsFactors = F)

pbi[pbi$Country.Name == 'United Kingdom',]$Country.Name = "England"
pbi_2 = data.frame()
for( country in  c("Argentina", "Italy", "Spain", "France", "Japan", "China", "Chile", "Mexico", "Portugal", "England")) {
  for ( p in colnames(pbi[pbi$Country.Name == country,][, 6:ncol(pbi)-1]) ) {
    pbi_2 = rbind(pbi_2, cbind(country = country, year = as.integer(gsub("X", "", p)), pbi = pbi[pbi$Country.Name == country,][, 6:ncol(pbi)-1][[p]] ))
  }
}
pbi = pbi_2

stations$lat = NA
stations$lon = NA
g = regmatches(stations$geometry, gregexpr("-*\\d+.\\d+e*-*\\d+", stations$geometry), invert = F)
for( i in 1:length(g) ) {
  stations[i,]$lat = as.double(g[[i]][2])
  stations[i,]$lon = as.double(g[[i]][1])
}
# Se quita la vieja columna geometry
stations = stations[c(-4)]

#Punto 1
#Evolucion de construction de km por año
#Percentiles-75/Media distancia entre estaciones por linea por pais

# Se renombran las columnas para evitar autorenombre de columnas con mismo nombre
colnames(cities) = paste0("city_", colnames(cities))
colnames(lines) = paste0("line_", colnames(lines))
colnames(stations) = paste0("station_", colnames(stations))
colnames(systems) = paste0("system_", colnames(systems))

# Joins de las tablas
data = merge(cities, lines, all.y = TRUE, by.x = "city_id", by.y = "line_city_id")
data = merge(data, stations, all.y = T, by.x = "line_id", by.y = "station_line_id")
data = merge(data, systems, all.x = T, by.x = "line_system_id", by.y = "system_id")

#Se eliminan las estaciones clausuradas
data = data[ (is.na(data$station_closure) | data$station_closure > 2020), ]
data = data[ (!is.na(data$station_opening) & data$station_opening > 0 & data$station_opening < 2030 ), ]

data = data[with(data, order(line_id, station_lat, station_lon)),]
by_line <- data %>% group_by(line_id)

by_line$line_meters = NA
by_line$line_meters_acumulated = NA
by_line$station_meters = NA

for ( group_ID in unique(group_indices(by_line)) ) {
  line = by_line[group_indices(by_line) == group_ID,]

  sort_stations_lon = line[with(line, order(station_lon, station_lat)),]
  sort_stations_lat = line[with(line, order(station_lat, station_lon)),]

  if (  sort_stations_lon[1,]$station_opening > sort_stations_lon[nrow(sort_stations_lon),]$station_opening ) {
    sort_stations_lon = line[with(line, order(station_lon, station_lat, decreasing = T)),]
  }
  if (  sort_stations_lon[1,]$station_opening > sort_stations_lon[nrow(sort_stations_lon),]$station_opening ) {
    sort_stations_lat = line[with(line, order(station_lat, station_lon, decreasing = T)),]
  }

  d1 = round(distm(sort_stations_lon[, c('station_lon', 'station_lat')], fun = distHaversine))
  d2 = round(distm(sort_stations_lat[, c('station_lon', 'station_lat')], fun = distHaversine))
  distance = d1
  if( is.unsorted(d1[,1]) ) {
    distance = d2
    rownames(distance) = sort_stations_lat$station_id
    colnames(distance) = sort_stations_lat$station_id
  } else {
    distance = d1
    rownames(distance) = sort_stations_lon$station_id
    colnames(distance) = sort_stations_lon$station_id
  }

  aux = NA
  lineMeters = 0
  for ( station_id in rownames(distance) ) {
    by_line[by_line$station_id == station_id,]$line_meters_acumulated = distance[[station_id, 1]]
    lineMeters = lineMeters + ifelse( is.na(aux), 0,  distance[[station_id, aux]])
    by_line[by_line$station_id == station_id,]$station_meters = ifelse( is.na(aux), 0,  distance[[station_id, aux]])
    aux = station_id
  }
  # only the last station has line meters seted
  by_line[by_line$station_id == station_id,]$line_meters = lineMeters
}

# lines examples
#View(by_line[by_line$line_id == 9, c("line_id", "station_opening", "station_name", "station_closure", "line_meters", "line_meters_acumulated", "station_lat", "station_lon")])
#View(by_line[by_line$line_id == 382, c("line_id", "station_opening", "station_name", "station_closure", "line_meters", "line_meters_acumulated", "station_lat", "station_lon")])
#View(by_line[group_indices(by_line) == line_id, ])

library(RSQLite)

db <- dbConnect(SQLite(), dbname="myDB.sqlite")
dbWriteTable(conn = db, name = "underground", ungroup(by_line), overwrite=T, row.names=T)
dbWriteTable(conn = db, name = "pbi", pbi, overwrite=T, row.names=T)
dbGetQuery(conn=db, "SELECT city_country, count(distinct line_id) cant FROM underground group by city_country order by cant desc")
dbGetQuery(conn=db, "SELECT * FROM pbi desc")
dbGetQuery(conn=db, "SELECT * FROM years ")

d = dbGetQuery(conn=db,
               "SELECT distinct city_country, sum(line_meters), group_concat(distinct line_name)
               FROM underground
               where system_name like '%subte%'
               or system_name like 'underground'
               or system_name like '%metro%'
               or system_name like '%sub%'
               or system_name like 'Métro%'
               group by city_country
               order by 2 desc")

dbSendQuery(conn = db,
            "CREATE TABLE YEARS
            (year INTEGER)")
dbSendQuery(conn=db, "delete from YEARS")
for ( year in 1840:2018) {
  dbSendQuery(conn = db,
              paste0("INSERT INTO YEARS
                     VALUES (", year , ")"))
}

dbGetQuery(conn=db, "select * from YEARS limit 5")

options("digits" = 7)

View(dbGetQuery(conn=db, " select * from underground where station_id = 100"))

data_to_export2 = dbGetQuery(conn=db, "
select
 city_country city_country,
 y.year year,
 coalesce( cast(pbi.pbi as number), 0) pbi,
 coalesce(sum(u.station_meters/ (u.station_opening - u.station_buildstart) ), 0) meters
 from YEARS y
 join pbi on y.year = pbi.year
 left join underground u on pbi.country = u.city_country and y.year between u.station_buildstart and u.station_opening
 where y.year between u.station_buildstart and u.station_opening and  ( u.city_country is null or
 (
 u.system_name like '%subte%'
 or u.system_name like 'underground'
 or u.system_name like '%metro%'
 or u.system_name like '%sub%'
 or u.system_name like 'Métro%')
 )
 group by
 city_country,
 y.year,
 pbi.pbi
 ")

data_to_export = dbGetQuery(conn=db,
                            "SELECT city_country, line_id, station_id, station_opening, line_name, station_name, station_meters, line_meters, line_meters_acumulated
                            FROM underground
                            where system_name like '%subte%'
                            or system_name like 'underground'
                            or system_name like '%metro%'
                            or system_name like '%sub%'
                            or system_name like 'Métro%'
                            order by line_id,  line_meters_acumulated  ")

db2 <- dbConnect(SQLite(), dbname="myDB2.sqlite")
dbWriteTable(conn = db2, name = "underground2", data_to_export, overwrite=T, row.names=T)

View(dbGetQuery(conn=db2,
                "SELECT city_country, station_opening, sum(station_meters)
                FROM underground2
                group by city_country, station_opening
                "))

ll= dbGetQuery(conn=db2,
"SELECT city_country, station_opening, sum(station_meters) meters
FROM underground2
where station_opening < '2016'
group by city_country, station_opening
")

library(ggplot2)
ggplot(ll, aes(city_country, meters/1000, fill=factor(city_country))) +
  geom_boxplot()

View(data_to_export)

# Exporting data to json
library(jsonlite)

json = toJSON(data_to_export, pretty = T)
json2 = toJSON(data_to_export2, pretty = T)
write(json, "lines.json")
write(json2, "pbi.json")


# GetAuditRandomData.r

source("../common/DataUtil.r")
source("../common/PlotUtil.r")

# G E T   D A T A
rm(results)
results <- fndfGetGiantData("./")
# Get fewer columns to work with, easier to see.
dat.auditrandom <- as.data.frame(fndfGetAuditData(results))

# S U B S E T S
dat.auditrandom <- dat.auditrandom[dat.auditrandom$lifem<=100,]
dat.auditbaseline <- dat.auditrandom[dat.auditrandom$auditsegments==1
                                    & dat.auditrandom$lifem>=3,]
dat.auditrandom.monthly <- dat.auditrandom[dat.auditrandom$auditsegments==10,]
dat.auditrandom.quarterly <- dat.auditrandom[dat.auditrandom$auditsegments==4,]
dat.auditrandom.semiannually <- dat.auditrandom[dat.auditrandom$auditsegments==2,]

source("./RandomTables.r")

# T A B U L A T E   D A T A  A S   T E X T

# M O N T H L Y
sOutputFilename <- "./Data_AuditRandom_Monthly.txt"
sTitle <- "Document losses with multiple copies and MONTHLY random auditing"
sSubtitle <- "Table of percentage loss of collection tabulated\n" %+%
    "by number of copies and sector half-lifetime"
dat.tmp <- dat.auditrandom.monthly
tbl.tmp <- fnPrintTableRandom(dat.tmp, sOutputFilename, sTitle, sSubtitle
)

# IF THAT WORKS, DO SOME MORE.

# Re-form the data into a table for printing.
foo<-(with(dat.auditrandom,
       tapply(mdmlosspct, list(copies, lifem), FUN=identity)))
foo2<-cbind(as.numeric(levels(factor(results$copies))), foo)
tbl2<-data.frame(foo2)
colnames(tbl2)<-c("copies",as.numeric(colnames(foo2[,2:ncol(foo2)])))
# Pretty-print this to a file with explanatory headings.
sink(sOutputFilename)
cat("MIT Preservation Simulation Project", "\n\n")
cat(sOutputFilename, format(Sys.time(),"%Y%m%d_%H%M%S%Z"), "\n\n")
cat(sTitle, "\n\n")
cat(sSubtitle, "\n\n")
cat("\n")
print(tbl2)
sink()

# Micah succeeded in bending dcast to his will, thanks; see email.
library(reshape2)
bar.small <- dat.auditrandom[,c("copies", "lifem", "mdmlosspct")]
bar.melted <- melt(bar.small, id=c("copies", "lifem"))
bar.recast <- dcast(bar.melted, copies~lifem)

# P L O T   D A T A
library(ggplot2)

# Compare random qtly and monthly against total annual.

source("./RandomPlots.r")

# R A N D O M   V S   B A S E L I N E

# Show lines for 3 copies, with random segmented auditing, over wiiiide range.
nCopies <- 3
gp <- fnPlotRandomMonthlyVsBaseline(nCopies)
plot(gp)
fnPlotMakeFile(gp, "baseline-auditrandomvsbaseline-c3.png")

# Show lines for 4 copies, with random segmented auditing, over wiiiide range.
nCopies <- 4
gp <- fnPlotRandomMonthlyVsBaseline(nCopies)
plot(gp)
fnPlotMakeFile(gp, "baseline-auditrandomvsbaseline-c4.png")

# Show lines for 5 copies, with random segmented auditing, over wiiiide range.
nCopies <- 5
gp <- fnPlotRandomMonthlyVsBaseline(nCopies)
plot(gp)
fnPlotMakeFile(gp, "baseline-auditrandomvsbaseline-c5.png")

# M O R E   R A N D O M   S E G M E N T S

# Compare random semiannual, quarterly, and monthly.

# Show lines for 3 copies, with random segmented auditing, over wiiiide range.
nCopies <- 3
gp <- fnPlotRandomVariousSegments(nCopies)
plot(gp)
fnPlotMakeFile(gp, "baseline-auditrandomvarioussegments-c3.png")

# Show lines for 4 copies, with random segmented auditing, over wiiiide range.
nCopies <- 4
gp <- fnPlotRandomVariousSegments(nCopies)
plot(gp)
fnPlotMakeFile(gp, "baseline-auditrandomvarioussegments-c4.png")

# Show lines for 5 copies, with random segmented auditing, over wiiiide range.
nCopies <- 5
gp <- fnPlotRandomVariousSegments(nCopies)
plot(gp)
fnPlotMakeFile(gp, "baseline-auditrandomvarioussegments-c5.png")

# Unwind any remaining sink()s to close output files.
while (sink.number() > 0) {sink()}


#' @export
bib_crossprod = function(x)
{
  storage.mode(x) = "double"
  .Call("bib_crossprod_", x)
}

#' @export
bib_tcrossprod = function(x)
{
  storage.mode(x) = "double"
  .Call("bib_tcrossprod_", x)
}

#' @export
bib_mvprod = function(trans=FALSE, x, y)
{
  storage.mode(x) = "double"
  storage.mode(y) = "double"
  .Call("bib_mvprod_", trans, x, y)
}


if (!require("BiocManager")) install.packages("BiocManager"); library(BiocManager)
if (!require("DESeq2")) BiocManager::install("DESeq2"); library(DESeq2)
if (!require("edgeR")) BiocManager::install("edgeR"); library(edgeR)
if (!require("genefilter")) BiocManager::install("genefilter"); library(genefilter)

# PC Users only, install Rtools https://cran.r-project.org/bin/windows/Rtools/

if (!require("devtools")) install.packages("devtools"); library(devtools)
if (!require("SARTools")) install_github("KField-Bucknell/SARTools", build_vignettes=TRUE, force=TRUE); library(SARTools)

################################################################################
### R script to compare several conditions with the SARTools and edgeR packages
### Hugo Varet
### November 28th, 2019
### designed to be executed with SARTools 1.7.2
################################################################################

################################################################################
###                parameters: to be modified by the user                    ###
################################################################################
rm(list=ls())                                        # remove all the objects from the R session

workDir <- "/Users/rileymcdonnell/Desktop/Biology 364/rrm020/HW 7/SARTools/SARTools.edgeR.genes"
projectName <- "SARTools.edgeR.genes"                         # name of the project
author <- "Riley McDonnell"                                # author of the statistical analysis/report

targetFile <- "../genes.target.txt"                           # path to the design/target file
rawDir <- "../"                                      # path to the directory containing raw counts files
featuresToRemove <- NULL

varInt <- "Treatment"                                    # factor of interest
condRef <- "Untreated"                                      # reference biological condition
batch <- NULL                                        # blocking factor: NULL (default) or "batch" for example

idColumn = 1                                         # column with feature Ids (usually 1)
countColumn = 5                                      # column with counts  (2 for htseq-count, 7 for featurecounts, 5 for RSEM/Salmon, 4 for kallisto)
rowSkip = 0                                          # rows to skip (not including header)

alpha <- 0.05                                        # threshold of statistical significance
pAdjustMethod <- "BH"                                # p-value adjustment method: "BH" (default) or "BY"

cpmCutoff <- 1                                       # counts-per-million cut-off to filter low counts
gene.selection <- "pairwise"                         # selection of the features in MDSPlot
normalizationMethod <- "TMM"                         # normalization method: "TMM" (default), "RLE" (DESeq) or "upperquartile"

colors <- c("#f3c300", "#875692", "#f38400",         # vector of colors of each biological condition on the plots
            "#a1caf1", "#be0032", "#c2b280",
            "#848482", "#008856", "#e68fac",
            "#0067a5", "#f99379", "#604e97")

forceCairoGraph <- FALSE

################################################################################
###                             running script                               ###
################################################################################
setwd(workDir)
library(SARTools)
if (forceCairoGraph) options(bitmapType="cairo")

# checking parameters
checkParameters.edgeR(projectName=projectName,author=author,targetFile=targetFile,
                      rawDir=rawDir,featuresToRemove=featuresToRemove,varInt=varInt,
                      condRef=condRef,batch=batch,alpha=alpha,pAdjustMethod=pAdjustMethod,
                      cpmCutoff=cpmCutoff,gene.selection=gene.selection,
                      normalizationMethod=normalizationMethod,colors=colors)

# loading target file
target <- loadTargetFile(targetFile=targetFile, varInt=varInt, condRef=condRef, batch=batch)

# loading counts
# loading counts
counts <- loadCountData(target=target, rawDir=rawDir, featuresToRemove=featuresToRemove,
                        skip=rowSkip, idColumn=idColumn, countColumn=countColumn)

# description plots
majSequences <- descriptionPlots(counts=counts, group=target[,varInt], col=colors)

# edgeR analysis
out.edgeR <- run.edgeR(counts=counts, target=target, varInt=varInt, condRef=condRef,
                       batch=batch, cpmCutoff=cpmCutoff, normalizationMethod=normalizationMethod,
                       pAdjustMethod=pAdjustMethod)

# MDS + clustering
exploreCounts(object=out.edgeR$dge, group=target[,varInt], gene.selection=gene.selection, col=colors)

# summary of the analysis (boxplots, dispersions, export table, nDiffTotal, histograms, MA plot)
summaryResults <- summarizeResults.edgeR(out.edgeR, group=target[,varInt], counts=counts, alpha=alpha, col=colors)

# save image of the R session
#save.image(file=paste0(projectName, ".RData"))

# generating HTML report
writeReport.edgeR(target=target, counts=counts, out.edgeR=out.edgeR, summaryResults=summaryResults,
                  majSequences=majSequences, workDir=workDir, projectName=projectName, author=author,
                  targetFile=targetFile, rawDir=rawDir, featuresToRemove=featuresToRemove, varInt=varInt,
                  condRef=condRef, batch=batch, alpha=alpha, pAdjustMethod=pAdjustMethod, cpmCutoff=cpmCutoff,
                  colors=colors, gene.selection=gene.selection, normalizationMethod=normalizationMethod)


library(Seurat)
library(scMRMA)
library(plyr)

ORA_celltype<-function(medianexp,cellType,weight){
  ORA_result<-matrix(NA, nrow=length(cellType),ncol=dim(medianexp)[2])
  CTA_result<-matrix(0,nrow=length(cellType),ncol=dim(medianexp)[2])
  exp_z<-scale(medianexp)
  genenames<-rownames(medianexp)
  for (j in 1: dim(medianexp)[2]){
    clusterexp<-medianexp[,j]
    clusterexp_z<-exp_z[,j]
    for (i in 1:length(cellType)){

      ct_exp<-length(intersect(genenames[clusterexp>0],cellType[[i]]))
      ct_not_exp<-length(cellType[[i]])-ct_exp
      exp_not_ct<-sum(clusterexp>0)-ct_exp
      not_exp_not_ct<-length(clusterexp)-ct_not_exp
      cont.table<-matrix(c(ct_exp,ct_not_exp,exp_not_ct,not_exp_not_ct),nrow=2)
      ORA_result[i,j]<-fisher.test(cont.table,alternative="greater")$p.value
      ###
      weight_ss<-weight[names(weight)%in%cellType[[i]]]
      ind<-match(names(weight_ss),genenames)
      exp_ss<-clusterexp_z[ind[!is.na(ind)]]
      weight_ss<-weight_ss[!is.na(ind)]
      CTA_result[i,j]<-sum(exp_ss*weight_ss)/(length(exp_ss)^(1/3))
    }
  }
  rownames(ORA_result)<-rownames(CTA_result)<-names(cellType)
  minp_ora_ind<- apply(ORA_result,2,function(x){which.min(x)})
  minp_ora<-apply(ORA_result,2,min)
  names(minp_ora)<-rownames(ORA_result)[minp_ora_ind]

  max_cta_ind<- apply(CTA_result,2,function(x){which.max(x)})
  max_cta<-apply(CTA_result,2,max,na.rm=T)
  names(max_cta)<-rownames(CTA_result)[max_cta_ind]
  return(list(ora=ORA_result,cta=CTA_result,min_ora=minp_ora,max_cta=max_cta))
}

get_celltype_weight<-function(marker, i) {
  celltype <- tapply(marker[,1],marker[,i],list)
  celltype <- lapply(celltype, unique)
  freq<-sort((table(unlist(celltype)))/length(celltype))
  if(max(freq)-min(freq)==0){
    weight <- rep(1,length(freq))
    names(weight) <- names(freq)
  }else{
    weight<-1+sqrt((max(freq)-freq)/(max(freq)-min(freq)))
  }
  return(list(celltype=celltype, weight=weight))
}

#get annotation result for each cluster
ori_annotation_normdata <- function(marker,i,data.norm,p){
  ct<-get_celltype_weight(marker, i)
  result<-ORA_celltype(data.norm,ct$celltype,ct$weight)
  colnames(result$ora)<-colnames(data.norm)
  colnames(result$cta)<-colnames(data.norm)
  result$ct=ct
  return(result)
}

get_annotation_list <-function(predict_celltype) {
  annoP <- predict_celltype$ora
  max_cta_pvalue = unlist(lapply(c(1:length(predict_celltype$max_cta)), function(x){
    cluster = x
    cta = names(predict_celltype$max_cta)[x]
    annoP[cta, cluster]
  }))
  celltype = unlist(lapply(c(1:length(max_cta_pvalue)), function(x){
    ifelse(max_cta_pvalue[x] > p, "unassigned", names(predict_celltype$max_cta)[x])
  }))

  result = data.frame(  predict_celltype=names(predict_celltype$max_cta),
                        activity= predict_celltype$max_cta,
                        pvalue=max_cta_pvalue,
                        celltype=celltype)
  rownames(result)<-colnames(predict_celltype$cta)

  return(result)
}

get_annotation_normdata <- function(data.norm, species,db="panglaodb",p=0.05){
  if(is(db,"data.frame")){
    CellType <- db
  }else if (is(db,"matrix")){
    CellType <- data.frame(db)
  }else {
    CellType <- scMRMA:::get_celltype(species,db)
  }

  annoResult <- list()
  anno <- matrix("unknown",nrow = dim(data.norm)[2],ncol = (ncol(CellType)) * 3)
  rownames(anno)<- colnames(data.norm)
  colnames(anno) <- paste(rep(c(colnames(CellType)[2:ncol(CellType)], "extend"),each=3),
                          rep(c("celltype","activity","pValue"),3),sep = "_")

  annoDetails <- matrix(NA,nrow = dim(data.norm)[2],ncol = (ncol(CellType)-1)*2)
  rownames(annoDetails)<- colnames(data.norm)
  colnames(annoDetails)<- paste(rep(colnames(CellType)[2:ncol(CellType)],each=2),
                                rep(c("celltypeActivity","pValue"),2),sep = "_")
  annoDetails <- as.data.frame(annoDetails,stringsAsFactors = FALSE)

  anno_markers<-list()
  anno<-list()
  cat("Multi Resolution Annotation Started.","\n")
  i=2
  lastlayer_data = NULL
  for (i in 2:ncol(CellType)){
    layer=paste0("layer", (i-1))
    cat(layer,"annotation started.","\n")
    if(i==2){
      marker <- CellType
      predict_celltype <- ori_annotation_normdata(marker,i,data.norm,p)
      lastlayer_anno = get_annotation_list(predict_celltype)
      anno[[layer]] = lastlayer_anno
    }else{
      curlayer_anno=NULL
      m= "CD4"
      for (m in unique(lastlayer_anno$celltype)){
        if (m != "unassigned"){
          cat("sub annotation of ", m, "\n")
          marker <- subset(CellType,CellType[,i-1]==m)
          if(length(unique(marker[,i])) > 1 ){##stop if there is no subtype
            clusternames <- rownames(lastlayer_anno)[lastlayer_anno$celltype==m]
            sub <- data.norm[,clusternames,drop=F]
            predict_celltype <- ori_annotation_normdata(marker,i,sub,p)
            sub_anno = get_annotation_list(predict_celltype)
            curlayer_anno=rbind(curlayer_anno, sub_anno)
          }else{
            sub_anno = subset(lastlayer_anno, lastlayer_anno$celltype == m)
            curlayer_anno=rbind(curlayer_anno, sub_anno)
          }
        }else{
          sub_anno = subset(lastlayer_anno, lastlayer_anno$celltype == m)
          curlayer_anno=rbind(curlayer_anno, sub_anno)
        }
      }
      anno[[layer]] = curlayer_anno
      lastlayer_anno = curlayer_anno
    }
  }

  predict_celltype <- ori_annotation_normdata(CellType,ncol(CellType),data.norm,p)
  anno[["uniformR"]] = get_annotation_list(predict_celltype)

  return(anno)
}

finalList<-readRDS(parFile1)
obj<-finalList$obj

data.norm<-read.csv(parFile2, header=T, row.names=1, check.names=F)
colnames(data.norm)<-gsub("Cluster","",colnames(data.norm))

options_table<-read.table(parSampleFile2, sep="\t", header=F, stringsAsFactors = F)
options<-split(options_table$V1, options_table$V2)

species=options$species
prefix<-options$prefix
db=options$db
p=as.numeric(options$p)

res=get_annotation_normdata(data.norm, species, db, p)

for(layer in names(res)){
  curlayer = res[[layer]]
  curcelltype=plyr::mapvalues(obj$seurat_clusters, rownames(curlayer), as.character(curlayer$celltype))

  layer_name = paste0("scMRMA_", layer)
  obj[[layer_name]] <- curcelltype

  png(paste0(prefix, layer_name, ".png"), width=4000, height=3000, res=300)
  print(DimPlot(obj,reduction = "umap",group.by = layer_name,label = TRUE,repel = TRUE)+ggplot2::ggtitle(layer_name))
  dev.off()
}

finalListFile=paste0(prefix, ".scMRMA.rds")
saveRDS(finalList, file=finalListFile)


#!/usr/bin/env Rscript
options(stringAsfactors = FALSE, useFancyQuotes = FALSE)
# This script is used to group or link different mass traces across samples
# Taking the command line arguments
args <- commandArgs(trailingOnly = TRUE)

if(length(args)==0)stop("No file has been specified! Please select a file for performing grouping!\n")
require(xcms)
previousEnv<-NA
output<-NA
bw<-15
mzwid=0.005
minfrac<-0.3
minsamp<-1
max<-50
ipo_in<-NA

for(arg in args)
{
  argCase<-strsplit(x = arg,split = "=")[[1]][1]
  value<-strsplit(x = arg,split = "=")[[1]][2]
  if(argCase=="input")
  {
    previousEnv=as.character(value)
  }
  if(argCase=="ipo_in")
  {
    ipo_in=as.character(value)
  }
  if(argCase=="bandwidth")
  {
    bw=as.numeric(value)
  }
  if(argCase=="minfrac")
  {
    minfrac=as.numeric(value)
  }
  if(argCase=="minsamp")
  {
    minsamp=as.numeric(value)
  }
  if(argCase=="max")
  {
    max=as.numeric(value)
  }

  if(argCase=="mzwid")
  {
    mzwid=as.numeric(value)
  }
  if(argCase=="output")
  {
    output=as.character(value)
  }

}
if(is.na(previousEnv) | is.na(output)) stop("Both input and output need to be specified!\n")

load(file = previousEnv)

toBeGrouped<-get(varNameForNextStep)

if(!is.na(ipo_in))
{
  ## Read IPO params
  ## This will overwrite the parameters that have been supplies by the user
  library(jsonlite)
  ipo_json<-read_json(ipo_in,simplifyVector = T)
  ipo_params<-fromJSON(ipo_json)
  bw<-ipo_params$bw
  minfrac<-ipo_params$minfrac
  mzwid<-ipo_params$mzwid
  minsamp<-ipo_params$minsamp
  max<-ipo_params$max
}

ipo_inv<-get("ipo_inv")
if(ipo_inv==TRUE & is.na(ipo_in))
{
  ipo_params<-get("ipo_params_set")
  ipo_params<-ipo_params
  bw<-ipo_params$bw
  minfrac<-ipo_params$minfrac
  mzwid<-ipo_params$mzwid
  minsamp<-ipo_params$minsamp
  max<-ipo_params$max
}

xcmsSetGrouped<-  group(toBeGrouped,bw=bw,mzwid=mzwid,max=max,minsamp=minsamp,minfrac=minfrac,method="density")

preprocessingSteps<-c(preprocessingSteps,"Group")

varNameForNextStep<-as.character("xcmsSetGrouped")

save(list = c("xcmsSetGrouped","preprocessingSteps","varNameForNextStep"),file = output)


suppressPackageStartupMessages({
    library(data.table)
})
load('../../generated/model/model-data-image.rdata', v=F)

source('../../../config.r')
source('../../../labs.r')

load('../../../input-data/grid/grids.rdata')

spplist  <- fread('../../acap-species-list.csv')
source('../../../functions.r')

ov <- overlaps[type == 'observed']
ov[, sgroup := ifelse(base_species == T, species_group, species_code)]

ov[, sum(captures), sgroup]

captures <- overlaps[type == 'observed' & base_species == T,
                     .(captures = sum(captures)),
                     .(species_group, grid_id)]

pal <- c("#FEEDB0","#F9C58B","#F39E6E","#EA785A","#D85455","#BE375A","#9D2461","#791A60","#531653","#2F0F3E")

spg=captures$species_group[1]
for (spg in unique(captures$species_group)) {
    cat(spg, '\n')
    d <- captures[species_group == spg, .(grid_id, captures)]
    g <- map_grid_values(grid_values=d, legend.title = 'Observed\ncaptures', pal=pal, colourscale.trans='identity')
    ggsave(sprintf('../assets/map-observed-captures_%s.png', spg), g, width = 7, height = 7, dpi=100)
}