# library(edgeR)
# library(gamlss.mx)
# library(parallel)
# library(tidyverse)
# library(SuppDists)
# library(quantreg)
# library(caret)
# library(MASS)
# library(viridis)
# library(gplots)
library(reshape2)

setwd("/media/yuri/Data/home1/GNI_data/infection/ResultsSciRep")
load("CAP_Sepsis_H1N1_gene_noise_Figure1.Rdat")

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

# Mean gene expression noise (variance) +/- std.dev for CAP (see CAP_Sepsis_H1N1_gene_noise_Figure1.r)
df1_cap <- melt(sqrt(gene_noise_CAP[,c(4:6)]))
df1_cap_mu <- aggregate(value ~ variable, df1_cap, mean)$value
df1_cap_upp_sd <- aggregate(value ~ variable, data=df1_cap, function(x) mean(x) + sd(x))$value
df1_cap_lwr_sd <- aggregate(value ~ variable, data=df1_cap, function(x) mean(x) - sd(x))$value

# Mean gene expression noise (variance) +/- std.dev for genes for which variance changes significantly in CAP
# (see CAP_Sepsis_H1N1_gene_noise_Figure1.r)
df2_cap <- melt(sqrt(subset(gene_noise_CAP, padj_sigma <= 0.05)[,c(4:6)]))
df2_cap_mu <- aggregate(value ~ variable, df2_cap, mean)$value
df2_cap_upp_sd <- aggregate(value ~ variable, data=df2_cap, function(x) mean(x) + sd(x))$value
df2_cap_lwr_sd <- aggregate(value ~ variable, data=df2_cap, function(x) mean(x) - sd(x))$value

# Mean gene expression noise (variance) +/- std.dev for Sepsis (see CAP_Sepsis_H1N1_gene_noise_Figure1.r)
df1_sps <- melt(sqrt(gene_noise_SPS[,c(4:6)]))
df1_sps_mu <- aggregate(value ~ variable, df1_sps, mean)$value
df1_sps_upp_sd <- aggregate(value ~ variable, data=df1_sps, function(x) mean(x) + sd(x))$value
df1_sps_lwr_sd <- aggregate(value ~ variable, data=df1_sps, function(x) mean(x) - sd(x))$value

# Mean gene expression noise (variance) +/- std.dev for genes for which variance changes significantly in Sepsis
# (see CAP_Sepsis_H1N1_gene_noise_Figure1.r)
df2_sps <- melt(sqrt(subset(gene_noise_SPS, padj_sigma <= 0.05)[,c(4:6)]))
df2_sps_mu <- aggregate(value ~ variable, df2_sps, mean)$value
df2_sps_upp_sd <- aggregate(value ~ variable, data=df2_sps, function(x) mean(x) + sd(x))$value
df2_sps_lwr_sd <- aggregate(value ~ variable, data=df2_sps, function(x) mean(x) - sd(x))$value

# Mean gene expression noise (variance) +/- std.dev for H1N+ (see CAP_Sepsis_H1N1_gene_noise_Figure1.r)
df1_h1n <- melt(sqrt(gene_noise_H1N[,c(4:6)]))
df1_h1n_mu <- aggregate(value ~ variable, df1_h1n, mean)$value
df1_h1n_upp_sd <- aggregate(value ~ variable, data=df1_h1n, function(x) mean(x) + sd(x))$value
df1_h1n_lwr_sd <- aggregate(value ~ variable, data=df1_h1n, function(x) mean(x) - sd(x))$value

# Mean gene expression noise (variance) +/- std.dev for genes for which variance changes significantly in H1N1
# (see CAP_Sepsis_H1N1_gene_noise_Figure1.r)
df2_h1n <- melt(sqrt(subset(gene_noise_H1N, padj_sigma <= 0.05)[,c(4:6)]))
df2_h1n_mu <- aggregate(value ~ variable, df2_h1n, mean)$value
df2_h1n_upp_sd <- aggregate(value ~ variable, data=df2_h1n, function(x) mean(x) + sd(x))$value
df2_h1n_lwr_sd <- aggregate(value ~ variable, data=df2_h1n, function(x) mean(x) - sd(x))$value

setwd("/media/yuri/Data/home1/GNI_data/infection/ResultsSciRep/Figures")

pdf("Figure1A.pdf", paper="a4r", width=5.5, height=10)

par(mfrow=c(2,3))

stripchart(value ~ variable, data = df1_cap, method="jitter", vertical = TRUE,
  col = NULL, pch=NA, cex=0.3, ylab = "sigma", las=1, ylim=c(0,0.95))
lines(c(1:3), df1_cap_mu, col=1, lty=2, lwd=2  )
segments(c(1:3), df1_cap_upp_sd, c(1:3), df1_cap_lwr_sd, lwd=3, col = c("#21A883", "#4591CC", "#673AB7")  )
points(c(1:3), df1_cap_mu, pch=21, col = c("#21A883", "#4591CC", "#673AB7"), bg = "white", cex=3, lwd=3  )
legend("bottomright", legend =
c(paste0("p(1-0) = ", round(t.test(sqrt(gene_noise_CAP$v_ctl),  sqrt(gene_noise_CAP$v_cap0))$p.value, 5)),
  paste0("p(2-1) = ", round(t.test(sqrt(gene_noise_CAP$v_cap1), sqrt(gene_noise_CAP$v_cap0))$p.value, 5)))
)

stripchart(value ~ variable, data = df1_sps, method="jitter", vertical = TRUE,
  col = NULL, pch=NA, cex=0.3, ylab = "sigma", las=1, ylim=c(0,0.95))
lines(c(1:3), df1_sps_mu, col=1, lty=2, lwd=2  )
segments(c(1:3), df1_sps_upp_sd, c(1:3), df1_sps_lwr_sd, lwd=3, col = c("#21A883", "#4591CC", "#673AB7")  )
points(c(1:3), df1_sps_mu, pch=21, col = c("#21A883", "#4591CC", "#673AB7"), bg = "white", cex=3, lwd=3  )
legend("bottomright", legend =
c(paste0("p(1-0) = ", round(t.test(sqrt(gene_noise_SPS$v_ctl ), sqrt(gene_noise_SPS$v_sps0))$p.value, 5)),
  paste0("p(2-1) = ", round(t.test(sqrt(gene_noise_SPS$v_sps1), sqrt(gene_noise_SPS$v_sps0))$p.value, 5)) )
)

stripchart(value ~ variable, data = df1_h1n, method="jitter", vertical = TRUE,
col = NULL, pch=NA, cex=0.3, ylab = "sigma", las=1, ylim=c(0,0.65))
lines(c(1:3), df1_h1n_mu, col=1, lty=2, lwd=2  )
segments(c(1:3), df1_h1n_upp_sd, c(1:3), df1_h1n_lwr_sd, lwd=3, col = c("#21A883", "#4591CC", "#673AB7")  )
points(c(1:3), df1_h1n_mu, pch=21, col = c("#21A883", "#4591CC", "#673AB7"), bg = "white", cex=3, lwd=3  )
legend("bottomright", legend =
c(paste0("p(1-0) = ", round(t.test(sqrt(gene_noise_H1N$v_ctl ), sqrt(gene_noise_H1N$v_h1n0))$p.value, 5)),
  paste0("p(2-1) = ", round(t.test(sqrt(gene_noise_H1N$v_h1n1), sqrt(gene_noise_H1N$v_h1n0))$p.value, 5)) )
)

stripchart(value ~ variable, data = df2_cap, method="jitter", vertical = TRUE,
col = NULL, pch=NA, cex=0.3, ylab = "sigma, padj <= 0.05", las=1, ylim=c(0,1.1))
lines(c(1:3), df2_cap_mu, col=1, lty=2, lwd=2  )
segments(c(1:3), df2_cap_upp_sd, c(1:3), df2_cap_lwr_sd, lwd=3, col = c("#21A883", "#4591CC", "#673AB7")  )
points(c(1:3), df2_cap_mu, pch=21, col = c("#21A883", "#4591CC", "#673AB7"), bg = "white", cex=3, lwd=3  )
legend("bottomright", legend =
c(paste0("p(1-0) = ", round(t.test(sqrt(subset(gene_noise_CAP, padj_sigma <= 0.05)$v_ctl),  sqrt(subset(gene_noise_CAP, padj_sigma <= 0.05)$v_cap0))$p.value, 5)),
  paste0("p(2-1) = ", round(t.test(sqrt(subset(gene_noise_CAP, padj_sigma <= 0.05)$v_cap1), sqrt(subset(gene_noise_CAP, padj_sigma <= 0.05)$v_cap0))$p.value, 5)))
)

stripchart(value ~ variable, data = df2_sps, method="jitter", vertical = TRUE,
col = NULL, pch=NA, cex=0.3, ylab = "sigma, padj <= 0.05", las=1, ylim=c(0,1.1))
lines(c(1:3), df2_sps_mu, col=1, lty=2, lwd=2  )
segments(c(1:3), df2_sps_upp_sd, c(1:3), df2_sps_lwr_sd, lwd=3, col = c("#21A883", "#4591CC", "#673AB7")  )
points(c(1:3), df2_sps_mu, pch=21, col = c("#21A883", "#4591CC", "#673AB7"), bg = "white", cex=3, lwd=3  )
legend("bottomright", legend =
c(paste0("p(1-0) = ", round(t.test(sqrt(subset(gene_noise_SPS, padj_sigma <= 0.05)$v_ctl),  sqrt(subset(gene_noise_SPS, padj_sigma <= 0.05)$v_sps0))$p.value, 5)),
  paste0("p(2-1) = ", round(t.test(sqrt(subset(gene_noise_SPS, padj_sigma <= 0.05)$v_sps1), sqrt(subset(gene_noise_SPS, padj_sigma <= 0.05)$v_sps0))$p.value, 5)))
)

stripchart(value ~ variable, data = df2_h1n, method="jitter", vertical = TRUE,
col = NULL, pch=NA, cex=0.3, ylab = "sigma, padj <= 0.05", las=1, ylim=c(0,0.9))
lines(c(1:3), df2_h1n_mu, col=1, lty=2, lwd=2  )
segments(c(1:3), df2_h1n_upp_sd, c(1:3), df1_h1n_lwr_sd, lwd=3, col = c("#21A883", "#4591CC", "#673AB7")  )
points(c(1:3), df2_h1n_mu, pch=21, col = c("#21A883", "#4591CC", "#673AB7"), bg = "white", cex=3, lwd=3  )
legend("bottomright", legend =
c(paste0("p(1-0) = ", round(t.test(sqrt(subset(gene_noise_H1N, padj_sigma <= 0.05)$v_ctl),  sqrt(subset(gene_noise_H1N, padj_sigma <= 0.05)$v_h1n0))$p.value, 5)),
  paste0("p(2-1) = ", round(t.test(sqrt(subset(gene_noise_H1N, padj_sigma <= 0.05)$v_h1n1), sqrt(subset(gene_noise_H1N, padj_sigma <= 0.05)$v_h1n0))$p.value, 5)))
)

dev.off()

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

library(Rfit)
library(quantreg)
library(mvoutlier)

# Fluctuation-responce: variance in gene expression correlates with response in mean gene expression
# See main text for details

pdf("Figure1BCD.pdf", width=11, height=12.75)

par(mfrow=c(3,3))

# CAP
dfd <-  data.frame(v = gene_noise_CAP$V_ave, d = abs(gene_noise_CAP$mu2_cap - gene_noise_CAP$mu2_ctl))
R_dfd <- cor.test(dfd$d, dfd$v, method="spearman")
plot(d ~ v, data=dfd, las=1, xlab="variance", ylab="difference mu CAP - ctl", xlim=c(5e-03,5), ylim=c(1e-03,10), pch=20, col="#00000022", log="xy", cex=0.7)
abline(rq(d ~ v,, data =  log10(dfd)[ sign2(log10(dfd), explvar = 0.5, qcrit = 0.5)$wfinal01 == 0, ]), col=2, lwd =2)
legend("topleft", legend=c( paste0("r = ", round(R_dfd$estimate, 3)), paste0("p = ", round(R_dfd$p.value, 5)) ) )

dfv <-  data.frame(v = gene_noise_CAP$V_ave, d = abs(gene_noise_CAP$v2_cap - gene_noise_CAP$v2_ctl))
R_dfv <- cor.test(dfv$d, dfv$v, method="spearman")
plot(d ~ v, data=dfv, las=1, xlab="variance", ylab="difference v CAP - ctl", xlim=c(5e-03,5), ylim=c(1e-03,10), pch=20, col="#00000022", log="xy", cex=0.7)
abline(rq(d ~ v,, data =  log10(dfv)[ sign2(log10(dfv), explvar = 0.5, qcrit = 0.5)$wfinal01 == 0, ]), col=2, lwd =2)
legend("topleft", legend=c( paste0("r = ", round(R_dfv$estimate, 3)), paste0("p = ", round(R_dfv$p.value, 5)) ) )

dfdv <-  data.frame(v = abs(gene_noise_CAP$v2_cap - gene_noise_CAP$v2_ctl), d = abs(gene_noise_CAP$mu2_cap - gene_noise_CAP$mu2_ctl))
R_dfdv <- cor.test(dfdv$d, dfdv$v, method="spearman")
plot(v ~ d, data=dfdv, las=1, xlab="difference mu CAP - ctl", ylab="difference v CAP - ctl",
     xlim=c(1e-03,10), ylim=c(1e-03,10), pch=20, col="#00000022", log="xy", cex=0.7)
abline(rq(v ~ d, data =  log10(dfdv)[ sign2(log10(dfdv), explvar = 0.5, qcrit = 0.5)$wfinal01 == 0, ]), col=2, lwd =2)
legend("topleft", legend=c( paste0("r = ", round(R_dfdv$estimate, 3)), paste0("p = ", round(R_dfdv$p.value, 5)) ) )

# Sepsis
dfd <-  data.frame(v = gene_noise_SPS$V_ave, d = abs(gene_noise_SPS$mu2_sps - gene_noise_SPS$mu2_ctl))
R_dfd <- cor.test(dfd$d, dfd$v, method="spearman")
plot(d ~ v, data=dfd, las=1, xlab="variance", ylab="difference mu SPS - ctl", xlim=c(5e-03,5), ylim=c(1e-03,10), pch=20, col="#00000022", log="xy", cex=0.7)
abline(rq(d ~ v,, data =  log10(dfd)[ sign2(log10(dfd), explvar = 0.5, qcrit = 0.5)$wfinal01 == 0, ]), col=2, lwd =2)
legend("topleft", legend=c( paste0("r = ", round(R_dfd$estimate, 3)), paste0("p = ", round(R_dfd$p.value, 5)) ) )

dfv <-  data.frame(v = gene_noise_SPS$V_ave, d = abs(gene_noise_SPS$v2_sps - gene_noise_SPS$v2_ctl))
R_dfv <- cor.test(dfv$d, dfv$v, method="spearman")
plot(d ~ v, data=dfv, las=1, xlab="variance", ylab="difference v SPS - ctl", xlim=c(5e-03,5), ylim=c(1e-03,10), pch=20, col="#00000022", log="xy", cex=0.7)
abline(rq(d ~ v,, data =  log10(dfv)[ sign2(log10(dfv), explvar = 0.5, qcrit = 0.5)$wfinal01 == 0, ]), col=2, lwd =2)
legend("topleft", legend=c( paste0("r = ", round(R_dfv$estimate, 3)), paste0("p = ", round(R_dfv$p.value, 5)) ) )

dfdv <-  data.frame(v = abs(gene_noise_SPS$v2_sps - gene_noise_SPS$v2_ctl), d = abs(gene_noise_SPS$mu2_sps - gene_noise_SPS$mu2_ctl))
R_dfdv <- cor.test(dfdv$d, dfdv$v, method="spearman")
plot(v ~ d, data=dfdv, las=1, xlab="difference mu SPS - ctl", ylab="difference v SPS - ctl",
     xlim=c(1e-03,10), ylim=c(1e-03,10), pch=20, col="#00000022", log="xy", cex=0.7)
abline(rq(v ~ d, data =  log10(dfdv)[ sign2(log10(dfdv), explvar = 0.5, qcrit = 0.5)$wfinal01 == 0, ]), col=2, lwd =2)
legend("topleft", legend=c( paste0("r = ", round(R_dfdv$estimate, 3)), paste0("p = ", round(R_dfdv$p.value, 5)) ) )

# H1N1
dfd <-  data.frame(v = gene_noise_H1N$V_ave, d = abs(gene_noise_H1N$mu2_h1n - gene_noise_H1N$mu2_ctl))
R_dfd <- cor.test(dfd$d, dfd$v, method="spearman")
plot(d ~ v, data=dfd, las=1, xlab="variance", ylab="difference mu H1N1 - ctl", xlim=c(5e-03,5), ylim=c(1e-03,10), pch=20, col="#00000022", log="xy", cex=0.7)
abline(rq(d ~ v,, data =  log10(dfd)[ sign2(log10(dfd), explvar = 0.5, qcrit = 0.5)$wfinal01 == 0, ]), col=2, lwd =2)
legend("topleft", legend=c( paste0("r = ", round(R_dfd$estimate, 3)), paste0("p = ", round(R_dfd$p.value, 5)) ) )

dfv <-  data.frame(v = gene_noise_H1N$V_ave, d = abs(gene_noise_H1N$v2_h1n - gene_noise_H1N$v2_ctl))
R_dfv <- cor.test(dfv$d, dfv$v, method="spearman")
plot(d ~ v, data=dfv, las=1, xlab="variance", ylab="difference v H1N1 - ctl", xlim=c(5e-03,5), ylim=c(1e-03,10), pch=20, col="#00000022", log="xy", cex=0.7)
abline(rq(d ~ v,, data =  log10(dfv)[ sign2(log10(dfv), explvar = 0.5, qcrit = 0.5)$wfinal01 == 0, ]), col=2, lwd =2)
legend("topleft", legend=c( paste0("r = ", round(R_dfv$estimate, 3)), paste0("p = ", round(R_dfv$p.value, 5)) ) )

dfdv <-  data.frame(v = abs(gene_noise_H1N$v2_h1n - gene_noise_H1N$v2_ctl), d = abs(gene_noise_H1N$mu2_h1n - gene_noise_H1N$mu2_ctl))
R_dfdv <- cor.test(dfdv$d, dfdv$v, method="spearman")
plot(v ~ d, data=dfdv, las=1, xlab="difference mu H1N1 - ctl", ylab="difference v H1N1 - ctl",
     xlim=c(1e-03,10), ylim=c(1e-03,10), pch=20, col="#00000022", log="xy", cex=0.7)
abline(rq(v ~ d, data =  log10(dfdv)[ sign2(log10(dfdv), explvar = 0.5, qcrit = 0.5)$wfinal01 == 0, ]), col=2, lwd =2)
legend("topleft", legend=c( paste0("r = ", round(R_dfdv$estimate, 3)), paste0("p = ", round(R_dfdv$p.value, 5)) ) )

dev.off()


#cross tissue XT-SCAN
#gtex v8

args<-as.numeric(commandArgs(TRUE))
library('glmnet')

#set up subjobs
run_id<-1
run_list<-list()
#for (i in c(13,31,49)){ #13,31,49  brain,liver,blood
for (i in c(32,49)){  #tissues  32 lung
#for (i in c(seq(1,49))[-c(13,31,49)]){ #1:49
  for (j in 1:50){  #subjobs per tissue
    run_list[[run_id]]<-c(i,j)
    run_id=run_id+1
  }
}

run_i<-run_list[[args]]
print(run_i)

folder='xt'

#tissue
tissue_list<-dir('/data/c*/z*/data/gtex/exp/v8/weighted')
tissue<-tissue_list[run_i[1]]

#mkdir
dir.create(paste0('/data/c*/z*/projects/gtex/weights/',folder,'/'))
dir.create(paste0('/data/c*/z*/projects/gtex/weights/',folder,'/',tissue))

#get gene list
#load annotation
anno<-read.table('/data/c*/z*/anno/gencode/37/gencode.v32.GRCh37.txt',header = T,stringsAsFactors = F)
anno<-anno[which(anno$chr=='chr3' & anno$left>(45859651-1e6) & anno$right<(45909024+1e6)),]

#load tissue level dhs similarity (when gene level dhs similarity is not available)
dhs_weight_tissue<-read.table(paste0('/data/c*/z*/projects/cross_tissue/encode/simularity_tissue/',tissue),header = T,stringsAsFactors = F)
#get gene level dhs similarity gene list
dhs_gene_list<-dir(paste0('/data/c*/z*/projects/cross_tissue/encode/simularity/',tissue,'/gene/'))

#gene list
exp_list<-sub('....$','',dir(paste0('/data/c*/z*/data/gtex/exp/v8/weighted/',tissue))) #expression
geno_list<-sub('....$','',dir('/data/c*/z*/data/gtex/geno/v8/gene/dosage_1m/')) #dosage genotype
gene_list<-intersect(exp_list,geno_list)
gene_list<-intersect(anno$geneid,gene_list)

#---------------------------
#i=which(gene_list=='ENSG00000240654')

if(length(gene_list)>=run_i[2]){
  gene_id = gene_list[run_i[2]]

  print(paste0('INFO processing ',gene_id,' ...'))

  #load expression levels
  exp<-readRDS(paste0('/data/c*/z*/data/gtex/exp/v8/weighted/',tissue,'/',gene_id,'.rds'));colnames(exp)[3]<-'exp_w'

  #merge with dhs weights
  dhs_weight_gene<-read.table(paste0('/data/g*/z*/covid19_neanderthals/jti/dhs/similarity/',tissue,'/table/covid19_segment_QN.txt'),header = T,stringsAsFactors = F)
  dhs_weight<-data.frame(tissue=colnames(dhs_weight_gene[-1]),dhs_w=as.numeric(dhs_weight_gene[1,-1]))
  dhs_weight[which(dhs_weight[,2]<0),2]<-0

  exp<-merge(exp,dhs_weight,by='tissue')

  #-----data prepare-----
  #load geno snpinfo
  #1m
  geno_1m<-readRDS(paste0('/data/c*/z*/data/gtex/geno/v8/gene/dosage_1m/',gene_id,'.rds'))
  geno_1m[,1]<-paste0('GTEX.',geno_1m[,1])
  snp_info_1m<-readRDS(paste0('/data/c*/z*/data/gtex/geno/v8/gene/info_1m/',gene_id,'.rds'))
  snp_info_1m$pos = sapply(snp_info_1m$chr_bp, function(x) as.numeric(strsplit(x,"[_]")[[1]][2]))

  cis_left = anno[which(anno$geneid==gene_id),'left'] - 1e6
  cis_right = anno[which(anno$geneid==gene_id),'right'] + 1e6

  output = data.frame(seed = seq(1,100), r = NA, p = NA)

  for(k in 1:101){
    print(k)
    set.seed(k+i)
    start_pos = sample(cis_left:(cis_right-49373),1)
    end_pos = start_pos + 49373

    if(k == 1){
      start_pos = 45859651
      end_pos = 45909024
    }

    snp_info = snp_info_1m[which(snp_info_1m$pos > start_pos & snp_info_1m$pos < end_pos),]
    if(nrow(snp_info)<2){next}
    geno = geno_1m[,c('sampleid',snp_info$rsid)]

    #-----model training-----
    #fit single tissue model to get proper window size and lambda range for each gene
    exp_st<-exp[exp$tissue==tissue,] #load single tissue data
    d_st<-merge(exp_st,geno,by='sampleid')
    if(nrow(d_st)<10){next}

    set.seed(as.numeric(sub('^....','',gene_id)))
    fit<-cv.glmnet(x=as.matrix(d_st[,6:ncol(d_st)]),y=as.matrix(d_st[,'exp']), nfolds = 5,keep = T,alpha=0.5,nlambda=50,pmax=200) #pmax=200

    #find proper window size and set up for downstream analysis
    #The cross tissue lambda range was set around the best single tissue lambda
    lambda_list<-fit$lambda[max(1,which(fit$lambda==fit$lambda.min)-20):min(length(fit$lambda),which(fit$lambda==fit$lambda.min)+20)]

    #dataframe for grid search and performance collection
    r_matrix<-as.data.frame(matrix(data=NA,nrow=(4*4),ncol=6))
    i_loop<-1
    for (exp_power in c(1,4,16,64)){
      for (dhs_power in c(1,4,16,64)){
        r_matrix[i_loop,1:2]<-c(exp_power,dhs_power)
        i_loop=i_loop+1
      }
    }
    colnames(r_matrix)<-c('exp_power','dhs_power','lambda','window','r_test','p_test')
    r_matrix$window='segment'

    #sample id map for each fold (fold=5)
    d_tmp<-merge(exp,geno,by='sampleid')
    sample_all<-unique(d_tmp$sampleid)
    set.seed(as.numeric(sub('^....','',gene_list[1]))+1)
    id_map<-data.frame(sampleid=sample_all,id_map=sample(rep(seq(1,5),ceiling(length(sample_all)/5)),length(sample_all)),stringsAsFactors = F)

    #beta list of each hyper-parameter pairs
    beta_list<-list()

    #go through each of the hyper-parameter pairs
    for (j in 1:nrow(r_matrix)){
      #print(j)
      exp_power=r_matrix[j,1];dhs_power=r_matrix[j,2]
      exp$w<-(exp$exp_w)^exp_power*(exp$dhs_w)^dhs_power

      #merge
      d<-merge(exp,geno,by='sampleid')

      #rm tissues with low similarity levels (w<0.1)
      d<-d[d[,'w']>=0.1,]; d<-d[!is.na(d[,1]),]

      #id map
      d<-merge(id_map,d,by='sampleid')
      #print(dim(d))

      #target tissue position (the performance will be only estimated in the target tissue)
      tt_pos<-which(d$tissue==tissue)

      #cross-tissue weighted elastic net
      set.seed(as.numeric(sub('^....','',gene_list[1]))+2)
      ans<-try(cv.glmnet(x=as.matrix(d[,8:ncol(d)]),y=as.matrix(d[,'exp']),weights=d[,'w'],foldid=d[,'id_map'],lambda=lambda_list,keep = T,pmax=200)) #pmax=200
      if ('try-error' %in% class(ans)){
        r_matrix[j,'r_test']<-0
      }else{
        #correlation between pred and obs expression levels
        cor_ans<-cor.test(ans$fit.preval[tt_pos,which(ans$lambda==ans$lambda.min)],d[tt_pos,'exp'])

        r_matrix[j,'r_test']<-cor_ans$estimate
        r_matrix[j,'p_test']<-cor_ans$p.value
        r_matrix[j,'lambda']<-ans$lambda.min

        #collect the weights
        beta_list[[j]]<-as.numeric(ans$glmnet.fit$beta[,which(ans$lambda==ans$lambda.min)])

      }
    }

    #find the best hyperparameters with the largest r_test
    best_row=which.max(r_matrix[,'r_test'])[1]
    r_test=r_matrix[best_row,'r_test']
    p_test=r_matrix[best_row,'p_test']

    output[k, 'r'] = r_test
    output[k, 'p'] = p_test

  }

  output$tissue = tissue

  write.table(output,paste0('/data/g*/z*/covid19_neanderthals/random_segment/raw/',tissue,'_',gene_id,'.txt'),quote = F,sep='\t',row.names = F)

}


library(here)
library(readr)
library(ggplot2)
library(ggthemes)
library(scales)
library(RColorBrewer)
library(cowplot, warn.conflicts = F)
library(viridis)
library(tidyr)
library(dplyr, warn.conflicts = FALSE)
library(lubridate, warn.conflicts = FALSE)

# load data
# calendar quarter, case ordinal, door2_contact, door2_ct, ct2_read, cbc2_result, inr2_result, tpa2_deliver
col_names <- c('year','month','case','d2_dr','d2_ct','ct2_r','cbc2_r','inr2_r','d2_n','tpa2_d')
col_spec <- cols(
  year = col_integer(),
  month = col_integer(),
  case = col_integer(),
  d2_dr = col_integer(),
  d2_ct = col_integer(),
  ct2_r = col_skip(),
  cbc2_r = col_skip(),
  inr2_r = col_skip(),
  d2_n = col_integer(),
  tpa2_d = col_skip()
)

file_path <- file.path( here::here(), 'input', 'tPA_case_data_processed.csv')
df <- read_csv( file_path, skip = 1, col_names = col_names, col_types = col_spec )

## Add a date column
df2 <- df %>% mutate(date=make_date(year, month))

# Generate an axis label given the start and end of an interval
label_interval <- function(start, end){
  ys <- unique( c(year(start),year(end)) )
  ms <- c(as.character(month(start, abbr=T, label=T)),
          as.character(month(end, abbr=T, label=T)))
  line_one <- paste0(ms,collapse='-')
  line_two <- paste(ys,collapse=' ')
  paste0(line_one,"\n",line_two)
}

# Given vector of dates,
# Return table with group boundaries an labels
time_group_table <- function(dates){
  min_month <- floor_date(min(dates), "months")
  max_month <- floor_date(max(dates), "months")
  num_months <- interval(min(dates),max(dates)) %/% months(1)
  num_groups <- floor(num_months / 3)

  #Build interval table
  end_months <- rev(seq(max_month, by="-1 quarters", length.out = num_groups))
  ends <- ceiling_date(end_months, unit="months") - days(1)
  starts <- end_months %m-% months(2)
  labels <- mapply(label_interval, starts, ends, SIMPLIFY = T)

  mm <- data.frame(start=starts,
                   end=ends,
                   quarter=c(1:length(ends)),
                   label=labels)
}

# Function to look up the quarter from a lookup table
lookup <- function(d,tbl){
  row_mask <- d >= tbl$start & d <= tbl$end
  ifelse(any(row_mask), tbl[row_mask, 'quarter'], NA)
}

# Build lookup table
lkup_tbl <- time_group_table(df2$date)

# use lookup table to add column for tracking the quarter
df2$quarter <- sapply(df2$date, FUN=lookup, lkup_tbl)

# Calculate the lower limit of quarter to include such that most recent 4 are shown.
calc_q_lim <- max(df2$quarter, na.rm=T) - 4
q_low_lim <- ifelse(calc_q_lim > 0, calc_q_lim, 0)

# Remove rows that don't fall into a rolling quarter
# Remove rows outside of most recent 4 quarters (q_low_lim)
# Remove other date columns
df_mod <- df2 %>%
  select( -month, -year, -date ) %>%
  filter( !is.na(quarter), quarter > q_low_lim)

# Convert category columns (all but quarter and case_ord) to
df_cnt <- df_mod %>%
  group_by(quarter) %>%
  summarise_all(funs(sum(!is.na(.)))) %>%
  gather(evt, count, -quarter)

df_med <- df_mod %>%
  group_by(quarter) %>%
  summarise_all(funs(median),na.rm=T) %>%
  gather(evt, median, -quarter)

pd <- inner_join(df_med,df_cnt) %>% filter(evt != "case")

# Join lookup table to pull in quarter labels
# Rename events
evt_lookup <- data.frame(
  'from'=c('d2_dr','d2_ct','d2_n'),
  'to'=c('Door to Doctor', 'Door to Head CT', 'Door to Treatment'))
plot_data <- pd %>%
  left_join(lkup_tbl[,c('quarter','label')]) %>%
  mutate(evt=evt_lookup$to[match(evt, evt_lookup$from)],
         label=as.character(label),
         quarter=as.factor(quarter))

### PLOTTING

## Calculate Scales
# half the value of maxium door to needle median
d2rx_h_max <- max(plot_data$median[plot_data$evt == "Door to Treatment"]) /2
# Maximum value of remaining events * 1.1
d2o_max <- max(plot_data$median[plot_data$evt != "Door to Treatment"]) * 1.1
# Scale max for other plots will be whichever is greater
y_scale_max <- max(c(d2rx_h_max, d2o_max))

# Make Palrette
pal <- c(brewer.pal(5, "Set1")[c(1,3,4,5)], brewer.pal(5, "Pastel1")[c(2,5,1,3)])
pal <- brewer.pal(8,"Set2")

## Door to Treatment Plot
df_d2rx <- plot_data %>% filter(evt == "Door to Treatment")
plot_d2rx <- ggplot(df_d2rx, aes(x = quarter, y = median)) +
  geom_col(aes(fill = evt), color="black") +
  scale_x_discrete(labels=plot_data$label) +
  scale_y_continuous(breaks=pretty_breaks()) +
  labs(title = "Door to Treatment", x = NULL, y = "Time (minutes)") +
  theme(
    panel.grid.minor = element_blank(),
    axis.text.x = element_text(angle=45,hjust=1),
    legend.position = "none"
  ) +
  scale_fill_manual(values=pal[3])

## Facetted other plots
df_o <- plot_data %>% filter(evt != "Door to Treatment")
plot_o <- ggplot(df_o, aes(x = quarter, y = median)) +
  geom_col(aes(fill = evt), color="black") +
  facet_wrap(~evt, nrow=2, scales="free_x", strip.position = 'top') +
  scale_y_continuous(limits=c(0, y_scale_max), breaks=pretty_breaks()) +
  scale_x_discrete(labels=plot_data$label) +
  labs(x = NULL, y = "Time (minutes)") +
  theme(
    panel.grid.minor = element_blank(),
    axis.text.x = element_text(angle=45,hjust=1),
    axis.line=element_line(),
    legend.position = "none"
  ) +
  scale_fill_brewer(palette=2)

# Combine Plots
# Combo of main plot and a facetted plot
pgrid <- plot_grid(plot_d2rx, plot_o)

# Write plot to file
plot_path <- file.path(here::here(), "door_to_events.png")
ggsave(plot_path, pgrid, device="png", width=10, height=7, units="in", dpi=72)


# Extract bird traits

# Install devtools if not available
# if(!"remotes" %in% installed.packages()[,"Package"]) install.packages("remotes")

# Install traitdata package from Github
# remotes::install_github("RS-eco/traitdata")

# load packages
library(traitdata)
library(dplyr)

## Load the Canadian dataset

clpi <- read.csv("data-raw/CIEE_LPI_dataset.csv")

# subset to birds
sp_birds <- filter(lpd, Class %in% c("Aves", "Birds")) %>% summarise(sp = unique(Binomial))

# convert to a vector
sp_birds <- sp_birds$sp

## 1. Extract avian elton traits

# load Elton Traits
data("elton_birds")

# extract data
clpi_eltonbirds <- elton_birds %>%
  # switch out species for _ in the species names to match the LPD
  mutate(scientificNameStd = gsub(" ", "_", scientificNameStd)) %>%
  # filter for species who are in the LPD dataset
  filter(scientificNameStd %in% sp_birds) %>%
  # subset to the traits we want
  subset(select = c(scientificNameStd,
                    Diet.5Cat,
                    BodyMass.Value))

# look at the dataset
summary(clpi_eltonbirds)

# check which species are missing body mass data
clpi_eltonbirds[which(is.na(clpi_eltonbirds$Diet.5Cat)), "scientificNameStd"]
clpi_eltonbirds[which(is.na(clpi_eltonbirds$BodyMass.Value)), "scientificNameStd"]

colnames(clpi_eltonbirds)[1] <- "Binomial"

## 2. Extract avian body size

# load avian body size data
data("AvianBodySize")

# extract data
clpi_aviansize <- AvianBodySize %>%
  # switch out species for _ in the species names to match the LPD
  mutate(scientificNameStd = gsub(" ", "_", scientificNameStd)) %>%
  # filter for species who are in the LPD dataset
  filter(scientificNameStd %in% sp_birds) %>%
  # subset to the traits we want
  subset(select = c(scientificNameStd,
                    M_mass,
                    F_mass)) %>%
  # change -999.0 to NAs
  mutate(M_mass = replace(M_mass, M_mass == -999.0, NA),
         F_mass = replace(F_mass, F_mass == -999.0, NA))
  # compute average for male and female mass

# look at the dataset
summary(clpi_aviansize)

# check which species are missing body mass data
clpi_aviansize[which(is.na(clpi_aviansize$mass)), "scientificNameStd"]
colnames(clpi_aviansize)[1] <- "Binomial"

## Join to the larger clpi dataset

clpi_birds <- clpi %>%
                left_join(clpi_eltonbirds, by = "Binomial") %>%
                left_join(clpi_aviansize, by = "Binomial")

# change NAs to NULL
clpi_birds[is.na(clpi_birds)] <- "NULL"

head(clpi_birds)

# write to rds
saveRDS(clpi_birds, "data-clean/LPI_birds.rds")


print("--------------- File mobility-regression.r")

library(lubridate)
library(modelr)
library(broom)
library(tidyverse)
library(visdat)
library(mlr3verse)

source("./read-mobility.r")

forecast_googleMob <- function(codeToName, stateList) {
  # read data

  # google
  google_data <- read_google_mobility(codeToName = codeToName, regression = TRUE)

  statedf <- as.data.frame(stateList)

  colnames(statedf) <- "sub_region_1"
  google_data <- left_join(google_data, statedf, by = c("sub_region_1"))

  # new foursquare data
  new_foursquare <- read_csv("../modelInput/mobility/visit-data/visitdata-grouped.csv")
  new_foursquare$categoryname <- as.factor(new_foursquare$categoryname)

  # c("Airport" ,  "Arts & Entertainment"        "Banks"
  # [5] "Beach"                       "Big Box Stores"              "Bus"                         "Colleges & Universities"
  # [9] "Convenience Store"           "Discount Stores"             "Drug Store"                  "Events"
  # [13] "Fast Food Restaurants"       "Fitness Center"              "Food"                        "Gas Stations"
  # [17] "Government"                  "Grocery"                     "Gun Shops"                   "Hardware Stores"
  # [21] "Hotel"                       "Light Rail Stations"         "Medical"                     "Metro Stations"
  # [25] "Nightlife Spots"             "Office"                      "Outdoors & Recreation"       "Professional & Other Places"
  # [29] "Residences"                  "School"                      "Shops & Services"            "Skiing"
  # [33] "Spiritual Center"            "Sports"                      "Travel & Transport"

  sfsq <- new_foursquare %>%
    filter(categoryname != "Skiing", demo == "All") %>%
    select(c(-demo, -county, -p50Duration)) # revisit p50

  # notice: visit data is only by state, not by county -> this is okay
  # just apply the same state-level signal to every county
  # just need to generate a functional table at this point
  google_cleaned <- google_data %>%
    select(date, state = sub_region_1, retail.recreation, grocery.pharmacy, parks, transitstations, workplace, residential) %>%
    filter(state != "")

  print("google last obs:")
  print(tail(google_cleaned$date, 1))
  print("visitdata last obs:")
  print(tail(sfsq$date, 1))

  mobility_data <- left_join(sfsq, google_cleaned, by = c("state" = "state", "date" = "date"))

  # mobility_data <- mobility_data %>% #  filter(!(state %in% c("Alaska", "District of Columbia", "Hawaii")))
  mobility_data <- mobility_data %>%
    pivot_wider(names_from = categoryname, values_from = c(avgDuration, visits))
  mobility_data$state <- as.factor(mobility_data$state)
  names(mobility_data) <- make.names(names(mobility_data), unique = TRUE)

  # check fit on last week
  last_google <- ymd((mobility_data %>% filter(!is.na(retail.recreation)) %>% summarise(last(date)))[[1, 1]])
  train_stop <- last_google - 6

  # foursquare broken then # should be fine
  mobility_data <- mobility_data %>% filter(date != ymd("2020-04-19"))

  # need to remove date for mlr
  mobility_data <- mobility_data %>% arrange(date)
  mobility_data$id <- c(1:nrow(mobility_data))

  train_end_id <- (mobility_data %>% filter(date == train_stop) %>% summarise(last(id)))[[1, 1]]
  google_end_id <- (mobility_data %>% filter(date == last_google) %>% summarise(last(id)))[[1, 1]]
  dates <- mobility_data$date
  mobility_data <- mobility_data %>% select(c(-date, -categoryid))

  # revisit imputation
  mobility_data <- mobility_data %>% fill(names(mobility_data), .direction = "updown")

  # convert single-item list cols to numeric
  tmp <- sapply(mobility_data, class)
  mobility_data[tmp == "list"] <- sapply(mobility_data[tmp == "list"], function(l) l[1])

  print("retail.recreation")
  task <- TaskRegr$new(id = "retail.recreation", backend = as.data.frame(mobility_data %>%
    select(c(-"grocery.pharmacy", -"parks", -"transitstations", -"workplace", -"residential"))), target = "retail.recreation")
  learner <- lrn("regr.ranger")
  train_set <- c(1:train_end_id)
  test_set <- c((train_end_id + 1):google_end_id)
  learner$train(task, row_ids = train_set)
  prediction <- learner$predict(task, row_ids = test_set)
  abs(prediction$truth - prediction$response)
  df_lastweek <- data.frame(id = prediction$row_ids, retail.recreation = (abs(prediction$truth - prediction$response)))
  train_set <- c(1:google_end_id)
  test_set <- setdiff(seq_len(task$nrow), train_set)
  learner$train(task, row_ids = train_set)
  prediction <- learner$predict(task, row_ids = test_set)
  mobility_data[test_set, "retail.recreation"] <- prediction$response

  print("grocery.pharmacy")
  task <- TaskRegr$new(
    id = "grocery.pharmacy", backend = as.data.frame(mobility_data %>%
      select(c(-"retail.recreation", -"parks", -"transitstations", -"workplace", -"residential"))),
    target = "grocery.pharmacy"
  )
  learner <- lrn("regr.ranger")
  train_set <- c(1:train_end_id)
  test_set <- c((train_end_id + 1):google_end_id)
  learner$train(task, row_ids = train_set)
  prediction <- learner$predict(task, row_ids = test_set)
  abs(prediction$truth - prediction$response)
  df_lastweek <- cbind(df_lastweek, data.frame(grocery.pharmacy = (abs(prediction$truth - prediction$response))))
  train_set <- c(1:google_end_id)
  test_set <- setdiff(seq_len(task$nrow), train_set)
  learner$train(task, row_ids = train_set)
  prediction <- learner$predict(task, row_ids = test_set)
  mobility_data[test_set, "grocery.pharmacy"] <- prediction$response

  print("parks")
  task <- TaskRegr$new(
    id = "parks", backend = as.data.frame(mobility_data %>%
      select(c(-"retail.recreation", -"grocery.pharmacy", -"transitstations", -"workplace", -"residential"))),
    target = "parks"
  )
  learner <- lrn("regr.ranger")
  train_set <- c(1:train_end_id)
  test_set <- c((train_end_id + 1):google_end_id)
  learner$train(task, row_ids = train_set)
  prediction <- learner$predict(task, row_ids = test_set)
  abs(prediction$truth - prediction$response)
  df_lastweek <- cbind(df_lastweek, data.frame(parks = (abs(prediction$truth - prediction$response))))
  train_set <- c(1:google_end_id)
  test_set <- setdiff(seq_len(task$nrow), train_set)
  learner$train(task, row_ids = train_set)
  prediction <- learner$predict(task, row_ids = test_set)
  mobility_data[test_set, "parks"] <- prediction$response

  print("transitstations")
  task <- TaskRegr$new(
    id = "transitstations", backend = as.data.frame(mobility_data %>%
      select(c(-"retail.recreation", -"grocery.pharmacy", -"parks", -"workplace", -"residential"))),
    target = "transitstations"
  )
  learner <- lrn("regr.ranger")
  train_set <- c(1:train_end_id)
  test_set <- c((train_end_id + 1):google_end_id)
  learner$train(task, row_ids = train_set)
  prediction <- learner$predict(task, row_ids = test_set)
  abs(prediction$truth - prediction$response)
  df_lastweek <- cbind(df_lastweek, data.frame(transitstations = (abs(prediction$truth - prediction$response))))
  train_set <- c(1:google_end_id)
  test_set <- setdiff(seq_len(task$nrow), train_set)
  learner$train(task, row_ids = train_set)
  prediction <- learner$predict(task, row_ids = test_set)

  mobility_data[test_set, "transitstations"] <- prediction$response

  print("workplace")
  task <- TaskRegr$new(
    id = "workplace", backend = as.data.frame(mobility_data %>%
      select(c(-"retail.recreation", -"grocery.pharmacy", -"parks", -"transitstations", -"residential"))),
    target = "workplace"
  )
  learner <- lrn("regr.ranger")
  train_set <- c(1:train_end_id)
  test_set <- c((train_end_id + 1):google_end_id)
  learner$train(task, row_ids = train_set)
  prediction <- learner$predict(task, row_ids = test_set)
  abs(prediction$truth - prediction$response)
  df_lastweek <- cbind(df_lastweek, data.frame(workplace = (abs(prediction$truth - prediction$response))))
  train_set <- c(1:google_end_id)
  test_set <- setdiff(seq_len(task$nrow), train_set)
  learner$train(task, row_ids = train_set)
  prediction <- learner$predict(task, row_ids = test_set)
  mobility_data[test_set, "workplace"] <- prediction$response

  print("residential")
  task <- TaskRegr$new(
    id = "residential", backend = as.data.frame(mobility_data %>%
      select(c(-"retail.recreation", -"grocery.pharmacy", -"parks", -"transitstations", -"workplace"))),
    target = "residential"
  )
  learner <- lrn("regr.ranger")
  train_set <- c(1:train_end_id)
  test_set <- c((train_end_id + 1):google_end_id)
  learner$train(task, row_ids = train_set)
  prediction <- learner$predict(task, row_ids = test_set)
  abs(prediction$truth - prediction$response)
  df_lastweek <- cbind(df_lastweek, data.frame(residential = (abs(prediction$truth - prediction$response))))
  train_set <- c(1:google_end_id)
  test_set <- setdiff(seq_len(task$nrow), train_set)
  learner$train(task, row_ids = train_set)
  prediction <- learner$predict(task, row_ids = test_set)
  mobility_data[test_set, "residential"] <- prediction$response

  mobility_data$date <- dates

  # error analysis
  df_raw_error <- copy(df_lastweek)
  print("Error last week:")
  print(df_raw_error %>% summarise(
    retail.recreation = mean(retail.recreation),
    grocery.pharmacy = mean(grocery.pharmacy),
    parks = mean(parks), transitstations = mean(transitstations),
    workplace = mean(workplace), residential = mean(residential)
  ))
  df_lastweek <- df_lastweek %>% pivot_longer(c("retail.recreation", "grocery.pharmacy", "parks", "transitstations", "workplace", "residential"),
    names_to = "cat", values_to = "error"
  )

  return(mobility_data)
}

# case-mortality table
d <- read.csv("../modelInput/CaseAndMortalityV2.csv", stringsAsFactors = FALSE)
d$countryterritoryCode <- sapply(d$countryterritoryCode, as.character)
d$countryterritoryCode <- sub("840", "", d$countryterritoryCode)
codeToName <- unique(data.frame("countyCode" = d$countryterritoryCode, "countyName" = d$countriesAndTerritories))
stateList <- unique(d$state)

f <- forecast_googleMob(codeToName = codeToName, stateList = stateList)
google_forecast <- f %>% select(state, retail.recreation, grocery.pharmacy, parks, transitstations, workplace, residential, date)
write.csv(google_forecast, "../modelInput/mobility/google-mobility-forecast.csv", row.names = FALSE)


##CTE534=group
##Imagen=raster
##Vector=vector
##Corte=output raster
Corte <- raster::crop(Imagen, Vector)
Corte


code 'str_contrast_liquid'
name '流动性缺口对照'
dimensions {
	accbook null
	liquidGap null
	stress null
}
layout {
	rows 'accbook'
	columns (['liquidGap','stress'])
}
dataRequest {
	name 'stress1'
	table 'sceLiquid',{
		allDimensions (['accbook','liquidGap'])
	}
	fields 'accbook,liquidGap,principal value'
	contextParams (['stress1'])
}
dataRequest {
	name 'stress2'
	table 'sceLiquid',{
		allDimensions (['accbook','liquidGap'])
	}
	fields 'accbook,liquidGap,principal value'
	contextParams (['stress2'])
}

derivedHeads{
    accbook ([
			new Head(name:'流动性缺口',aggregate:true,
				formula:{
					def grids=thisColGrids({parent==null})
					def a=grids.find{it.rowHeadGrid.model?.alType=='A'}
					def l=grids.find{it.rowHeadGrid.model?.alType=='L'}
					if(a && l){
						a-l
					}
				}
			),
			new Head(name:'缺口累计',aggregate:true,
				formula:{
					(col<2)? higher:(cr(-2)+higher)
                })
		])
}
dataGrids {
    apply selectRows({children!=null}),{
		formula {sumChildren()}
	}
	apply sel([scene:'stress2']),{
		params {
			dataRequest 'stress2'
		}
	}
}


cleanup()
incl.sp<-seq(15,23)                      # species number to be included. Numbers or "all"
incl.sp<-"all"
#incl.sp<-1
comp.like<-F

first.pch<-0    # first pch symbol
first.color<-1   # first color

if (F) {
  dirs<-c("bal-1-area-run-00","bal-1-area-run-00-test01","bal-1-area-run-00-test02","bal-1-area-run-00-test03")
  labels<-c("Run 00","test 01","test 02","test 03")
}

for (dir in dirs) {
  if ( file.access(file.path(root,dir,"sms.dat"), mode = 0)!=0)  stop(paste('Directory',dir,'does not exist')) #else cat(dir,'\n')
}

Init.function() # get SMS.contol object  including sp.names
for (dir in dirs) {
  a<-Read.objective.function(dir=file.path(root,dir),read.init.function=FALSE)
  a$dir<-dir
  a$label<-labels[ which(dirs==dir)]

 if (dir==dirs[1]) aa<-a else aa<-rbind(aa,a)

}

bb<-subset(aa,select = c(label,Species, catch, CPUE, SSB.Rec, stomachs,stomachs.N ,penalty))

bb2<-subset(bb,select=c(-Species,-label))
bb3<-aggregate(bb2,list(label=bb$label),sum)
bb3$all<- bb3$catch +bb3$CPUE+bb3$SSB.Rec+bb3$stomachs+bb3$penalty
#print(bb3,digits=1)

read.fit<-function(dir=data.path){
  # Function to read a basic fit
  k<-2
  parfile<-as.numeric(scan(file.path(dir,"sms.par"),
                      what='', n=16, quiet=TRUE)[c(6,11,16)])
  data.frame(n.par=as.integer(parfile[1]),
             neg.log.like=parfile[2],
             max.grad=parfile[3],
           AIC=round(k*parfile[1]+2*parfile[2],2)
           )
}

for (dir in dirs) {
  a<-read.fit(dir=file.path(root,dir))
  a$dir<-dir
    a$label<-labels[ which(dirs==dir)]
 if (dir==dirs[1]) aa<-a else aa<-rbind(aa,a)
}

aa<-subset(aa,select=c(label,n.par,neg.log.like, max.grad,AIC))
if (comp.like) {
  ll<-dim(aa)[[1]]
  aa$dif.like<-NA
  aa$dif.n.par<-NA
  for (i in (2:ll)) {
    aa$dif.like[i]<-abs(aa$neg.log.like[i]-aa$neg.log.like[i-1])
    aa$dif.n.par[i]<-abs(aa$n.par[i]-aa$n.pa[i-1])
  }
  aa$prob.likelihood.ratio<-NA
  for (i in (2:ll))aa[i,]$prob.likelihood.ratio <- 1-pchisq(2*aa[i,]$dif.like,aa[i,]$dif.n.par)
}
aaa<-merge(bb3,aa,by='label')
print(aaa)

write.table(aaa,file=file.path(data.path,"compare_like.csv"),sep=',',row.names=F)


##### Mapping CWHL and NWHL Teams
# Imports ----
library(maps)
library(mapdata)
library(ggplot2)
library(ggthemes)
library(ggrepel) # Helps space labels
library(raster)
# Data input nnd setup ----
teams <- read.csv('nwhl_cwhl.csv')
teams$League <- factor(teams$League,
                       levels = c('NWHL', 'CWHL', 'NWHL/CWHL', 'Independent'))
teams$City <- factor(teams$City)

us <- getData("GADM", country = "USA", level = 1)
canada <- getData("GADM", country = "CAN", level = 1)
states <- c('Connecticut', 'New York', 'New Jersey', 'Massachusetts',
            'Minnesota')
provinces <- c('Ontario', 'Alberta', 'Québec', 'Saskatchewan', 'Manitoba')

us.states <- us[us$NAME_1 %in% states, ]
ca.provinces <- canada[canada$NAME_1 %in% provinces, ]

# Plotting the map ----
countries <- ggplot(
  us.states,
  aes(x = long, y = lat, group = group)
  ) + geom_path(
    size = 0.25,
    color = 'red'
  ) + geom_path(
    data = ca.provinces,
    size = 0.25,
    color = 'red'
  ) + coord_map() + theme(
    panel.grid = element_blank(),
    panel.background = element_rect(fill = 'grey', color = 'white'),
    axis.ticks = element_blank(),
    axis.title = element_blank(),
    axis.text = element_blank()
  )

# Plotting the teams ----
whl <- countries + geom_point(
  data = teams,
  aes(Longitude, Latitude, color = League,
      shape = League, group = NULL),
  size = 2.
  ) + scale_color_manual(
    values = c(
      'NWHL' = 'blue',
      'CWHL' = 'red',
      'NWHL/CWHL' = 'green',
      'Independent' = 'black'
    )
  ) + scale_shape_manual(
    values = c(
      'NWHL' = 15,
      'CWHL' = 16,
      'NWHL/CWHL' = 17,
      'Independent' = 18
    )
  ) + geom_text_repel(
  data = teams,
  aes(Longitude, Latitude, label = City, group = NULL),
  color = 'black',
  size = 4) + ggtitle("Professional Women's Hockey Teams") + theme(
    plot.title = element_text(hjust = 0.5), # Centers the title
    legend.background = element_blank()
  )

whl


################################################################################
# lociSelection function
#
# Author: Heidi Lischer
# Date: 8.2009
################################################################################

lociSelection <- function(pValList, FStatCiList, timeAttr, outfile, fStat){

    if(fStat == "FST"){
        fst <- 3
        fstP <- 4
    } else {
        fst <- 5
        fstP <- 6
    }

    MaxHet <- max(pValList[,2])
    MaxF <- max(pValList[,fst])
    if(max(FStatCiList[,8]) > MaxF){
      MaxF <- max(FStatCiList[,8])
    }

    MinHet <- 0
    MinF <- 0

    if(min(pValList[,2]) < 0){
      MinHet <- min(pValList[,2])
    }
    if(min(pValList[,fst]) < 0){
      MinF <- min(pValList[,fst])

      if(min(FStatCiList[,2]) < MinF){
        MinF <- min(FStatCiList[,2])
      }
    }

    FST_h0.05 <- pValList[pValList[,fstP] > 0.05, c(2, fst)]
    pValList_l0.05 <- pValList[pValList[,fstP] <= 0.05, ]

    lociNames_0.05_lowFst <- list()
    lociNames_0.05_highFst <- list()
    dh <- 1
    dl <- 1
    for(i in nrow(pValList_l0.05)){
      #test for high/low FST
      index <- 1
      while(FStatCiList[index, 1] <= pValList_l0.05[i, 2] & index < nrow(FStatCiList)){
        index <- index + 1
      }
      limit <- FStatCiList[index, 5]

      if(FStatCiList[index, 5] > pValList_l0.05[i, fst]){
        lociNames_0.05_lowFst[[dl]] <- pValList_l0.05[i, 1]
        dl <- dl + 1
      } else {
        lociNames_0.05_highFst[[dh]] <- pValList_l0.05[i, 1]
        dh <- dh + 1
      }
    }
    lociNames_0.05_lowFst <- as.vector(as.character(lociNames_0.05_lowFst))
    lociNames_0.05_highFst <- as.vector(as.character(lociNames_0.05_highFst))

    FST_0.05 <- pValList_l0.05[pValList_l0.05[,fstP] > 0.01, c(2, fst)]
    FST_0.01 <- pValList[pValList[,fstP] <= 0.01, c(2, fst)]
    lociNames_0.01 <- as.character(pValList[pValList[,fstP] <= 0.01, 1])
    pValList_l0.01 <- pValList[pValList[,fstP] <= 0.01, ]

    lociNames_0.01_lowFst <- list()
    lociNames_0.01_highFst <- list()
    eh <- 1
    el <- 1
    for(i in nrow(pValList_l0.01)){
      #test for high/low FST
      index <- 1
      while(FStatCiList[index, 1] <= pValList_l0.01[i, 2] & index < nrow(FStatCiList)){
        index <- index + 1
      }

      if(FStatCiList[index, 5] > pValList_l0.01[i, fst]){
        lociNames_0.01_lowFst[[el]] <- pValList_l0.01[i, 1]
        el <- el + 1
      } else {
        lociNames_0.01_highFst[[eh]] <- pValList_l0.01[i, 1]
        eh <- eh + 1
      }
    }
    lociNames_0.01_lowFst <- as.vector(as.character(lociNames_0.01_lowFst))
    lociNames_0.01_highFst <- as.vector(as.character(lociNames_0.01_highFst))

    write.table(lociNames_0.01_lowFst, paste(outfile, "LociUnderSelection_low", fStat, "_0.01.txt", sep=""), quote=FALSE, row.names=FALSE, col.names=c("loci"))
    write.table(lociNames_0.05_lowFst, paste(outfile, "LociUnderSelection_low", fStat, "_0.05.txt", sep=""), quote=FALSE, row.names=FALSE, col.names=c("loci"))
    write.table(lociNames_0.01_highFst, paste(outfile, "LociUnderSelection_high", fStat, "_0.01.txt", sep=""), quote=FALSE, row.names=FALSE, col.names=c("loci"))
    write.table(lociNames_0.05_highFst, paste(outfile, "LociUnderSelection_high", fStat, "_0.05.txt", sep=""), quote=FALSE, row.names=FALSE, col.names=c("loci"))

  # graphic---------------------------------------------------------------------
  outfileGraphic <- paste(outfile, "lociSelection_", fStat," ", timeAttr,".png",
                           sep="")

  #save graphic
   png(outfileGraphic, width = 1300, height = 1300, res=144)

      plot(FST_h0.05, cex=0.8, xlab="Heterozygosity", ylab="", main="",
            xlim=c(MinHet, MaxHet), ylim=c(MinF, MaxF), cex.axis=0.9)

      if(fStat == "FST"){
        mtext(text=expression(bold(Detection~of~loci~under~selection~from~genome~scans~based~on~F[ST])),
                 side=3, line=1.5, cex=1.2)
        mtext(text=expression(F[ST]), side=2, line=2.5, cex=1.2)
      } else {
        mtext(text=expression(bold(Detection~of~loci~under~selection~from~genome~scans~based~on~F[CT])),
                 side=3, line=1.5, cex=1.2)
        mtext(text=expression(F[CT]), side=2, line=2.5, cex=1.2)
      }

      if(length(FST_0.05) != 0){
         points(FST_0.05, pch=16, cex=0.8, col="blue")
      }
      if(length(FST_0.01) != 0){
        points(FST_0.01, pch=16, cex=0.8, col="red3")
      }

      lines(FStatCiList[,1], FStatCiList[,5])

      lines(FStatCiList[,1], FStatCiList[,4], lty=5)
      lines(FStatCiList[,1], FStatCiList[,6], lty=5)

      lines(FStatCiList[,1], FStatCiList[,3], lty=2, col="blue")
      lines(FStatCiList[,1], FStatCiList[,7], lty=2, col="blue")

      lines(FStatCiList[,1], FStatCiList[,2], lty=3, col="red3")
      lines(FStatCiList[,1], FStatCiList[,8], lty=3, col="red3")

      legend("topleft",
             c("", "", "", "50% quantile", "10% quantile", "5% quantile", "1% quantile"),
             lty=c(1, 1, 1, 1, 5, 2, 3),
             col=c("white", "white", "white", "black", "black", "blue", "red3"),
             cex=0.8,  bty="n")

      legend("topleft", legend=c("p > 5%", "p <= 5%", "p <= 1%"),
             pch=c(1, 16, 16), col=c("black", "blue", "red3"), cex=0.8, bty="n")

  dev.off()

  # graphic---------------------------------------------------------------------
  outfileGraphic <- paste(outfile, "lociSelection_Names_", fStat," ", timeAttr,".png",
                           sep="")

  #save graphic
  png(outfileGraphic, width = 1300, height = 1300, res=144)

      plot(FST_h0.05, cex=0.8, xlab="Heterozygosity", ylab="", main="",
            xlim=c(MinHet, MaxHet), ylim=c(MinF, MaxF), cex.axis=0.9)

      if(fStat == "FST"){
        mtext(text=expression(bold(Detection~of~loci~under~selection~from~genome~scans~based~on~F[ST])),
                 side=3, line=1.5, cex=1.2)
        mtext(text=expression(F[ST]), side=2, line=2.5, cex=1.2)
      } else {
        mtext(text=expression(bold(Detection~of~loci~under~selection~from~genome~scans~based~on~F[CT])),
                 side=3, line=1.5, cex=1.2)
        mtext(text=expression(F[CT]), side=2, line=2.5, cex=1.2)
      }

      if(length(FST_0.05) != 0){
         points(FST_0.05, pch=16, cex=0.8, col="blue")
      }
      if(length(FST_0.01) != 0){
        points(FST_0.01, pch=16, cex=0.7, col="red3")
        text(FST_0.01, lociNames_0.01, adj = c(-0.3,0.3), cex=0.75, col="red3")
      }

      lines(FStatCiList[,1], FStatCiList[,5])

      lines(FStatCiList[,1], FStatCiList[,4], lty=5)
      lines(FStatCiList[,1], FStatCiList[,6], lty=5)

      lines(FStatCiList[,1], FStatCiList[,3], lty=2, col="blue")
      lines(FStatCiList[,1], FStatCiList[,7], lty=2, col="blue")

      lines(FStatCiList[,1], FStatCiList[,2], lty=3, col="red3")
      lines(FStatCiList[,1], FStatCiList[,8], lty=3, col="red3")

      legend("topleft",
             c("", "", "", "50% quantile", "10% quantile", "5% quantile", "1% quantile"),
             lty=c(1, 1, 1, 1, 5, 2, 3),
             col=c("white", "white", "white", "black", "black", "blue", "red3"),
             cex=0.8,  bty="n")

      legend("topleft", legend=c("p > 5%", "p <= 5%", "p <= 1%"),
             pch=c(1, 16, 16), col=c("black", "blue", "red3"), cex=0.8, bty="n")

  dev.off()
}


#Usage:
#Rscript quality_control.r lower_bound upper_bound min_gene_expression min_cells
library("monocle")
library("reshape")
args <- commandArgs(trailingOnly=TRUE)
lower_bound <- as.numeric(args[1])
upper_bound <- as.numeric(args[2])
min_gene_expression <- as.numeric(args[3])
min_cells <- as.numeric(args[4])

if(length(args)!=4)
{
	print("Usage: Rscript quality_control.r lower_bound upper_bound min_gene_expression min_cells")
}
fpkm_matrix <- read.table('genes.fpkm_table', sep="\t", header = TRUE, row.names=1) # fpkm matrix
sample_sheet<- read.delim("samples.table", row.names=1) # sample sheet
gene_annotations<- read.delim("genes.attr_table", row.names=1) # gene annotations
fd<- new("AnnotatedDataFrame", data = gene_annotations)
pheno.data <- colnames(fpkm_matrix)
pheno.data <- unlist(lapply(pheno.data, function(x) strsplit(x, '_')[[1]][1]))
pheno.data.df <- data.frame(type=pheno.data)
rownames(pheno.data.df) <- colnames(fpkm_matrix)
row_names <- rownames(pheno.data.df)
pheno.data.df$name <- row_names
pheno.data.df$type <- NULL
pd <- new('AnnotatedDataFrame', data = pheno.data.df)
HSMM <- newCellDataSet(as.matrix(fpkm_matrix), phenoData = pd, featureData = fd)
pData(HSMM)$Total_mRNAs <- Matrix::colSums(exprs(HSMM))
HSMM <- detectGenes(HSMM, min_expr = min_gene_expression)
HSMM <- HSMM[,pData(HSMM)$Total_mRNAs > lower_bound & pData(HSMM)$Total_mRNAs < upper_bound]
is_significant_gene <- apply(exprs(HSMM),1,function(x) length(x[x>min_gene_expression])>min_cells)
gene_names <- names(which(is_significant_gene == TRUE))
write.table(length(gene_names),"num_genes.txt", sep="\t",quote=FALSE)
fData(HSMM) <- fData(HSMM)[gene_names,]
new_fpkm <- fpkm_matrix[gene_names,]
fd<- new("AnnotatedDataFrame", data = fData(HSMM))
pd<- new("AnnotatedDataFrame", data = pData(HSMM))
#print(names(is_significant_gene)[1])
#print(length(names(is_significant_gene)))

#significant_genes <- row.names(subset(exprs(HSMM)), length(exprs(HSMM)[exprs(HSMM) > 1]))

##expressed_genes <- row.names(subset(fData(HSMM), num_cells_expressed >= 3))
##fData(HSMM) <- fData(HSMM)[expressed_genes,]

#fData(HSMM) <- fData(HSMM)[,expressed_genes]
#HSMM <- newCellDataSet(as.matrix(fpkm_matrix), phenoData = pd, featureData = fData(HSMM))

##fd<- new("AnnotatedDataFrame", data = fData(HSMM))
##pd<- new("AnnotatedDataFrame", data = pData(HSMM))
##new_fpkm <- fpkm_matrix[expressed_genes,]
HSMM <- newCellDataSet(as.matrix(new_fpkm), phenoData = pd, featureData = fd)
##print(head(exprs(HSMM)))
##print(head(fData(HSMM)))
##print(nrow(fData(HSMM)))
saveRDS(HSMM,'post_quality_control_data.rds')
pData(HSMM)$Size_Factor <- NULL
rownames(pData(HSMM)) <- NULL
pData(HSMM)$Total_mRNAs <- Matrix::colSums(exprs(HSMM))
write.table(pData(HSMM), "post_quality_control.txt", sep="\t",quote=FALSE)


#' Create Network Reaches, Points and Transects
#'
#' Splits network COMIDs into reaches, identifies midpoints
#' and creates lateral transects
#'
#' @param network a single network extracted from NHDPlusV2
#' @param vaa NHDPlusV2 value added attributes table, PlusFlowlineVAA.dbf"
#' @param n number of reaches per network COMID
#' @param what one of c("reaches", "midpoints", "transects")
#' @param NHDCatchments NHDPlusV2 catchment coverage, Catchment.shp, required if what = "transects"
#' @param keep.divergent logical keep divergent flow paths
#'
#' @return sf object of either lines or points. Transects are perpendicular to the reach
#'
#' @export

net_sample <- function(network, vaa, n = 5, what = c("reaches", "midpoints", "transects"),
                       NHDCatchments = NULL, keep.divergent =  F){

  names(vaa)<-toupper(names(vaa))
  #need to supply catchment
  if (what == "transects" & is.null(NHDCatchments)){
    stop("must supply NHDCatchments for transects")
  }

  #drop divergent paths
  if(!keep.divergent){
    mainpath <- vaa[vaa$STREAMORDE == vaa$STREAMCALC, "COMID"]
    network <- network[network$COMID %in% mainpath, ]
  }

  splits <- seq(0, 1, by = 1/n)
  start <- splits[-length(splits)]
  end <- splits[-1]

  lines <- sf::st_cast(network[["geometry"]], "LINESTRING")

  #lines<-network[1,]
  lines <- sf::st_transform(lines, 5070)

  #splits flowlines into equal parts (line segments)
  lines <- lapply(lines, function(z)
    sf::st_sfc(sapply(1:n, simplify = F, function(x)
      lwgeom::st_linesubstring(z, start[x], end[x], 0.001)),
      crs = 5070))

  if(what == "reaches"){
    #name output
    names(lines) <- network$COMID
    lines <- sapply(names(lines), simplify = F, function(x)
      sf::st_as_sf(data.frame(PointID = 1:length(lines[[x]]), COMID = x, lines[[x]])))
    lines <- do.call(rbind,lines)
    lines <- sf::st_transform(lines, crs = sf::st_crs(network))
    return(lines)
  }

  #find midpoints of each line
  coords <- lapply(lines, function(g)
    sf::st_sfc(lapply(g, function(x)
      sf::st_point(get_mids(sf::st_coordinates(x)[,c(1,2)]))),
      crs = 5070))

  if (what == "midpoints"){
    #name output
    names(coords) <- network$COMID
    coords <- sapply(names(coords), simplify = F, function(x)
      sf::st_as_sf(data.frame(PointID = 1:length(coords[[x]]), COMID = x, coords[[x]])))
    coords <- do.call(rbind,coords)
    coords <- sf::st_transform(coords, crs = sf::st_crs(network))
    return(coords)
  }

  #need to supply catchment
  if (what == "transects"){

    cats <- NHDCatchments[NHDCatchments$FEATUREID %in% network$COMID, ]
    cats <- sf::st_transform(cats, crs = 5070)

    #some times the flowlines do not have catchments
    network2 <- network[which(network$COMID%in%cats$FEATUREID),]
    lines <- lines[which(network$COMID%in%cats$FEATUREID)]
    coords <- coords[which(network$COMID%in%cats$FEATUREID)]

    q <- sapply(1:length(network2$COMID), simplify = F, function(p){
      #p<-667
      #for(p in 1:length(network2$COMID)){
      #print(p)}
      cat <- cats[cats$FEATUREID==network2$COMID[p],]
      lns <- lines[[p]]
      mid_coord <- coords[[p]]

      #uses bounding box of catchment to determine transect length
      box <- sf::st_bbox(cat)

      vert <- sf::st_linestring(as.matrix(rbind(c(box$xmin,box$ymin), c(box$xmin,box$ymax))))
      vert <- sf::st_length(vert)

      horiz <- sf::st_linestring(as.matrix(rbind(c(box$xmin,box$ymin),c(box$xmax,box$ymin))))
      horiz <- sf::st_length(horiz)

      mxln <- max(horiz, vert)

      z <- sapply(1:n, simplify = F, function (s){
        #s<-4
        #coordinates for straingt line connecting start & end points of reach
        tcoords <- sf::st_coordinates(lns[s])
        pos_vec <- tcoords[1, c("X","Y")] - tcoords[nrow(tcoords), c("X","Y")]

        #perpendicular lines have dot product sum(pos_vec*opp_pos) = 0
        #transpose and make one negative
        opp_pos <- c(X = pos_vec["Y"], Y = -1*pos_vec["X"])

        #divied by magnitude such that its a unit vector...
        #unitvectors have magnutude == 1; dist(rbind(c(0,0),unitvector))
        #sqrt((opp_pos[1]^2) + (opp_pos[2]^2)) is distance formula (magnitude)
        #starting form 0,0
        unitvector <- opp_pos/sqrt((opp_pos[1]^2) + (opp_pos[2]^2))

        mpt <- mid_coord[s]
        mpt <- sf::st_coordinates(mpt)

        #calculate transect on either sidt of midpoint
        zneg <- c(mpt - (mxln * as.numeric(opp_pos)))
        zpos <- c(mpt + (mxln * as.numeric(opp_pos)))
        transect <- sf::st_sfc(sf::st_linestring(rbind(zpos,zneg)), crs = 5070)
        transect <- sf::st_cast(sf::st_intersection(transect, cat), "LINESTRING")

        #sometimes the transect can intersect catchment multipl times
        #choose the line that intersects the straight channel
        #that its peprpendicular to

        if(length(transect)>1){
          #stop()
          tcoords <- sf::st_linestring(rbind(tcoords[1,c("X","Y")],tcoords[nrow(tcoords),c("X","Y")]))
          transect <- transect[sf::st_intersects(transect, tcoords, sparse = F),]
          #plot(transect, add = T, col = "green")
        }

        return (sf::st_as_sf(transect))
      })

      if(any(unlist(lapply(z, function(x) nrow(x)))>0)){
        z <- sf::st_as_sf(data.frame(COMID = network2$COMID[p],
                                     PointID = which(unlist(lapply(z, function(x) nrow(x)))>0),
                                     sf::st_geometry(do.call(rbind, z))))
      }
      #return(z)

    })

    q <- do.call(rbind, q)
    q <- sf::st_transform(q, crs = sf::st_crs(network))

    return(q)
  }
}

#' INTERNAL FUNCTION identify midpoints
#'
#' identify mid point from a set of points
#' used in net sample points
#'
#' @param coords coordinates to identify midpoint
#'
#' @details adapted from View(maptools:::getMidpoints)
#'
#' @return  midpoint returned from set of points

get_mids <- function (coords) {
  dist <- sqrt((diff(coords[, 1])^2 + (diff(coords[, 2]))^2))
  dist_mid <- sum(dist)/2
  dist_cum <- c(0, cumsum(dist))
  end_index <- which(dist_cum > dist_mid)[1]
  start_index <- end_index - 1
  start <- coords[start_index, ]
  end <- coords[end_index, ]
  dist_remaining <- dist_mid - dist_cum[start_index]
  mid <- start + (end - start) * (dist_remaining/dist[start_index])
  return(mid)
}

#flowlines <- net_p1[[1]]

#' @title merge adjacent line segements of the same class
#'
#' @description function takes a series of flowlines and merges adjacent line segments
#' of the same class
#'
#' @param lines an sf object of LINESTRING
#' @param groupName field containing classification
#'
#' @return sf object with adjacent lines of the same class merged together
#'
#' @export

merge_lines <- function(lines, groupName = "grps"){

  q<-lapply(split(lines, sf::st_set_geometry(lines[,groupName], NULL)), function(x){

    #q<-split(lines, st_set_geometry(lines[,groupName], NULL)
    #x<-q[[3]]

    #intersecting lines with themselves
    net_int <- suppressWarnings(sf::st_intersection(x))

    #merge the list elements that contain the same index
    inlist <- net_int$origins

    outlist <- list()
    count <- 1

    #inlist elements are iterariively removed
    while(length(inlist) > 0){
      j <- inlist[[1]]

      #iteratively match across list elements
      while(any(do.call(rbind, lapply(inlist, function (x) any(x %in% j))))){
        #index of matching elements
        ind <- do.call(rbind, lapply(inlist, function (x) any(x %in% j)))
        #new values to combine
        j <- unique(append(j, unique(unlist(inlist[ind])), length(j)))
        #update to remove elements that need to be combined
        inlist <- inlist[!ind]
      }

      #update new list with values
      outlist[[count]] <- j
      count <- count + 1
    }

    if (length(setdiff(1:nrow(x), sort(unlist(outlist))))!=0|
        any(duplicated(sort(unlist(outlist))))){

      stop("something is wrong")
    }

    nmatrix <- lapply(outlist, function(z) sf::st_line_merge(sf::st_combine(x[z,])))

    nmatrix <- lapply(nmatrix, function(w)
      sf::st_sf(data.frame(groupName = unique(sf::st_set_geometry(x[,groupName],NULL))),
                geometry = w))
    nmatrix <- do.call(rbind, nmatrix)
    nmatrix$patchid <- 1:nrow(nmatrix)

    return(nmatrix)
  })

  return(do.call(rbind,q))
}

#' @title sf to tidygraph
#'
#' @description creates tidy graph from sf object
#'
#' @param x sf network
#' @param directed logical
#'
#' @return super useful graph
#'
#' @details adapted from https://www.r-spatial.org/r/2019/09/26/spatial-networks.html embedded within class metrics
#'
#' @importFrom magrittr %>%
#'
#' @export
#'

sf_to_tidygraph <- function(x, directed = TRUE) {
  #x<-splitln
  L1<-edgeID<-.<-xy<-start_end<-nodeID<-geometry<-NULL
  edges <- x %>%
    dplyr::mutate(edgeID = c(1:dplyr::n()))

  nodes <- edges %>%
    sf::st_coordinates() %>%
    dplyr::as_tibble() %>%
    dplyr::rename(edgeID = L1) %>%
    dplyr::group_by(edgeID) %>%
    dplyr::slice(c(1, dplyr::n())) %>%
    dplyr::ungroup() %>%
    dplyr::mutate(start_end = rep(c('start', 'end'), times = dplyr::n()/2)) %>%
    dplyr::mutate(xy = paste(.$X, .$Y)) %>%
    dplyr::mutate(nodeID = tidygraph::group_indices(., factor(xy, levels = unique(xy)))) %>%
    dplyr::select(-xy)

  source_nodes <- nodes %>%
    dplyr::filter(start_end == 'start') %>%
    dplyr::pull(nodeID)

  target_nodes <- nodes %>%
    dplyr::filter(start_end == 'end') %>%
    dplyr::pull(nodeID)

  edges = edges %>%
    dplyr::mutate(from = source_nodes, to = target_nodes)

  nodes <- nodes %>%
    tidygraph::distinct(nodeID, .keep_all = TRUE) %>%
    dplyr::select(-c(edgeID, start_end)) %>%
    sf::st_as_sf(coords = c('X', 'Y')) %>%
    sf::st_set_crs(sf::st_crs(edges))

  graph <- tidygraph::tbl_graph(nodes = nodes, edges = dplyr::as_tibble(edges), directed = directed)

  graph %>%
    tidygraph::activate(edges) %>%
    dplyr::mutate(length = sf::st_length(geometry))

}

#' @title average distance between patches
#'
#' @description embedded within class metrics
#'
#' @param graph result from sf_todygraph
#' @param net_HGP a classified stream network
#' @param groupName name of field containing classification result
#' @param patch calss value
#'
#' @return long pairwise patch distances
#'
#' @importFrom magrittr %>%
#' @export

patch_dist <- function(graph, net_HGP, groupName, patch = "2"){
  edges<-geometry<-NULL
  plen <- split(net_HGP, sf::st_set_geometry(net_HGP[,groupName], NULL))
  plen <- plen[[patch]]

  nodes <- graph %>%
    tidygraph::activate(nodes)%>%
    dplyr::as_tibble() %>%
    sf::st_as_sf()

  #nodes where patch intersects a matrix
  intnodes <- suppressWarnings(sf::st_intersection(plen, nodes))

  #calculate length of edges and pairwise distances to all nodes
  graph <- graph %>% tidygraph::activate(edges) %>% dplyr::mutate(length = sf::st_length(geometry))
  dist_tbl <- igraph::distances(graph = graph, weights = graph %>% tidygraph::activate(edges) %>% dplyr::pull(length))

  i <- split(intnodes$nodeID,intnodes$patchid)
  j <- split(intnodes$nodeID,intnodes$patchid)

  out<-lapply(i, function(p)
    lapply(j, function(q) {
      m<-dist_tbl[p, q]
      #closest vertex
      d <- min(m)
      indx <- which(m == d, arr.ind = TRUE)
      data.frame(to_node = p[indx[1,1]],
                 from_node = q[indx[1,2]], d)
    }))

  out <- do.call(rbind, lapply(out, function(z) do.call(rbind, z)))
  pnam <- stats::setNames(data.frame(do.call(rbind, strsplit(row.names(out), "\\."))), c("patch_i", "patch_j"))
  out<-cbind(pnam, out)
  out<-merge(data.frame(patch_j = plen$patchid, patch_j_len = sf::st_length(plen)), out, by = "patch_j")
  out<-merge(data.frame(patch_i = plen$patchid, patch_i_len = sf::st_length(plen)), out, by = "patch_i")

  return(out)
}

#' @title Distance-Baised Dendritic Connectivity Index
#'
#' @description calculates modified dentritic connectivity
#' index baised on watercourse distance
#'
#' @param plen_i length of patch i
#' @param plen_j length of patch j
#' @param dist_ij distance separating patch i and patch j
#' @param mu mean dispersal distance
#'
#' @return long pairwise patch distances
#'
#' @details index modified from cote et al 2009
#'
#' median parent offspring dispersal distance is
#' 12km = 12,000m (Comte and Olden 2017)
#'
#' @example
#' mu = 1000; mean(rexp(100000, rate = 1/mu)) ~ 1,000
#'
#' @export

DCI_dist <- function(plen_i, plen_j, dist_ij, mu = 12000){
  #DCI Calculation

  tlen <- sum(unique(plen_i))
  li <- (plen_i / tlen)
  lj <- (plen_j / tlen)

  #probability is dist_tblce based on exponential distribution
  #i.e. the probability of making it past a given dist_tblce
  p <- 1 - stats::pexp(dist_ij, rate = 1/mu)

  #DCI calculation
  DCI <- sum(p * li * lj) * 100

  return(units::set_units(DCI,NULL))

}


install.packages('ggplot2', repos='https://cloud.r-project.org')
install.packages('cowplot', repos='https://cloud.r-project.org')
install.packages('ROCR', repos='https://cloud.r-project.org')
install.packages('mixtools', repos='https://cloud.r-project.org')
install.packages('lars', repos='https://cloud.r-project.org')
install.packages('ica', repos='https://cloud.r-project.org')
install.packages('tsne', repos='https://cloud.r-project.org')
install.packages('Rtsne', repos='https://cloud.r-project.org')
install.packages('fpc', repos='https://cloud.r-project.org')
install.packages('ape', repos='https://cloud.r-project.org')
install.packages('pbapply', repos='https://cloud.r-project.org')
install.packages('igraph', repos='https://cloud.r-project.org')
install.packages('RANN', repos='https://cloud.r-project.org')
install.packages('dplyr', repos='https://cloud.r-project.org')
install.packages('RColorBrewer', repos='https://cloud.r-project.org')
install.packages('irlba', repos='https://cloud.r-project.org')
install.packages('reshape2', repos='https://cloud.r-project.org')
install.packages('gplots', repos='https://cloud.r-project.org')
install.packages('Rcpp', repos='https://cloud.r-project.org')
install.packages('dtw', repos='https://cloud.r-project.org')
install.packages('SDMTools', repos='https://cloud.r-project.org')
install.packages('plotly', repos='https://cloud.r-project.org')
install.packages('diffusionMap', repos='https://cloud.r-project.org')
install.packages('Hmisc', repos='https://cloud.r-project.org')
install.packages('tidyr', repos='https://cloud.r-project.org')
install.packages('ggridges', repos='https://cloud.r-project.org')
install.packages('metap', repos='https://cloud.r-project.org')
install.packages('lmtest', repos='https://cloud.r-project.org')
install.packages('fitdistrplus', repos='https://cloud.r-project.org')
install.packages('png', repos='https://cloud.r-project.org')
install.packages('doSNOW', repos='https://cloud.r-project.org')
install.packages('reticulate', repos='https://cloud.r-project.org')
install.packages('foreach', repos='https://cloud.r-project.org')
install.packages('hdf5r', repos='https://cloud.r-project.org')
install.packages('RcppEigen', repos='https://cloud.r-project.org')
install.packages('RcppProgress', repos='https://cloud.r-project.org')


output$main_misc <- renderUI({
  mainPanel(
    tabsetPanel(
      tabPanel("Critical & Fumbles", uiOutput("misc_crits_ui"))
    )
  )
})

### NPC
output$misc_crits_ui <- renderUI({
  list(
    sidebarLayout(
      sidebarPanel(

        radioButtons(inputId="misc_crits_hitmiss",
                     label="Crit or Fumble",
                     c("Crit", "Fumble"),
                     selected="Crit",
                     inline=FALSE),

        radioButtons(inputId="misc_crits_type",
                     label="Weapon Type",
                     c("Melee", "Ranged"),
                     selected="Melee",
                     inline=FALSE),

        actionButton("misc_crits_fit", "Generate!")
      ),

      mainPanel(
        renderUI({
          localstate$misc_crits
        })
      )
    )
  )
})

misc_crits <- function(input)
{
  observeEvent(input$misc_crits_fit, {
    hitmiss <- input$misc_crits_hitmiss
    type <- input$misc_crits_type

    if (hitmiss == "Crit")
      crit <- gmhelper:::gencrit(type)
    else if (hitmiss == "Fumble")
      crit <- gmhelper:::genmiss(type)

    crit <- sub(paste0("<b>", crit), pattern="!", replacement="!</b>")

    localstate$misc_crits <- HTML(crit)
  })

  invisible()
}


### Explore community compostion for Barrow

# Dependencies
library(dplyr)

# Load community compositon data
load("data/ITEX_ALL.RData")
names(itex.all)

barrow <- itex.all %>% filter(SITE == "BARROW") %>%
  group_by(SUBSITE, GENUS, SPECIES) %>%
  summarise(mean_abundance = mean(Abundance)) %>%
  filter(mean_abundance >= 10)

# Load Janet's ITEX dataset
itex_phen <- read.csv("scripts/users/jassmann/phenology/phenology_data/ITEX_data_Janet/CCIN12722_20171116_Arctic_phenology_database_1992-2014.csv")
sites_of_interest <- c("ALEXFIORD", "BARROW", "ZACKENBERG", "QHI")
phenology <- itex_phen %>% filter(site_name %in% sites_of_interest) %>% group_by(site_name)
site_spp_snow_melt <- phenology %>% group_by(site_name,spp,phenophase, genus, species) %>% summarise(mean_snow_melt = mean(as.numeric(as.character(snowfree_date)), na.rm = T), mean_phenology = mean(day, na.rm = T), difference = mean_phenology - mean_snow_melt, min_year = min(year, na.rm = T), max_year = max(year, na.rm = T), n_years = max_year-min_year+1, n_individ = length(as.character(unique(plot))))
spring_spp <- site_spp_snow_melt %>% filter(difference <= 30 & phenophase != "FlowerEnd" & n_years > 3)

spring_spp_barrow <- spring_spp %>% filter(site_name == "BARROW")

spring_spp_barrow[which(spring_spp_barrow$species %in% barrow$SPECIES),]
barrow[which(barrow$SPECIES %in% spring_spp_barrow$species),]

## Selectes species phenostage combinations are:
selected <- paste0(spring_spp_barrow[which(spring_spp_barrow$species %in% barrow$SPECIES),]$spp, "_",
                   spring_spp_barrow[which(spring_spp_barrow$species %in% barrow$SPECIES),]$phenophase)
selected


#UTMOST *modified

args=as.numeric(commandArgs(TRUE)) #subjobs

options(stringsAsFactors=F)
library(glmnet)
library(foreach)

#load glasso function
source('/home/z***/script/v8/utmost/glasso.r')

#get full gene list
gene_list_geno<-dir('/data/c***/z***/data/gtex/geno/v8/gene/p_1m/')
gene_list_exp<-sub('....$','',dir('/data/c***/z***/projects/cross_tissue/exp_gene/'))
gene_list<-intersect(gene_list_geno,gene_list_exp)

#10 genes per subjob
i_start=min((args-1)*10+1,length(gene_list))
i_end=min(args*10,length(gene_list))

#for testing
#gene_id='ENSG00000134243' #SORT1
#gene_id='ENSG00000198670' #LPA

for (gene_i in i_start:i_end){
  gene_id=gene_list[gene_i]
  print(gene_id)

  ###input data prepare###
  #format transfer for expression data
  dir.create(paste0('/data/c***/z***/projects/cross_tissue/utmost/exp/',gene_id))
  exp<-readRDS(paste0('/data/c***/z***/projects/cross_tissue/exp_gene/',gene_id,'.rds'))
  tissue_list<-unique(exp$tissue)
  for (tissue in tissue_list){
    exp_tmp<-exp[exp$tissue==tissue,-3]
    saveRDS(exp_tmp,paste0('/data/c***/z***/projects/cross_tissue/utmost/exp/',gene_id,'/',tissue,'.rds'))
  }

  #rename sampleid of genotype dosage files
  geno<-read.table(paste0('/data/c***/z***/data/gtex/geno/v8/gene/p_1m/',gene_id),header = T,stringsAsFactors = F)
  geno[,1]<-paste0('GTEX.',geno[,1])
  saveRDS(geno,paste0('/data/c***/z***/projects/cross_tissue/utmost/geno/',gene_id,'.rds'))

  #generate genotype info files
  geno_info<-read.table(paste0('/data/c***/z***/data/gtex/geno/v8/gene/p_1m_info/',gene_id),header = T,stringsAsFactors = F)
  chr_pos<-geno_info[,c(1,2)]
  geno_info<-geno_info[,-2]
  colnames(geno_info)<-c('SNP','REF.0.','ALT.1.')
  write.table(geno_info,paste0('/data/c***/z***/projects/cross_tissue/utmost/info/',gene_id),quote = F,row.names = F,sep='\t')

  ### data import ###
  main_dir='/data/c***/z***/projects/cross_tissue/utmost/'

  dose_path = paste0(main_dir,'geno/',gene_id,'.rds') #dosage
  info_path = paste0(main_dir,'info/',gene_id) #geno info
  Yt_path=paste0(main_dir,'exp/',gene_id,'/')  #expression
  Yt = dir(paste0(main_dir,'exp/',gene_id,'/'))  #tissue list
  ntune = 5  #number of grids for each tuning parameter
  P = length(Yt)
  fold = 5

  if(P){
    ## exp files ##
    Y = list()
    for(t in 1:P){
      Y[[t]] = readRDS(paste0(Yt_path, '/', Yt[t]))
    }
    ssize = unlist(lapply(Y, nrow))  #N of samples for each tissue
    T_num = length(Yt)  #N of tissues

    ## genotype files ##
    dose = readRDS(dose_path)
    dose$id<-dose[,1]
    dose<-dose[,c(1,ncol(dose),2:(ncol(dose)-1))]

    for(j in 3:ncol(dose)){ #center dosage to 0, not sure why
      dose[,j] = dose[,j] - mean(dose[,j])
    }
    N = nrow(dose) #overall genotyped sample size i.e. 838

    ## covariance matrix ##
    tmp = as.matrix(dose[,-(1:2)])
    XX = t(tmp)%*%as.matrix(tmp)/N #var cor matrix
    Xnorm = diag(XX)  #var of dosage
    remove(tmp); remove(XX)
    sub_id = dose[,1]  #subject id 838
    M = ncol(dose) - 2 #no of snps

    sub_id_map = list()  #subject id map for each tissue
    for(t in 1:T_num){
      tmp = rep(0, nrow(Y[[t]]))
      for(j in 1:length(tmp)){
        tmp[j] = which(sub_id==Y[[t]][j,1])
      }
      sub_id_map[[t]] = tmp
    }

    cv_config = cv_helper(N, fold) #cv setting
    cv_perm = cv_config$perm
    cv_idx = cv_config$idx

    single_res_test = list()
    single_lam = matrix(0,fold,P)
    single_theta_est = list()

    multi_res_test = list()
    multi_lam = matrix(0,fold,2)
    multi_theta_est = list()

    multi_res_test2 = list()
    multi_lam2 = array(0, dim=c(fold, P, 2))
    multi_theta_est2 = list()

    res_tune = list()
    rec_lamv = matrix(0, fold, ntune)

    avg_tune_res<-list() #average tuning error
    single_initial_est<-list()

    #----------------------

    for(f in 1:fold){
      print(f)
      #bgt = Sys.time()
      test_index = cv_perm[cv_idx[f,1]:cv_idx[f,2]]
      test_id = sub_id[test_index] #sample id in the testing set
      tuning_index = cv_perm[cv_idx[f%%fold+1,1]:cv_idx[f%%fold+1,2]]
      tuning_id = sub_id[tuning_index] #sample in the 'early stop' set

      #dfs for each set
      X_test = list()
      Y_test = list()
      X_tune = list()
      Y_tune = list()
      X_train = list()
      Y_train = list()
      X_all = list()
      Y_all = list()

      for(t in 1:T_num){
        X_train_tmp = sub_id_map[[t]][!(sub_id_map[[t]]%in%c(test_index,tuning_index))]
        Y_train_tmp = !(sub_id_map[[t]]%in%c(test_index,tuning_index))
        X_tuning_tmp = sub_id_map[[t]][(sub_id_map[[t]]%in%tuning_index)]
        Y_tuning_tmp = (sub_id_map[[t]]%in%tuning_index)
        X_test_tmp = sub_id_map[[t]][(sub_id_map[[t]]%in%test_index)]
        Y_test_tmp = (sub_id_map[[t]]%in%test_index)
        X_train[[t]] = apply(as.matrix(dose[X_train_tmp,-c(1,2)]),2,as.numeric)
        Y_train[[t]] = Y[[t]][Y_train_tmp, 2]
        X_tune[[t]] = apply(as.matrix(dose[X_tuning_tmp,-c(1,2)]),2,as.numeric)
        Y_tune[[t]] = Y[[t]][Y_tuning_tmp, 2]
        X_test[[t]] = apply(as.matrix(dose[X_test_tmp,-c(1,2)]),2,as.numeric)
        Y_test[[t]] = Y[[t]][Y_test_tmp, 2]
        X_all_tmp = sub_id_map[[t]]
        X_all[[t]] = apply(as.matrix(dose[X_all_tmp,-c(1,2)]),2,as.numeric)
        Y_all[[t]] = Y[[t]][,2]

        #rbind training and test set
        X_train[[t]]=rbind(X_train[[t]],X_test[[t]])
        Y_train[[t]]=c(Y_train[[t]],Y_test[[t]])

      }

      ## model training using all of the samples to get lambda range and initial est ##
      if (f==1){
        single_initial_est_all = matrix(0, ncol(X_train[[1]]), T_num) #N of snp by N tissue matrix
        single_summary_all = list()
        for(t in 1:T_num){
          set.seed(as.numeric(sub('^....','',gene_id)))
          tt = cv.glmnet(X_all[[t]], Y_all[[t]], alpha = 0.5, nfolds = 5,nlambda=50,pmax=200) #cv in 100% of the data, do not find the lambda here
          single_summary_all[[t]] = tt
          single_initial_est_all[,t] = tt$glmnet.fit$beta[,which.min(tt$cvm)] #single tissue EN, beta and lambda with best cv error
        }
      }

      ## for each fold
      single_initial_est[[f]] = matrix(0, ncol(X_train[[1]]), T_num) #N of snp by N tissue matrix
      #single_summary = list()
      for(t in 1:T_num){
        set.seed(f)
        #print(length(Y_tune[[t]]))
        tt = cv.glmnet(X_train[[t]], Y_train[[t]], alpha = 0.5, nfolds = 5,nlambda=50,pmax=200) #cv in 100% of the data, do not find the lambda here
        #single_summary[[t]] = tt
        single_initial_est[[f]][,t] = tt$glmnet.fit$beta[,which.min(tt$cvm)] #single tissue EN, beta and lambda with best cv error
      }

      ## use elastic net ests row norm as weights ##
      lam_range = minmax_lambda(single_summary_all) #lambda range
      # sig_norm = apply(single_initial_est[[f]], 1, function(x){sqrt(sum(x^2))}) #norm for each snp
      # sig_norm[sig_norm==0] = rep(min(sig_norm[sig_norm>0]), sum(sig_norm==0))/2  #replace =0 with min?
      # sig_norm = sig_norm/sum(sig_norm) #??? length=N of snps
      # weights2 = 1/sig_norm; weights2 = weights2/sum(weights2);
      #
      # tis_norm = apply(single_initial_est[[f]], 2, function(x){sum(abs(x))})
      # tis_norm[tis_norm==0] = rep(min(tis_norm[tis_norm>0]), sum(tis_norm==0))/2
      # tis_norm = tis_norm/sum(tis_norm)
      # weights1 = 1/tis_norm; weights1 = weights1/sum(weights1);
      lam_V = seq(lam_range[1], lam_range[2], length.out = ntune)

      initial_numeric = as.numeric(single_initial_est[[f]])

      ## preparation
      XY = grad_prep(X_train, Y_train)
      XX_train = lapply(X_train, function(x){t(x)%*%x/nrow(x)})
      spsz = unlist(lapply(X_train,nrow)) #N of samples for each training set
      res_tune[[f]] = array(NA, dim=c(ntune, ntune, P)) #5*5 matrix *49 tissue, to find the best comb of lam1 and lam2

      rec_lamv[f,] = lam_V  #should be the same across 5 folds

      for(lam1 in 1:ntune){
        for(lam2 in 1:ntune){
          print(paste0('lam1= ',lam1,' lam2= ',lam2))
          single_est = matrix(initial_numeric, M, P) #snps by tissue matrix. initial iteration with single tissue estimates, save compute time
          ans = glasso(X=X_train, Y=Y_train, X1=X_tune, Y1=Y_tune, XX=XX_train, XY=XY, Xnorm=Xnorm, lambda1=lam_V[lam1]/spsz, lambda2=lam_V[lam2], theta=single_est)

          #apply to tuning set
          if (lam1==1 & lam2==1){
            multi_res_test[[f]]<-list()
          }
          multi_res_test[[f]][[paste0(lam1,'_',lam2)]] = multi_mse(ans$est, X_tune, Y_tune)

          res_tune[[f]][lam1,lam2, ] = ans$tune_err #tuning err for each lam pair
          remove(single_est); remove(ans);

        }
      }

      avg_tune_res[[f]] = apply(res_tune[[f]], c(1,2), mean) #average tuning error across the tissues for each lambda pair
    }
    #print(rec_lamv)  #should be the same across 5 folds

    #-----------------------------
    #find the best comb of lambda1 and lambda2 across 5 folds
    avg_tune_cross_fold<-matrix(rep(1,ntune*ntune),nrow = ntune,ncol=ntune)
    for (i_tune in 1:ntune){
      for (j_tune in 1:ntune){
        avg_tune_cross_fold[i_tune,j_tune]=mean(c(avg_tune_res[[1]][i_tune,j_tune],avg_tune_res[[2]][i_tune,j_tune],avg_tune_res[[3]][i_tune,j_tune],avg_tune_res[[4]][i_tune,j_tune],avg_tune_res[[5]][i_tune,j_tune]),na.rm = T)
        avg_tune_cross_fold[i_tune,j_tune]<-ifelse(is.na(avg_tune_cross_fold[i_tune,j_tune]),1,avg_tune_cross_fold[i_tune,j_tune])
      }
    }

    #find the best comb for each fold
    best.lam = which(avg_tune_cross_fold == min(avg_tune_cross_fold), arr.ind = TRUE)[1,]

    #predicted expression in tuning set under best lambda comb
    multi_res<-list()
    for(f in 1:ntune){
      multi_res[[f]]<-multi_res_test[[f]][[paste0(as.numeric(best.lam)[1],'_',as.numeric(best.lam)[2])]]
    }

    #combine 5 fold results
    cv_df<-list()
    cv_r<-cv_p<-c()
    for (tissue_i in 1:T_num){
      cv_df[[tissue_i]]<-multi_res[[1]][tissue_i][[1]]

      for(fold_i in 2:fold){
        cv_df[[tissue_i]]<-rbind(cv_df[[tissue_i]],multi_res[[fold_i]][tissue_i][[1]])
      }
      print(nrow(cv_df[[tissue_i]]))
      fit<-cor.test(cv_df[[tissue_i]][,1],cv_df[[tissue_i]][,2])
      cv_r[tissue_i]<-as.numeric(fit$estimate)
      cv_p[tissue_i]<-as.numeric(fit$p.value)

      cv_r[tissue_i]<-ifelse(is.na(cv_r[tissue_i]),0,cv_r[tissue_i])
      cv_p[tissue_i]<-ifelse(is.na(cv_p[tissue_i]),1,cv_p[tissue_i])
    }

    ## generate an estimate with whole data ##
    XY = grad_prep(X_all, Y_all)
    XX_all = lapply(X_all, function(x){t(x)%*%x/nrow(x)})
    ans = glasso_no_early_stopping(X=X_all, Y=Y_all, XX=XX_all, XY=XY, Xnorm=Xnorm, lambda1=lam_V[best.lam[1]]/spsz, lambda2=lam_V[best.lam[2]], theta=single_initial_est_all)

    info = read.table(info_path, header=T, sep='\t')
    downstream_est = data.frame(info[,1:3], ans$est)
    colnames(downstream_est)[4:ncol(downstream_est)]<-Yt

    #-------------------------------------------------------------
    #calculate r and p (retrained)
    pred_exp_list<-list()
    for (tissue_i in 1:length(Yt)){
      tissue_name=sub('....$','',Yt[tissue_i])
      pred_exp_list[[tissue_i]]<-t(apply(X_all[[tissue_i]],function(x) x*downstream_est[,tissue_i+3],MARGIN = 1))
      cor_result<-cor.test(rowSums(pred_exp_list[[tissue_i]]),Y_all[[tissue_i]]) #retrained

      weight_df<-data.frame(gene=gene_id,rsid=downstream_est$SNP,chr_bp=NA,ref_allele=downstream_est$REF.0.,counted_allele=downstream_est$ALT.1.,weight=downstream_est[,tissue_i+3],r2=round((cv_r[tissue_i])^2,3),p=cv_p[tissue_i],lambda=paste0(round(lam_V[best.lam[1]],2),';',round(lam_V[best.lam[2]],2)),r2_rt=as.numeric(cor_result$estimate^2),p_rt=cor_result$p.value,iter=ans$iter)

      #rm 0
      weight_df<-weight_df[weight_df$weight!=0,]

      #anno with chr and pos
      weight_df$chr_bp<-sapply(weight_df$rsid,function(x) chr_pos[which(x==chr_pos[,1]),2])

      if(nrow(weight_df)>0 & cv_r[tissue_i]>0.1 & cv_p[tissue_i]<0.05){
        print(tissue_i)
        saveRDS(weight_df,paste0('/data/c***/z***/projects/v8/weights_cv/ut/',tissue_name,'/',gene_id,'.rds'))
      }

    }

  }

}


#Transforming interactions as binary values (0-1)
binary_interaction <- function(diet_matrix) {
  # matrix of diet interaction can be asymmetric
  # matrix of diet needs to have only interaction values
    # if matrix includes names of species, use that as row and column names, not as part of matrix

  for(i in 1:nrow(diet_matrix)){
    for(j in 1:ncol(diet_matrix)){
      matrix.dims <- dim(diet_matrix)
      if(is.matrix(diet_matrix) == FALSE) {diet_matrix <- as.matrix(diet_matrix)}
      if(identical(matrix.dims,dim(diet_matrix)) == FALSE) {stop("VERIFY TABLE STRUCTURE.  Matrix of diet interaction can be asymmetric. Matrix of diet needs to have only interaction values. If matrix includes names of species, use that as row and column names, not as part of matrix")}
      if(diet_matrix[i,j] == "0") {NULL} else {diet_matrix[i,j] <- "1"}
    }
  }
  diet_matrix <- apply(diet_matrix,2,as.numeric)

  return(diet_matrix)
}


#!/usr/bin/env Rscript
# Integrate multiple single cell datasets (samples)
# Mahdi Moradi Marjaneh

# ____________________________________________________________________________
# Initialization ####

options(mc.cores = max(2, future::availableCores(methods = "mc.cores")))

## ............................................................................
## Load packages ####
library(scFlow)
library(argparse)
library(parallel)

## ............................................................................
## Parse command-line arguments ####

# create parser object
parser <- ArgumentParser()

# specify options
required <- parser$add_argument_group("Required", "required arguments")
optional <- parser$add_argument_group("Optional", "required arguments")

required$add_argument(
  "--sce_path",
  help = "-path to the SingleCellExperiment",
  metavar = "dir",
  required = TRUE
)

required$add_argument(
  "--method",
  required = TRUE,
  help ="The integration method to use",
  metavar = "Liger"
)

required$add_argument(
  "--unique_id_var",
  required = TRUE,
  help ="Unique id variable",
  metavar = "manifest"
)

required$add_argument(
  "--take_gene_union",
  default = FALSE,
  required = TRUE,
  help ="Whether to fill out raw.data matrices with union of genes across all datasets (filling in 0 for missing data)",
  metavar = "Boolean"
)

required$add_argument(
  "--remove_missing",
  default = TRUE,
  required = TRUE,
  help ="Whether to remove cells not expressing any measured genes, and genes not expressed in any cells",
  metavar = "Boolean"
)

required$add_argument(
  "--num_genes",
  default = 3000,
  type = "integer",
  required = TRUE,
  help ="Number of genes to find for each dataset",
  metavar = "N"
)

required$add_argument(
  "--combine",
  default = "union",
  required = TRUE,
  help ="How to combine variable genes across experiments",
  metavar = "union,intersect"
)

required$add_argument(
  "--capitalize",
  default = FALSE,
  required = TRUE,
  help ="Capitalize gene names to match homologous genes(ie. across species)",
  metavar = "Boolean"
)

required$add_argument(
  "--use_cols",
  default = TRUE,
  required = TRUE,
  help ="Treat each column as a cell",
  metavar = "Boolean"
)

required$add_argument(
  "--k",
  default = 30,
  type = "integer",
  required = TRUE,
  help ="Inner dimension of factorization (number of factors)",
  metavar = "N"
)

required$add_argument(
  "--lambda",
  default = 5.0,
  type = "double",
  required = TRUE,
  help ="Regularization parameter. Larger values penalize dataset-specific effects more strongly (ie. alignment should increase as lambda increases)",
  metavar = "N"
)

required$add_argument(
  "--thresh",
  default = 0.0001,
  type = "double",
  required = TRUE,
  help ="Convergence threshold. Convergence occurs when |obj0-obj|/(mean(obj0,obj)) < thresh",
  metavar = "N"
)

required$add_argument(
  "--max_iters",
  default = 100,
  type = "integer",
  required = TRUE,
  help ="Maximum number of block coordinate descent iterations to perform",
  metavar = "N"
)

required$add_argument(
  "--nrep",
  default = 1,
  type = "integer",
  required = TRUE,
  help ="Number of restarts to perform",
  metavar = "N"
)

required$add_argument(
  "--rand_seed",
  default = 1,
  type = "integer",
  required = TRUE,
  help ="Random seed to allow reproducible results",
  metavar = "N"
)

required$add_argument(
  "--knn_k",
  default = 20,
  type = "integer",
  required = TRUE,
  help ="Number of nearest neighbors for within-dataset knn graph",
  metavar = "N"
)

required$add_argument(
  "--ref_dataset",
  default = '',
  required = TRUE,
  help ="Name of dataset to use as a reference for normalization",
  metavar = "ref"
)

required$add_argument(
  "--min_cells",
  default = 2,
  type = "integer",
  required = TRUE,
  help ="Minimum number of cells to consider a cluster shared across datasets",
  metavar = "N"
)

required$add_argument(
  "--quantiles",
  default = 50,
  type = "integer",
  required = TRUE,
  help ="Number of quantiles to use for quantile normalization",
  metavar = "N"
)

required$add_argument(
  "--resolution",
  default = 1,
  type = "double",
  required = TRUE,
  help ="Controls the number of communities detected (Higher resolution -> more communities)",
  metavar = "N"
)

required$add_argument(
  "--center",
  default = FALSE,
  required = TRUE,
  help ="Centers the data when scaling factors (useful for less sparse modalities like methylation data)",
  metavar = "Boolean"
)

### . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . ..
### Pre-process args ####

args <- parser$parse_args()
args <- purrr::map(args, function(x) {
  if (length(x) == 1) {
    if (toupper(x) == "TRUE") {
      return(TRUE)
    }
    if (toupper(x) == "FALSE") {
      return(FALSE)
    }
    if (toupper(x) == "NULL") {
      return(NULL)
    }
  }
  return(x)
})

## ............................................................................
## Integrate sce ####

sce <- read_sce(args$sce_path)

sce <- integrate_sce(
  sce,
  method = args$method,
  unique_id_var = args$unique_id_var,
  take_gene_union = args$take_gene_union,
  remove.missing = args$remove_missing,
  num_genes = args$num_genes,
  combine = args$combine,
  capitalize = args$capitalize,
  use_cols = args$use_cols,
  num_cores = future::availableCores(methods = "mc.cores"),
  k = args$k,
  lambda = args$lambda,
  thresh = args$thresh,
  max_iters = args$max_iters,
  nrep = args$nrep,
  H_init = NULL,
  W_init = NULL,
  V_init = NULL,
  rand_seed = args$rand_seed,
  knn_k = args$knn_k,
  ref_dataset = args$ref_dataset,
  min_cells = args$min_cells,
  quantiles = args$quantiles,
  resolution = args$resolution,
  center = args$center,
  print_obj = FALSE
)

## ............................................................................
## Save Outputs ####

# Save SingleCellExperiment
write_sce(
  sce = sce,
  folder_path = file.path(getwd(), "integrated_sce"),
  write_metadata = TRUE
)


#!/usr/bin/env Rscript
###
### Use MASS::stepAIC to perform backward selection on variants.
###
### Imputes missing genotype data by using the mean; ignores strains with
### missing phenotype data.
###

library(data.table)
library(MASS)

argv = commandArgs(trailingOnly=TRUE)
genotype_file = argv[1]
phenotype_file = argv[2]
variant_file = argv[3]
n_vars = as.numeric(unlist(strsplit(argv[4], ',')))
min_maf = as.numeric(argv[5])
output_prefix = argv[6]

oh = file(paste0(output_prefix, '.stats.tsv'), 'wb')
ohf = file(paste0(output_prefix, '.fitted.tsv'), 'wb')

n_random_vars = 10000

genotypes = fread(genotype_file, header=TRUE)
setkey(genotypes, 'rs')
phenotypes = fread(phenotype_file)
variants = scan(variant_file, what='character')

maf = apply(genotypes[, -(1:3)], 1,
            function(x) min(sum(x == 0, na.rm=TRUE), sum(x == 1, na.rm=TRUE))/sum(!is.na(x)))
genotypes = genotypes[maf >= min_maf, ]
cat(nrow(genotypes), 'variants left after MAF filtering\n', file=stderr())

if(length(variants) < max(n_vars)) {
    stop("Can't choose that many variants")
}

X = apply(t(as.matrix(genotypes[variants, -(1:3)])), 2,
          function(x) { x[is.na(x)] = mean(x, na.rm=TRUE); x})
p = phenotypes[match(rownames(X), as.character(phenotypes[[ 2]])), ]
y = p[[3]]

X_rand = t(as.matrix(genotypes[sample(1:nrow(genotypes), n_random_vars, FALSE), -(1:3)]))

cat('n_vars_start\tr2\tr2_unadj\tgenomic_r2\tgenomic_r2_unadj\tn_vars_final\t',
    'ranks_final\tvars_final\tcoefficients\n',
    file=oh, sep='')
cat('n_vars_start\tphenotype\tfitted\n', file=ohf)
for(nv in n_vars) {
    XX = as.matrix(X[, 1:nv]) # NEW
    colnames(XX) = paste0('XX', 1:nv)
    #rhs = paste('~', paste(paste0('X[,', 1:nv, ']'), collapse=' + '))
    rhs = '~ XX'   # NEW
    form = paste('y', rhs)
    XX = as.matrix(XX[, !is.na(apply(XX, 2, mean))])
    if(ncol(XX) == 0) { next }
    m_full = lm(form)
    m_final = stepAIC(m_full, scope=list(lower=~1), direction='backward',
                      trace=FALSE)
    s = summary(m_final)
    r2 = s$r.squared
    r2a = s$adj.r.squared
    rhs_final = as.character(m_final$call$formula)[3]
    ranks_final = as.numeric(gsub('XX', '',
                                  names(m_final$coefficients)[-1]))
    coefs_final = m_final$coefficients
    variants_final = variants[ranks_final]
    ft = m_final$fitted.values
    gr2 = 0
    gr2c = 0
    gr2a = 0
    gr2ac = 0
    for(i in 1:n_random_vars) {
        ss = summary(lm(paste('X_rand[, i] ~', rhs_final)))
        if(!is.na(ss$r.squared)) {
            gr2 = gr2 + ss$r.squared
            gr2c = gr2c + 1
        }
        if(!is.na(ss$adj.r.squared)) {
            gr2a = gr2a + ss$adj.r.squared
            gr2ac = gr2ac + 1
        }
    }
    cat(nv, '\t', round(r2a, 3), '\t', round(r2, 3),
        '\t', round(gr2a/gr2ac, 3),
        '\t', round(gr2/gr2c, 3),
        '\t', length(variants_final),
        '\t', paste(ranks_final, collapse=','),
        '\t', paste(variants_final, collapse=','),
        '\t', paste(coefs_final, collapse=','),
        '\n', sep='', file=oh)
    write.table(cbind(rep(nv, sum(!is.na(y))), y[!is.na(y)], ft),
                col.names=FALSE, row.names=FALSE, quote=FALSE,
                sep='\t', file=ohf)
    flush(oh)
    flush(ohf)
}

close(oh)
close(ohf)