library(tidyverse)
library(ppcor)
library(ggpubr)
library(broom)
library(svglite)

#### import and format tract-tracing connectivity matrix
tt_path  <- '/home/celine/ferret-mri-annex/scratch/work_celine/compDiffTT/data/Bizley2009/retrogradeTT_raw_dzero_normFLN_sym.csv'
tt_data <- read.csv(tt_path, header = FALSE, sep = '')
mask <- upper.tri(tt_data,diag = FALSE)
tt_data_flat <- tt_data[mask]

#### import euclidean distance between parcels
eucldist_path = '/home/celine/ferret-mri-annex/scratch/work_celine/compDiffTT/data/Bizley2009/euclideanDistance_selected.csv'
eucldist = read.csv(eucldist_path, header = FALSE, sep = '')
eucldist_flat <- eucldist[mask]

#### import and format diffusion data (connectivity matrices and average streamline lengths)
i <- 0
nbfib <- '1M'
pathConn <- '/home/celine/ferret-mri-annex/scratch/work_celine/compDiffTT/data/connectomes/F01_Adult/selected/processed/'
pathLen <- '/home/celine/ferret-mri-annex/scratch/work_celine/compDiffTT/data/connectomes/F01_Adult/length/selected/'
savepath <- '/home/celine/ferret-mri-annex/scratch/work_celine/compDiffTT/figures/'

dti_det_path <-  paste(pathConn,'connectomeBizley_whole_dti_',nbfib,'_',i,'_weights_selected_dzero_normFS_sym.csv',sep = '' )
dti_det_data <-  read.csv(dti_det_path, header = FALSE, sep = ' ')
dti_det_data_flat <- dti_det_data[mask]
dti_det_length_path <-  paste(pathLen,'connectomeBizley_whole_dti_',nbfib,'_',i,'_lengths_selected.csv',sep = '' )
dti_det_length_data <-  read.csv(dti_det_length_path, header = FALSE, sep = ' ')
dti_det_length_data_flat <- dti_det_length_data[mask]

dti_prob_path <-  paste(pathConn,'connectomeBizley_whole_dti_Prob_',nbfib,'_',i,'_weights_selected_dzero_normFS_sym.csv',sep = '' )
dti_prob_data <-  read.csv(dti_prob_path, header = FALSE, sep = ' ')
dti_prob_data_flat <- dti_prob_data[mask]
dti_prob_length_path <-  paste(pathLen,'connectomeBizley_whole_dti_Prob_',nbfib,'_',i,'_lengths_selected.csv',sep = '' )
dti_prob_length_data <-  read.csv(dti_prob_length_path, header = FALSE, sep = ' ')
dti_prob_length_data_flat <- dti_prob_length_data[mask]

csd_det_path <-  paste(pathConn,'connectomeBizley_whole_csd_SD_',nbfib,'_',i,'_weights_selected_dzero_normFS_sym.csv',sep = '' )
csd_det_data <-  read.csv(csd_det_path, header = FALSE, sep = ' ')
csd_det_data_flat <- csd_det_data[mask]
csd_det_length_path <-  paste(pathLen,'connectomeBizley_whole_csd_SD_',nbfib,'_',i,'_lengths_selected.csv',sep = '' )
csd_det_length_data <-  read.csv(csd_det_length_path, header = FALSE, sep = ' ')
csd_det_length_data_flat <- csd_det_length_data[mask]

csd_prob_path <-  paste(pathConn,'connectomeBizley_whole_csd_iFOD2_',nbfib,'_',i,'_weights_selected_dzero_normFS_sym.csv',sep = '' )
csd_prob_data <-  read.csv(csd_prob_path, header = FALSE, sep = ' ')
csd_prob_data_flat <- csd_prob_data[mask]
csd_prob_length_path <-  paste(pathLen,'connectomeBizley_whole_csd_iFOD2_',nbfib,'_',i,'_lengths_selected.csv',sep = '' )
csd_prob_length_data <-  read.csv(csd_prob_length_path, header = FALSE, sep = ' ')
csd_prob_length_data_flat <- csd_prob_length_data[mask]

dholl_det_path <-  paste(pathConn,'connectomeBizley_whole_msmt_dhollander_SD_',nbfib,'_',i,'_weights_selected_dzero_normFS_sym.csv',sep = '' )
dholl_det_data <-  read.csv(dholl_det_path, header = FALSE, sep = ' ')
dholl_det_data_flat <- dholl_det_data[mask]
dholl_det_length_path <-  paste(pathLen,'connectomeBizley_whole_msmt_dhollander_SD_',nbfib,'_',i,'_lengths_selected.csv',sep = '' )
dholl_det_length_data <-  read.csv(dholl_det_length_path, header = FALSE, sep = ' ')
dholl_det_length_data_flat <- dholl_det_length_data[mask]

dholl_prob_path <-  paste(pathConn,'connectomeBizley_whole_msmt_dhollander_',nbfib,'_',i,'_weights_selected_dzero_normFS_sym.csv',sep = '' )
dholl_prob_data <-  read.csv(dholl_prob_path, header = FALSE, sep = ' ')
dholl_prob_data_flat <- dholl_prob_data[mask]
dholl_prob_length_path <-  paste(pathLen,'connectomeBizley_whole_msmt_dhollander_',nbfib,'_',i,'_lengths_selected.csv',sep = '' )
dholl_prob_length_data <-  read.csv(dholl_prob_length_path, header = FALSE, sep = ' ')
dholl_prob_length_data_flat <- dholl_prob_length_data[mask]

#### compute correlations SPEARMAN

cor.test(x = tt_data_flat,y = dti_det_data_flat,method = 'spearman')
cor.test(x = tt_data_flat,y = dti_prob_data_flat,method = 'spearman')

cor.test(x = tt_data_flat,y = csd_det_data_flat,method = 'spearman')
cor.test(x = tt_data_flat,y = csd_prob_data_flat,method = 'spearman')

cor.test(x = tt_data_flat,y = dholl_det_data_flat,method = 'spearman')
cor.test(x = tt_data_flat,y = dholl_prob_data_flat,method = 'spearman')

#### compute bootstrapped confidence intervals for spearman correlations
library(DescTools)

spearman <- function(x,y) cor(x,y,method = "spearman",use = "p")

DescTools::BootCI(tt_data_flat, dti_det_data_flat,FUN = spearman, R = 10000, conf.level = 0.95)
DescTools::BootCI(tt_data_flat, dti_prob_data_flat,FUN = spearman, R = 10000, conf.level = 0.95)

DescTools::BootCI(tt_data_flat, csd_det_data_flat,FUN = spearman, R = 10000, conf.level = 0.95)
DescTools::BootCI(tt_data_flat, csd_prob_data_flat,FUN = spearman, R = 10000, conf.level = 0.95)

DescTools::BootCI(tt_data_flat, dholl_det_data_flat,FUN = spearman, R = 10000, conf.level = 0.95)
DescTools::BootCI(tt_data_flat, dholl_prob_data_flat,FUN = spearman, R = 10000, conf.level = 0.95)

#### compute correlations PEARSON (to be computed with the connectivity matrices incremented by one before normalisation)

cor.test(x = log10(tt_data_flat),y = log10(dti_det_data_flat),method = 'pearson')
cor.test(x = log10(tt_data_flat),y = log10(dti_prob_data_flat),method = 'pearson')

cor.test(x = log10(tt_data_flat),y = log10(csd_det_data_flat),method = 'pearson')
cor.test(x = log10(tt_data_flat),y = log10(csd_prob_data_flat),method = 'pearson')

cor.test(x = log10(tt_data_flat),y = log10(dholl_det_data_flat),method = 'pearson')
cor.test(x = log10(tt_data_flat),y = log10(dholl_prob_data_flat),method = 'pearson')

#### PLOT correlation tt/diff ####

max_len = max(cbind(t(dti_det_length_data_flat),t(dti_prob_length_data_flat),t(csd_det_length_data_flat),t(csd_prob_length_data_flat),t(dholl_det_length_data_flat),t(dholl_prob_length_data_flat)))

(cdti_det <- ggplot(data = NULL, aes(x=rank(tt_data_flat),y = rank(dti_det_data_flat))) +
    geom_point(aes(fill=dti_det_length_data_flat/max_len),shape=21,size=2) +
    geom_smooth(method = 'lm',se = TRUE,color='royalblue1',fill='royalblue1',alpha=0.2) +
    scale_fill_gradient(guide = FALSE,low = 'white',high = 'black') +
    scale_x_continuous(limits = c(-1,length(tt_data_flat)+1.5)) +
    scale_y_continuous(limits = c(-1,length(tt_data_flat)+1.5))+
    theme_set(theme_gray(base_size = 11))+
    theme(
      axis.title.x=element_blank(),
      axis.title.y=element_blank())+
    coord_fixed())

(cdti_prob <- ggplot(data = NULL, aes(x=rank(tt_data_flat),y = rank(dti_prob_data_flat))) +
    geom_point(aes(fill=dti_prob_length_data_flat/max_len),shape=21,size=2) +
    geom_smooth(method = 'lm',se = TRUE,color='royalblue1',fill='royalblue1',alpha=0.2) +
    scale_fill_gradient(guide = FALSE,low = 'white',high = 'black') +
    scale_x_continuous(limits = c(-1,length(tt_data_flat)+1.5)) +
    scale_y_continuous(limits = c(-1,length(tt_data_flat)+1.5))+
    theme_set(theme_gray(base_size = 11))+
    theme(
      axis.title.x=element_blank(),
      axis.title.y=element_blank())+
    coord_fixed())

(ccsd_det <- ggplot(data = NULL, aes(x=rank(tt_data_flat),y = rank(csd_det_data_flat))) +
    geom_point(aes(fill=csd_det_length_data_flat/max_len),shape=21,size=2) +
    geom_smooth(method = 'lm',se = TRUE,color='darkorange',fill='darkorange',alpha=0.2) +
    scale_fill_gradient(guide = FALSE,low = 'white',high = 'black')+
    scale_x_continuous(limits = c(-1,length(tt_data_flat)+1.5)) +
    scale_y_continuous(limits = c(-1,length(tt_data_flat)+1.5))+
    theme_set(theme_gray(base_size = 11))+
    theme(
      axis.title.x=element_blank(),
      axis.title.y=element_blank())+
    coord_fixed())

(ccsd_prob <- ggplot(data = NULL, aes(x=rank(tt_data_flat),y = rank(csd_prob_data_flat))) +
    geom_point(aes(fill=csd_prob_length_data_flat/max_len),shape=21,size=2) +
    geom_smooth(method = 'lm',se = TRUE,color='darkorange',fill='darkorange',alpha=0.2) +
    scale_fill_gradient(guide = FALSE,low = 'white',high = 'black')+
    scale_x_continuous(limits = c(-1,length(tt_data_flat)+1.5)) +
    scale_y_continuous(limits = c(-1,length(tt_data_flat)+1.5))+
    theme_set(theme_gray(base_size = 11))+
    theme(
      axis.title.x=element_blank(),
      axis.title.y=element_blank())+
    coord_fixed())

(cdholl_det <- ggplot(data = NULL, aes(x=rank(tt_data_flat),y = rank(dholl_det_data_flat))) +
  geom_point(aes(fill=dholl_det_length_data_flat/max_len),shape=21,size=2) +
  geom_smooth(method = 'lm',se = TRUE,color='green4',fill='green4',alpha=0.2) +  #se=TRUE
  scale_fill_gradient(guide=FALSE,low = 'white',high = 'black')+#guide='colorbar'
    scale_x_continuous(limits = c(-1,length(tt_data_flat)+1.5)) +
    scale_y_continuous(limits = c(-1,length(tt_data_flat)+1.5))+
  theme_set(theme_gray(base_size = 11))+
    theme(
      axis.title.x=element_blank(),
      axis.title.y=element_blank())+
    coord_fixed())

(cdholl_prob <- ggplot(data = NULL, aes(x=rank(tt_data_flat),y = rank(dholl_prob_data_flat))) +
    geom_point(aes(fill=dholl_prob_length_data_flat/max_len),shape=21,size=2) +
    geom_smooth(method = 'lm',se = TRUE,color='green4',fill='green4',alpha=0.2) +  #se=TRUE
    scale_fill_gradient(guide=FALSE,low = 'white',high = 'black')+#guide='colorbar'
    scale_x_continuous(limits = c(-1,length(tt_data_flat)+1.5)) +
    scale_y_continuous(limits = c(-1,length(tt_data_flat)+1.5))+
    theme_set(theme_gray(base_size = 11))+
    theme(
      axis.title.x=element_blank(),
      axis.title.y=element_blank())+
    coord_fixed())

(ggarrange(cdti_det,ccsd_det,cdholl_det,cdti_prob,ccsd_prob,cdholl_prob,ncol=3,nrow = 2))
ggsave(paste(savepath,'spearmancorr_det_prob_sym_plot_FSFLN.svg'), device = svg(),width = 18,height = 10,units = 'cm')
ggsave(paste(savepath,'spearmancorr_det_prob_sym_plot_FSFLN.png'), device = svg(),width = 18,height = 10,units = 'cm')

(ggarrange(cdti_det,ccsd_det,cdholl_det,ncol=3,nrow = 1))
ggsave(paste(savepath,'spearmancorr_det_prob_sym_plot_FS-DET.svg'), device = svg(),width = 18,height = 5,units = 'cm')
ggsave(paste(savepath,'spearmancorr_det_prob_sym_plot_FS-DET.png'), device = svg(),width = 18,height = 5,units = 'cm')

(ggarrange(cdti_prob,ccsd_prob,cdholl_prob,ncol=3,nrow = 1))
ggsave(paste(savepath,'spearmancorr_det_prob_sym_plot_FS-PROB.svg'), device = svg(),width = 18,height = 5,units = 'cm')
ggsave(paste(savepath,'spearmancorr_det_prob_sym_plot_FS-PROB.png'), device = svg(),width = 18,height = 5,units = 'cm')

##save colorbar
(ggplot(data = NULL, aes(x=rank(tt_data_flat),y = rank(dti_det_data_flat))) +
    geom_point(aes(fill=dti_det_length_data_flat/max(dti_det_length_data_flat)),shape=21,size=3) +
    geom_smooth(method = 'lm',se = TRUE,color='royalblue1',fill='royalblue1',alpha=0.2) +  #se=TRUE
    scale_fill_gradient(guide='colorbar',low = 'white',high = 'black')+#guide='colorbar'
    scale_x_continuous(limits = c(-1,length(tt_data_flat))) +
    scale_y_continuous(limits = c(-1,length(tt_data_flat)))+
    guides(fill=guide_colorbar(barwidth = 2.5,barheight = 15))+
    theme(legend.text = element_text(size = 15),
          legend.title = element_blank(),
          axis.title.x=element_blank(),
          axis.title.y=element_blank())+
    coord_fixed())

ggsave(paste(savepath,'spearmancorr_colorbar.svg'),dpi=300)

#### partial corr, distance regressed ####

ttlm <- lm(log10(tt_data_flat)~eucldist_flat,na.action=na.exclude)
ttresid <- resid(ttlm)

dti_det_data_na <- dti_det_data_flat
dti_det_data_na[dti_det_data_na==0] <- NA
dti_det_dist_data_na <- eucldist_flat
dti_det_dist_data_na[is.na(dti_det_data_na)] <- NA
dtilm_d <- lm(log10(dti_det_data_na)~dti_det_dist_data_na,na.action=na.exclude)
dtiresid_d <- resid(dtilm_d)

dti_prob_data_na <- dti_prob_data_flat
dti_prob_data_na[dti_prob_data_na==0] <- NA
dti_prob_dist_data_na <- eucldist_flat
dti_prob_dist_data_na[is.na(dti_prob_data_na)] <- NA
dtilm_p <- lm(log10(dti_prob_data_na)~dti_prob_dist_data_na,na.action=na.exclude)
dtiresid_p <- resid(dtilm_p)

csd_det_data_na <- csd_det_data_flat
csd_det_data_na[csd_det_data_na==0] <- NA
csd_det_dist_data_na <- eucldist_flat
csd_det_dist_data_na[is.na(csd_det_data_na)] <- NA
csdlm_d <- lm(log10(csd_det_data_na)~csd_det_dist_data_na,na.action=na.exclude)
csdresid_d <- resid(csdlm_d)

csd_prob_data_na <- csd_prob_data_flat
csd_prob_data_na[csd_prob_data_na==0] <- NA
csd_prob_dist_data_na <- eucldist_flat
csd_prob_dist_data_na[is.na(csd_prob_data_na)] <- NA
csdlm_p <- lm(log10(csd_prob_data_na)~csd_prob_dist_data_na,na.action=na.exclude)
csdresid_p <- resid(csdlm_p)

dholl_det_data_na <- dholl_det_data_flat
dholl_det_data_na[dholl_det_data_na==0] <- NA
dholl_det_dist_data_na <- eucldist_flat
dholl_det_dist_data_na[is.na(dholl_det_data_na)] <- NA
dholllm_d <- lm(log10(dholl_det_data_na)~dholl_det_dist_data_na,na.action=na.exclude)
dhollresid_d <- resid(dholllm_d)

dholl_prob_data_na <- dholl_prob_data_flat
dholl_prob_data_na[dholl_prob_data_na==0] <- NA
dholl_prob_dist_data_na <- eucldist_flat
dholl_prob_dist_data_na[is.na(dholl_prob_data_na)] <- NA
dholllm_p <- lm(log10(dholl_prob_data_na)~dholl_prob_dist_data_na,na.action=na.exclude)
dhollresid_p <- resid(dholllm_p)

dtiresid_d[is.na(dtiresid_d)] <- 0
dtiresid_p[is.na(dtiresid_p)] <- 0
csdresid_d[is.na(csdresid_d)] <- 0
csdresid_p[is.na(csdresid_p)] <- 0
dhollresid_d[is.na(dhollresid_d)] <- 0
dhollresid_p[is.na(dhollresid_p)] <- 0

#### SPEARMAN semi-partial correlations

cor.test(ttresid,dtiresid_d,method = 'spearman')
cor.test(ttresid,dtiresid_p,method = 'spearman')
cor.test(ttresid,csdresid_d,method = 'spearman')
cor.test(ttresid,csdresid_p,method = 'spearman')
cor.test(ttresid,dhollresid_d,method = 'spearman')
cor.test(ttresid,dhollresid_p,method = 'spearman')

#### PEARSON semi-partial correlations

cor.test(ttresid,(dtiresid_d),method = 'pearson')
cor.test(ttresid,(dtiresid_p),method = 'pearson')
cor.test(ttresid,(csdresid_d),method = 'pearson')
cor.test(ttresid,(csdresid_p),method = 'pearson')
cor.test(ttresid,(dhollresid_d),method = 'pearson')
cor.test(ttresid,(dhollresid_p),method = 'pearson')

#### plot partial correlations

(rdti_d <- ggplot(mapping = aes(x=rank(ttresid),y=rank(dtiresid_d))) +
    geom_point()+geom_smooth(method = 'lm', se = TRUE,color='royalblue1',fill='royalblue1',alpha=0.2)+
    scale_x_continuous(limits = c(-1,length(tt_data_flat))) +
    scale_y_continuous(limits = c(-1,length(tt_data_flat)))+
    theme_set(theme_gray(base_size = 11))+
    theme(
      axis.title.x=element_blank(),
      axis.title.y=element_blank())+
    coord_fixed())

(rdti_p <- ggplot(mapping = aes(x=rank(ttresid),y=rank(dtiresid_p))) +
    geom_point()+geom_smooth(method = 'lm', se = TRUE,color='royalblue1',fill='royalblue1',alpha=0.2)+
    scale_x_continuous(limits = c(-1,length(tt_data_flat))) +
    scale_y_continuous(limits = c(-1,length(tt_data_flat)))+
    theme_set(theme_gray(base_size = 11))+
    theme(
      axis.title.x=element_blank(),
      axis.title.y=element_blank())+
    coord_fixed())

(rcsd_d <- ggplot(mapping = aes(x=rank(ttresid),y=rank(csdresid_d))) +
    geom_point()+geom_smooth(method = 'lm', se = TRUE,color='darkorange',fill='darkorange',alpha=0.2)+
    scale_x_continuous(limits = c(-1,length(tt_data_flat))) +
    scale_y_continuous(limits = c(-1,length(tt_data_flat)))+
    theme_set(theme_gray(base_size = 11))+
    theme(
      axis.title.x=element_blank(),
      axis.title.y=element_blank())+
    coord_fixed())

(rcsd_p <- ggplot(mapping = aes(x=rank(ttresid),y=rank(csdresid_p))) +
    geom_point()+geom_smooth(method = 'lm', se = TRUE,color='darkorange',fill='darkorange',alpha=0.2)+
    scale_x_continuous(limits = c(-1,length(tt_data_flat))) +
    scale_y_continuous(limits = c(-1,length(tt_data_flat)))+
    theme_set(theme_gray(base_size = 11))+
    theme(
      axis.title.x=element_blank(),
      axis.title.y=element_blank())+
    coord_fixed())

(rdholl_d <- ggplot(mapping = aes(x=rank(ttresid),y=rank(dhollresid_d))) +
  geom_point()+geom_smooth(method = 'lm', se = TRUE,color='green4',fill='green4',alpha=0.2)+
    scale_x_continuous(limits = c(-1,length(tt_data_flat))) +
    scale_y_continuous(limits = c(-1,length(tt_data_flat)))+
    theme_set(theme_gray(base_size = 11))+
    theme(
      axis.title.x=element_blank(),
      axis.title.y=element_blank())+
    coord_fixed())

(rdholl_p <- ggplot(mapping = aes(x=rank(ttresid),y=rank(dhollresid_p))) +
    geom_point()+geom_smooth(method = 'lm', se = TRUE,color='green4',fill='green4',alpha=0.2)+
    scale_x_continuous(limits = c(-1,length(tt_data_flat))) +
    scale_y_continuous(limits = c(-1,length(tt_data_flat)))+
    theme_set(theme_gray(base_size = 11))+
    theme(
      axis.title.x=element_blank(),
      axis.title.y=element_blank())+
    coord_fixed())

(ggarrange(rdti_d,rcsd_d,rdholl_d,rdti_p,rcsd_p,rdholl_p,nrow = 2,ncol = 3))
ggsave(paste(savepath,'spearmancorr_residuals_partcorr_det_prob_sym_plot.svg'),dpi=300,width = 18,height = 10,units = 'cm')
ggsave(paste(savepath,'spearmancorr_residuals_partcorr_det_prob_sym_plot.png'),dpi=300,width = 18,height = 10,units = 'cm')


# This file creates introductory data used by all following code
# In particular it creates grids of points at which to generate simulations
# set the directory locations in lines 5-13 then run whole file.

# base directory to save all output
base_dir_on_comp <- "C:/Users/christina/"
base_dir_sim <- base_dir_on_comp + "multinomial_simulations/"
# subdirectories to save csv output and generated images
file_save_dir <- paste0(base_dir_sim, "csv_files/")
img_save_dir <- paste0(base_dir_sim, "image_files/")
# code currently in multinomial branch of MRSea so need to download package from github to base dir on comp
# then switch to multinomial branch
devtools::load_all(paste0(base_dir_on_comp, "MRsea"))

library(knitr)
library(tidyverse)
library(kableExtra)
library(viridis)
library(hexbin)
library(car)
library(mvtnorm)
library(sf)
library(Rfast)

changeSciNot <- function(n) {
  output <- format(n, scientific = TRUE) #Transforms the number into scientific notation even if small
  output <- sub("e", "*10^", output) #Replace e with 10^
  output <- sub("\\+0?", "", output) #Remove + symbol and leading zeros on expoent, if > 1
  output <- sub("-0?", "-", output) #Leaves - symbol but removes leading zeros on expoent, if < 1
  output <- sub("1\\*", "", output) # Removes 1*10 but leaves anything else raised to 10
  parse(text=output)
}

cbbPalette <- c("#004949","#009292","#ff6db6","#ffb6db","#490092","#006ddb","#b66dff","#6db6ff","#b6dbff","#920000","#924900","#db6d00","#24ff24","#ffff6d", "#000000")

if (file.exists(paste0(file_save_dir, "location_grid.csv"))) {
  grid <- read.csv(paste0(file_save_dir, "location_grid.csv"))
} else {
  n <- seq(0.005, 0.995, length.out=100)
  xx <- rep(n, times=100)
  yy <- rep(n, each=100)
  grid <- cbind(xx,yy)
  grid <- as.data.frame(grid)
  write.csv(grid, paste0(file_save_dir, "location_grid.csv"), row.names=F)
}

png(filename=paste0(img_save_dir, "Grid.png"))
par(pty="s")
plot(grid$xx,grid$yy, type='p', pch=4, cex=.2, main='Base grid', asp=1, xlab="X coordinate", ylab="Y coordinate")
dev.off()

linestr_create <- function(pt1, pt2){
  linestr <- st_linestring(rbind(st_coordinates(pt1), st_coordinates(pt2)))
  return(linestr)
}

dist_exclude_vec <- function(vec, pt, ez) {
  distpt <- st_distance(vec, pt)
  linechk <- st_sfc(lapply(vec, linestr_create, pt2=pt))
  intchk <- as.vector(st_intersects(ez, linechk, sparse=FALSE))
  distpt <- ifelse(intchk, Inf, distpt)
  return(distpt)
}

if (file.exists(paste0(file_save_dir,"location_grid_island.csv"))) {
  grid_i <- read.csv(paste0(file_save_dir, "location_grid_island.csv"))
} else {
  nnn <- nrow(grid)
  pointz <- cbind(grid$xx, grid$yy)
  pt1 <- st_point(pointz[1,])
  pt2 <- st_point(pointz[2,])
  ptlist <- list(pt1, pt2)
  for (pt in 3:nnn){
    pt1 <- st_point(pointz[pt,])
    ptlist[[pt]] <- pt1
  }
  sfpointz <- st_sfc(ptlist)
  #create exclusion zone and remove points in exclusion zone
  #island_in <- st_polygon(list(rbind(c(0.1, 0.3), c(0.15, 0.3), c(0.8, 0.55),
  #                                   c(0.75, 0.75), c(0.1, 0.4), c(0.1, 0.3))))
  island_in <- st_polygon(list(rbind(c(0.0, 0.3), c(0.15, 0.3), c(0.8, 0.55),
                                     c(0.75, 0.75), c(0.0, 0.4), c(0.0, 0.3))))
  pointz_keep <- st_disjoint(island_in, sfpointz)
  sfpointz <- sfpointz[unlist(pointz_keep)]
  nnn <- length(sfpointz)
  # create distmat
  distmat1 <- dist_exclude_vec(sfpointz[2:nnn], pt=sfpointz[1], ez=island_in)
  distmat1 <- c(0, distmat1)
  # need to do the first two so that there is a row for the distmat[ii,] line to work
  distcol <- dist_exclude_vec(sfpointz[3:nnn], sfpointz[2], island_in)
  distcol <- c(distmat1[2], 0, distcol)
  distmat1 <- cbind(distmat1, distcol)
  for (ii in 3:(nnn-1)) {
    print(ii)
    distcol <- dist_exclude_vec(sfpointz[(ii + 1):nnn], sfpointz[ii], island_in)
    distcol <- c(distmat1[ii,], 0, distcol)
    distmat1 <- cbind(distmat1, distcol)
  }
  distmat1 <- cbind(distmat1, c(distmat1[nnn,],0))
  write.csv(distmat1, paste0(file_save_dir, "island_distmat1.csv"), row.names=F)
  positionMat <- st_coordinates(sfpointz)
  xxxx <- positionMat[, 1]
  yyyy <- positionMat[, 2]
  GeoDistMat <- floyd(as.matrix(distmat1))
  write.csv(GeoDistMat, paste0(file_save_dir, "island_geodistmat.csv"), row.names=FALSE)
  grid_i <- as.data.frame(cbind(xxxx, yyyy))
  colnames(grid_i) <- c("xx", "yy")
  write.csv(grid_i, paste0(file_save_dir, "location_grid_island.csv"), row.names=FALSE)
}

png(filename=paste0(img_save_dir, "GridIsland.png"))
par(pty="s")
plot(grid_i$xx,grid_i$yy, type='p', pch=4, cex=.2, main='Points with exclusion zone', asp=1, xlab="X coordinate", ylab="Y coordinate")
dev.off()

nsim <- 100
nnn <- dim(grid)[1]

set.seed(3004)
store_state <- .Random.seed
store_state <- as.data.frame(store_state)
colnames(store_state) <- "Start"

if (file.exists(paste0(file_save_dir, "dataset_rows1.csv"))) {
  dataset_rows1 <- read.csv(paste0(file_save_dir, "dataset_rows1.csv"))
} else {
  nsamp1 <- 100
  dataset_rows1 <- matrix(rep(NA, nsim*nsamp1), nrow=nsim)
  store_state <- cbind(store_state, .Random.seed)
  colnames(store_state)[ncol(store_state)] <- paste0("predatasetgen")
  # data generation
  for (ii in 1:nsim) {
    dataset_rows1[ii,] <- sample(nnn, nsamp1)
  }
  write.csv(dataset_rows1, paste0(file_save_dir,"dataset_rows1.csv"), row.names=F)
}

if (file.exists(paste0(file_save_dir, "dataset_rows2.csv"))) {
  dataset_rows2 <- read.csv(paste0(file_save_dir, "dataset_rows2.csv"))
} else {
  nsamp2 <- 500
  dataset_rows2 <- matrix(rep(NA, nsim*nsamp2), nrow=nsim)
  store_state <- cbind(store_state, .Random.seed)
  colnames(store_state)[ncol(store_state)] <- paste0("predatasetgen2")
  # data generation
  for (ii in 1:nsim) {
    dataset_rows2[ii,] <- sample(nnn, nsamp2)
  }
  write.csv(dataset_rows2, paste0(file_save_dir,"dataset_rows2.csv"), row.names=F)
}

if (file.exists(paste0(file_save_dir, "dataset_rows3.csv"))) {
  dataset_rows3 <- read.csv(paste0(file_save_dir, "dataset_rows3.csv"))
} else {
  nsamp3 <- 5000
  dataset_rows3 <- matrix(rep(NA, nsim*nsamp3), nrow=nsim)
  # data generation
  store_state <- cbind(store_state, .Random.seed)
  colnames(store_state)[ncol(store_state)] <- paste0("predatasetgen3")
  for (ii in 1:nsim) {
    dataset_rows3[ii,] <- sample(nnn, nsamp3)
  }
  write.csv(dataset_rows3, paste0(file_save_dir,"dataset_rows3.csv"), row.names=F)
  store_state <- cbind(store_state, .Random.seed)
  colnames(store_state)[ncol(store_state)] <- "postdatasetgen"
  write.csv(store_state, paste0(file_save_dir,"store_state.csv"), row.names=F)
}

nnn_i <- dim(grid_i)[1]

if (file.exists(paste0(file_save_dir, "dataset_rows1_island.csv"))) {
  dataset_rows1 <- read.csv(paste0(file_save_dir, "dataset_rows1_island.csv"))
} else {
  nsamp1 <- 100
  dataset_rows1 <- matrix(rep(NA, nsim*nsamp1), nrow=nsim)
  # data generation
  store_state <- cbind(store_state, .Random.seed)
  colnames(store_state)[ncol(store_state)] <- paste0("predatasetgen1island")
  for (ii in 1:nsim) {
    dataset_rows1[ii,] <- sample(nnn_i, nsamp1)
  }
  write.csv(dataset_rows1, paste0(file_save_dir,"dataset_rows1_island.csv"), row.names=F)
}

if (file.exists(paste0(file_save_dir, "dataset_rows2_island.csv"))) {
  dataset_rows2 <- read.csv(paste0(file_save_dir, "dataset_rows2_island.csv"))
} else {
  nsamp2 <- 500
  dataset_rows2 <- matrix(rep(NA, nsim*nsamp2), nrow=nsim)
  # data generation
  store_state <- cbind(store_state, .Random.seed)
  colnames(store_state)[ncol(store_state)] <- paste0("predatasetgen2island")
  for (ii in 1:nsim) {
    dataset_rows2[ii,] <- sample(nnn_i, nsamp2)
  }
  write.csv(dataset_rows2, paste0(file_save_dir,"dataset_rows2_island.csv"), row.names=F)
}

if (file.exists(paste0(file_save_dir, "dataset_rows3_island.csv"))) {
  dataset_rows3 <- read.csv(paste0(file_save_dir, "dataset_rows3_island.csv"))
} else {
  nsamp3 <- 5000
  dataset_rows3 <- matrix(rep(NA, nsim*nsamp3), nrow=nsim)
  # data generation
  store_state <- cbind(store_state, .Random.seed)
  colnames(store_state)[ncol(store_state)] <- paste0("predatasetgen3island")
  for (ii in 1:nsim) {
    dataset_rows3[ii,] <- sample(nnn_i, nsamp3)
  }
  write.csv(dataset_rows3, paste0(file_save_dir,"dataset_rows3_island.csv"), row.names=F)
  store_state <- cbind(store_state, .Random.seed)
  colnames(store_state)[ncol(store_state)] <- "postdatasetgenisland"
  write.csv(store_state, paste0(file_save_dir,"store_state.csv"), row.names=F)
}


otus.all.records.for.sample <- function(X, sample_id){
  row_names <- row.names(X)
  indeces <- which(startsWith(row_names, paste("X", sample_id, sep = '')))
  return(X[indeces, ])
}

otus.all.records.for.timepoints <- function(otus, timepoint){
  row_names <- row.names(otus)
  indeces <- which(substr(samples, start = 5, stop = 7) %in% timepoint)
  return(otus[indeces, ])
}

otus.normalize <- function(otus, otu_threashold){

  # calculate otu percentages per sample
  otus_sums_by_sample <- rowSums(otus)
  otus_percentages <- otus / otus_sums_by_sample

  # filter otus. if an otu is below threashold for all samples, exclude it
  otus_to_keep <- colSums(otus_percentages > otu_threashold) > 0
  otus_percentages_filtered <- otus_percentages[, otus_to_keep]

  # normalize otus
  otus_norm <- min(rowSums(otus)) * otus_percentages_filtered
  #mode(otus_norm) <- "integer"

  return(otus_norm)
}

otus.load <- function(data.folder, otus.filename, otus.tree.filename){

  # read otus file
  otus <- t(read.delim2(paste(data.folder, otus.filename, sep = ''), header=T, sep="\t", row.names = 1))

  # remove taxonomy row from otu table
  otus.contains.taxonomy.row <- tail(rownames(otus), n=1) == "taxonomy"
  if (otus.contains.taxonomy.row) {otus <- otus[1:nrow(otus)-1,]}

  # make all strings integers
  mode(otus) <- "integer"

  # order otus based on rownames (aka sample names)
  otus <- otus[ order(row.names(otus)), ]

  # read the tree
  otus.tree <- read.tree(paste(data.folder, otus.tree.filename, sep = ''))

  result <- list('otus' = otus, 'otus.tree' = otus.tree)
  return(result)
}


#!/usr/bin/env Rscript

#########################################
# Author: [Ivan Juric](https://github.com/ijuric)
# File: MAPS_regression_and_peak_caller.r
# Source: https://github.com/ijuric/MAPS/blob/master/bin/MAPS/MAPS_regression_and_peak_caller.r
# Source+commit: https://github.com/ijuric/MAPS/blob/e6d5fdee7241b8f9a466cc778be6d0769b984e81/bin/MAPS/MAPS_regression_and_peak_caller.r
# Data: 11/08/2021, commit: e6d5fde
# modified by Jianhong:
# ## 1. set the Rscript environment.
# ## 2. export the COUNT_CUTOFF, RATIO_CUTOFF and FDR parameters
# ## 3. Automatic detect the chromosome names
# ## 4. Handle the error if the input count table is empty
# ## 5. Prefilter the data before fit to vglm to handle the NA error by replace the loglikelihood function.
# ## 6. Handle the error if output is empty
# ## 7. Handle the error if AND or XOR table is empty
# ## 8. clean unused code
# ## 9. fix the indent space
#########################################

## run example:
##  Rscript MAPS_regression_and_peak_caller.r /home/jurici/work/PLACseq/MAPS_pipe/results/mESC_test/ MY_115.5k 5000 1 None pospoisson NA
##
## arguments:
## INFDIR - dir with reg files
## SET - dataset name
## RESOLUTION - resolution (for example 5000 or 10000)
## COUNT_CUTOFF - count cutoff, default 12
## RATIO_CUTOFF - ratio cutoff, default 2.0
## FDR - -log10(fdr) cutoff, default 2
## FILTER - file containing bins that need to be filtered out. Format: two columns "chrom", "bin". "chrom" contains 'chr1','chr2',.. "bin" is bin label
## regresison_type - pospoisson for positive poisson regression, negbinom for negative binomial. default is pospoisson

library(VGAM)
library(MASS)
options(warn=-1)

### constants
chroms = NULL
runs = c(1)
RESOLUTION = NULL

COUNT_CUTOFF = 12
RATIO_CUTOFF = 2.0
GAP = 15000
FDR = 2

REG_TYPE = 'pospoisson'
###

args <- commandArgs(trailingOnly=TRUE)
fltr = data.frame(chr='chrNONE',bin=-1)

if (length(args) < 3 || length(args) > 8) {
    print('Wrong number of arguments. Stopping.')
    print('Arguments needed (in this order): INFDIR, SET, RESOLUTION, COUNT_CUTOFF, RATIO_CUTOFF, FDR, FILTER, regression_type.')
    print('FILTER is optional argument. Omitt it if no filtering required.')
    print(paste('Number of arguments entered:',length(args)))
    print('Arguments entered:')
    print(args)
    quit()
} else {
    print(args)
    INFDIR = args[1]
    SET = args[2]
    RESOLUTION = as.integer(args[3])
    SET <- paste0(SET, ".", ceiling(RESOLUTION/1e3), "k")
    chroms <- dir(INFDIR, "reg_raw.*")
    chroms <- unique(sub("reg_raw\\.(.*?)\\..*$", "\\1", chroms))
    if(length(args)>3){
        COUNT_CUTOFF = as.numeric(args[4])
        RATIO_CUTOFF = as.numeric(args[5])
        FDR = as.numeric(args[6])
        print('filter used (if any):')
        if (length(args) > 6) {
            if (args[7] != 'None') {
                FILTER = args[7]
                fltr = read.table(FILTER,header=T)
                print(fltr)
            } else {
                print('None')
            }
            ## this done so that the script is compatible with previous run_pipeline scripts
            if (length(args) > 7) {
                if (args[8] != 'pospoisson' && args[8] != 'negbinom') {
                    print(paste('wrong regression choice. Your choice:', args[8], '. Avaiable choices: pospoisson or negbinom'),sep = ' ')
                    quit()
                }
                REG_TYPE = args[8]
            }
        } else {
            print('None')
        }
    }
}

## loading data
mm_combined_and = data.frame()
mm_combined_xor = data.frame()
outf_names = c()
for (i in chroms) {
    for (j in c('.and','.xor')) {
        print(paste('loading chromosome ',i,' ',j,sep=''))
        inf_name = paste(INFDIR,'reg_raw.',i,'.',SET,sep='')
        if(file.exists(paste(inf_name,j,sep=''))){
            outf_names = c(outf_names, paste(inf_name,j,'.MAPS2_',REG_TYPE,sep = ''))
            mm = read.table(paste(inf_name,j,sep=''),header=T)
            mm$chr = rep(i, nrow(mm))
            mm = subset( mm, dist > 1) # removing adjacent bins
            mm = subset(mm, !(mm$chr %in% fltr$chr & (mm$bin1_mid %in% fltr$bin | mm$bin2_mid %in% fltr$bin ))) ## filtering out bad bins
            if (j == '.and') {
                mm_combined_and = rbind(mm_combined_and, mm)
            } else if (j == '.xor') {
                mm_combined_xor = rbind(mm_combined_xor, mm)
            }
        }
    }
}

dataset_length_and = length(mm_combined_and$bin1_mid)
dataset_length_xor = length(mm_combined_xor$bin1_mid)
dataset_length = dataset_length_and + dataset_length_xor

## doing statistics and resampling
loglikelihood <- function (mu, y, w, residuals = FALSE, eta, extra = NULL, summation = TRUE) {
    lambda <- eta2theta(eta, "loglink", earg = list(bvalue = NULL, inverse = FALSE, deriv = 0, short = TRUE,
        tag = FALSE))
    if (residuals) {
        stop("loglikelihood residuals not implemented yet")
    }
    else {
        ll.elts <- c(w) * dgaitpois(y, lambda, truncate = 0,
            log = TRUE)
        if (summation) {
            sum(ll.elts[!is.infinite(ll.elts)])
        }
        else {
            ll.elts
        }
    }
}
pospoisson_regression <- function(mm, dataset_length) {
    family <- pospoisson()
    family@loglikelihood <- loglikelihood
    # fit <- vglm(count ~ logl + loggc + logm + logdist + logShortCount, family = pospoisson(), data = mm)
    fit <- vglm(count ~ loggc + logm + logdist + logShortCount, family = family, data = mm)
    mm$expected = fitted(fit)
    mm$p_val = ppois(mm$count, mm$expected, lower.tail = FALSE, log.p = FALSE) / ppois(0, mm$expected, lower.tail = FALSE, log.p = FALSE)
    m1 = mm[ mm$p_val > 1/length(mm$p_val),]
    # fit <- vglm(count ~ logl + loggc + logm + logdist + logShortCount, family = pospoisson(), data = m1)
    fit <- vglm(count ~  loggc + logm + logdist + logShortCount, family = family, data = m1)
    coeff<-round(coef(fit),10)
    # mm$expected2 <- round(exp(coeff[1] + coeff[2]*mm$logl + coeff[3]*mm$loggc + coeff[4]*mm$logm + coeff[5]*mm$logdist + coeff[6]*mm$logShortCount), 10)
    mm$expected2 <- round(exp(coeff[1]  + coeff[2]*mm$loggc + coeff[3]*mm$logm + coeff[4]*mm$logdist + coeff[5]*mm$logShortCount), 10)
    mm$expected2 <- mm$expected2 /(1-exp(-mm$expected2))
    mm$ratio2 <- mm$count / mm$expected2
    mm$p_val_reg2 = ppois(mm$count, mm$expected2, lower.tail = FALSE, log.p = FALSE) / ppois(0, mm$expected2, lower.tail = FALSE, log.p = FALSE)
    mm$p_bonferroni = mm$p_val_reg2 * dataset_length
    mm$fdr <- p.adjust(mm$p_val_reg2, method='fdr')
    return(mm)
}

negbinom_regression <- function(mm, dataset_length) {
    #fit <- glm.nb(count ~ logl + loggc + logm + logdist + logShortCount, data = mm)
    fit <- glm.nb(count ~  loggc + logm + logdist + logShortCount, data = mm)
    mm$expected = fitted(fit)
    sze = fit$theta ##size parameter
    mm$p_val = pnbinom(mm$count, mu = mm$expected, size = sze, lower.tail = FALSE)
    m1 = mm[ mm$p_val > ( 1 / length(mm$p_val)),]
    ## second regression
    # fit <- glm.nb(count ~ logl + loggc + logm + logdist + logShortCount, data = m1)
    fit <- glm.nb(count ~  loggc + logm + logdist + logShortCount, data = m1)
    coeff<-round(fit$coefficients,10)
    sze = fit$theta
    #mm$expected2 <- round(exp(coeff[1] + coeff[2]*mm$logl + coeff[3]*mm$loggc + coeff[4]*mm$logm + coeff[5]*mm$logdist + coeff[6]*mm$logShortCount), 10) ## mu parameter
    mm$expected2 <- round(exp(coeff[1]  + coeff[2]*mm$loggc + coeff[3]*mm$logm + coeff[4]*mm$logdist + coeff[5]*mm$logShortCount), 10) ## mu parameter
    mm$ratio2 <- mm$count / mm$expected2
    mm$p_val_reg2 = pnbinom(mm$count, mu = mm$expected2, size = sze, lower.tail = FALSE)
    mm$p_bonferroni = mm$p_val_reg2 * dataset_length
    mm$fdr <- p.adjust(mm$p_val_reg2, method='fdr')
    return(mm)
}

do_summaries <- function(peaks_and,peaks_xor, peaks, fraction, r) {
    ## no peaks with this fdr
    if (ncol(peaks_and) == 0) {
        peaks_and = data.frame('count' = NA, 'dist'=NA, 'p_val_reg2'=NA, 'fdr'=NA)
    }
    if (ncol(peaks_xor) == 0) {
        peaks_xor = data.frame('count' = NA, 'dist'=NA, 'p_val_reg2'=NA, 'fdr'=NA)
    }
    if (ncol(peaks_and) == 0 & ncol(peaks_xor) == 0) {
        peaks = data.frame('count' = NA, 'dist'=NA, 'p_val_reg2'=NA, 'fdr'=NA)
    }
    summary_one_fdr_val = data.frame('run' = r, 'log10_fdr_cutoff' = fdr_cutoff, 'singleton_fraction' = fraction,
'AND_size'=length(peaks_and$count), 'AND_mean_dist'=mean(peaks_and$dist)*RESOLUTION,'AND_median_dist'=median(peaks_and$dist)*RESOLUTION,
'AND_min_count'=min(peaks_and$count), 'AND_max_pval'=max(peaks_and$p_val_reg2), 'AND_max_fdr'=max(peaks_and$fdr),
'XOR_size'=length(peaks_xor$count), 'XOR_mean_dist'=mean(peaks_xor$dist)*RESOLUTION,'XOR_median_dist'=median(peaks_xor$dist)*RESOLUTION,
'XOR_min_count'=min(peaks_xor$count), 'XOR_max_pval'=max(peaks_xor$p_val_reg2), 'XOR_max_fdr'=max(peaks_xor$fdr),
'size'=length(peaks$count), 'mean_dist'=mean(peaks$dist)*RESOLUTION,'median_dist'=median(peaks$dist)*RESOLUTION,
'min_count'=min(peaks$count), 'max_pval'=max(peaks$p_val_reg2), 'max_fdr'=max(peaks$fdr)
    )
    return(summary_one_fdr_val)
}

label_peaks <- function(df) {
    chroms = unique(df$chr)
    print('chromosomes with potential interactions:')
    print(chroms)
    final = data.frame()
    for (CHR in chroms) {
        y = df[df$chr == CHR,]
        y$p_val_reg2[ y$p_val_reg2 == 0 ] = 1111111
        y$p_val_reg2[ y$p_val_reg2 == 1111111 ] = min(y$p_val_reg2)
        for(i in 1:nrow(y)) {
            z <- y[ abs(y$bin1_mid - y$bin1_mid[i])<=GAP & abs(y$bin2_mid - y$bin2_mid[i])<=GAP,]
            y$CountNei[i] <- nrow(z)
        }
        u <- y[ y$CountNei == 1 ,] # singletons
        v <- y[ y$CountNei >= 2 ,] # peak cluster: sharp peak + broad peak
        out <- NULL
        if(nrow(u)>0) {
            u$label <- 0 # for singletons, assign cluster label 0
            # for singletons, cluster size = 1
            u$NegLog10P <- -log10(u$p_val_reg2 )
            u$ClusterSize <- 1
            out <- rbind(out, u)
        }
        if(nrow(v)>0) {
            v$label <- seq(1,nrow(v),1) # for peak cluster, assign label 1, 2, ..., N
            # for all bin pairs within the neighborhood
            # assign the same cluster label, using the minimal label
            for(i in 1:nrow(v)) {
                w <- v[ abs(v$bin1_mid - v$bin1_mid[i])<=GAP & abs(v$bin2_mid - v$bin2_mid[i])<=GAP ,]
                w.min <- min(w$label)
                w.label <- sort(unique(w$label))
                for(j in 2:length(w.label)) {
                    v$label[ v$label == w.label[j] ] <- w.min
                }
            }
            # step 4: assign consecutive label number
            v.rec <- sort( unique( v$label ) )
            v.rec <- cbind(v.rec, seq(1, length(v.rec), 1))
            for(i in 1:nrow(v)) {
                v$label[i] <- v.rec[ v.rec[,1]==v$label[i] ,2]
            }
            # step 5: calculate cumulative NegLog10P and the cluster size
            v$NegLog10P <- 0
            v$ClusterSize <- 0
            for(i in 1:nrow(v.rec)) {
            # find all bin pairs within the same cluster i
                vtmp <- v[ v$label == i ,]
                v$NegLog10P[ v$label == i ] <- sum( -log10( vtmp$p_val_reg2 ) )
                v$ClusterSize[ v$label == i ] <- nrow(vtmp)
            }
            out <- rbind(out, v)
        }
        final<-rbind(final, out)
    }
    print(dim(final))
    return(final)
}

classify_peaks <- function(final) {

    # only keep unique peak clusters, not bin pairs
    x <- unique( final[ final$label != 0, c('chr', 'label', 'NegLog10P', 'ClusterSize')] )
    if(nrow(x)==0){
        final$ClusterType <- 'Singleton'
        return(final)
    }

    # sort rows by cumulative -log10 P-value
    x <- x[ order(x$NegLog10P) ,]
    y<-sort(x$NegLog10P)
    z<-cbind( seq(1,length(y),1), y )

    # keep a record of z before normalization
    z0 <- z

    z[,1]<-z[,1]/max(z[,1])
    z[,2]<-z[,2]/max(z[,2])

    u<-z
    u[,1] <-  1/sqrt(2)*z[,1] + 1/sqrt(2)*z[,2]
    u[,2] <- -1/sqrt(2)*z[,1] + 1/sqrt(2)*z[,2]

    v<-cbind(u, seq(1,nrow(u),1) )
    RefPoint <- v[ v[,2]==min(v[,2]) , 3] # 1423
    RefValue <- z0[RefPoint,2]

    # define peak cluster type
    final$ClusterType <- '0'
    final$ClusterType[ final$label==0 ] <- 'Singleton'
    final$ClusterType[ final$label>=1 & final$NegLog10P<RefValue  ] <-  'SharpPeak'
    final$ClusterType[ final$label>=1 & final$NegLog10P>=RefValue  ] <- 'BroadPeak'
    #table(final$ClusterType)
    return(final)
}

mx_combined_and = data.frame()
mx_combined_xor = data.frame()
summary_all_runs = data.frame()

singletons_names = paste(chroms,'_0',sep='')
for (r in runs) {
## in case you want to do resampling
## you'd put resampling code here
    name_counter = 1
    for (i in chroms) {
            ## regression
            tryCatch({
                print(paste('run',r,': regression on chromosome',i))
                print(outf_names[name_counter])
                mm = subset(mm_combined_and, chr == i)
                if(nrow(mm)>6){
                    if (REG_TYPE == 'pospoisson') {
                        mm = pospoisson_regression(mm, dataset_length)
                    } else if (REG_TYPE == 'negbinom') {
                        mm = negbinom_regression(mm, dataset_length)
                    }
                    mx_combined_and = rbind(mx_combined_and, mm)
                }
                write.table(mm,outf_names[name_counter],row.names = TRUE,col.names = TRUE,quote=FALSE)
                name_counter = name_counter + 1
                print(outf_names[name_counter])
                mm = subset(mm_combined_xor, chr == i)
                if(nrow(mm)>6){
                    if (REG_TYPE == 'pospoisson') {
                        mm = pospoisson_regression(mm, dataset_length)
                    } else if (REG_TYPE == 'negbinom') {
                        mm = negbinom_regression(mm, dataset_length)
                    }
                    mx_combined_xor = rbind(mx_combined_xor, mm)
                }
                write.table(mm,outf_names[name_counter],row.names = TRUE,col.names = TRUE,quote=FALSE)
            }, error=function(.e){
                message(.e)
            })
            name_counter = name_counter + 1
            ## finding min FDR so I can set appropriate lower boundary for FDR
    }
    ## save QC file
    qc_out = paste(INFDIR,SET,'.maps.qc',sep = '')
    qc_label = c('AND_set','XOR_set')
    qc_val = c(sum(mm_combined_and$count), sum(mm_combined_xor$count))
    qc_name = c('number of sequencing pairs in AND set', 'number of sequencing pairs in XOR set')
    df_qc = data.frame()

    summary_one_run = data.frame()
    singletons = data.frame()
    for (fdr_cutoff in FDR) {
        peaks_and = if(nrow(mx_combined_and)>0) subset(mx_combined_and, count >= COUNT_CUTOFF & ratio2 >= RATIO_CUTOFF & -log10(fdr) > fdr_cutoff) else data.frame()
        peaks_xor = if(nrow(mx_combined_xor)>0) subset(mx_combined_xor, count >= COUNT_CUTOFF & ratio2 >= RATIO_CUTOFF & -log10(fdr) > fdr_cutoff) else data.frame()
        print("finding peaks")
        peaks = rbind(peaks_and, peaks_xor)
        if (dim(peaks)[1] == 0) {
            print(paste('ERROR MAPS_regression_and_peak_caller.r: 0 bin pairs with count >= ',COUNT_CUTOFF,' observed/expected ratio >= ',RATIO_CUTOFF,' and -log10(fdr) > ',fdr_cutoff,sep=''))
            quit()
        }
        peaks = label_peaks(peaks)
        peaks$lab = paste(peaks$chr, peaks$label,sep='_')
        peak_types = classify_peaks(peaks)
        outf_name = paste(INFDIR,SET, '.',fdr_cutoff,'.peaks',sep='')
        write.table(peak_types,outf_name, row.names = FALSE, col.names = TRUE, quote=FALSE)
        print("finding singletons")
        peak_classes = table(peaks$lab)
        n_singletons = sum(peak_classes[names(peak_classes) %in% singletons_names])
        n_singleton_chroms = length(peak_classes[names(peak_classes) %in% singletons_names])

        fraction= n_singletons / (length(peak_classes) + n_singletons - n_singleton_chroms)
        fraction = n_singletons / (length(peak_classes) + n_singletons - n_singleton_chroms)

        singletons_one_run = data.frame('fdr'=fdr_cutoff, 'fraction'=fraction)
        singletons = rbind(singletons, singletons_one_run)
        print(paste(fdr_cutoff,':',singletons))
        summary_one_run = rbind(summary_one_run, do_summaries(peaks_and, peaks_xor, peaks, fraction, r))
    }
    ## find singletons, sharp peaks, broad peaks
    summary_all_runs = rbind(summary_all_runs, summary_one_run)
}
summary_outf_name = paste(INFDIR,'summary.',SET,'.txt',sep='')
write.table(summary_all_runs, summary_outf_name, row.names = FALSE, col.names = TRUE, quote=FALSE)


#Function to read and plot survey residuals
# parameter start.year: first year on X-axis, default=0 (defined from data)
# parameter end.year: end year on X-axis, default=0 (defined from data)
#
# use over.all.max to set the maximum size of the reference buble. A value of 0 scales bubles individually

over.all.max<-6  # use over.all.max different from 0 to set bublesize
over.all.max<-2.5

use.ref.dot<-TRUE

plot.catch.residuals2<-function(dev,nox=1,noy=1,Portrait=T,start.year=0,end.year=0,reverse.colors=F,standardize=F,use.ref.dot=TRUE,add.title=TRUE,over.all.max=1.5,my.species=NA) {

file<-file.path(data.path,'catch_survey_residuals.out')
res<-read.table(file,comment.char = "#",header=T)
res<-subset(res,data=='catch')
if (standardize) res$residual<- res$stand.residual
res[res$residual==-99.9,'residual']<-NA
if (reverse.colors) res$residual<- -res$residual
quarters<-unique(res$Quarter)
max.buble<-max(abs(res$residual),na.rm=TRUE)

Init.function() # get SMS.contol object  including sp.names

nsp<-nsp-first.VPA+1

nox.noy<-nox*noy
plot.no<-0

years<-rep(0,2)
ages<-rep(0,2)
if (is.na(my.species)) my.species<-1:nsp

for (sp in 1:nsp) if (sp %in% my.species) {
  aa<-subset(res,Species.n==first.VPA+sp-1)
  sp.name<-sp.names[sp+first.VPA-1]

  quarters<-unique(aa$Quarter)

  for (q in quarters) {

    print(paste(sp.name,"  quarter:",q))

    nyr<-years[2]-years[1]+1
    nag<-ages[2]-ages[1]+1
    plot.no<-plot.no+1

    if (plot.no%%nox.noy==0 || q==1){
     newplot(dev,nox,noy,Portrait=Portrait,filename=paste("catch",sp,q,plot.no))
      par(mar=c(3,4,3,2))
      if (dev=="wmf") par(mar=c(2,4,2,2))
      plot.no<-0
    }

    bb<-subset(aa,Quarter==q)
    tmp<-tapply(bb$residual,list(age=bb$Age,year=bb$Year),sum,na.rm=T)
    tmp[tmp==-99.99]<-0

    xpos <- as.numeric(dimnames(tmp)[[2]]) # years
    ypos <- as.numeric(dimnames(tmp)[[1]]) #ages
    title<- paste(sp.name," Q:",q,sep="")

    if (length(ypos)==1) {

        tmp2<-tmp
        tmp2[]<-0
        if (ypos[1]>=1) {
          tmp<-rbind(tmp2,tmp,tmp2)
          ypos <- (ypos-1):(ypos+1)
        }
        else if (ypos[1]==0) {
          tmp<-rbind(tmp,tmp2)
          ypos <- ypos:(ypos+1)
        }
    }
     #print(tmp)
    if (over.all.max>0) residplot(tmp,xpos,ypos,main=title,refdot=use.ref.dot,start.year=start.year,end.year=end.year,maxn=over.all.max)
    else residplot(tmp,xpos,ypos,main=title,refdot=use.ref.dot,start.year=start.year,end.year=end.year)

  }
}

cat("Max buble size=",max.buble,'\n')
cat("log(Survey observed CPUE) - log(expected CPUE). 'Red' positive, 'White' negative\n")
if (dev !='screen') cleanup()
}


library(scales)
library(ggplot2)
library(gridExtra)
library(data.table)
library(RColorBrewer)

args <- commandArgs(trailingOnly = TRUE)

file1 <- args[1]
file2 <- args[2]
call <- args[3]
date1 <- args[4]
date2 <- args[5]

# file1 <- 'wsprspots-2016-04-SWLJO20.csv'
# file2 <- 'wsprspots-2016-04-snr-norm-SWLJO20.png'
# call <- 'SWLJO20'
# date1 <- '2016-04-01'
# date2 <- '2016-12-31'

colNames <- c('id', 'epoch', 'rcall',
  'rgrid', 'snr', 'freq', 'call',
  'grid', 'power', 'drift', 'distance',
  'azimuth', 'band', 'version', 'code')
colClasses <- c('numeric', 'numeric', 'character',
  'character', 'numeric', 'numeric', 'character',
  'character', 'numeric', 'numeric', 'numeric',
  'numeric', 'numeric', 'character', 'numeric')

spots <- as.data.table(read.table(file1, header = F, sep = ',', col.names = colNames, colClasses = colClasses))

spots[, time := as.POSIXct(epoch, origin = '1970-01-01')]

freqs <- c(0, 1, 3, 5, 7, 10, 14, 18, 21, 24, 28, 50)
bands <- c('MF', '160m', '80m', '60m', '40m', '30m', '20m', '17m', '15m', '12m', '10m', '6m')

proc1 <- function(x){
  x[
    ,
    list(
      norm = mean(snr/power)
    ),
    list(
      mday = mday(time),
      hour = hour(time),
      band
    )
  ]
}

norm <- proc1(spots)
norm[, time := as.POSIXct(paste0('2016/04/', mday, ' ', hour, ':00:00'))]

subset <- norm[time >= as.POSIXct(paste0(date1, ' 00:00:00')) & time <= as.POSIXct(paste0(date2, ' 23:59:59'))]

p <- lapply(2:7, function(i)
  ggplot(data = subset[band == freqs[i]], aes(x = time, y = norm)) +
    geom_point() +
    scale_x_datetime(breaks = date_breaks('1 day'), minor_breaks = date_breaks('1 hour')) +
    theme(axis.text.x = element_text(angle = 45)) +
    labs(title = bands[i]) + labs(x = '', y = 'SNR over power') +
    theme(legend.position = 'none') + coord_cartesian(ylim = c(-2.0, 1.0))
)

png(file2, width = 1200, height = 600, res = 90)
grid.arrange(arrangeGrob(grobs = p, nrow = 2))
dev.off()


# wahpenayo at gmail dot com
# 2018-01-21
#-----------------------------------------------------------------
if (file.exists('e:/porta/projects/taigabench')) {
  setwd('e:/porta/projects/taigabench')
} else {
  setwd('c:/porta/projects/taigabench')
}
source('src/scripts/r/functions.r')
readr.show_progress <- FALSE
#-----------------------------------------------------------------
dataset <- 'ontime'
problem <- 'l2'
response <- 'arrdelay'
dataf <- ontime.data
dtest <- dataf(test.file(dataset=dataset))
#suffixes <- c('32768','131072','524288','2097152','8388608','33554432')
suffix <- '2097152'
mincounts <- c(7,15,31,63,127,255,511,1023,2047,4095)
#mincounts <- c(1023,511,255)
#-----------------------------------------------------------------
sweep.mincount(
  dataset=dataset,
  problem=problem,
  dataf=dataf,
  dtest=dtest,
  response=response,
  suffix=suffix,
  #trainf=l2.randomForestSRC,
  trainf=l2.h2o.randomForest,
  prefix='h2o',
  mincounts=mincounts)
#-----------------------------------------------------------------


#core-level forecast to NEON.
#once data have been aggregated at core-plot-site level, we need to fill in missing values and uncertainties hierarchically.
#this product is then shipped to the forecast, which draws missing data.
#1. hierarchically execute your site-level forecast, it should basically be the same, but at the core level.
#2. No need to update yet, Just get hierarchical means.
#3. You in principle can use this as your plot and site level forecast? Once you figure out hierarchical ddirch means.
#4. The relEM problem- you solve this in forecast because missing data happens outside of JAGS.
#5. Once you get this done, hope ddirch aggregation is solved. If not, ask Mike. THen we can validate.
#6. Replication *should* be quick on the bacteria side. Clustered, binned taxonomically.
#7. Fit prior, then send prior through core-level forecast, aggregate plot and site level using something.
#8. NOTE: CPER, STER and WOOD are plains. You need to tell the filling that there are no ectomycorrhizal trees here.
#clearn environment, loads paths.
rm(list=ls())
source('paths.r')
source('NEFI_functions/precision_matrix_match.r')

#set output path.
output.path <- hierarch_filled.path

#specify sites with zero ectomycorrhizal trees (plains sites)
no.ecm <- c('CPER','STER','WOOD')

#load prior model fit- model fit at site level.
mod <- readRDS(ted_ITS.prior_fg_JAGSfit)
preds <- mod$all.preds$species_parameter_output$other$predictor
if('relEM' %in% preds){preds <- c(as.character(preds),'b.relEM')}
#add plot, site and sampleID to preds.
keys <- c('sampleID','plotID','siteID')
check <- c(as.character(preds),keys)
check_sd <-c(paste0(as.character(preds), '_sd'), keys)

#load NEON data.
core_obs  <- readRDS( core_obs.path)
core_core <- readRDS(core_core.path)
core_plot <- readRDS(core_plot.path)
core_site <- readRDS(core_site.path)
core_glob <- readRDS(core_glob.path)
plot_plot <- readRDS(plot_plot.path)
plot_site <- readRDS(plot_site.path)
plot_glob <- readRDS(plot_glob.path)
site_site <- readRDS(site_site.path)
site_glob <- readRDS(site_glob.path)

#cores, plots and sites that need to be present.
needed <- list()
needed[[1]] <- as.character(unique(core_obs$geneticSampleID))
needed[[2]] <- as.character(unique(core_obs$plotID))
needed[[3]] <- as.character(unique(core_obs$siteID))
names(needed) <- c('geneticSampleID','plotID','siteID')

#all y-cores present in core_core geneticSampleIDs?
sum(unique(core_obs$geneticSampleID) %in% core_core$geneticSampleID) == length(unique(core_obs$geneticSampleID))
nrow(core_obs) == nrow(core_core)
#all plots in core_core present in core_plot?
sum(unique(core_core$plotID) %in% core_plot$plotID) == length(unique(core_core$plotID))
#all sites in core_core present in core_site?
sum(unique(core_core$siteID) %in% core_site$siteID) == length(unique(core_core$siteID))
#all y-plots present in plot_plot plotIDs? FALSE
sum(unique(core_obs$plotID) %in% plot_plot$plotID) == length(unique(core_obs$plotID))
#all sites in plot_plot present in plot_site?
sum(unique(plot_plot$siteID) %in% plot_site$siteID) == length(unique(plot_plot$siteID))
#all y-sites present in site_site siteIDs?
sum(unique(core_obs$siteID) %in% site_site$siteID) == length(unique(core_obs$siteID))

#Get core-plot-site indexing variables.
sites <- site_site$siteID
plots <- plot_plot$plotID
cores <- core_core$sampleID
plot.site <- substring(plots,1,4)
core.plot <- substring(cores,1,8)
core.site <- substring(cores,1,4)

#subset based on predictors actually in the model.
core_site_mu <- core_site[,colnames(core_site) %in% (check   )]
core_site_sd <- core_site[,colnames(core_site) %in% (check_sd)]
core_site_sd <- precision_matrix_match(core_site_mu,core_site_sd)
core_plot_mu <- core_plot[,colnames(core_plot) %in% (check   )]
core_plot_sd <- core_plot[,colnames(core_plot) %in% (check_sd)]
core_plot_sd <- precision_matrix_match(core_plot_mu,core_plot_sd)
core_core_mu <- core_core[,colnames(core_core) %in% (check   )]
core_core_sd <- core_core[,colnames(core_core) %in% (check_sd)]
core_core_sd <- precision_matrix_match(core_core_mu,core_core_sd)
plot_site_mu <- plot_site[,colnames(plot_site) %in% (check   )]
plot_site_sd <- plot_site[,colnames(plot_site) %in% (check_sd)]
plot_site_sd <- precision_matrix_match(plot_site_mu,plot_site_sd)
plot_plot_mu <- plot_plot[,colnames(plot_plot) %in% (check   )]
plot_plot_sd <- plot_plot[,colnames(plot_plot) %in% (check_sd)]
plot_plot_sd <- precision_matrix_match(plot_plot_mu,plot_plot_sd)
site_site_mu <- site_site[,colnames(site_site) %in% (check   )]
site_site_sd <- site_site[,colnames(site_site) %in% (check_sd)]
site_site_sd <- precision_matrix_match(site_site_mu,site_site_sd)

#Step 1. Missing data model. Assign missing means and sd hierarchically as necessary
#core_site
for(j in 1:ncol(core_site_mu)){
  name <- colnames(core_site_mu)[j]
  if(name %in% preds){
    core_site_mu[is.na(core_site_mu[,j]),j] <- core_glob[core_glob$pred == name,'Mean']
    core_site_sd[is.na(core_site_sd[,j]),j] <- core_glob[core_glob$pred == name,'SD'  ]
  }
}
#core_plot
for(j in 1:ncol(core_plot_mu)){
  name <- colnames(core_plot_mu)[j]
  if(name %in% preds){
    for(i in 1:nrow(core_plot_mu)){
      c.site <- core_plot_mu$siteID[i]
      if(is.na(core_plot_mu[i,j])){
        core_plot_mu[i,j] <- core_site_mu[core_site_mu$siteID == c.site,name]
        core_plot_sd[i,j] <- core_site_sd[core_site_sd$siteID == c.site,name]
      }
    }
  }
}
#core_core
for(j in 1:ncol(core_core_mu)){
  name <- colnames(core_core_mu)[j]
  if(name %in% preds){
    for(i in 1:nrow(core_core_mu)){
      c.plot <- core_core_mu$plotID[i]
      if(is.na(core_core_mu[i,j])){
        core_core_mu[i,j] <- core_plot_mu[core_plot_mu$plotID == c.plot,name]
        core_core_sd[i,j] <- core_plot_sd[core_plot_sd$plotID == c.plot,name]
      }
    }
  }
}
#plot_site
for(j in 1:ncol(plot_site_mu)){
  name <- colnames(plot_site_mu)[j]
  if(name %in% preds){
    plot_site_mu[is.na(plot_site_mu[,j]),j] <- plot_glob[plot_glob$pred == name,'Mean']
    plot_site_sd[is.na(plot_site_sd[,j]),j] <- plot_glob[plot_glob$pred == name,'SD'  ]
  }
  if(name == 'b.relEM'){
    plot_site_mu[plot_site_mu$siteID %in% no.ecm,j] <- -10
    plot_site_sd[plot_site_sd$siteID %in% no.ecm,j] <- 0.01
  }
}
#plot_plot
for(j in 1:ncol(plot_plot_mu)){
  name <- colnames(plot_plot_mu)[j]
  if(name %in% preds){
    for(i in 1:nrow(plot_plot_mu)){
      c.site <- plot_plot_mu$siteID[i]
      if(is.na(plot_plot_mu[i,j]) & name %in% colnames(plot_site_mu)){
        plot_plot_mu[i,j] <- plot_site_mu[plot_site_mu$siteID == c.site,name]
        plot_plot_sd[i,j] <- plot_site_sd[plot_site_sd$siteID == c.site,name]
      }
    }
  }
  if(name == 'b.relEM'){
    plot_plot_mu[plot_plot_mu$siteID %in% no.ecm, j] < -10
    plot_plot_sd[plot_plot_sd$siteID %in% no.ecm, j] <- 0.01
  }
}

#site_site
site_site_mu <- site_site_mu[site_site_mu$siteID %in% core_obs$site,]
site_site_sd <- site_site_sd[site_site_sd$siteID %in% core_obs$site,]

output.list <- list(core_obs,
                    core_core_mu,core_core_sd,
                    core_plot_mu,core_plot_sd,
                    core_site_mu,core_site_sd,
                    plot_plot_mu,plot_plot_sd,
                    plot_site_mu,plot_site_sd,
                    site_site_mu,site_site_sd)
names(output.list) <- c('core.obs',
                        'core.core.mu','core.core.sd',
                        'core.plot.mu','core.plot.sd',
                        'core.site.mu','core.site.sd',
                        'plot.plot.mu','plot.plot.sd',
                        'plot.site.mu','plot.site.sd',
                        'site.site.mu','site.site.sd')
#save output.
saveRDS(output.list, output.path)


setwd("/home/sugon/code/R/ClassicalGroupmean/files/")
library(ANTsR)
library(fslr)
library(parallelDist)

avg_1<-0
chosen_num<-93
iter <<- 10
sum<-0
batch_size<-20
Sys.setenv(ITK_GLOBAL_DEFAULT_NUMBER_OF_THREADS = 64)

flowSigma_start <- 3.5
# totalSigma_start <- 5
flowSigma_end <- 1
# totalSigma_end <- 0

for(i in seq(batch_size))
{
  if(i != chosen_num)
  {
    print(paste0("Linear reg ", i))
    img <- flirt(infile = paste("/run/media/sugon/4t/T1Img/temp/ext", i, sep = ""), reffile = paste("/run/media/sugon/4t/T1Img/temp/ext", chosen_num, sep = ""), dof = 12, outfile = paste("0-", i, sep = ""), retimg = T)
    sum<-sum+img@.Data
  }
  else
  {
    img <- antsImageRead(paste0("/run/media/sugon/4t/T1Img/temp/ext", chosen_num, ".nii.gz"))
    antsImageWrite(img, paste0("0-", i, ".nii.gz"))
  }
}
img <- antsImageRead("0-1.nii.gz")
antsImageWrite(as.antsImage(sum/batch_size, direction = antsGetDirection(img)), "avg0.nii.gz")

for(i in seq(batch_size))
{
  img <- antsImageRead(paste0("/run/media/sugon/4t/T1Img/temp/ext", i, ".nii.gz"))
  sum<-sum+img[]
}
a <- 1/11081*3-6

flowSigma_current <- c(a, 3*a, 6*a, 10*a, 15*a, 21*a, 28*a, 36*a, 45*a, 55*a)

  sum <- 0
  for(j in seq(iter))
  {
    sum <- 0
    for(i in seq(batch_size))
    {
      flowSigma_current <- -2/81*iter^2+4/81*iter+237/81
      # flowSigma_current <- 2/(iter-1)
      # flowSigma_current <- 17-(iter-1)^2
      # flowSigma_current <- getParam(ceiling(), iter, flowSigma_end, flowSigma_start)
      # totalSigma_current <- getParam(%%2, iter, totalSigma_end, totalSigma_start)
      mov <- antsImageRead(paste("/run/media/sugon/4t/T1Img/temp/ext", i, ".nii.gz", sep = ""))
      # mov <- antsImageRead(paste0(j-1, "-", i, ".nii.gz"))
      fix <- antsImageRead(paste0("avg", j-1, ".nii.gz"))
      print(paste0("Nonlinear reg ", j, " - ", i))
      img <- antsRegistration(moving = mov, fixed = fix, typeofTransform = "SyNOnly", flowSigma = flowSigma_current)
      # img <- antsRegistration(moving = mov, fixed = fix, typeofTransform = "SyNOnly", flowSigma = flowSigma_current, totalSigma = totalSigma_current)
      antsImageWrite(img$warpedmovout, paste(j, "-", i, ".nii.gz", sep = ""))
      sum<-sum+img$warpedmovout[]
    }
    avg_0<-sum/batch_size
    print(paste("Difference = ", sum(avg_0 - avg_1)), sep = "")
    antsImageWrite(as.antsImage(avg_0, direction = antsGetDirection(img$warpedmovout)), paste0("avg", j, ".nii.gz"))
    avg_1<-avg_0
  }


#MODE <- '24hrs'
library(doParallel)
library(foreach)
registerDoParallel(cores=32)
#list.mode.results <- foreach(MODE=c('24hrs', '48hrs', '72hrs', '24hrs~72hrs', '7days', '30days')) %dopar% {
list.mode.results <- foreach(MODE=c('48hrs', '7days', 'Bounceback')) %dopar% {
#for(MODE in c('24hrs', '48hrs', '72hrs', '24hrs~72hrs', '7days', '30days', 'bounceback')) {
Prefix <- './FOLDS_PROBS/IsReadmitted_'

library(glmnet)
library(xgboost)
library(pROC)
source('./xgboostWrapper.R')
source('./catToBin.R')

list.predglm <- list()
list.predxgb <- list()
list.rocglm <- list()
list.rocxgb <- list()
list.xgbparam <- list()
list.glm <- list()
list.xgb <- list()
list.featurenames <- list()
list.labels <- list()

list.train.in <- list()
list.test.in <- list()
list.train.out <- list()
list.test.out <- list()

for(f in 1:5) {
  cat(paste('fold:', f, '\n'))
  train.data <- read.csv(paste(Prefix, MODE, '/fold_', f, '/training.csv', sep=''))
  test.data <- read.csv(paste(Prefix, MODE, '/fold_', f, '/testing.csv', sep=''))

  cols.remove <- which(grepl('HADM_ID', colnames(train.data)) |
                         grepl('ICUSTAY_ID', colnames(train.data)) |
                         grepl('INTIME', colnames(train.data)) |
                         grepl('OUTTIME', colnames(train.data)) |
                         grepl('SUBJECT_ID', colnames(train.data)) |
                         grepl('INSURANCE', colnames(train.data)) |
                         grepl('RELIGION', colnames(train.data)) |
                         grepl('LANGUAGE', colnames(train.data)) |
                         grepl('MARITAL_STATUS', colnames(train.data)))

  train.data <- train.data[,-cols.remove]
  test.data <- test.data[,-cols.remove]
  cols.out <- which(grepl('IsReadmitted_', colnames(train.data)))

  train.out <- train.data[,cols.out]
  test.out <- test.data[,cols.out]

  train.in <- train.data[,-cols.out]
  test.in <- test.data[,-cols.out]

  first.care <- catToBin(train.in$FIRST_CAREUNIT)
  colnames(first.care) <- paste('FIRST_CARE_', colnames(first.care), sep='')
  first.care.test <- catToBin(test.in$FIRST_CAREUNIT)
  colnames(first.care.test) <- paste('FIRST_CARE_', colnames(first.care.test), sep='')

  train.in <- cbind(train.in, first.care)
  test.in <- cbind(test.in, first.care.test)

  train.in$FIRST_CAREUNIT <- NULL
  test.in$FIRST_CAREUNIT <- NULL

  adm.type <- catToBin(train.in$ADMISSION_TYPE)
  colnames(adm.type) <- paste('ADMISSION_TYPE_', colnames(adm.type), sep='')
  adm.type.test <- catToBin(test.in$ADMISSION_TYPE)
  colnames(adm.type.test) <- paste('ADMISSION_TYPE', colnames(adm.type.test), sep='')

  train.in <- cbind(train.in, adm.type)
  test.in <- cbind(test.in, adm.type.test)

  train.in$ADMISSION_TYPE <- NULL
  test.in$ADMISSION_TYPE <- NULL

  ethn <- catToBin(train.in$ETHNICITY)
  colnames(ethn) <- paste('ETHNICITY_', colnames(ethn), sep='')
  ethn.test <- catToBin(test.in$ETHNICITY)
  colnames(ethn.test) <- paste('ETHNICITY_', colnames(ethn.test), sep='')

  #Rebuild Ethnicity into groups
  # ethn.nativeamerican <- rowSums(ethn[,c(1,2)])
  # ethn.asian <- rowSums(ethn[,c(3,4,5,6,7,8,9,10,11,12)])
  # ethn.black <- rowSums(ethn[,c(13,14,15,16,17)])
  # ethn.hispanic <- rowSums(ethn[,seq(18,27,1)])
  # ethn.white <- rowSums(ethn[,c(33,34,37,38,39,40,41)])
  # ethn.other <- rowSums(ethn[,c(28,29,30,31,32,35,36)])
  #
  # ethn.nativeamerican[which(ethn.nativeamerican > 1)] <- 1
  # ethn.asian[which(ethn.asian > 1)] <- 1
  # ethn.black[which(ethn.black > 1)] <- 1
  # ethn.hispanic[which(ethn.hispanic > 1)] <- 1
  # ethn.white[which(ethn.white > 1)] <- 1
  # ethn.other[which(ethn.other > 1)] <- 1
  #
  # ethn.nativeamerican.test <- rowSums(ethn.test[,c(1,2)])
  # ethn.asian.test<- rowSums(ethn.test[,c(3,4,5,6,7,8,9,10,11,12)])
  # ethn.black.test <- rowSums(ethn.test[,c(13,14,15,16,17)])
  # ethn.hispanic.test <- rowSums(ethn.test[,seq(18,27,1)])
  # ethn.white.test <- rowSums(ethn.test[,c(33,34,37,38,39,40,41)])
  # ethn.other.test <- rowSums(ethn.test[,c(28,29,30,31,32,35,36)])
  #
  # ethn.nativeamerican.test[which(ethn.nativeamerican.test > 1)] <- 1
  # ethn.asian.test[which(ethn.asian.test > 1)] <- 1
  # ethn.black.test[which(ethn.black.test > 1)] <- 1
  # ethn.hispanic.test[which(ethn.hispanic.test > 1)] <- 1
  # ethn.white.test[which(ethn.white.test > 1)] <- 1
  # ethn.other.test[which(ethn.other.test > 1)] <- 1
  #
  # train.in <- cbind(train.in, ethn.nativeamerican, ethn.asian, ethn.black, ethn.hispanic, ethn.white, ethn.other)
  # test.in <- cbind(test.in, ethn.nativeamerican.test, ethn.asian.test, ethn.black.test, ethn.hispanic.test, ethn.white.test, ethn.other.test)
  #
  #
  train.in$ETHNICITY <- NULL
  test.in$ETHNICITY <- NULL

  train.in <- data.matrix(train.in)
  test.in <- data.matrix(test.in)

  col.means <- colMeans(train.in ,na.rm=TRUE)
  for(j in 1:dim(train.in)[2]) {
    if(any(is.na(train.in[,j]))) {
      train.in[,j][which(is.na(train.in[,j]))] <- col.means[j]
    }
  }

  for(j in 1:dim(test.in)[2]) {
    if(any(is.na(test.in[,j]))) {
      test.in[,j][which(is.na(test.in[,j]))] <- col.means[j]
    }
  }

  if(MODE == '24hrs') {
    train.labels <- train.out$IsReadmitted_24hrs
    test.labels <- test.out$IsReadmitted_24hrs
  } else if(MODE== '48hrs') {
    train.labels <- train.out$IsReadmitted_48hrs
    test.labels <- test.out$IsReadmitted_48hrs
  } else if(MODE == '72hrs') {
    train.labels <- train.out$IsReadmitted_72hrs
    test.labels <- test.out$IsReadmitted_72hrs
  } else if(MODE == '24hrs~72hrs') {
    train.labels <- train.out$IsReadmitted_24hrs.72hrs
    test.labels <- test.out$IsReadmitted_24hrs.72hrs
  } else if(MODE == '7days') {
    train.labels <- train.out$IsReadmitted_7days
    test.labels <- test.out$IsReadmitted_7days
  } else if(MODE == '30days') {
    train.labels <- train.out$IsReadmitted_30days
    test.labels <- test.out$IsReadmitted_30days
  } else {
    train.labels <- train.out$IsReadmitted_Bounceback
    test.labels <- test.out$IsReadmitted_Bounceback
  }

  w.samples <- rep(1, dim(train.in)[1])
  w.samples[which(train.labels == 1)] <- round((length(train.labels) - sum(train.labels))/sum(train.labels))
    #round((length(train.labels)-sum(train.labels))/sum(train.labels))
  library(doParallel)
  library(foreach)
  registerDoParallel(cores=32)
  source('fMeasure.R')
  cat(paste('fold:', f, ' GLM\n'))
  glm.model <- cv.glmnet(x=train.in,y=as.factor(train.labels), family='binomial',
                         type.measure='auc', parallel=TRUE, weights=w.samples)
  glm.pred <- predict(glm.model, test.in, type='response')
  glm.roc <- roc(as.numeric(test.labels), as.numeric(glm.pred))
  glm.f <- allROC_par(as.numeric(glm.pred), as.numeric(test.labels))[[1]]
  cat(paste('fold:', f, ' GLM ROC:', glm.roc$auc, '\n'))

  xgb.params <- xgcv_par(train.in, train.labels, seq(1,6,1), c(0.1), c(50,100,150, 200), FALSE, nfolds = 5, ncores=16, nthread=32, linux=TRUE)

  xgb.model <- xgboost(train.in, as.numeric(train.labels), verbose=0, nrounds=xgb.params[3],
                       eta=0.1, max.depth=xgb.params[2],  objective='binary:logistic',nthread=32,
                       save_period=NULL, save_name=NULL)
  xgb.pred <- predict(xgb.model, test.in)
  xgb.roc <- roc(as.numeric(test.labels), as.numeric(xgb.pred))
  xgb.f <- allROC_par(as.numeric(xgb.pred), as.numeric(test.labels))[[1]]
  cat(paste('fold:', f, ' XGB:', xgb.roc$auc, '\n'))

  list.featurenames[[f]] <- colnames(train.in)
  list.predglm[[f]] <- glm.pred
  list.predxgb[[f]] <- xgb.pred
  list.rocglm[[f]] <- glm.roc
  list.rocxgb[[f]] <- xgb.roc
  list.xgbparam[[f]] <- xgb.params
  list.glm[[f]] <- glm.model
  list.xgb[[f]] <- xgb.model
  list.labels[[f]] <- list(train.labels, test.labels)

  list.train.in[[f]] <- train.in
  list.test.in[[f]] <- test.in
  list.train.out[[f]] <- train.out
  list.test.out[[f]] <- test.out
}

save('list.predglm',
     'list.predxgb',
     'list.rocglm',
     'list.rocxgb',
     'list.xgbparam',
     'list.glm',
     'list.xgb',
     'list.featurenames',
     'list.labels',

     'list.train.in',
     'list.test.in',
     'list.train.out',
     'list.test.out',

     file=paste('./results/aucs_FEB2018_', MODE,'_data.RData', sep=''))

}


# movies is already pre-loaded

# Create a boxplot of the runtime variable
boxplot(movies$runtime)

# Subset the dateframe and plot it entirely
plot(data.frame(movies$rating,movies$votes,movies$runtime))

# Create a pie chart of the table of counts of the genres
pie(table(movies$genre))


# Calculate codon usage and other statistics for gene sets.
# For the terminology used in this module, please see
#
#   Konrad Rudolph, “Investigating the link between tRNA and mRNA abundance in mammals”,
#   2015 (PhD thesis). Chapter 1.6 “Quantifying codon usage and anticodon abundance”
#

.bios = modules::import_package('Biostrings')
modules::import_package('dplyr', attach = TRUE)
tidyr = modules::import_package('tidyr')

#' The genetic code
genetic_code = data.frame(AA = .bios$GENETIC_CODE) %>%
    add_rownames('Codon') %>%
    tbl_df()

#' Vector of stop codons
stop_codons = filter(genetic_code, AA == '*')$Codon

#' Calculate codon usage for gene set
#'
#' @param genes the DNA sequences (see \link{Details})
#' @return Tidy table of per-gene codon usage.
#' @details \code{genes} is either a named character vector or a
#' \code{\link{data.frame}} of \code{Gene}–\code{Sequence} pairs, or a
#' \code{\link[Biostrings]{DNAStringSet}}.
cu = function (genes) UseMethod('cu')

cu.default = function (genes) {
    stopifnot(is.character(genes))
    cu(.bios$DNAStringSet(genes))
}

cu.data.frame = function (genes)
    cu(.bios$DNAStringSet(setNames(genes$Sequence, genes$Gene)))

cu.DNAStringSet = function (genes)
    .bios$trinucleotideFrequency(genes, 3) %>%
    as.data.frame() %>%
    mutate(Gene = names(genes)) %>%
    tidyr$gather(Codon, CU, -Gene) %>%
    mutate(Codon = as.character(Codon)) %>%
    filter(! Codon %in% stop_codons) %>%
    tbl_df() %>%
    `class<-`(c('codon_usage$cu', class(.)))

#' Calculate relative codon usage for gene set
#'
#' @param x gene set (see \link{Details})
#' @return Tidy table of per-gene relative codon usage.
#' @details The accepted input corresponds to either the output of
#' \code{\link{cu}}, or any input that function accepts.
rcu = function (x, column = Gene)
    rcu_(x, deparse(substitute(column)))

rcu_ = function (x, column = 'Gene') UseMethod('rcu_')

`rcu_.codon_usage$cu` = function (x, column = 'Gene')
    inner_join(x, genetic_code, by = 'Codon') %>%
    group_by_(.dots = c(column, 'AA')) %>%
    mutate(RCU = CU / sum(CU)) %>%
    mutate(RCU = ifelse(is.nan(RCU), 0, RCU)) %>%
    ungroup() %>%
    `class<-`(c('codon_usage$rcu', class(.)))

rcu_.default = function (x, column = 'Gene')
    rcu_(cu(x), column)

#' Calculate adaptation between codons and tRNA
#'
#' Calculate the correlation between codon usage and anticodon abundance as a
#' measure of goodness of adaptation of the anticodon supply to the codon
#' demand.
#'
#' @param cu codon usage as given by \code{cu}
#' @param aa anticodon abundance, with \code{Codon} column
#' @param cds coding sequences
#' @note \code{raa} is equivalent to \code{rcu} for the abundance of anticodons.
#' The function expects this to be given with reverse complemented anticodons,
#' so that the format of the data is equivalent for \code{cu} and \code{aa}.
adaptation = function (cu, aa, cds, method = adaptation_no_wobble)
    method(cu, aa, cds)

#' \code{adaptation_no_wobble} computes a simple codon–anticodon correlation,
#' ignoring wobble base pairing.
#' @rdname adaptation
adaptation_no_wobble = function (cu, aa, cds)
    cu %>%
    group_by(Codon, add = TRUE) %>%
    summarize(CU = sum(CU)) %>%
    inner_join(aa, by = 'Codon') %>%
    mutate(CU = CU / sum(CU),
           AA = AA / sum(AA)) %>%
    summarize(Cor = cor(CU, AA, method = 'spearman')) %>%
    .$Cor

wobble_pairing = import('./wobble_pairing')

#' \code{adaptation_wobble} computes a codon–anticodon correlation while
#' accounting for wobble base pairing.
adaptation_wobble = function (cu, aa, cds)
    cu %>% do(Cor = wobble_pairing$adaptation(., aa)) %>% .$Cor %>% unlist()

# Calculate outside function for speed — `adaptation` is called very frequently.
coding_codons = setdiff(genetic_code$Codon, stop_codons)
tai = import('./tai')

#' \code{adaptation_tai} computes the tRNA adaptation index.
#' @param s tAI s-values
#' @rdname adaptation
adaptation_tai = function (cu, aa, cds, s = tai$naive_s) {
    lengths = setNames(cds$Length, cds$Gene)[unique(cu$Gene)]
    cu = tidyr$spread(cu, Codon, CU) %>% select(one_of(coding_codons))
    aa = setNames(aa$AA, aa$Codon)
    tai$tai(cu, tai$w(aa, s), lengths)
}

#' Normalize codon usage
#'
#' Normalizing codon usage ensures that the codon usage sums to 1, in other
#' words, calculate \code{n[i] = x[i] / sum(x)}.
#' @param x codon usage in tidy data format
#' @return The normalized codon usage in tidy data format.
norm = function (x) UseMethod('norm')

`norm.codon_usage$cu` = function (x)
    mutate(x, CU = CU / sum(CU)) %>%
    `class<-`(c('codon_usage$cu', class(.)))

`norm.codon_usage$rcu` = function (x) {
    warning('Normalizing RCU makes no sense, skipped.')
    x
}

#' Reverse complement a set of sequences
#'
#' @param seq a character vector
#' @return A character vector of the reverse complemented sequences.
revcomp = function (seq)
    as.character(.bios$reverseComplement(.bios$DNAStringSet(seq)))


data <- read.csv('../data/MXvideos_cc50_202101.csv')

# Eliminar columnas con ID vacio y categoryId
data <- data[!is.na(data$video_id),]
data <- data[!is.na(data$category_id),]
data <- data[!is.na(data$views),]

empty_data <- is.na(data)
summary(empty_data)
# to clean = likes, dislikes, comment_count
data$likes.mean <- ifelse(is.na(data$likes), mean(data$likes, na.rm = TRUE), data$likes)
data$dislikes.mean <- ifelse(is.na(data$dislikes), mean(data$dislikes, na.rm = TRUE), data$dislikes)
data$comment_count.mean <- ifelse(is.na(data$comment_count), mean(data$comment_count, na.rm = TRUE), data$comment_count)
summary(is.na(data))

View(data)

write.csv(data,"../data/cleaned_MXvideos_cc50_202101.csv", row.names = FALSE)


##
## Analysis code for Thomas et al. (2015): Saami reindeer herders cooperate with social group members and genetic kin
##
## This modifies the `standardize` function in the package `arm` to work with GEE models.
##
## Author: Matthew Gwynfryn Thomas
##
##      {------- email --------}
##         {-- twitter --}
##      mgt@matthewgthomas.co.uk
##          {------ web -------}
##
##
## Copyright (c) 2015 Matthew Gwynfryn Thomas
##
## This program is free software; you can redistribute it and/or modify
## it under the terms of the GNU General Public License as published by
## the Free Software Foundation; either version 2 of the License, or
## (at your option) any later version.
##
## This program is distributed in the hope that it will be useful,
## but WITHOUT ANY WARRANTY; without even the implied warranty of
## MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
## GNU General Public License for more details.
##
## You should have received a copy of the GNU General Public License along
## with this program; if not, write to the Free Software Foundation, Inc.,
## 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
##
standardize.default <- function(call, unchanged=NULL,
                                standardize.y=FALSE, binary.inputs="center"){
  form <- call$formula
  varnames <- all.vars (form)
  n.vars <- length (varnames)
  #
  # Decide which variables will be unchanged
  #
  transform <- rep ("leave.alone", n.vars)
  if (standardize.y) {
    transform[1] <- "full"
  }
  for (i in 2:n.vars){
    v <- varnames[i]
    if (is.null(call$data)) {
      thedata <- get(v)
    }
    else {
      thedata <- get(as.character(call$data))[[v]]
    }
    if (is.na(match(v,unchanged))){
      num.categories <- length (unique(thedata[!is.na(thedata)]))
      if (num.categories==2){
        transform[i] <- binary.inputs
      }
      else if (num.categories>2 & is.numeric(thedata)){
        transform[i] <- "full"
      }
    }
  }
  #
  # New variable names:
  #   prefix with "c." if centered or "z." if centered and scaled
  #
  varnames.new <- ifelse (transform=="leave.alone", varnames,
                          ifelse (transform=="full", paste ("z", varnames, sep="."),
                                  paste ("c", varnames, sep=".")))
  transformed.variables <- (1:n.vars)[transform!="leave.alone"]

  #Define the new variables
  if (is.null(call$data)) {
    for (i in transformed.variables) {
      assign(varnames.new[i], rescale(get(varnames[i]), binary.inputs))
    }
  }
  else {
    newvars <- NULL
    for (i in transformed.variables) {
      assign(varnames.new[i], rescale(get(as.character(call$data))[[varnames[i]]],
                                      binary.inputs))
      newvars <- cbind(newvars, get(varnames.new[i]))
    }
    assign(as.character(call$data), cbind(get(as.character(call$data)), newvars))
  }

  # Now call the regression with the new variables

  call.new <- call
  L <- sapply (as.list (varnames.new), as.name)
  names(L) <- varnames
  call.new$formula <- do.call (substitute, list (form, L))
  formula <- as.character (call.new$formula)
  if (length(formula)!=3) stop ("formula does not have three components")
  formula <- paste (formula[2],formula[1],formula[3])
  formula <- gsub ("factor(z.", "factor(", formula, fixed=TRUE)
  formula <- gsub ("factor(c.", "factor(", formula, fixed=TRUE)
  call.new$formula <- as.formula (formula)
  return (eval (call.new))
}

standardize.gee = function(object, unchanged=NULL,
                   standardize.y=FALSE, binary.inputs="center")
          {
            call <- object$call
            out <- standardize.default(call=call, unchanged=unchanged,
                                       standardize.y=standardize.y, binary.inputs=binary.inputs)
            return(out)
          }


#loading data

DIFSLIKA <- vector("list", 1000)

for (i in 1:1000) {
  str_path = paste0("Desktop/1000/input", i, "/DIFSLIKA.TXT")
  temp_data_frame <- read.table(str_path, quote = "\"", comment.char = "")
  DIFSLIKA[[i]] <- temp_data_frame
}

#loading input parameters

INPUT <- array(, dim = c(1000, 2))

for (i in 1:1000) {
  str_path = paste0("Desktop/1000/input", i, "/INPUT.TXT")
  res <- readLines(str_path)
  INPUT[i, 1] <- as.double(res[1])
  INPUT[i, 2] <- as.double(res[2])
}

# finding max luminance

max_lum <- max(DIFSLIKA[[1]]$V3)

for (i in 2:1000) {
  max_cur <- max(DIFSLIKA[[i]]$V3)
  if (max_cur > max_lum)
    max_lum <- max_cur
}

# normalizing

for (i in 1:1000) {
  DIFSLIKA[[i]]$V3 <- DIFSLIKA[[i]]$V3 / max_lum
}

# transforming indexes

for (i in 1:1000) {
  DIFSLIKA[[i]]$V1 <- (DIFSLIKA[[i]]$V1 + 10000) / 100 + 1
  DIFSLIKA[[i]]$V2 <- (DIFSLIKA[[i]]$V2 + 10000) / 100 + 1
}

# creating matrices

IMG_MAT <- array(, dim = c(1000, 201, 201))

for (i in 1:1000) {
  for (j in 1:nrow(DIFSLIKA[[i]])) {
    IMG_MAT[i, DIFSLIKA[[i]][j, 1], DIFSLIKA[[i]][j, 2]] <- DIFSLIKA[[i]][j, 3]
  }
}

# writing matrices to files

for (i in 1:1000) {
  str_path <- paste0("Desktop/1000_imgs/SLIKA", i, ".txt")
  write.table(IMG_MAT[i, ,], file = str_path, row.names = FALSE, col.names = FALSE)
}


library(stm)

#setwd() #set working directory to your home directory

### Load Data

df <- read.csv("<filename>")
df <- df[ which (df$code!=5),]
namesdf)
)
####################################
######### Pre-processing ###########
####################################

temp<-textProcessor(documents=df$text,metadata=df)
meta<-temp$meta
vocab<-temp$vocab
docs<-temp$documents
out <- prepDocuments(docs, vocab, meta)
docs<-out$documents
vocab<-out$vocab
meta <-out$meta
meta$text <- as.character(meta$text)

#head(meta)

set.seed(02138)

#plotRemoved(out$documents,lower.thresh=seq(1,200,by=100))

##################################
######### Choose Model ###########
##################################

### Model search across numbers of topics

storage <- manyTopics(docs,vocab,K=c(10,20,30,40,50,60),prevalence=~year,data=meta,runs=10,max.em.its=15)

mean(storage$exclusivity[[3]])

mod.10 <- storage$out[[1]]
mod.20 <- storage$out[[2]] # most coherent
mod.30 <- storage$out[[3]]
mod.40 <- storage$out[[4]] # most exclusive
mod.50 <- storage$out[[5]]
mod.60 <- storage$out[[6]]

model <- mod.60
# Labels
labelTopics(model)

save.image("stm_allmodels.RData")

labels <- labelTopics(model, n=20)

write.csv(labels$prob, file="stm60_terms.csv")
write.csv(labels$frex, file="stm60_terms_frex.csv")

findThoughts(model,texts=meta$text,n=5,topics=47)$docs[[1]]

meta$ID <- seq.int(nrow(df))
theta <- data.frame(model$theta)
theta$ID <- seq.int(nrow(theta))

df_all <- merge(meta, theta)
df_all$X1

write.csv(df_all, file="stm60_theta.csv")


#' Calculate cluster similarity between clusters from different single cell samples.
#'
#' `cluster_fold_similarity()` returns a dataframe containing the best top similarities between all possible pairs of single cell samples.
#'
#' This function will calculate a similarity coeficient using the fold changes of shared genes among clusters of different samples/batches. The similarity coeficient
#' is calculated using the dotproduct of every pairwise combination of Fold Changes between a source cluster i of sample n and all the target clusters in sample j.
#'
#' @param sce_list List. A list of single cell experiments. At least 2 single cell experiments are needed. The objects are expected to be subsets of the original data,
#' containing the selected features (e.g. 2000 most variable genes).
#' @param sample_names Character Vector. Specify the sample names, if not a number corresponding with its position on (sce_list).
#' @param top_n Numeric. Specifies the number of target clusters with best similarity to report for each cluster comparison (default 1).
#' @param top_n_genes Numeric. Number of top genes that explains the clusters similarity to report for each cluster comparison (default 1).
#'
#' @return The function returns a \linkS4class{DataFrame} containing the best top similarities between all possible pairs of single cell samples. Column values are:
#' \tabular{ll}{
#'    \code{similarity_value} \tab The top similarity value calculated between dataset_l:cluster_l and dataset_r. \cr
#'    \tab \cr
#'    \code{sem} \tab Standar Error of the Mean (SEM) of the mean of the values of the coeficient calculated for all genes. \cr
#'    \tab \cr
#'    \code{dataset_l} \tab Sample left, the sample source which is being compared.  \cr
#'    \tab \cr
#'    \code{cluster_l} \tab Cluster left, the cluster source which is being compared. \cr
#'    \tab \cr
#'    \code{dataset_r} \tab Sample right, the sample target which is being compared with dataset_l. \cr
#'    \tab \cr
#'    \code{cluster_r} \tab Cluster right, the cluster target which is being compared with cluster_l. \cr
#'    \tab \cr
#'    \code{top_gene_conserved} \tab The gene that showed most similar between cluster_l & cluster_r. \cr
#' }
#'
#' @export
cluster_fold_similarity <- function(sce_list = NULL,
                                  sample_names = NULL,
                                  top_n = 1,
                                  top_n_genes = 1){
  if(is.null(sce_list) | (length(sce_list)<2)){
    stop("At least two Single Cell Experiments are needed for cluster comparison.")
  }
  is_seurat <- FALSE
  is_sce <- FALSE
  # Function starts by loading dependencies
  if(class(sce_list[[1]]) == "Seurat" ){
    if (!requireNamespace("Seurat", quietly = TRUE)) {
      stop("Package \"Seurat\" needed for this function to work. Please install it.",
           call. = FALSE)}
    is_seurat <- TRUE
    is_sce <- FALSE
  }
  if(class(sce_list[[1]]) == "SingleCellExperiment" ){
    if (!requireNamespace("SingleCellExperiment", quietly = TRUE)) {
      stop("Package \"SingleCellExperiment\" needed for this function to work. Please install it.",
           call. = FALSE)}
    is_seurat <- FALSE
    is_sce <- TRUE
  }
  if (!is_seurat & !is_sce){
    stop("One or more objects in the input list is neither of class Seurat nor SingleDataExperiment.")
  }
  summary_results <- data.frame(similarity_value=integer(),
                                sem=integer(),
                                dataset_l=integer(),
                                cluster_l=integer(),
                                dataset_r=integer(),
                                cluster_r=integer(),
                                top_gene_conserved=character(),
                                stringsAsFactors=FALSE)
  # Select common genes in all samples
  features <- Reduce(intersect,lapply(sce_list,function(x){rownames(x)}))
  if(length(features) == 0){
    stop("No common genes between datasets. Please, select a subset of common variable genes among all datasets.")
  }
  if(length(features) < 100){
    warning(paste("The number of common genes among datasets is: ",length(features),". More than 100 common genes among all datasets is recomended.",sep = ""))
  }
  # Control filtered level factors using droplevels
  for (i in length(sce_list)){
    if(is_sce){
      if(is.null(SingleCellExperiment::colLabels(sce_list[[i]]))){
        stop(paste("No clusters specified on colLabels on sample",i))
      }
      SingleCellExperiment::colLabels(sce_list[[i]]) <- droplevels(SingleCellExperiment::colLabels(sce_list[[i]]))
    }
    if(is_seurat){
      Seurat::Idents(sce_list[[i]]) <- droplevels(Seurat::Idents(sce_list[[i]]))
    }
  }
  # Save the cluster name identification given by the user
  if(is_sce){cluster_names <- lapply(sce_list,function(x)levels(SingleCellExperiment::colLabels(x)))}
  if(is_seurat){cluster_names <- lapply(sce_list,function(x)levels(Seurat::Idents(x)))}
  # Calculate cluster FoldChange pairwise values:
  markers_sce_list <- list()
  # markers_sce_list <- lapply(sce_list,function(x){findMarkers(x,pval.type="all")})
  message("Computing fold changes.")
  if(is_sce){
    markers_sce_list <- lapply(sce_list,function(x){
      pairwise_cluster_fold_change(x = as.matrix(SingleCellExperiment::logcounts(x)),clusters = SingleCellExperiment::colLabels(x))
      })
  }
  if(is_seurat){
    markers_sce_list <- lapply(sce_list,function(x){
      pairwise_cluster_fold_change(x = as.matrix(Seurat::GetAssayData(x, slot = "data")),clusters = Seurat::Idents(x))
    })
  }
  # Main loop - samples
  for (i in 1:(length(markers_sce_list))){
    # Pick a sample in ascending order
    y <- markers_sce_list[[i]]
    for (j in seq_along(y)){
      # We choose a root cluster and compare it with clusters of samples i+1+...+n
      root <- y[[j]]
      # for (k in seq(from=i+1,to=length(markers_sce_list),by = 1)){
      for (k in seq(from=1,to=length(markers_sce_list),by = 1)){
        if(k == i)next() # If root and target samples are the same, we go for the next sample and skip this loop
        sce_comparative <- markers_sce_list[[k]]
        results <- data.frame(similarity_value=integer(),
                              sem=integer(),
                              dataset_l=integer(),
                              cluster_l=integer(),
                              dataset_r=integer(),
                              cluster_r=integer(),
                              top_gene_conserved=character(),
                              stringsAsFactors=FALSE)
          for(n in seq_along(sce_comparative)){
            # The sample for comparing will be the sample_i+1
            comparative <- sce_comparative[[n]]
            # Comparative = single cluster from sample_i+1
            message(paste("Comparing [ cluster",cluster_names[[i]][j],"] from dataset:",i,"with [ cluster:",cluster_names[[k]][n] ,"] from dataset:",k))
            # Create a matrix A and B to compute the dotproduct of all possible combinations of cluster comparison FoldChanges for each gene
            mat <- foldchange_composition(root[features,],comparative[features,])
            mat_colmean <- colMeans(mat)
            top_genes <- head(colnames(mat)[order(mat_colmean,decreasing = T)],n=top_n_genes)
            n_negative <- sum(mat_colmean < 0)
            n_positive <- sum(mat_colmean > 0)
            sem <- round(sd(mat_colmean) / sqrt(n_negative + n_positive), digits = 4)
            weight <- round( sqrt(abs(n_negative - n_positive) / (n_negative + n_positive)), digits = 4) # Weight based on the number of concordant-discordant FCs
            # We divide the similarity by the SEM value -> then we scale it using sqrt and conserve the sign
            # similarity_weighted <- sqrt(abs(sum(mat_colmean)) / sem) * sign(sum(mat_colmean))
            similarity_weighted <- sqrt(abs(sum(mat_colmean))) * weight * sign(sum(mat_colmean))
            # Save results
            for (g in top_genes){
              results[nrow(results)+1,] <- list(
                similarity_weighted, # Similarity_value
                sem, # Standar Error of the Mean
                i, # dataset_l
                cluster_names[[i]][j], # Cluster_l (left; source of comparison) -> j corresponding to the loop
                k, # dataset_r
                cluster_names[[k]][n], # Cluster_r (right; target of comparison) -> n corresponding to the internal loop
                g) # Top gene conserved
            }
          }
        results <- data.table::rbindlist(by(results,results$cluster_l,function(x){head(x[order(x[,"similarity_value"],decreasing = T),], n=top_n*top_n_genes)}))
        summary_results <- rbind.data.frame(summary_results,results)
      }
    }
  }
  message("Ploting graph using the similarity values of clusters.")
  plot_clusters_graph(similarity.table = summary_results)
  message("Returning similarity table.")
  return(summary_results)
}


# importing libraries
library(plyr)
library(foreign)
library(RWeka)
library(dplyr)
library(caret)
library(xgboost)

# reading datasets
esl = read.arff("esl.arff")
era = read.arff("era.arff")
lev = read.arff("lev.arff")
swd = read.arff("swd.arff")

# function to create dataset train and test partitions
createPartitions = function(dataset){
  set.seed (20)
  # let's change class attribute name to "class"
  colnames(dataset)[length(dataset)] = "class"
  # we use 66% for train an the rest for test
  trainIndex = sample(1:nrow(dataset), (66*nrow(dataset))/100)
  # returning train and test
  list(as.data.frame(dataset[trainIndex,]),as.data.frame(dataset[-trainIndex,]))
}

# function to create n-1 models to ordinal classification
ordinalDatasets = function(dataset)
{
  # extracting the original class attribute
  # (assuming that class attribute is in the end)
  originalClassAttribute = dataset[,dim(dataset)[2]]

  # inspecting which classes contains class attribute of the dataset
  classes = sort(unique(originalClassAttribute))

  # we select the first one as current class
  currentClasses = classes[1]

  # let's remove it from classes
  classes = classes[-1]

  # we only need to make numberOfClasses-1 models, so last "classes"
  # item won't be considered.
  # we create a list containing each class combination attribute.
  newClassAttributes = originalClassAttribute
  for(class in classes){
    newClassAttributes = cbind(newClassAttributes,Newclass = ifelse(originalClassAttribute%in%currentClasses, 0, 1))
    currentClasses = c(currentClasses,class)
  }

  # we remove the original class attribute
  newClassAttributes = newClassAttributes[,-1]

  # let's create the models
  models = apply(newClassAttributes, 2, function(class){
    # we assign the new class attribute
    dataset[,dim(dataset)[2]] = class
    # xgboost only accepts matrix or xgb.DMatrix
    dataset = xgb.DMatrix(as.matrix(dataset[,-dim(dataset)[2]]), label=dataset[,dim(dataset)[2]])
    # let's call de model
    xgboost(data = dataset, monotone_constraints=1,nrounds = 2)
  })
}

# function to predict an instance (or set of instances) class
monotonePrediction = function(models, newInstances,classes){

  # firstly we get the probabilities of each instance
  probabilities = lapply(models, function(model){as.numeric(predict(model,as.matrix(newInstances[,-ncol(newInstances)])) > 0.5)})
  #probabilities = lapply(models, function(model){predict(model,as.matrix(newInstances[,-ncol(newInstances)]))})
  print(probabilities)

  # we transform the list into data.frame
  probs = do.call("cbind",probabilities)

  # let's predict
  indexOfPredictedClasses = apply(probs, 1, function(p){
    sum(p)+1
  })
  print(indexOfPredictedClasses)
  classes[indexOfPredictedClasses]
}

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

# firstly we partition datasets
# <datasetName>Partitiors[[1]] will contain train partition
# <datasetName>Partitiors[[2]] will contain test partition
eslPartitions = createPartitions(esl)
eraPartitions = createPartitions(era)
levPartitions = createPartitions(lev)
swdPartitions = createPartitions(swd)

# let's create the models with the train datasets
eslModels = ordinalDatasets(eslPartitions[[1]])
eraModels = ordinalDatasets(eraPartitions[[1]])
levModels = ordinalDatasets(levPartitions[[1]])
swdModels = ordinalDatasets(swdPartitions[[1]])

# we predict using test dataset without class attribute
eslPredictedResults = monotonePrediction(eslModels, eslPartitions[[2]], sort(unique(esl$out1)))
eraPredictedResults = monotonePrediction(eraModels, eraPartitions[[2]], sort(unique(era$out1)))
levPredictedResults = monotonePrediction(levModels, levPartitions[[2]], sort(unique(lev$Out1)))
swdPredictedResults = monotonePrediction(swdModels, swdPartitions[[2]], sort(unique(swd$Out1)))

# now we get the accuracy results
eslAccuracy <- sum(eslPredictedResults == eslPartitions[[2]]$class)/length(eslPredictedResults)
eraAccuracy <- sum(eraPredictedResults == eraPartitions[[2]]$class)/length(eraPredictedResults)
levAccuracy <- sum(levPredictedResults == levPartitions[[2]]$class)/length(levPredictedResults)
swdAccuracy <- sum(swdPredictedResults == swdPartitions[[2]]$class)/length(swdPredictedResults)

# let's see how this model fits the datasets
eslAccuracy
eraAccuracy
levAccuracy
swdAccuracy

# as we can see, accuracy values using ordinal classification method is not really good, so
# it may be because datasets are note made to apply this classification technique


# GetAuditVsNotData.r
source("../common/DataUtil.r")
library(ggplot2)
source("../common/PlotUtil.r")

# Params
sPlotFile <- "auditvsnot.png"
fnGroupBy <- function(dfIn) {group_by(dfIn, copies, lifem, auditfrequency)}
fnSubset <- function(dfIn) {subset(dfIn, copies==5 & lifem<=1000)}
sTitleLine <-   (   "Auditing dramatically decreases "
                %+% "permanent document losses "
                %+% "over a wide range "
                %+% "\n"
                %+% "\n(Copies=5, "
                %+% "annual total auditing vs no auditing, "
                %+% "duration = 10 years)"
                )
sLegendLabel <- "Audited? Y/N"
lLegendItemLabels <- c("Not audited", "Yes, audited")
sXLabel <- ("1MB sector half-life (megahours)"
            %+% "                           (lower error rate =====>)")
sYLabel <- ("permanent document losses (%)")

# G E T   D A T A
# Get the data into the right form for these plots.
alldat.df <- fndfGetGiantDataRaw("")
newdat <- alldat.df %>% fnGroupBy() %>%
summarize(mdmlosspct=round(midmean(lost/docstotal)*100.0, 2), n=n()) %>%
fnSubset()
trows <- newdat

# P L O T   D A T A

gp <- ggplot(data=trows
            , aes(x=lifem,y=safe(mdmlosspct), color=factor(auditfrequency))
            )
gp <- gp + labs(color=sLegendLabel)

gp <- fnPlotLogScales(gp, x="YES", y="YES"
                ,xbreaks=c(2,5,10,100,1000)
                ,ybreaks=c(0.01,0.10,1.00)
                )
gp <- gp + geom_line(
                  size=3
                , show.legend=TRUE
                )
gp <- gp + geom_point(data=trows
                , size=6
                , show.legend=TRUE
                , color="black"
                )

gp <- gp + theme(legend.position=c(0.8,0.7))
gp <- gp + theme(legend.background=element_rect(fill="lightgray",
                                  size=0.5, linetype="solid"))
gp <- gp + theme(legend.key.size=unit(0.3, "in"))
gp <- gp + theme(legend.key.width=unit(0.6, "in"))
gp <- gp + theme(legend.text=element_text(size=16))
gp <- gp + theme(legend.title=element_text(size=14))
gp <- gp + scale_color_discrete(labels=lLegendItemLabels)

gp <- fnPlotTitles(gp
            , titleline=sTitleLine
            , xlabel=sXLabel
            , ylabel=sYLabel
        )
# Label the percentage lines out on the right side.
xlabelposition <- log10(800)
gp <- fnPlotPercentLine(gp, xloc=xlabelposition)
gp <- fnPlotMilleLine(gp, xloc=xlabelposition)
gp <- fnPlotSubMilleLine(gp, xloc=xlabelposition)

plot(gp)
fnPlotMakeFile(gp, sPlotFile)

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


x1 = c(.09, .19, .2, .25, .3, .4)
y1 = c(.09, .43, .3, .1, .4, .25)
x2 = c(.68, .7, .82, .66, .91, 1.02)
y2 = c(.6, 1, .9, .7, 1, .85)

plot(x1, y1, xlim=range(c(x1,x2)), ylim=range(c(y1,y2)), col="blue", xlab="x", ylab="y", xaxt="n", yaxt="n")
points(x2, y2, pch=4, col="red")

set.seed(1)
rand_indices = sample(1:12)
x = c(x1,x2)
y = c(y1,y2)
xr1 = vector(length=6)
xr2 = vector(length=6)
yr1 = vector(length=6)
yr2 = vector(length=6)
for (i in 1:6) {
	xr1[i] <- x[rand_indices[i]]
	yr1[i] <- y[rand_indices[i]]
}
for (i in 1:6) {
	xr2[i] <- x[rand_indices[i+6]]
	yr2[i] <- y[rand_indices[i+6]]
}

quartz()
plot(xr1, yr1, xlim=range(c(xr1,xr2)), ylim=range(c(yr1,yr2)), col="blue", xlab="x", ylab="y", xaxt="n", yaxt="n")
points(xr2, yr2, pch=4, col="red")