#Base_screen
#clean_rank1_module_new
#R1_list_filtering_step1_new
#Step2plus_Celltype_marker_inference_fixedCT
#Step2plus_Celltype_marker_inference_Hclust_plus
#Step2plus_Celltype_marker_inference_Hclust_CTES
#compute_CompRowspace_NN_uni

#------------------
.onLoad_temp_func3 <- function()
{
	IM_reso_level<-rep(0,length(names(ICTD::IM_id_list)))
	names(IM_reso_level)<-names(ICTD::IM_id_list)
	IM_reso_level[1:12]<-1
	IM_reso_level[13]<-2
	IM_reso_level[14]<-3
	IM_reso_level[15]<-4
	IM_reso_level[16]<-2
	IM_reso_level[17]<-4

	 assign("IM_reso_level", IM_reso_level, envir = parent.env(environment()))
}

compute_CompRowspace_NN_uni <- function(tg_data_c,module_RB=Base_c,ROUNDS=3)
{
          tg_list_c<-list()
          tg_list_c[[1]]<-rownames(tg_data_c)
          dd<-Compute_Rbase_SVD(tg_data_c,tg_list_c)
        dd<-dd/sd(dd)
          tg_list_selected<-c()
          ee_all<-c()
        ee_all<-c(ee_all,RMSE_row(dd))
        for(ii in 1:ROUNDS)
        {
        ccc<-cor(t(dd),t(module_RB))
                tg_id_c<-which(ccc==max(ccc))[1]
                if(ccc[tg_id_c]>0)
                {
                  tg_list_selected<-c(tg_list_selected,tg_id_c)
                ttt_ccc<-module_RB[tg_id_c,]%*%t(module_RB[tg_id_c,])/sum((module_RB[tg_id_c,])^2)
                dd<-dd-dd%*%ttt_ccc
                  ee_all<-c(ee_all,RMSE_row(dd))
                }
        }
        ee_all<-ee_all/ee_all[1]
          ee_all2<-ee_all[-1]
          if(length(ee_all2)>0)
          {
                for(i in 2:length(ee_all))
                {
                        ee_all2[i-1]<-ee_all[i-1]-ee_all[i]
                }
          }
          ee_all<-ee_all[-1]
          ccc<-c()
          if(length(ee_all)>0)
          {
             ccc<-rbind(tg_list_selected,ee_all,ee_all2)
 colnames(ccc)<-1:ncol(ccc)
          }
         return(ccc)
}

Base_screen<-function(bbb_all0,hh,tg_R1_list_stat)
{
        tg_R1_list_stat0<-tg_R1_list_stat
        names(tg_R1_list_stat0)<-1:length(tg_R1_list_stat)
        ttt<-unique(hh)
        merge_list_info<-list()
        R1_selected_c<-c()
        for(i in 1:length(ttt))
        {
                #print(i)
                cc<-names(which(hh==ttt[i]))
                merge_list_info[[i]]<-list(cc,1)
                if(length(cc)==1)
                {
                        R1_selected_c<-c(R1_selected_c,cc)
                }
                if(length(cc)==2)
                {
                        ddd<-cor(t(bbb_all0[cc,]))
                        #print(ddd)
                        m1<-max(apply(tg_R1_list_stat0[[cc[1]]],2,mean))
                        m2<-max(apply(tg_R1_list_stat0[[cc[2]]],2,mean))
                        if(m1>=m2)
                        {
                                R1_selected_c<-c(R1_selected_c,cc[1])
                        }
                        else
                        {
                                R1_selected_c<-c(R1_selected_c,cc[2])
                        }
                        merge_list_info[[i]][[2]]<-ddd
                }
                if(length(cc)>2)
                {
                        ddd<-cor(t(bbb_all0[cc,]))
                        fff<-apply(ddd,1,mean)
                        ggg<-which(fff==max(fff))
                        if(length(ggg)==1)
                        {
                                R1_selected_c<-c(R1_selected_c,cc[ggg])
                        }
                        else
                        {
                                dd<-cc[ggg]
                                mm<-c()
                                for(j in 1:length(dd))
                                {
                                        mm<-c(mm,max(apply(tg_R1_list_stat0[[dd[j]]],2,mean)))
                                }
                                ee<-dd[which(mm==max(mm))[1]]
                                R1_selected_c<-c(R1_selected_c,ee)
                        }
                        merge_list_info[[i]][[2]]<-ddd
                }
        }
      return(list(R1_selected_c,merge_list_info))
}

clean_rank1_module_new<-function(data_c,module_info,module_rank,st0=8,RR=50,msep_cut0=0.01)
{
        N<-0
        nc<-c()
        module_new<-list()
        for(i in 1:length(module_info))
        {
                if(module_rank[i]==1)
                {
                        N<-N+1
                        nc<-c(nc,names(module_info)[i])
                        module_new[[N]]<-module_info[[i]]
                }
                if(module_rank[i]>1)
                {
                        ccc<-module_info[[i]]
                        st<-st0
                        rr<-1
                        while((rr==1)&(st<=length(ccc)))
                        {
                                tg_genes<-c(ccc[1:st])
                                pp<-BCV_ttest2(data_c[tg_genes,],rounds=RR,maxrank0=5,msep_cut=msep_cut0)
                                rr<-sum(pp<0.001)
                                st<-st+1
                        }
                        tg_genes<-tg_genes[-length(tg_genes)]
                        if(length(tg_genes)>st0)
                        {
                                N<-N+1
                                nc<-c(nc,names(module_info)[i])
                                module_new[[N]]<-tg_genes
                        }
                }
        }
        names(module_new)<-nc
        return(module_new)
}

R1_list_filtering_step1_new<-function(list_c2,data_CORS_cancer,max_cut=20,cutn0=20,cut10=0.8,IM_id_list,immune_cell_uni_table=immune_cell_uni_table0_GPL570)
{
tg_1_rank_markers0<-list_c2[[1]]
tg_m_names0<-list_c2[[2]]
RMSE_on_CORS_cancer_c<-RMSE_row(data_CORS_cancer)
tg_marker_lists<-list()
for(i in 1:length(list_c2[[1]]))
{
        ccc<-c(names(list_c2[[1]])[i],rownames(list_c2[[1]][[i]]))
        tg_marker_lists[[i]]<-ccc
}
names(tg_marker_lists)<-names(list_c2[[1]])

pp_all<-c()
for(i in 1:length(tg_marker_lists))
{
        pp<-sum(BCV_ttest2(data_CORS_cancer[tg_marker_lists[[i]],],maxrank0=20,msep_cut=0.01)<0.001, na.rm=T)
        pp_all<-c(pp_all,pp)
}
pp_R1_marker_list_f1<-clean_rank1_module_new(data_CORS_cancer,tg_marker_lists,pp_all,st0=6)
pp_R1_marker_list_f1.5<-cut_modules(pp_R1_marker_list_f1,cutn=cutn0)

stat_p1<-list()
for(i in 1:length(pp_R1_marker_list_f1.5))
{
        tg_gene_c<-pp_R1_marker_list_f1.5[[i]][-1]
        stat_p1[[i]]<-tg_1_rank_markers0[[names(pp_R1_marker_list_f1.5)[i]]][tg_gene_c,]
}

names(tg_marker_lists)<-names(pp_R1_marker_list_f1.5)
tg_genes_all<-c()
for(i in 1:length(pp_R1_marker_list_f1.5))
{
        tg_genes_all<-c(tg_genes_all,pp_R1_marker_list_f1.5[[i]])
}
tg_genes_all<-unique(sort(tg_genes_all))

print("filter 1 and stat done!")
#ccc<-MAP_GPL570_genes2(R1_markers_f1)
#names(ccc)<-names(Top_cell_proportion)
#table(names(Top_cell_proportion))
R1_markers_f1<-pp_R1_marker_list_f1.5

cut1<-cut10
ccc<-compute_min_jaccard(R1_markers_f1)
ccc0<-ccc>cut1

stat_cc<-c(1:nrow(ccc0))
names(stat_cc)<-1:nrow(ccc0)
for(i in 1:nrow(ccc0))
{
        for(j in 1:ncol(ccc0))
        {
                if((i<j)&(ccc0[i,j]>0))
                {
                        nn<-max(i,j)
                        stat_cc[which(stat_cc==i)]<-nn
                        stat_cc[which(stat_cc==j)]<-nn
                }
        }
}
table(stat_cc)
tg_ccc<-unique(stat_cc)
R1_marker_list_f2<-list()
N<-0
for(i in 1:length(tg_ccc))
{
        N<-N+1
        tg_ids<-as.numeric(names(stat_cc)[which(stat_cc==tg_ccc[i])])
        ccc<-c()
        for(j in 1:length(tg_ids))
        {
                ccc<-c(ccc,R1_markers_f1[[tg_ids[j]]])
        }
        ccc<-unique(ccc)
        R1_marker_list_f2[[N]]<-ccc
}

R1_marker_list_f2.5_stat<-rank_based_module_sorting(data_CORS_cancer,R1_marker_list_f2,IM_id_list,immune_cell_uni_table=immune_cell_uni_table)
R1_marker_list_f2.5<-R1_marker_list_f2.5_stat[[1]]

pp_all<-c()
for(i in 1:length(R1_marker_list_f2.5))
{
        pp<-sum(BCV_ttest2(data_CORS_cancer[R1_marker_list_f2.5[[i]],],maxrank0=20,msep_cut=0.01)<0.001, na.rm=T)
        pp_all<-c(pp_all,pp)
}
pp_R1_marker_list_f3<-clean_rank1_module(data_CORS_cancer,R1_marker_list_f2.5,pp_all,st0=6)
pp_R1_marker_list_f3.5<-cut_modules(pp_R1_marker_list_f3,cutn=cutn0)
R1_marker_list_f3.5_stat<-rank_based_module_sorting(data_CORS_cancer,pp_R1_marker_list_f3.5,IM_id_list,immune_cell_uni_table=immune_cell_uni_table)

print("filter 2 done!")
ccc<-c()
nn<-c()
for(i in 1:length(pp_R1_marker_list_f3.5))
{
        ccc0<-c()
        for(j in 1:length(IM_id_list))
        {
      if(length(IM_id_list[[j]])>1)
      {
            cc0<-apply(immune_cell_uni_table[pp_R1_marker_list_f3.5[[i]],IM_id_list[[j]]],1,sum)/sum((1/(1:length(IM_id_list[[j]]))))
      }
      else
      {
           cc0<-immune_cell_uni_table[pp_R1_marker_list_f3.5[[i]],IM_id_list[[j]]]
      }
                ccc0<-cbind(ccc0,cc0)
        }
        colnames(ccc0)<-names(IM_id_list)
      ddd<-apply(ccc0,2,mean)
      ccc<-rbind(ccc,ddd)
      nn<-c(nn,colnames(ccc0)[which(ddd==max(ddd))[1]])
}
rownames(ccc)<-nn
cell_enrich_stat<-ccc
names(pp_R1_marker_list_f3.5)<-nn
rrr<-rep(1,length(pp_R1_marker_list_f3.5))
Filter_1_result_list<-list(pp_R1_marker_list_f1,R1_marker_list_f2,R1_marker_list_f3.5_stat,pp_R1_marker_list_f3.5,rrr,cell_enrich_stat)
names(Filter_1_result_list)<-c("R1_marker_list_f1","R1_marker_list_f2","R1_marker_list_f3.5_stat","R1_marker_list_f3.5","R1_marker_list_rank","R1_marker_list_f3.5_cell_enrich_stat")
return(Filter_1_result_list)
}

Step2plus_Celltype_marker_inference_fixedCT<-function(tg_R1_lists,tg_R1_list_stat)
{
stat_c<-tg_R1_list_stat
cc<-c()
nn<-c()
for(i in 1:length(stat_c))
{
aaa<-apply(stat_c[[i]],2,mean)
cc<-c(cc,max(aaa))
nn<-c(nn,names(which(aaa==max(aaa))[1]))
}
names(cc)<-nn
dd<-unique(sort(nn))
tg_id_selected<-c()
cell_enrich_s<-c()
for(i in 1:length(dd))
{
tg_id_c<-which(names(cc)==dd[i])
tg_id_selected<-c(tg_id_selected,tg_id_c[order(-cc[tg_id_c])[1]])
cell_enrich_s<-c(cell_enrich_s,cc[tg_id_c[order(-cc[tg_id_c])[1]]])
}
tg_R1_selected<-list()
for(i in 1:length(tg_id_selected))
{
       tg_R1_selected[[i]]<-tg_R1_lists[[tg_id_selected[i]]]
}
names(tg_R1_selected)<-dd
names(cell_enrich_s)<-dd
cc<-list(tg_R1_selected,cell_enrich_s)
names(cc)<-c("tg_R1_selected_fixedCT","tg_R1_selected_fixedCT")
return(cc)
}

Step2plus_Celltype_marker_inference_Hclust_plus<-function(tg_R1_lists,data_CORS_cancer,tg_R1_cut=8,tg_R1_list_stat,cell_type_enrich_cut=0.5,
resolution_level=resolution_level0,hcutn0=40,hclust_cor_cut=0.95,IM_reso_level=IM_reso_level)
{
        stat_c<-tg_R1_list_stat
        cc<-c()
        nn<-c()
        for(i in 1:length(stat_c))
        {
        aaa<-apply(stat_c[[i]],2,mean)
        cc<-c(cc,max(aaa))
        nn<-c(nn,names(which(aaa==max(aaa))[1]))
        }
        names(cc)<-nn
        dd<-unique(sort(nn))
        tg_id_selected<-c()
        cell_enrich_s<-c()
        for(i in 1:length(dd))
        {
                tg_id_c<-which(names(cc)==dd[i])
                tg_id_selected<-c(tg_id_selected,tg_id_c[order(-cc[tg_id_c])[1]])
                cell_enrich_s<-c(cell_enrich_s,cc[tg_id_c[order(-cc[tg_id_c])[1]]])
        }
        tg_R1_selected<-list()
        for(i in 1:length(tg_id_selected))
        {
               tg_R1_selected[[i]]<-tg_R1_lists[[tg_id_selected[i]]]
        }
        names(tg_R1_selected)<-dd
        names(cell_enrich_s)<-dd
        dd0<-dd
        names(dd0)<-tg_id_selected

         tg_R1_lists_st<-tg_R1_lists
       for(i in 1:length(tg_R1_lists_st))
       {
            tg_R1_lists_st[[i]]<-tg_R1_lists_st[[i]][1:min(length(tg_R1_lists_st[[i]]),tg_R1_cut)]
       }

        print("Compute_total_rank!")
        tg_all_genes<-c()
        for(i in 1:length(tg_R1_lists_st))
        {
                tg_all_genes<-c(tg_all_genes,tg_R1_lists_st[[i]])
        }
        tg_all_genes<-unique(tg_all_genes)
        tg_data_ccc<-data_CORS_cancer[tg_all_genes,]
        BCV_stat_c<-BCV_ttest3(tg_data_ccc,rounds=100,slice0=4,maxrank0=30,msep_cut=0.0001)
        dim_tt<-sum(BCV_stat_c[[1]]<0.01)
        print("Total Cell Dim")
        print(dim_tt)
        data_c<-data_CORS_cancer
        Base_all<-c()
        for(i in 1:length(tg_R1_lists_st))
        {
        tg_data_c<-data_c[tg_R1_lists_st[[i]],]
        cc<-svd(tg_data_c)$v[,1]
        ccc<-cor(cc,t(tg_data_c))
        if(mean(ccc)<0)
        {
                cc<--cc
        }
        Base_all<-rbind(Base_all,cc)
        }
        rownames(Base_all)<-names(tg_R1_lists_st)
        bbb_all0<-Base_all
        rownames(bbb_all0)<-1:nrow(bbb_all0)
        hcutn0<-min(hcutn0,nrow(bbb_all0))
        hcutn0<-min(hcutn0,dim_tt)
        data_genes_all<-data_CORS_cancer[tg_all_genes,]
        hcutn1<-min(hcutn0+3,nrow(bbb_all0))
        hclust_R1_screen<-hclust_screen_top_bases(bbb_all0,data_genes_all,hcutn=hcutn1)

R1_hhh<-hclust_R1_screen[[3]]
        ccc<-c()
        for(i in 1:length(hclust_R1_screen[[1]]))
        {
                aaa<-cor(t(hclust_R1_screen[[1]][[i]]))
                diag(aaa)<-0
                ccc<-c(ccc,max(aaa))
        }
        R_bases_hclust_top_correlations<-ccc
        hcutn2<-max(which(R_bases_hclust_top_correlations<hclust_cor_cut))
        hh<-hclust_R1_screen[[3]][[hcutn2]]
        Base_hclust_screen_result<-Base_screen(bbb_all0,hh,tg_R1_list_stat)
        Base_hclust_screen_selected<-as.numeric(Base_hclust_screen_result[[1]])
        ttt<-unique(hh)
        Base_hclust_screen_selected_hp<-Base_hclust_screen_selected
        IM_reso_level0<-IM_reso_level

for(i in 1:length(ttt))
        {
                cc1<-c()
                cc1<-intersect(names(which(hh==ttt[i])),Base_hclust_screen_result[[1]][i])
                cc2<-c()
                cc2<-intersect(as.character(tg_id_selected),names(which(hh==ttt[i])))
                if(length(cc2)==1)
                {
                        Base_hclust_screen_selected_hp[i]<-as.numeric(cc2)
                }
                if(length(cc2)>1)
                {
                        ccc<-IM_reso_level[dd0[cc2]]
                        cc3<-cc2[which(ccc==max(ccc))]
                        Base_hclust_screen_selected_hp[i]<-as.numeric(cc3)[1]
                }
        }
        print("done!")
        tg_R1_lists_selected<-list()
        tg_R1_list_stat_selected<-list()
        nn<-c()
        for(i in 1:length(Base_hclust_screen_selected_hp))
        {
                tg_R1_lists_selected[[i]]<- tg_R1_lists_st[[Base_hclust_screen_selected_hp[[i]]]]
                tg_R1_list_stat_selected[[i]]<-tg_R1_list_stat[[Base_hclust_screen_selected_hp[[i]]]][tg_R1_lists_selected[[i]],]
                cc<-apply(tg_R1_list_stat_selected[[i]],2,mean)
                nn<-c(nn,names(which(cc==max(cc))[1]))
        }
        names(tg_R1_lists_selected)<-nn
        tgs<-tg_R1_lists_selected
        cc<-list(tgs,tg_R1_list_stat_selected,dim_tt,length(Base_hclust_screen_selected_hp),Base_hclust_screen_result)
        names(cc)<-list("tg_R1_selected_Hclust","tg_R1_list_stat_selected","Inferred_CT_dimension","Forced_CT_number","Base_hclust_screen_result")
        return(cc)
}

Step2plus_Celltype_marker_inference_Hclust_plus<-function(tg_R1_lists,data_CORS_cancer,tg_R1_cut=8,tg_R1_list_stat,cell_type_enrich_cut=0.5,
resolution_level=resolution_level0,hcutn0=40,hclust_cor_cut=0.95,IM_reso_level=IM_reso_level)
{
        stat_c<-tg_R1_list_stat
        cc<-c()
        nn<-c()
        for(i in 1:length(stat_c))
        {
        aaa<-apply(stat_c[[i]],2,mean)
        cc<-c(cc,max(aaa))
        #nn<-c(nn,names(which(aaa==max(aaa)[1])))
        nn<-c(nn,names(which(aaa==max(aaa))[1]))
        }
        names(cc)<-nn
        dd<-unique(sort(nn))
        tg_id_selected<-c()
        cell_enrich_s<-c()
        for(i in 1:length(dd))
        {
                tg_id_c<-which(names(cc)==dd[i])
                tg_id_selected<-c(tg_id_selected,tg_id_c[order(-cc[tg_id_c])[1]])
                cell_enrich_s<-c(cell_enrich_s,cc[tg_id_c[order(-cc[tg_id_c])[1]]])
        }
        tg_R1_selected<-list()
        for(i in 1:length(tg_id_selected))
        {
               tg_R1_selected[[i]]<-tg_R1_lists[[tg_id_selected[i]]]
        }
        names(tg_R1_selected)<-dd
        names(cell_enrich_s)<-dd
        dd0<-dd
        names(dd0)<-tg_id_selected

         tg_R1_lists_st<-tg_R1_lists
       for(i in 1:length(tg_R1_lists_st))
       {
            tg_R1_lists_st[[i]]<-tg_R1_lists_st[[i]][1:min(length(tg_R1_lists_st[[i]]),tg_R1_cut)]
       }

        print("Compute_total_rank!")
        tg_all_genes<-c()
        for(i in 1:length(tg_R1_lists_st))
        {
                tg_all_genes<-c(tg_all_genes,tg_R1_lists_st[[i]])
        }
        tg_all_genes<-unique(tg_all_genes)
        tg_data_ccc<-data_CORS_cancer[tg_all_genes,]
        BCV_stat_c<-BCV_ttest3(tg_data_ccc,rounds=100,slice0=4,maxrank0=30,msep_cut=0.0001)
        dim_tt<-sum(BCV_stat_c[[1]]<0.01)
        print("Total Cell Dim")
        print(dim_tt)
        data_c<-data_CORS_cancer
        Base_all<-c()
        for(i in 1:length(tg_R1_lists_st))
        {
        tg_data_c<-data_c[tg_R1_lists_st[[i]],]
        cc<-svd(tg_data_c)$v[,1]
        ccc<-cor(cc,t(tg_data_c))
        if(mean(ccc)<0)
        {
                cc<--cc
        }
        Base_all<-rbind(Base_all,cc)
        }
        rownames(Base_all)<-names(tg_R1_lists_st)
        bbb_all0<-Base_all
        rownames(bbb_all0)<-1:nrow(bbb_all0)
        hcutn0<-min(hcutn0,nrow(bbb_all0))
        hcutn0<-min(hcutn0,dim_tt)
        data_genes_all<-data_CORS_cancer[tg_all_genes,]
        hcutn1<-min(hcutn0+3,nrow(bbb_all0))
        hclust_R1_screen<-hclust_screen_top_bases(bbb_all0,data_genes_all,hcutn=hcutn1)

	 R1_hhh<-hclust_R1_screen[[3]]
        ccc<-c()
        for(i in 1:length(hclust_R1_screen[[1]]))
        {
                aaa<-cor(t(hclust_R1_screen[[1]][[i]]))
                diag(aaa)<-0
                ccc<-c(ccc,max(aaa))
        }
        R_bases_hclust_top_correlations<-ccc
        hcutn2<-max(which(R_bases_hclust_top_correlations<hclust_cor_cut))
        hh<-hclust_R1_screen[[3]][[hcutn2]]
        Base_hclust_screen_result<-Base_screen(bbb_all0,hh,tg_R1_list_stat)
        Base_hclust_screen_selected<-as.numeric(Base_hclust_screen_result[[1]])
        ttt<-unique(hh)
        Base_hclust_screen_selected_hp<-Base_hclust_screen_selected
        IM_reso_level0<-IM_reso_level

	 for(i in 1:length(ttt))
        {
                cc1<-c()
                cc1<-intersect(names(which(hh==ttt[i])),Base_hclust_screen_result[[1]][i])
                cc2<-c()
                cc2<-intersect(as.character(tg_id_selected),names(which(hh==ttt[i])))
                if(length(cc2)==1)
                {
                        Base_hclust_screen_selected_hp[i]<-as.numeric(cc2)
                }
                if(length(cc2)>1)
                {
                        ccc<-IM_reso_level[dd0[cc2]]
                        cc3<-cc2[which(ccc==max(ccc))]
                        Base_hclust_screen_selected_hp[i]<-as.numeric(cc3)[1]
                }
        }
        print("done!")

        tg_R1_lists_selected<-list()
        tg_R1_list_stat_selected<-list()
        nn<-c()
        for(i in 1:length(Base_hclust_screen_selected_hp))
        {
                tg_R1_lists_selected[[i]]<- tg_R1_lists_st[[Base_hclust_screen_selected_hp[[i]]]]
                tg_R1_list_stat_selected[[i]]<-tg_R1_list_stat[[Base_hclust_screen_selected_hp[[i]]]][tg_R1_lists_selected[[i]],]
                cc<-apply(tg_R1_list_stat_selected[[i]],2,mean)
                nn<-c(nn,names(which(cc==max(cc))[1]))
        }
        names(tg_R1_lists_selected)<-nn
        tgs<-tg_R1_lists_selected
        cc<-list(tgs,tg_R1_list_stat_selected,dim_tt,length(Base_hclust_screen_selected_hp),Base_hclust_screen_result)
        names(cc)<-list("tg_R1_selected_Hclust","tg_R1_list_stat_selected","Inferred_CT_dimension","Forced_CT_number","Base_hclust_screen_result")
        return(cc)
}

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

Step2plus_Celltype_marker_inference_Hclust_CTES<-function(tg_R1_lists,data_CORS_cancer,tg_R1_cut=8,tg_R1_list_stat,cell_type_enrich_cut=0.5,
resolution_level=resolution_level0,hcutn0=40,hclust_cor_cut=0.95,IM_reso_level=IM_reso_level,extra_ctn=3)
{
        stat_c<-tg_R1_list_stat
        cc<-c()
        nn<-c()
        for(i in 1:length(stat_c))
        {
        aaa<-apply(stat_c[[i]],2,mean)
        cc<-c(cc,max(aaa))
        nn<-c(nn,names(which(aaa==max(aaa))[1]))
        }
        names(cc)<-nn
        dd<-unique(sort(nn))
        tg_id_selected<-c()
        cell_enrich_s<-c()
        for(i in 1:length(dd))
        {
                tg_id_c<-which(names(cc)==dd[i])
                tg_id_selected<-c(tg_id_selected,tg_id_c[order(-cc[tg_id_c])[1]])
                cell_enrich_s<-c(cell_enrich_s,cc[tg_id_c[order(-cc[tg_id_c])[1]]])
        }
        tg_R1_selected<-list()
        for(i in 1:length(tg_id_selected))
        {
               tg_R1_selected[[i]]<-tg_R1_lists[[tg_id_selected[i]]]
        }
        names(tg_R1_selected)<-dd
        names(cell_enrich_s)<-dd
        dd0<-dd
        names(dd0)<-tg_id_selected

       tg_R1_lists_st<-tg_R1_lists
       for(i in 1:length(tg_R1_lists_st))
       {
            tg_R1_lists_st[[i]]<-tg_R1_lists_st[[i]][1:min(length(tg_R1_lists_st[[i]]),tg_R1_cut)]
       }

        #print("Compute_total_rank!")
        tg_all_genes<-c()
        for(i in 1:length(tg_R1_lists_st))
        {
                tg_all_genes<-c(tg_all_genes,tg_R1_lists_st[[i]])
        }
        tg_all_genes<-unique(tg_all_genes)
        tg_data_ccc<-data_CORS_cancer[tg_all_genes,]
        BCV_stat_c<-BCV_ttest3(tg_data_ccc,rounds=100,slice0=4,maxrank0=30,msep_cut=0.0001)
        dim_tt<-sum(BCV_stat_c[[1]]<0.01)
        #print("Total Cell Dim")
        #print(dim_tt)

  NN_ES_table_R4<-Explanation_BASE(data_CORS_cancer,tg_R1_lists_st)
  tg_ES_scores<-diag(NN_ES_table_R4)
        data_c<-data_CORS_cancer
        Base_all<-c()
        for(i in 1:length(tg_R1_lists_st))
        {
        tg_data_c<-data_c[tg_R1_lists_st[[i]],]
        cc<-svd(tg_data_c)$v[,1]
        ccc<-cor(cc,t(tg_data_c))
        if(mean(ccc)<0)
        {
                cc<--cc
        }
        Base_all<-rbind(Base_all,cc)
        }
        rownames(Base_all)<-names(tg_R1_lists_st)
        bbb_all0<-Base_all
        rownames(bbb_all0)<-1:nrow(bbb_all0)
        hcutn0<-min(hcutn0,nrow(bbb_all0))
        hcutn0<-min(hcutn0,dim_tt)
        data_genes_all<-data_CORS_cancer[tg_all_genes,]
        hcutn1<-min(hcutn0+extra_ctn,nrow(bbb_all0))
        hclust_R1_screen<-hclust_screen_top_bases(bbb_all0,data_genes_all,hcutn=hcutn1)
	  R1_hhh<-hclust_R1_screen[[3]]
        ccc<-c()
        for(i in 1:length(hclust_R1_screen[[1]]))
        {
                aaa<-cor(t(hclust_R1_screen[[1]][[i]]))
                diag(aaa)<-0
                ccc<-c(ccc,max(aaa))
        }
        R_bases_hclust_top_correlations<-ccc
        hcutn2<-max(which(R_bases_hclust_top_correlations<hclust_cor_cut))
	  hcutn2<-min(hcutn2,hcutn1)
	  #print("hcut0")
	  #print(c(hcutn0,hcutn1,hcutn2))
        hh<-hclust_R1_screen[[3]][[hcutn2]]

        Base_hclust_screen_result<-Base_screen(bbb_all0,hh,tg_R1_list_stat)
        tg_selected_Bases<-c()
  for(i in 1:length(Base_hclust_screen_result[[2]]))
  {
tg_ids_c<-as.numeric(Base_hclust_screen_result[[2]][[i]][[1]])
tg_selected_Bases<-c(tg_selected_Bases,tg_ids_c[which(tg_ES_scores[tg_ids_c]==min(tg_ES_scores[tg_ids_c]))[1]])
        }
  Base_screen_selected<- tg_selected_Bases

  selected_cell_types<-intersect(names(IM_reso_level),unique(nn))
  rest_cell_types<-setdiff(selected_cell_types,unique(nn[Base_screen_selected]))
  names(Base_screen_selected)<-nn[Base_screen_selected]
  ccc<-c()
if(length(rest_cell_types)>0)
{
for(i in 1:length(rest_cell_types))
{
        tg_ids_c<-which(nn==rest_cell_types[i])
        ccc<-c(ccc,tg_ids_c[which(tg_ES_scores[tg_ids_c]==min(tg_ES_scores[tg_ids_c]))[1]])
}
names(ccc)<-rest_cell_types
}
R1_list_c1<-list()
for(i in 1:length(Base_screen_selected))
{
R1_list_c1[[i]]<-tg_R1_lists_st[[Base_screen_selected[i]]]
}
names(R1_list_c1)<-names(Base_screen_selected)

R1_list_c2<-list()
if(length(ccc)>0)
{
for(i in 1:length(ccc))
{
R1_list_c2[[i]]<-tg_R1_lists_st[[ccc[i]]]
}
names(R1_list_c2)<-names(ccc)
}
        cc<-list(R1_list_c1,R1_list_c2,Base_screen_selected,ccc,dim_tt,length(Base_screen_selected),Base_hclust_screen_result)
        names(cc)<-list("tg_R1_selected_ES","tg_R1_selected_extra_CT","tg_R1_selected_ES_ids","tg_R1_selected_extra_CT_ids","Inferred_CT_dimension","Forced_CT_number","Base_hclust_screen_result")
		return(cc)
}


library('dplyr')
chrstat<-read.table(file="./rn6_chr_length", header=F)
names(chrstat)<-c("chr","length")
chrstat$lengthadj<-c(0,cumsum(as.numeric(chrstat$length))[-21])
chrstat$chrmid<-chrstat$length/2+chrstat$lengthadj
head(chrstat)

genepos<-read.table(file="./rn6_gene_pos.tab", sep="\t", header=F)
names(genepos)<-c("gene","chr","start","end")
genepos<-merge(genepos,chrstat[,c("chr","lengthadj")], by="chr")
genepos$g_start<-genepos$start+genepos$lengthadj
genepos$g_end<-genepos$end+genepos$lengthadj
head(genepos)
genepos<-genepos[,c("chr","gene","g_start","g_end", "start", "end")]
names(genepos)<-paste("rn6",names(genepos),sep="_")
tail(genepos)

# for trans, p-values cut at -logp>4.9
filename="./eqtl_data.tab"
df0<-read.table(file=filename, header=F, sep="\t")
names(df0)<-c("region","gene","qtl_chr","qtl_bp","qtl_p")
df1<-merge(df0,chrstat,by.x="qtl_chr", by.y='chr')
df1$cumlength<-df1$qtl_bp+df1$lengthadj
df1<-df1[order(df1$gene,df1$cumlength),]
trans<-merge(df1,genepos, by.x="gene", by.y="rn6_gene")
trans$cistrans<-"inbetween"
transidx<- abs(trans$cumlength-trans$rn6_g_start)>1e+6 | abs(trans$cumlength-trans$rn6_g_end) > 1e+6
trans$cistrans[transidx]<-"trans"
#cisidx<- abs(trans$cumlength-trans$rn6_g_start)<1e+6 | abs(trans$cumlength-trans$rn6_g_end) < 1e+6
#trans$cistrans[cisidx]<-"cis"
trans$logp<- -log10(trans$qtl_p)
transeqtl<-subset(trans, logp>4.9 & cistrans=="trans") # threshold is 5.6 but keep a little more data points for the plot
dim(transeqtl)
# 348292 16

## for cis
filename="./five_regions_cis_filtered.tab"
df0<-read.table(file=filename, header=F, sep="\t")
names(df0)<-c("region","gene","qtl_chr","qtl_bp","qtl_p")
head(df0)
head(chrstat)
df1<-merge(df0,chrstat,by.x="qtl_chr", by.y='chr')
df1$cumlength<-df1$qtl_bp+df1$lengthadj
df1<-df1[order(df1$gene,df1$cumlength),]
cisCandidates<-merge(df1,genepos, by.x="gene", by.y="rn6_gene")
cisCandidates$cistrans<-"cis"
cisCandidates$logp<- -1 * log10(cisCandidates$qtl_p)

# for cis-, correct p-values
eigenmt<-read.table(file="./fpkm_eigenmt_hits.txt", header=F,sep="\t")
names(eigenmt)<-c("region","chr_loc","gene","p","padj","tests")
head(eigenmt)
# eigenMT calculates the Meff (effective multi-test) for each gene, then do Bonferroni. Here I am recapture this tests and apply this to all SNPs within the cis- of each gene. The tests are slightly different (with one or two) between different brains regions. So I am taking the mean
gene_testcounts<-aggregate(tests~gene, FUN=function(x) round(mean(x),0), data=eigenmt)
ciseqtl0<-merge(cisCandidates,gene_testcounts, by.x="gene", by.y="gene")
ciseqtl0$qtl_p<-ciseqtl0$qtl_p*ciseqtl0$tests
#ciseqtl0<-ciseqtl0[,1:16]
#names(ciseqtl0)
#names(transeqtl)
min_p<-aggregate(qtl_p~gene+region, FUN=min,data=ciseqtl0)
min_p_sig<-subset(min_p, qtl_p<0.05)
names(min_p_sig)[3]<-"min_p"
head(min_p)
ciseqtl<-merge(ciseqtl0, min_p_sig, by.x=c("gene","region"), by.y=c("gene","region"))[,1:16]
#dim(ciseqtl0)
#dim(ciseqtl_with_min_p)
#head(ciseqtl_with_min_p)
#tail(ciseqtl_with_min_p,10)

all_data<-rbind(ciseqtl,transeqtl)
names(all_data)
dat<-all_data[,c("gene","qtl_chr","region","qtl_bp","rn6_chr","rn6_start","rn6_g_start", "cistrans", "logp", "cumlength")]

#fdr from another script (fdr.r)
fdr5pct<-c(0.00481,0.00541,0.00594,0.00549,0.00443)
names(fdr5pct)<-c("AC","IL","PL","OF","LH")

# gene symbl
temp<-read.table(file="./ensembl_id2symb.tab", header=F)
symb<-temp[,2]
names(symb)<-temp[,1]
head(symb)
symb["ENSRNOG00000052790"]

# gene model
gmodel<-read.table(file="./ensembl_gene_model.tab", header=F)
names(gmodel)<-c("gm_chr","gm_type","gm_start","gm_end","gene")

# gaps
gaps<-read.table(file="./gap.txt", header=F)[,c(2,3,4)]
names(gaps)<-c("gap_chr","gap_start","gap_end")
head(gaps)

# svs
svs<-read.table(file="./svs.tab", header=F)
names(svs)<-c("sv_set","sv_chr","sv_start","sv_end", "sv_score", "sv_type")
head(svs)

save(file="eqtl.Rdata", dat, chrstat, symb, gaps, svs, gmodel, fdr5pct)

hide<-function(){# define peaks?
	distance<- c(0,df1$cumlength) - c(df1$cumlength,2800000000)
	dist0<- distance[distance>0 ]
	dist0
	#hist(dist0, breaks=100, col="lightgreen")
	span=1e+6 #18241 eqtls
	span=5e+6 #16457 eqtls ## merge SNPs within the span into one eqtl
	moveDownOne<-c(0,df1$cumlength[c(1:(dim(df1)[1]-1))])
	idx<-abs(df1$cumlength-moveDownOne) > span
	df1$peakcnt<-cumsum(idx)
	head(df1)
	df1<-df1[order(df1$gene,df1$peakcnt,df1$p_value),]
	eqtl<-df1%>% group_by(peakcnt)%>%slice(which.min(p_value))
	names(eqtl)<-paste("eqtl",names(eqtl),sep="_")
	dim(eqtl)
	head(eqtl)
	dim(eqtl)
	#write.table(file="matrix_eqtl_pl.csv",as.data.frame(eqtl),sep="\t")
}


# extract GOES16 data to fired polygons

libs<- c("tidyverse", "sf", "lubridate", "data.table", "vroom",
         "doParallel", "foreach")
invisible(sapply(libs, library, character.only=TRUE, quietly=TRUE))

# metadata ===========================================
modis_crs <- "+proj=sinu +lon_0=0 +x_0=0 +y_0=0 +a=6371007.181 +b=6371007.181 +units=m +no_defs"

brazil_dates<- c(as.Date("2019-07-28"),as.Date("2019-08-18"))

# data import ==================================================================

# choose appropriate goes files for dl

raw_goes_aws <- system(paste("aws s3 ls",
                             "s3://earthlab-mkoontz/goes16",
                             "--recursive"),
                   intern = TRUE)

goes_files <- raw_goes_aws %>%
  as_tibble() %>%
  tidyr::separate(value, into=c("s3date", "s3time", "size", "filename"), sep = "\\s+") %>%
  dplyr::select(filename) %>%
  tidyr::separate(filename, sep = "_", into = c("x1", "x2", "x3", "x4", "x5",
                                         "starttime", "endtime", "creationtime"),
                  remove= FALSE) %>%
  dplyr::select(starttime, filename) %>%
  dplyr::mutate(date = as.Date(str_sub(starttime,2,8), "%Y%j"),
                datetime = ymd_hms(paste(date,
                                     str_sub(starttime, 9,14)))) %>%
  dplyr::filter(date > as.Date("2002-01-01"))

# getting brazil files

brazil_files <- goes_files %>%
  dplyr::filter(date > brazil_dates[1] & date < brazil_dates[2]) %>%
  pull(filename)

# the slowest possible way
for(i in brazil_files){
  system(paste("aws s3 cp",
               file.path("s3://earthlab-mkoontz", i),
               file.path("data/goes16", "brazil",i),
               "--only-show-errors"))
}

braz <- st_read("data/brazil_fire.gpkg")%>%
  mutate(daynight = factor(daynight, levels = c("night", "day")))%>%
  mutate(acq_date = as.Date(acq_date)) %>%
  filter(acq_date > as.Date("2019-07-28"),
         acq_date < as.Date("2019-08-18")) %>%
  st_transform(crs = modis_crs) %>%
  st_coordinates %>%
  as_tibble() %>%
  summarise(xmin = min(X),
            ymin = min(Y),
            xmax = max(X),
            ymax = max(Y))

braz_goes<-list.files("data/goes16/brazil/goes16",full.names=TRUE, pattern = ".csv") %>%
  vroom()

braz_goes_counts <- braz_goes %>%
  filter(sinu_x>=braz$xmin[1],
         sinu_x<=braz$xmax[1],
         sinu_y>=braz$ymin[1],
         sinu_y<=braz$ymax[1]) %>%
  group_by(rounded_datetime) %>%
  summarise(n = n()) %>%
  ungroup()

# ggplot(braz_goes %>%
#          filter(sinu_x>=braz$xmin[1],
#                 sinu_x<=braz$xmax[1],
#                 sinu_y>=braz$ymin[1],
#                 sinu_y<=braz$ymax[1]) %>%
#          st_as_sf(coords = c("sinu_x", "sinu_y"), crs = modis_crs)%>%
#          st_buffer(dist = 1500, endCapStyle = "SQUARE")) +
#   geom_sf(alpha = 0.25, fill="blue", color = "transparent")

all_times <- seq(braz_goes_counts$rounded_datetime %>% min,
                 braz_goes_counts$rounded_datetime %>% max, by=3600)

tibble(rounded_datetime = all_times) %>%
  left_join(braz_goes_counts)%>%
  replace_na(list(n=0)) %>%
  write_csv("data/brazil_goes_counts.csv")


library(GenomicRanges)
library(reshape2)
library(lattice)
library(magrittr)
library(IRanges)
library(data.table)

#20180525_modification: See commented out code with Views(). Upgrading to R version 5.0 will cause RangesList to become deprecated and GRangesList is not compatible with this function. In order to circumvent, a newer updated version of splitting a GRanges into GRangesList was added.

read_matrix <- function(gr, cov, reverse_reads=FALSE, df=F, nu=25) {
  if(class(cov) == "character") {
    #cov <- import.bw(cov, which=gr, as="RleList") #deprecated command, rtracklayer will recognize values
    cov <- import(cov, which=gr, as="RleList")
  }
  transform_function <- if(reverse_reads) { rev } else { identity }
  gr <- granges(gr) # remove metadata to speed up RleList data retrieval in Views()
  o <- order(gr)
  gr <- gr[o]

  if(df==T){
	reads.list <- regionApply_list(gr,cov, as.numeric )
  	reads.list <-lapply(reads.list, function(reads) { approx(reads, n=nu)$y })
	reads.m <- matrix(as.numeric(unlist(reads.list, use.name=F)), nrow=length(reads.list), byrow=T)
	if(reverse_reads == T)reads.m <- reads.m[, ncol(reads.m):1]
  }else{
    reads.list <- regionApply(gr, cov, as.numeric)
	  #rl <- as(gr, "GRangesList")
	  rl <- split(gr, seqnames(gr))
	  rl <- rl[which(lapply(rl, function(x)length(x))!=0)] #eliminate chromosomes that are not used
	  view <- RleViewsList(rleList=cov[names(rl)], rangesList=rl)
	  reads.list <- viewApply(view, function(x) { transform_function(as.numeric(x)) })
	  reads.m <- matrix(unlist(sapply(reads.list, as.numeric)), nrow=length(gr), byrow=TRUE)
  }
  reads.m[o, ] <- reads.m
  reads.m
}

standard_metapeak_matrix <- function(regions.gr, sample.cov, upstream=100, downstream=100, keep_region_coordinates = F, diff_length = F, approx_nu=25) {
  if(diff_length == F){
    testit::assert("Coordinates in GRanges are variable length!", length(unique(width(regions.gr)))==1)
    if(keep_region_coordinates){
      reads <- matrix(nrow=length(regions.gr), ncol=width(regions.gr)[1])
    } else {
      regions.gr <- resize(regions.gr, width=downstream)
      regions.gr <- resize(regions.gr, width=upstream + width(regions.gr), fix="end")

      reads <- matrix(nrow=length(regions.gr), ncol=width(regions.gr)[1])
    }
  }else{
    reads <- matrix(nrow=length(regions.gr), ncol=approx_nu)
  }
  i_p <- which(as.logical(strand(regions.gr) == "+" | strand(regions.gr) == "*"))
  i_n <- which(as.logical(strand(regions.gr) == "-"))

  message("There are ", length(i_p), " positive granges and ", length(i_n), " negative granges")

  # if(class(sample.cov) == "character") {
  #   sample.cov <- import(sample.cov, which=regions.gr)
  # }
  if(diff_length == F){
	  if(length(i_p) > 0) reads[i_p, ] <- read_matrix(regions.gr[i_p], sample.cov)
		if(length(i_n) > 0) reads[i_n, ] <- read_matrix(regions.gr[i_n], sample.cov, reverse_reads=TRUE)
	}else{
		if(length(i_p) > 0)reads[i_p, ] <- read_matrix(regions.gr[i_p], sample.cov, df=diff_length, nu=approx_nu)
		if(length(i_n) > 0)reads[i_n, ]<- read_matrix(regions.gr[i_n], sample.cov, reverse_reads=TRUE, df=diff_length,  nu=an)
	}
  reads
}

exo_metapeak_matrix <- function(regions.gr, sample, upstream=100, downstream=100, keep_region_coordinates = F) {
  if(keep_region_coordinates){
    reads <- matrix(nrow=length(regions.gr), ncol=width(regions.gr)[1])
  } else {
    regions.gr <- GenomicRanges::resize(regions.gr, width=downstream)
    regions.gr <- GenomicRanges::trim(resize(regions.gr, width=upstream + width(regions.gr), fix="end")) #resize regions upstream on top of the previous GRanges file
    regions.gr <- regions.gr[width(regions.gr) == upstream+downstream] #regions must be equal to upstream+downstream
  }

  i_p <- which(as.vector(strand(regions.gr) == "+") | as.vector(strand(regions.gr) == "*")) #create i_p for where regions are +
  i_n <- which(as.vector(strand(regions.gr) == "-")) #create i_n for where regions are -

  message("There are ", length(i_p), " positive granges and ", length(i_n), " negative granges")

  reads.p <- matrix(nrow=length(regions.gr), ncol=width(regions.gr)[1]) #make matrix size (num of regions)x(width of regions, def:200)
  reads.n <- reads.p #same empty matrix for neg as pos strand

	  if(length(i_p) > 0) {
	    reads.p[i_p, ] <- read_matrix(regions.gr[i_p], sample$pos, df=F, nu=NULL)
	    reads.n[i_p, ] <- abs(read_matrix(regions.gr[i_p], sample$neg, df=F, nu=NULL))
	  } #writes in all the "positive" GRanges as they are listed in that order

	  if(length(i_n) > 0) {
	    reads.p[i_n, ] <- abs(read_matrix(regions.gr[i_n], sample$neg, reverse_reads=TRUE, df=F, nu=NULL))
	    reads.n[i_n, ] <- read_matrix(regions.gr[i_n], sample$pos, reverse_reads=TRUE, df=F, nu=NULL)
	  } #accounts for orientation and writes in the "negative" GRanges in their spots, but reverses them

  list(pos=reads.p, neg=reads.n)
}

standard_metapeak <- function(gr, sample, upstream=100, downstream=100, sample_name=NA, smooth=NA, different_length=F,approx_n=25) {
  message("standard metapeak: ", sample_name)
  if(different_length==F){
	  reads <- standard_metapeak_matrix(gr, sample, upstream, downstream, diff_length=F, approx_nu=NULL)
	  reads.df <- data.frame(tss_distance=(-1 * upstream):(downstream - 1),
	                        reads=colMeans(reads),
	                        sample_name=sample_name)
	  if(!is.na(smooth)) reads.df$reads <- as.numeric(runmean(Rle(reads.df$reads), k=smooth, endrule="constant"))

	}else{
	 reads <- standard_metapeak_matrix(gr, sample, dl= T, an=approx_n)
  	 reads.df <- data.frame(tss_distance=1:ncol(reads),
                        reads=colMeans(reads),
                        sample_name=sample_name, stringsAsFactors = F)
	}

  reads.df
}

exo_metapeak <- function(gr, sample, upstream=100, downstream=100, sample_name=NA, smooth=NA) {
  message("exo metapeak: ", sample_name)
  reads.list <- exo_metapeak_matrix(gr, sample, upstream, downstream) #get list of reads from function exo_metapeak_matrix

  reads.p <- reads.list$pos
  reads.n <- reads.list$neg

  df.p <- data.frame(tss_distance=(-1 * upstream):(downstream - 1),
                     reads=colMeans(reads.p),
                     strand="+")

  df.n <- data.frame(tss_distance=(-1 * upstream):(downstream - 1),
                     reads=colMeans(reads.n) *(-1),
                     strand="-")

  if(!is.na(smooth)) {
    df.n$reads <- as.numeric(runmean(Rle(df.n$reads), k=smooth, endrule="constant"))
    df.p$reads <- as.numeric(runmean(Rle(df.p$reads), k=smooth, endrule="constant"))
  }

  reads.df <- rbind(df.p, df.n)
  reads.df$sample_name <- sample_name
  reads.df$sample <- paste(reads.df$sample_name, reads.df$strand)
  reads.df
}

standard_metapeak_across_large_region_set<-function(gr, sample, upstream = 100, downstream = 100, cores = 8, chunk_size = 50000){
  chunks<-seq(1, length(gr), chunk_size)
  chunks.df<-mclapply(chunks, function(x){
    upper_limit<-min(x+(chunk_size-1), length(gr)); idx<-x:upper_limit
    df<-standard_metapeak(gr = gr[idx], sample = sample, upstream = upstream, downstream = downstream)
    n_chunk<-length(idx)
    df$reads_sum<-df$reads * n_chunk #get sum of reads across regions rather than mean
    return(df)
  }, mc.cores = cores) %>%
    rbindlist() %>%
    dplyr::group_by(tss_distance) %>%
    #once all regions are found, find mean
    dplyr::summarize(reads = sum(reads_sum, na.rm = T)/length(gr))
  colnames(chunks.df)<-c("position", "reads")
  return(chunks.df)
}

#The functions below rely on the load_bigwig function that deals with multiple samples. If you would like to use this strategy, refer to sample_common.R code.

get_exo_metapeak <- function(gr, sample, upstream=100, downstream=101, smooth=NA, sample_format = "merged", sample_name = NA){
  if(sample_format == "merged"){
    if(is.na(sample_name)){
      sample_name <-sample
      }
    sample_path = load_bigwig(sample)
    metapeak <- exo_metapeak(gr, sample_path,upstream=upstream, downstream=downstream, sample_name=sample_name, smooth=smooth)
  }
  if(sample_format == "separate"){
    if(is.na(sample_name)){
      sample_name <-sample
    }
    sample_path1 <- load_bigwig(sample, sample_format = "separate")[[1]]
    sample_path2 <- load_bigwig(sample, sample_format = "separate")[[2]]

    gr.ex <- resize(gr, upstream, "end") %>% resize(., downstream + upstream, "start")

    cov1 <- list(pos=import.bw(sample_path1$pos, which=gr.ex, as="RleList"), neg = import.bw(sample_path1$neg, which=gr.ex, as="RleList"))
    cov2 <- list(pos=import.bw(sample_path2$pos, which=gr.ex, as="RleList"), neg = import.bw(sample_path2$neg, which=gr.ex, as="RleList"))

    cov <- list(pos = cov1$pos + cov2$pos, neg = cov1$neg + cov2$neg)
    metapeak <- exo_metapeak(gr, cov, upstream=upstream, downstream=downstream, sample_name =sample_name, smooth=smooth)
  }
  if(sample_format == "data"){
    metapeak <- exo_metapeak(gr, sample, upstream=upstream, downstream=downstream, sample_name =sample_name, smooth=smooth)
  }

  metapeak
}

get_standard_metapeak <- function(gr, sample, upstream=100, downstream=101, smooth=NA){
  sample_path = import(sample) #returns problems with getSeqlevels (try just immediately going to standard_metapeak)
  metapeak <- standard_metapeak(gr, sample_path, upstream=upstream, downstream=downstream, sample_name=sample, smooth=smooth)
  metapeak
}

get_exo_matrix <- function(gr, sample, upstream=100, downstream=101, sample_format = "merged"){
  if(sample_format == "merged"){
    sample_path = load_bigwig(sample)
    exo_matrix <- exo_metapeak_matrix(gr, sample_path,upstream=upstream, downstream=downstream)
  }
  if(sample_format == "separate"){
    sample_path1 <- load_bigwig(sample, sample_format = "separate")[[1]]
    sample_path2 <- load_bigwig(sample, sample_format = "separate")[[2]]

    gr.ex <- resize(gr, upstream, "end") %>% resize(., downstream + upstream, "start")

    cov1 <- list(pos=import.bw(sample_path1$pos, which=gr.ex, as="RleList"), neg = import.bw(sample_path1$neg, which=gr.ex, as="RleList"))
    cov2 <- list(pos=import.bw(sample_path2$pos, which=gr.ex, as="RleList"), neg = import.bw(sample_path2$neg, which=gr.ex, as="RleList"))

    cov <- list(pos = cov1$pos + cov2$pos, neg = cov1$neg + cov2$neg)

    exo_matrix <-exo_metapeak_matrix(gr, cov,upstream=upstream, downstream=downstream)
  }
  if(sample_format == "data"){
    exo_matrix <-exo_metapeak_matrix(gr, sample,upstream=upstream, downstream=downstream)
  }
  exo_matrix
}


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

# ____________________________________________________________________________
# Initialization ####

options(mc.cores = future::availableCores())

## ............................................................................
## Load packages ####
library(argparse)
library(scFlow)
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",
  metavar = "Boolean"
)

required$add_argument(
  "--remove_missing",
  default = TRUE,
  required = TRUE,
  help = "Remove non-expressive genes and 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(
  "--keep_unique",
  default = FALSE,
  required = TRUE,
  help = "Keep genes that occur only in one dataset",
  metavar = "Boolean"
)

required$add_argument(
  "--capitalize",
  default = FALSE,
  required = TRUE,
  help = "Capitalize gene names to match homologous genes(i.e. 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",
  metavar = "N"
)

required$add_argument(
  "--thresh",
  default = 0.0001,
  type = "double",
  required = TRUE,
  help = "Convergence threshold.",
  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(
  "--k2",
  default = 500,
  type = "integer",
  required = TRUE,
  help = "Horizon parameter for shared nearest factor graph",
  metavar = "N"
)

required$add_argument(
  "--prune_thresh",
  default = 0.2,
  type = "double",
  required = TRUE,
  help = "Minimum allowed edge weight. Any edges below this are removed",
  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(
  "--nstart",
  default = 10,
  type = "integer",
  required = TRUE,
  help = "Number of times to perform Louvain community detection",
  metavar = "N"
)

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

required$add_argument(
  "--dims_use",
  default = "null",
  required = TRUE,
  help = "Indices of factors to use for shared nearest factor determination",
  metavar = "Indices"
)

required$add_argument(
  "--dist_use",
  default = "CR",
  required = TRUE,
  help = "Distance metric to use in calculating nearest neighbors",
  metavar = "CR"
)

required$add_argument(
  "--center",
  default = FALSE,
  required = TRUE,
  help = "Centers the data when scaling factors",
  metavar = "Boolean"
)

required$add_argument(
  "--small_clust_thresh",
  default = 0,
  type = "double",
  required = TRUE,
  help = "Extracts small clusters loading highly on single factor",
  metavar = "N"
)

### . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . ..
### 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,
  make.sparse = T,
  num_genes = args$num_genes,
  combine = args$combine,
  keep_unique = args$keep_unique,
  capitalize = args$capitalize,
  use_cols = args$use_cols,
  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,
  k2 = args$k2,
  prune_thresh = args$prune_thresh,
  ref_dataset = args$ref_dataset,
  min_cells = args$min_cells,
  quantiles = args$quantiles,
  nstart = args$nstart,
  resolution = args$resolution,
  dims_use = args$dims_use,
  dist_use = args$dist_use,
  center = args$center,
  small_clust_thresh = args$small_clust_thresh,
  do_plot = FALSE,
  id_number = NULL,
  print_obj = FALSE,
  print_mod = FALSE,
  print_align_summary = FALSE
)

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

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


#' Processing of Water Quality Data
#'
#' Processes water quality data. This function looks at detection limit and detection
#' conditions to determine if a value is left censored or not. Censored values are given the qualifier
#' "<".  The dataframe is also converted from a long to wide format.
#'
#' @param data dataframe from Water Quality Portal
#' @param pCode logical if TRUE, assume data came from a pCode search, if FALSE, characteristic name.
#' @keywords data import USGS web service
#' @return data dataframe with first column dateTime, and at least one qualifier and value columns
#' (subsequent qualifier/value columns could follow depending on the number of parameter codes)
#' @export
#' @seealso \code{\link[dataRetrieval]{readWQPqw}}
#' @examples
#' \donttest{
#' #library(dataRetrieval)
#'
#' #rawWQP <- readWQPqw('21FLEECO_WQX-IMPRGR80','Phosphorus', '', '')
#' #Sample2 <- processQWData(rawWQP, pCode=FALSE)
#' }
processQWData <- function(data,pCode=TRUE){

  detectText <- data$ResultDetectionConditionText
  detectText <- toupper(detectText)

  qualifier <- rep("",length(detectText))
  qualifier[grep("NON-DETECT",detectText)] <- "<"
  qualifier[grep("NON DETECT",detectText)] <- "<"
  qualifier[grep("NOT DETECTED",detectText)] <- "<"
  qualifier[grep("DETECTED NOT QUANTIFIED",detectText)] <- "<"
  qualifier[grep("BELOW QUANTIFICATION LIMIT",detectText)] <- "<"

  qualifier[!is.na(data$DetectionQuantitationLimitMeasure.MeasureValue) &
              data$ResultMeasureValue < data$DetectionQuantitationLimitMeasure.MeasureValue] <- "<"

  correctedData<-ifelse((nchar(qualifier)==0),data$ResultMeasureValue,data$DetectionQuantitationLimitMeasure.MeasureValue)
  if(pCode){
    test <- data.frame(data$USGSPCode)
  } else {
    test <- data.frame(data$CharacteristicName)
  }

  test$dateTime <- data$ActivityStartDate

  originalLength <- nrow(test)
  test$qualifier <- qualifier
  test$value <- as.numeric(correctedData)

  test <- test[!is.na(test$dateTime),]
  newLength <- nrow(test)
  if (originalLength != newLength){
    numberRemoved <- originalLength - newLength
    warningMessage <- paste(numberRemoved, " rows removed because no date was specified", sep="")
    warning(warningMessage)
  }

  if (pCode){
    colnames(test)<- c("USGSPCode","dateTime","qualifier","value")
    newTimeVar <- "USGSPCode"
  } else {
    colnames(test)<- c("CharacteristicName","dateTime","qualifier","value")
    newTimeVar <- "CharacteristicName"
  }

  data <- suppressWarnings(reshape(test, idvar="dateTime", timevar = newTimeVar, direction="wide"))
  data$dateTime <- format(data$dateTime, "%Y-%m-%d")
  data$dateTime <- as.Date(data$dateTime)
  return(data)
}


####################################################
#输出评分图
####################################################
--install.packages("ggplot2") #安装ggplot2
library(ggplot2)
evaluator<-read.table(file="evaluator.csv",header=TRUE,sep=",")
g<-ggplot(data=evaluator,aes(precision,recall,col=algorithm))
g<-g+geom_point(aes(size=3))
g<-g+geom_text(aes(label=algorithm))
g<-g+scale_x_continuous(limits=c(0,1))+scale_y_continuous(limits=c(0,1))
g

job<-read.table(file="job.csv",header=FALSE,sep=",")
names(job)<-c("jobid","create_date","salary")

pv<-read.table(file="pv.csv",header=FALSE,sep=",")
names(pv)<-c("userid","jobid")

pv[which(pv$userid==974),]
j1<-job[job$jobid %in% c(106,173,82,188,78),];j1
job[job$jobid %in% c(145,121,98,19),]
job[job$jobid %in% c(145,89,19),]

avg08<-mean(j1$salary)*0.8;avg08


library(zoo)
source(paste0(".","/getData.R"), echo=FALSE)
library(testit)
SENSOR_ID = list(Temperature_FARM_16B1=18, Temperature_Farm_16B2=27, Temperature_Farm_16B4=23)

report_print = function(report_Object) {
  report_Source = sprintf("Source: %s", report_Object$path)
  report_Dimension = sprintf("Dimension: [%s,%s]", dim(report_Object$object)[1],dim(report_Object$object)[2])
  report_Timestamps = sprintf("FarmTimestamp %s - %s", report_Object$object$FarmTimestamp[1], report_Object$object$FarmTimestamp[length(report_Object$object$FarmTimestamp)])
  report_TOC = c(report_Source,report_Dimension,report_Timestamps)

  for (content in report_TOC) {
    print(content)
  }
  print("")
}

path_208 = "../data/t_ee_208.RDS"
tee208 = list(path=path_208, object=readRDS(path_208))

#path_398 = "../data/t_ee_398.RDS"
#tee398 = list(path=path_398, object=readRDS(path_398))

#path_410 = "../data/t_ee_410.RDS"
#tee410 = list(path=path_410, object=readRDS(path_410))

report_Objects = list(tee208)

for (t_object in report_Objects) {
  report_print(t_object)
}

t_object = tee208
startDate = t_object$object$FarmTimestamp[1]
endDate = t_object$object$FarmTimestamp[length(t_object$object$FarmTimestamp)]
numberOfDays = 270
datesToGetData = list(startDate=startDate, endDate=startDate+(numberOfDays * SECONDS.PERDAY))

energy_raw = getEnergyData(limitRows = 0, datesToGetData = datesToGetData)
energy_rds=sprintf("../data/energy_raw.rds")
saveRDS(energy_raw,file = energy_rds)

env_rds=sprintf("../data/env_raw.rds")
env_raw = getTemperatureHumidityData(limitRows = 0, datesToGetData = datesToGetData)
env_raw_sensor18 = env_raw[env_raw[,"sensor_id"]==18,]
saveRDS(env_raw_sensor18, file=env_rds)

testRowCount = function(energy, env, t_ee) {
  assert("Energy has 31296 rows", {
    length(energy$timestamp) == 31296
  })
  assert("Temp/Humidity has 44751 rows", {
    length(env$timestamp) == 44751
  })
}

energy_raw=readRDS(energy_rds)
env_raw=readRDS(env_rds)

#testRowCount(energy_raw, env_raw_sensor18)

testDates = function(energy, env, t_ee) {
  tee_StartDate = as.POSIXct(t_ee$object$FarmTimestamp[1], format="%Y-%m-%d %H:%M:%S", tz="UTC")
  tee_EndDate = as.POSIXct(t_ee$object$FarmTimestamp[length(t_ee$object$FarmTimestamp)], format="%Y-%m-%d %H:%M:%S", tz="UTC")
  tee_Interval = lubridate::interval(startDate, endDate)

  energyAvailabilityStart = as.POSIXct(energy$timestamp[1], format="%Y-%m-%d %H:%M:%S", tz="UTC")
  energyAvailabilityEnd = as.POSIXct(energy$timestamp[length(energy$timestamp)], format="%Y-%m-%d %H:%M:%S", tz="UTC")
  energy_Interval = lubridate::interval(energyAvailabilityStart, energyAvailabilityEnd)

  # Checking start and end date
  assert(sprintf("FarmTimestamp %s",tee_Interval), {
    (t_ee$object$FarmTimestamp[1] == tee_StartDate)
    (t_ee$object$FarmTimestamp[length(t_ee$object$FarmTimestamp)] == tee_EndDate)
  })

  assert(sprintf("Energy %s", energy_Interval), {
    cat (sprintf("Energy interval: %s\n",energy_Interval))
    cat (sprintf("Tee StartDate: %s\n",tee_StartDate))
    cat (sprintf("Tee EndDate: %s\n",tee_EndDate))
    (energyAvailabilityStart %within% tee_Interval)
    (energyAvailabilityEnd %within% tee_Interval)
  })

}

#testEnv = function(env_raw, tee208){
  #assert("env_raw$temperature[1:5] == tee208",{
#  })
#}

#testDates(energy_raw, env_raw, tee208)

source(paste0(".","/may_cleandata.R"), echo=FALSE)
may_208 = readRDS("../data/t_ee_may_208.RDS")
may_208$Temperature_FARM_16B1[12:20]

> tee_208$Temperature_FARM_16B1[1:8]
[1] 20.1750 19.9500 19.6500 19.7000 20.1125 20.6125 22.2500 22.7250
> may_208$Temperature_FARM_16B1[12:20]
[1] 20.4750 19.9500 19.6500 19.7000 20.1125 20.6125 22.2500 22.7250 22.9625
> may_208$Humidity_FARM_16B1[12:20]
[1] 65.50 69.00 73.75 80.50 82.00 76.75 74.00 71.50 69.75
> tee_208$Humidity_FARM_16B1[1:8]
[1] 66.75 69.00 73.75 80.50 82.00 76.75 74.00 71.50
> tee_208$EnergyCP[1:8]
[1] 15.920 15.765 14.585 14.980 16.570 23.665 26.720 26.605
> may_208$EnergyCP[12:20]
[1] 15.920 15.765 14.585 14.980 16.570 23.665 26.720 26.605 27.260


source("alternate_methods/epiestim.r")

# Wrapper script to run a single area under the
# singlearea approximation
opt = epiestim_get_cmdline_options()
print(opt$area_index)
epiestim_run(opt$area_index, opt)


source("common.r")

# Preprocess latency data.

####################################
## Preprocessing / Sanity Checks. ##
####################################

clockDuration <- 1 / 3393e6

dataDir <- "../data/"
dataFolders <- dir(dataDir)
dataFolders <- paste(dataDir, "/", dataFolders[grepl("exp", dataFolders)], "/", sep = "")

allData.lat <- data.table()

progbar <- txtProgressBar(style = 3)

for (ii in 1:length(dataFolders)) {

    curFileList <- dir(dataFolders[ii])
    curFileList <- curFileList[grepl("histogram.*csv", curFileList)]

    setTxtProgressBar(progbar, ii / length(dataFolders))

    parts.folder <-
        dataFolders[ii] %>%
        str_split("/") %>%
        unlist() %>%
        nth(length(.) - 1) %>%
        str_split("-|_") %>%
        unlist()

    # => beta
    currentMaxFrameSize <- parts.folder[3] %>% as.numeric()
    # => pktsize
    currentPacketSize <- parts.folder[5] %>% as.numeric()
    # => L
    currentQueueSize <- parts.folder[7] %>% as.numeric()

    for (jj in 1:length(curFileList)) {

        parts <- str_match(
            curFileList[jj],
            "histogram-([[:alnum:]]+)-([[:digit:]]+)\\.csv")

        currentRate <- parts[3] %>% as.numeric()
        currentExpType <- parts[2]
        currentRepetition <- 1

        currentFilePath <- paste(dataFolders[ii], curFileList[jj], sep = "")

        currentData <-
            fread(currentFilePath, col.names = c("latns", "n")) %>%
            uncount(n) %>%
            mutate(rate = currentRate,
                   rep = currentRepetition,
                   exptype = currentExpType,
                   maxfs = currentMaxFrameSize,
                   pktsize = currentPacketSize,
                   qsize = currentQueueSize)

        allData.lat <- rbind(allData.lat, currentData)

    }
}

allData.lat <-
    allData.lat %>%
    mutate(
        exptype = factor(exptype),
        maxfs = factor(maxfs),
        rep = factor(rep),
        ratef = factor(rate))

# Aggregated latency information.
allData.lat.agg <-
    allData.lat %>%
    group_by(exptype, maxfs, pktsize, qsize, rate) %>%
    summarise(
        medlat = median(latns / 1e3),
        meanlat = mean(latns / 1e3),
        cvlat = sd(latns) / mean(latns)) %>%
    pivot_longer(medlat:cvlat, names_to = "metric", values_to = "val")


#!/usr/bin/Rscript

## bs2meancalc.r -- calculates mean / SD from bootstrap summary results

## Author: David Eccles (gringer), 2009 <programming@gringer.org>

usage <- function(){
  cat("usage: ./bs2meanvar.r <file> [options]\n");
  cat("\nOther Options:\n");
  cat("-help            : Only display this help message\n");
## ignore string... not yet implemented
##  cat("-ignore <string> : consider <string> to indicate missing values");
  cat("\n");
}

means.df <- NULL;
infile.name <- FALSE;
ignore.string <- FALSE;

argLoc <- 1;

# print(commandArgs());

argLoc <- grep("--args",commandArgs()) + 1; # hack to get around R v2.4
                                            # issue stopping
                                            # commandArgs(TRUE) from
                                            # working

while(!is.na(commandArgs()[argLoc])){
  if(file.exists(commandArgs()[argLoc])){ # file existence check
    if(infile.name == FALSE){
      infile.name <- commandArgs()[argLoc];
    } else{
      cat("Error: More than one input file specified\n");
      usage();
      quit(save = "no", status=1);
    }
  } else {
    if(commandArgs()[argLoc] == "-help"){
      usage();
      quit(save = "no", status=0);
    }
    if(commandArgs()[argLoc] == "-ignore"){
      ignore.string = commandArgs()[argLoc+1];
      argLoc <- argLoc + 1;
    }
  }
  argLoc <- argLoc + 1;
}

if(infile.name == FALSE){
  cat("Error: no input file specified\n");
  usage();
  quit(save = "no", status=2);
}

con <- gzfile(infile.name);
open(con);

## determine number of bootstraps
cat("Checking first marker to determine number of bootstraps...",file = stderr());
numBootstraps <- FALSE;
marker.df <- NULL;
line.df <- read.csv(con, header = TRUE, nrows = 1, colClasses =
                    c("character", "integer", "numeric"), col.names
                    = c("marker","bs","value"));
first.name <- line.df$marker[1];
marker.name <- line.df$marker[1];
while(marker.name == first.name){
  marker.df <- rbind(marker.df, line.df);
  numBootstraps <- numBootstraps + 1;
  line.df <- read.csv(con, header = FALSE, nrows = 1, colClasses =
                      c("character", "integer", "numeric"), col.names
                      = c("marker","bs","value"));
  marker.name <- line.df$marker[1];
}

## analyse first marker
marker.mean <- mean(marker.df$value);
marker.sd <- sd(marker.df$value);
write.table(data.frame(name = marker.name, mean = marker.mean, sd = marker.sd), row.names = FALSE, col.names = TRUE, sep = ",");

cat("Done, found", numBootstraps, "bootstraps\n",file = stderr());
firstLine <- TRUE;
lineCount <- 1;

cat("Calculating mean/SD (one '.' per 1000 markers)",file = stderr());
while(dim(marker.df)[1] > 0){
  if(lineCount %% 1000 == 0){
    cat(".",file = stderr());
  }
  if(firstLine){ # picks up remainder from bootstrap number check
    marker.df <-
      read.csv(con, header = FALSE, nrows = numBootstraps - 1,
               colClasses = c("character", "integer", "numeric"),
               col.names = c("marker","bs","value"));
    marker.df <- rbind(line.df, marker.df);
    firstLine <- FALSE;
  } else {
    marker.df <-
      read.csv(con, header = FALSE, nrows = numBootstraps,
               colClasses = c("character", "integer", "numeric"),
               col.names = c("marker","bs","value"));
  }
#  cat("Read",dim(marker.df)[1],"lines\n");
  if(dim(marker.df)[1] == numBootstraps){
    marker.name <- marker.df$marker[1];
    marker.mean <- mean(marker.df$value);
    marker.sd <- sd(marker.df$value);
    if(marker.df[numBootstraps,"marker"] != marker.df[1,"marker"]){
      stop("Error: first marker is not the same as the last marker");
    }
    write.table(data.frame(name = marker.name, mean = marker.mean, sd = marker.sd), row.names = FALSE, col.names = FALSE, sep = ",");
  }
  lineCount <- lineCount + 1;
}
close(con);

cat("done!\n",file = stderr());


# input
qcfile <- commandArgs(trailingOnly = T)[1]
outputdir <- commandArgs(trailingOnly = T)[2]
insert_d <- commandArgs(trailingOnly = T)[3]
reads_threshold <- as.numeric(commandArgs(trailingOnly = T)[4])
percentage_threshold <- as.numeric(commandArgs(trailingOnly = T)[5])
suppressPackageStartupMessages({
  library(ggplot2)
  library(viridis)
  library(gridExtra)
  })
####
#### draw figures for QC metrices
####
a <- read.csv(qcfile, header=T, sep="\t")
#brewer.pal(4, "Dark2")
#### fig 1
p1 <- ggplot(a, aes(x="", y=Overall_alignment_ratio)) +
    geom_violin(width=0.5, lwd=1.2, fill="#1B9E77") +
    geom_boxplot(width=0.02, outlier.shape = NA) +
    theme_classic(base_size=12)+
    xlab("Reads overall alignment") + ylab("Percentage")
# Reads_properly_paired_percentage
p2 <- ggplot(a, aes(x="", y=Reads_properly_paired_percentage)) +
    geom_violin(width=0.5, lwd=1.2, fill="#D95F02") +
    geom_boxplot(width=0.02, outlier.shape = NA) +
    theme_classic(base_size=13) +
    xlab("Reads properly paired") + ylab("Percentage")
# Reads_duplicated_percentage
p3 <- ggplot(a, aes(x="", y=Reads_duplicated_percentage)) +
    geom_violin(width=0.5, lwd=1.2, fill="#7570B3") +
    geom_boxplot(width=0.02, outlier.shape = NA) +
    theme_classic(base_size=13) +
    xlab("Reads duplicated") + ylab("Percentage")
# Reads_nuclear_percentage
p4 <- ggplot(a, aes(x="", y=Reads_nuclear_percentage)) +
    geom_violin(width=0.5, lwd=1.2, fill="#E7298A") +
    geom_boxplot(width=0.02, outlier.shape = NA) +
    theme_classic(base_size=13) +
    xlab("Reads nuclear") + ylab("Percentage")
png(filename = paste0(outputdir, "/QC-statistics-1.png"), width = 1000, height = 500)
grid.arrange(p1, p2, p3, p4, ncol=4)
invisible(dev.off())
# pdf
pdf(paste0(outputdir, "/QC-statistics-1.pdf"))
grid.arrange(p1, p2, p3, p4, ncol=4)
invisible(dev.off())
message("[ok]QC-figure1")

#### fig 2
plot2 = ggplot(a, aes(x = log10(Reads_properly_paired), y = Reads_in_peak_percentage)) +
  geom_hex(bins = 50) +
  theme_bw() + scale_fill_viridis() +
  xlab("log10 Properly Paired Reads") +
  ylab("Percentage of Reads Enrichment in Peaks") +
  geom_hline(yintercept = percentage_threshold, lty = "dashed") +
  geom_vline(xintercept = log10(reads_threshold), lty = "dashed") +
  theme_classic() +
  theme(axis.title.x = element_text(size=10))
# png
png(filename = paste0(outputdir, "/QC-statistics-2.png"), width = 800, height = 500)
plot2
invisible(dev.off())
# pdf
pdf(paste0(outputdir, "/QC-statistics-2.pdf"))
plot2
invisible(dev.off())
message("[ok]QC-figure2")

#### fig 3
xx <- read.csv(insert_d, header=F, sep="\t")
# png
png(filename = paste0(outputdir, "/QC-statistics-3.png"), width = 550, height = 500)
par(mar=c(5, 4.3, 4, 2) + 0.5)
plot(xx[,1], (xx[,2])/1000000, type="l", col="indianred",lwd=4, xlab="Insert Size", ylab=expression("Fragment Counts" ~ 10^6))
invisible(dev.off())
# pdf
pdf(paste0(outputdir, "/QC-statistics-3.pdf"))
par(mar=c(5, 4.3, 4, 2) + 0.5)
plot(xx[,1], (xx[,2])/1000000, type="l", col="indianred",lwd=4, xlab="Insert Size", ylab=expression("Fragment Counts" ~ 10^6))
invisible(dev.off())
message("[ok]QC-figure3")


library(magrittr)

## READ DATA (a table created using GATK VariantsToTable tool)
tab <- read.table("input.tsv", h=T, sep="\t")

## SAMPLE PAIRS
mlls_combn <- grep("GT",colnames(tab),val=T) %>% combn(2) %>% t

## PREPARE OUTPUT TABLE
mlls_dist <- data.frame(mlls_combn,matrix(NA,nrow(mlls_combn),3))
names(mlls_dist) <- c("anim1","anim2","total","mismatch","intraMLL")

## REMOVE SUSPICIOUS POSITIONS (homozygous in F1 hybrids, only makes sense for table of diagnostic positions)
tab <- tab[-grep("A/A|C/C|G/G|T/T",tab$csc069_GT),]
tab <- tab[-grep("A/A|C/C|G/G|T/T",tab$csc071_GT),]

## COUNT MISMATCHES FOR SAMPLE PAIRS
for(i in seq(nrow(mlls_dist))){
  x <- tab[which(is.na(tab[,grep(mlls_dist[i,1],colnames(tab))])==F & is.na(tab[,grep(mlls_dist[i,2],colnames(tab))])==F),c(grep(mlls_dist[i,1],colnames(tab)),grep(mlls_dist[i,2],colnames(tab)))]
  print(colnames(x))
  mlls_dist[i,3] <- nrow(x)
  mlls_dist[i,4] <- which(x[,1]!=x[,2]) %>% length()
}

## EXPORT TO CSV
write.csv2(mlls_dist,"pairwise_mismatches.csv")

## BOXPLOT
boxplot(list(interMLL=(mlls_dist$mismatch/mlls_dist$total)[which(mlls_dist$intraMLL==F)],intraMLL=(mlls_dist$mismatch/mlls_dist$total)[which(mlls_dist$intraMLL==T)]))

## WILCOXON RANK SUM TEST
wilcox.test(x=(mlls_dist$mismatch/mlls_dist$total)[which(mlls_dist$intraMLL==F)],y=(mlls_dist$mismatch/mlls_dist$total)[which(mlls_dist$intraMLL==T)])


loadInputData <- function(remove = NULL, maxout = NULL, replace = NULL, fireNudge = NULL) {

    files = list.files('data/driving_Data/')
    files = files[grepl('.nc', files)]

    dat = lapply(paste('data/driving_Data/', files, sep = '/'), raster)

    names(dat) = unlist(strsplit(files, '.nc', fixed = TRUE))

    MAP_vars = grepl("MAP_", names(dat))
    #dat[MAP_vars] = lapply(dat[MAP_vars], logmin)

    droughtMetrics = c("MADD_", "MADM_", "MDDM_", "MConc_")
    splitDrought <- function(metric) {
        nms = names(dat)
        index = which(grepl(metric,nms))
        new_dat = rep(dat[index], each = 2)
        new_nms = paste0(c('RainTerm_', 'StressTerm_'), rep(nms[index],each = 2))
        names(new_dat) = new_nms
        return(new_dat)
    }
    new_dat = lapply(droughtMetrics, splitDrought)
    dat = c(dat, unlist(new_dat))

    replaceVar <- function(dat, vname, replace) {

        if (vname == "Drought") {
            for (i in droughtMetrics)
                dat = replaceVar(dat, i, replace)

        } else if (vname == "RainTerm_Drought") {
            for (i in droughtMetrics)
                dat = replaceVar(dat, paste0("RainTerm_", i), replace)
        } else if (vname == "StressTerm_Drought") {
            for (i in droughtMetrics)
                dat = replaceVar(dat, paste0("StressTerm_", i), replace)
        } else {
            #if (vname == droughtMetrics[1]) browser()
            vars = grepl(vname, names(dat))
            repl <- function(i) {
                if (is.character(replace)) {
                    rn = raster(replace)
                    rn = raster::resample(rn, i)
                    i = rn
                } else i[!is.na(i)] = replace
                return(i)
            }
            dat[vars] = lapply(dat[vars], repl)
        }
	return(dat)
    }
    #if (remove == "RainTerm_Drought") browser()

    if (!is.null(remove)) {

        "if (!is.null(fireNudge)) {
            nudge <- function(x, var) {
                kc = conFire_params[, x[1]] * conFire_params[, x[2]]
                kc = quantile(kc, c(0.05, 0.5, 0.95))
                S = layer.apply(kc, function(i) exp(i * dat[[var]]))
                return(S)
            }
            Ss = mapply(nudge, fireNudge, names(fireNudge))
            browser()
        }"
        for (i in remove) dat = replaceVar(dat, i, 0.0)
    }

    if (!is.null(maxout))
	for (i in maxout) dat = replaceVar(dat, i, 9E9)

    if (!is.null(replace))
	for (i in 1:length(replace)) dat = replaceVar(dat, names(replace)[i], replace[i])

    return(dat)
}


#' temporal netwrok over metacells
#'
#' Splitting metacells over a discrete time axis, defining manifold connections and estimated flows over them
#'
#' @slot mc_id id of the metacell object we represent as a network
#' @slot mgraph_id id of the mgraph object defining manifold structure
#' @slot times_nms names of the time points (Default 1:T)
#' @slot mc_t distribution of metacells (rows) over time points (cols)
#' @slot mc_mgraph a data frame defining triplets mc1, mc2, distance.
#' @slot mc_manif_p probability of moving between mcs - matrix
#' @slot mc_manif_cost  probability of moving between mcs
#' @slot network - a data frame defining the network structure
#' @slot edge_flows - flow of mincost solution
#' @slot mc_t_infer - inferred fraction ofcells per mc and time
#'
#' @export tgMCTNetwork
#' @exportClass tgMCTNetwork
tgMCTNetwork <- setClass(
   "tgMCTNetwork",
	slots = c(
	  mc_id = "character",
	  mgraph_id = "character",
	  cell_time = "vector",
	  mc_t = "matrix",
	  mc_mgraph = "data.frame",
	  mc_cost_mat = "matrix",
	  mc_manif_cost = "data.frame",
	  network = "data.frame",
	  edge_flows = "vector",
	  mc_t_infer = "matrix",
	  mc_forward = "list",
	  mc_backward = "list")
)

#' Construct a meta cell time network
#'
#'
#'
#' @param mc_id metacell object id
#' @param mgraph_id metacell graph object id
#' @param cell_time vector assigning a time (number) to each cell
#' @param mc_prolif factor per mc
#' @export

setMethod(
  "initialize",
  signature = "tgMCTNetwork",
  definition =
    function(.Object, mc_id, mgraph_id, cell_time) {
		.Object@mc_id = mc_id
		.Object@mgraph_id = mgraph_id
		.Object@cell_time = cell_time
		mc = scdb_mc(mc_id)
		if(is.null(mc)) {
			stop("MC-ERR unkown mc_id ", mc_id, " when building network")
		}
		mc_t = table(mc@mc, cell_time[names(mc@mc)])
		mc_t = matrix(mc_t, ncol=ncol(mc_t))
		mc_t = t(t(mc_t)/colSums(mc_t))

		.Object@mc_t = matrix(mc_t, ncol=ncol(mc_t))

		mgraph = scdb_mgraph(mgraph_id)
		if(is.null(mgraph)) {
			stop("MC-ERR unkown manifold id ", mgraph_id, " when building network")
		}
		if(mgraph@mc_id != mc_id) {
			stop("MC-ERR mismatch of mc_id ", mc_id, " and mgraph ", mgraph_id, " when building network")
		}
		.Object@mc_mgraph = mgraph@mgraph

      return(.Object)
    }
)

#' Generate a new network in scdb
#'
#' This constructs a meta cell time network object from an mc and mgraph objects and assignments of cells to graphs
#'
#' @param net_id id of scdb network object ot be added
#' @param mc_id metacell object
#' @param mgraph_id metacell manfold graph object
#' @param cell_time assigning of time (discrete) to cells
#' @export
mcell_new_mctnetwork = function(net_id, mc_id, mgraph_id, cell_time)
{
	scdb_add_mctnetwork(net_id, tgMCTNetwork(mc_id, mgraph_id, cell_time))
}

#' Compute and update manifold costs for a mc time network
#'
#'
#' @param mct mct network object
#' @param t_exp time parameter for the markov exponential
#' @param T_cost threshold on the cost for retan
#'
#' @return an updated mct object
#' @export

mctnetwork_comp_manifold_costs = function(mct, t_exp = 1, T_cost = 1000)
{
  mgraph = mct@mc_mgraph
  df = mgraph[,c(2,1,3)]
  colnames(df) = colnames(mgraph)

  mgraph2 = rbind(mgraph, df)
  mgraph2 = unique(mgraph2[,c(1,2,3)])
  mgraph2$dist_inv = 1/mgraph2$dist

  adj_mat = sparseMatrix(i = mgraph2$mc1,j = mgraph2$mc2,x = mgraph2$dist_inv)
  adj_mat = as.matrix(adj_mat)

  diag(adj_mat) = 0

  row_max = apply(adj_mat,1,max)
  median_rate = median(row_max)

  adj_mat = adj_mat/median_rate

  row_sums = rowSums(adj_mat)
  diag(adj_mat) = -row_sums

  trans_mat = expm(t_exp*adj_mat)

  trans_mat = as.matrix(trans_mat)
  trans_mat = trans_mat/apply(trans_mat,1,max)

#  diag(trans_mat) = rowMaxs(trans_mat)

  cost_mat = round(10/trans_mat)
  cost_mat = as.matrix(cost_mat)
  rownames(cost_mat) = 1:nrow(cost_mat)
  colnames(cost_mat) = 1:ncol(cost_mat)

  manifold = as.data.frame.table(cost_mat)
  colnames(manifold) = c("mc1","mc2","cost")
  manifold = manifold[is.finite(manifold$cost),]
  manifold = manifold[manifold$cost < T_cost,]

  colnames(manifold) = c("mc1","mc2","cost")

	mct@mc_cost_mat = cost_mat
	mct@mc_manif_cost = manifold
	return(mct)
}

#' Compute and update network strcuture from mc, manifodld costs
#'
#' @param mct mct network object
#' @param mc_leak the fraciton of frequency loss per mc per time step. All zero if you don't know what to expect.
#'
#' @return an updated mct object
#' @export

mctnetwork_gen_network = function(mct, mc_leak,
								capacity_var_factor = NULL,
								off_capacity_cost1 = 1,
								off_capacity_cost2 = 1000,
								k_norm_ext_cost = 2,
								k_ext_norm_cost = 2,
								k_ext_ext_cost = 100,
								T_cost = 1000)
{
	k_inf = 100000

	manifold = mct@mc_manif_cost
	mc_t_freq = mct@mc_t
	max_t = ncol(mc_t_freq)
	gl = build_growth_mats(mct, mc_leak)
	growth_leak = gl$leak
	growth_compensate = gl$compensate

	if(is.null(capacity_var_factor)) {
		capacity_var_factor = rep(0.25, nrow(mc_t_freq))
	}

	edges = data.frame(from = c(), to = c(),
						ID = c(), capacity = c(), cost = c(),
						time1 = c(), time2 = c(), min_capacity = c(),
						type1 = c(), type2 = c())
#type are: norm, ext, growth, src ,sink

	n_mc = nrow(mc_t_freq)

#generate lists of nodes per network layer

	source_id = 1

	normal_nodes_t_back = list()
	extend_nodes_t_back = list()
	normal_nodes_t_front = list()
	extend_nodes_t_front = list()
	growth_nodes_t = list()
	next_n_id = 2
	for(t in 1:max_t) {
		normal_nodes_t_back[[t]] = next_n_id:(next_n_id + n_mc - 1)
		next_n_id = next_n_id + n_mc
		extend_nodes_t_back[[t]] = next_n_id:(next_n_id + n_mc - 1)
		next_n_id = next_n_id + n_mc
		normal_nodes_t_front[[t]] = next_n_id:(next_n_id + n_mc - 1)
		next_n_id = next_n_id + n_mc
		extend_nodes_t_front[[t]] = next_n_id:(next_n_id + n_mc - 1)
		next_n_id = next_n_id + n_mc
		growth_nodes_t[[t]] = next_n_id
		next_n_id = next_n_id + 1
	}
#we eliminate the last growth node by overiding its id with the sink
	sink_id = next_n_id - 1

#add edges from source to back time 1
	next_e_id = 1
	edges_src = data.frame(
						from = rep(source_id, n_mc),
						to = normal_nodes_t_back[[1]],
						ID = next_e_id:(next_e_id + n_mc - 1),
						capacity = rep(k_inf, n_mc),
						min_capacity = rep(0,n_mc),
						cost = rep(0, n_mc),
						mc1 = rep(-1, n_mc),
						mc2 = 1:n_mc,
						time1 = rep(0, n_mc), time2 = rep(1, n_mc),
						type1 = rep("src", n_mc), type2 = rep("norm_b", n_mc))
	next_e_id = next_e_id + n_mc

	edges_capacity = list()
	edges_manifold = list()
	edges_growth_in = list()
	edges_growth_out = list()
	alpha = capacity_var_factor
	for(t in 1:max_t) {
		edges_capacity[[t]] = data.frame(
						from = c(rep(normal_nodes_t_back[[t]],2),
										rep(extend_nodes_t_back[[t]],2)),
						to = c(rep(normal_nodes_t_front[[t]],2),
										rep(extend_nodes_t_front[[t]],2)),
						ID = next_e_id:(next_e_id + 4*n_mc - 1),
						capacity = c((1-1/(1+alpha))*mc_t_freq[,t],
										 (1/(1+alpha))*mc_t_freq[,t],
										 (alpha)*mc_t_freq[,t],
										 ifelse(mc_t_freq[,t]>0, k_inf,0)),
						min_capacity = rep(0, 4*n_mc),
						cost = rep(c(-off_capacity_cost2, -off_capacity_cost1,
										off_capacity_cost1, off_capacity_cost2), each=n_mc),
						mc1 = rep(1:n_mc, 4),
						mc2 = rep(1:n_mc, 4),
						time1 = rep(t, 4*n_mc), time2 = rep(t, 4*n_mc),
						type1 = c(rep("norm_b", 2*n_mc), rep("extend_b", 2*n_mc)),
						type2 = c(rep("norm_f", 2*n_mc), rep("extend_f", 2*n_mc)))

		next_e_id = next_e_id + 4*n_mc

		if(t != max_t) {
			n_e = nrow(manifold)
			norm_norm_from = normal_nodes_t_front[[t]][manifold$mc1]
			norm_norm_to = normal_nodes_t_back[[t+1]][manifold$mc2]

			norm_ext_from = normal_nodes_t_front[[t]][manifold$mc1]
			norm_ext_to = extend_nodes_t_back[[t+1]][manifold$mc2]

			ext_norm_from = extend_nodes_t_front[[t]][manifold$mc1]
			ext_norm_to = normal_nodes_t_back[[t+1]][manifold$mc2]

			ext_ext_from = extend_nodes_t_front[[t]][manifold$mc1]
			ext_ext_to = extend_nodes_t_back[[t+1]][manifold$mc2]

			edges_manifold[[t]] = data.frame(
						from = c(norm_norm_from, norm_ext_from, ext_norm_from, ext_ext_from),
						to = c(norm_norm_to, norm_ext_to, ext_norm_to, ext_ext_to),
						ID = next_e_id:(next_e_id+4*n_e-1),
						capacity = rep(k_inf, 4*n_e),
						min_capacity = rep(0,4*n_e),
						cost = c(manifold$cost,
									manifold$cost*k_norm_ext_cost,
									manifold$cost*k_ext_norm_cost,
									manifold$cost*k_ext_ext_cost),
						mc1 = rep(manifold$mc1, 4),
						mc2 = rep(manifold$mc2, 4),
						time1 = rep(t, 4*n_e),
						time2 = rep(t+1, 4*n_e),
						type1 = c(rep("norm_f", 2*n_e), rep("extend_f", 2*n_e)),
						type2 = rep(c(rep("norm_b", n_e), rep("extend_b", n_e)),2))

			next_e_id = next_e_id + 4*n_e

			edges_growth_in[[t]] = data.frame(
						from = normal_nodes_t_front[[t]],
						to = rep(growth_nodes_t[[t]], n_mc),
						ID = next_e_id:(next_e_id + n_mc - 1),
						capacity = growth_leak[, t],
						min_capacity = rep(0,n_mc),
						cost = rep(0, n_mc),
						mc1 = 1:n_mc,
						mc2 = -2,
						time1 = rep(t, n_mc), time2 = rep(t, n_mc),
						type1 = rep("norm_f", n_mc), type2 = rep("growth", n_mc))
			next_e_id = next_e_id + n_mc
			edges_growth_out[[t]] = data.frame(
						from = rep(growth_nodes_t[[t]], n_mc),
						to = normal_nodes_t_back[[t+1]],
						ID = next_e_id:(next_e_id + n_mc - 1),
						capacity = growth_compensate[,t+1],
						min_capacity = rep(0,n_mc),
						cost = rep(0, n_mc),
						mc1 = -2,
						mc2 = 1:n_mc,
						time1 = rep(t, n_mc), time2 = rep(t+1, n_mc),
						type1 = rep("growth", n_mc), type2 = rep("norm_b", n_mc))
			next_e_id = next_e_id + n_mc
		}
	}
	edges_sink = data.frame(
						from = c(normal_nodes_t_front[[max_t]],
									extend_nodes_t_front[[max_t]]),
						to = rep(sink_id, n_mc*2),
						ID = next_e_id:(next_e_id + n_mc*2 - 1),
						capacity = rep(k_inf, 2*n_mc),
						min_capacity = rep(0, 2*n_mc),
						cost = rep(0, 2*n_mc),
						mc1 = rep(1:n_mc, 2),
						mc2 = -1,
						time1 = rep(max_t, 2*n_mc), time2 = rep(max_t+1, 2*n_mc),
						type1 = c(rep("norm_f", n_mc), rep("extend_f", n_mc)), type2 = rep("sink", 2*n_mc))
	next_e_id = next_e_id + n_mc

	ec = do.call("rbind", edges_capacity)
	em = do.call("rbind", edges_manifold)
	egi = do.call("rbind", edges_growth_in)
	ego = do.call("rbind", edges_growth_out)

	network = rbind(edges_src, ec)
	network = rbind(network, em)
	network = rbind(network, egi)
	network = rbind(network, ego)
	network = rbind(network, edges_sink)

	# construct dataframe with all node IDs
	t_node = c()
	for (i in 1:max_t) {
	  t_node = c(t_node,rep(i,n_mc))
	}

	df_norm_ext_nodes = data.frame(node = c(unlist(normal_nodes_t_back),unlist(normal_nodes_t_front),unlist(extend_nodes_t_back),unlist(extend_nodes_t_front)),
	                               t = rep(t_node,4),
	                               mc = rep(c(1:n_mc),4*max_t),
	                               type = c(rep("norm_b",n_mc*max_t),rep("norm_f",n_mc*max_t),rep("extend_b",n_mc*max_t),rep("extend_f",n_mc*max_t)))

	growth_nodes = unlist(growth_nodes_t)[1:(max_t-1)]

	df_growth_nodes = data.frame(node = unlist(growth_nodes),
	                             t = c(1:length(growth_nodes)),
	                             mc = rep(-2,length(growth_nodes)),
	                             type = rep("growth",length(growth_nodes)))

	df_src_sink_nodes = data.frame(node = c(source_id,sink_id),t = c(0,max_t +1),mc = c(-1,-1),type = c("src","sink"))

	nodes = rbind(df_src_sink_nodes,df_growth_nodes)
	nodes = rbind(nodes,df_norm_ext_nodes)

	nodes = nodes[order(nodes$node),]
   rownames(nodes) = c(1:nrow(nodes))

	mct@network = network

#	return(list(net = network,
#	            nodes = nodes,
#					    norm_back_t_mc = normal_nodes_t_back,
#					    norm_front_t_mc = normal_nodes_t_front,
#					    ext_back_t_mc = extend_nodes_t_back,
#					    ext_front_t_mc = extend_nodes_t_front))

	return(mct)
}

build_growth_mats = function(mct, mc_leak)
{
	max_mc = nrow(mct@mc_t)
	min_t = 1
	max_t = ncol(mct@mc_t)
	mc_t_freq = mct@mc_t

	growth_leak = matrix(0, nrow=max_mc, ncol=(max_t-min_t+1))
	for(t in min_t:max_t) {
		growth_leak[,t-(min_t-1)] = mc_t_freq[,t]*mc_leak
	}

	tot_mass = colSums(mc_t_freq)

	lost_mass = colSums(growth_leak)/tot_mass

	growth_compensate = t(t(mc_t_freq)*c(0,lost_mass[-max_t]))
	return(list(leak=growth_leak, compensate=growth_compensate))
}

#' Compute mincost flow and update the mct objects with flows and
#' inferred mc capacity per time
#'
#' @param mct mct network object
#' @param flow_tolerance how much flow we should miss per time
#'
#' @return an updated mct object
#' @export
mctnetwork_gen_mincost_flows= function(mct, flow_tolerance=0.01)
{
	net = mct@network
	ncnstr = network_lp_constraints(net, 1-flow_tolerance, 100)

	edge_costs = net$cost[order(net$ID)]
	sol = lpsymphony::lpsymphony_solve_LP(obj = edge_costs,
										mat = ncnstr$lhs,
										rhs = ncnstr$rhs,
										dir = ncnstr$dir)

	flows = sol$solution
	net$flow = flows[net$ID]
	mct@network = net
	mct@edge_flows = net$flow
	names(mct@edge_flows) = net$ID

	f_cap = net$mc1 == net$mc2 & net$time1 == net$time2
	net_cap = net[f_cap,]

	mc_time_weight = summarize(group_by(net_cap,mc1,time1),tot_weight = sum(flow))
	mc_t_post = sparseMatrix(i = as.numeric(mc_time_weight$mc1),
									j = as.numeric(mc_time_weight$time1),
									x = mc_time_weight$tot_weight)
	mc_t_post = as.matrix(mc_t_post)
	rownames(mc_t_post) = c(1:nrow(mc_t_post))
	colnames(mc_t_post) = c(1:ncol(mc_t_post))

	mct@mc_t_infer = mc_t_post
	return(mct)
}

#' Compute matrices for forward and backwrd propagation using the flows
#'
#' @param mct mct network object
#'
#' @return an updated mct object
#' @export

mctnetwork_comp_propagation= function(mct)
{
#flows mc,mc,t
	max_t = ncol(mct@mc_t)
	for(t in 1:(max_t-1)) {
		mc_flows = mctnetwork_get_flow_mat(mct, t)

		mc_forward = mc_flows/rowSums(mc_flows)
		mc_backward= t(t(mc_flows)/colSums(mc_flows))
		mc_backward[is.nan(mc_backward)] = 0
		mc_forward[is.nan(mc_forward)] = 0
		mct@mc_forward[[t]] = mc_forward
		mct@mc_backward[[t]] = mc_backward
	}
	return(mct)
#forward flows
}

#' Compute matrix of flows between MCs in a given time point
#'
#' @param mct mct network object
#' @param time flows will be computed for the (time,time+1) interval. Time=-1 will generate total flow over all times
#'
#' @return a matrix on metacells
#' @export

mctnetwork_get_flow_mat = function(mct, time, max_time=time)
{
	net = mct@network
	if(time == -2) {
		f_t = net$type1 != "growth" & net$type2!="growth" & net$type2 != "sink"
	} else {
		if(time == -1) {
			f_t = net$type1 != "growth" & net$type2!="growth" & net$type1 != "source" & net$type2 != "sink"
		} else {
			f_t = net$time1 == time & net$time2==time+1 &
					net$type1 != "growth" & net$type2!="growth"
		}
	}

	net_t = net[f_t,]
   flow = as.data.frame(summarize(group_by(net_t, mc1, mc2),
													tot_flow = sum(flow)))

   mc_mat = pivot_wider(data = flow,
				names_from = mc2,
				values_from = tot_flow,
				values_fill = list(tot_flow = 0))

   mc_mat = as.data.frame(mc_mat)
   rownames(mc_mat) = mc_mat$mc1
   mc_mat = mc_mat[,-1]
	max_mc = ncol(mc_mat)
	if(time == -2) {
		mc_mat = mc_mat[as.character(c(-1, 1:max_mc)), as.character(1:max_mc)]
		mc_mat = cbind(rep(0,nrow(mc_mat)), mc_mat)
	} else {
		mc_mat = mc_mat[as.character(1:max_mc), as.character(1:max_mc)]
	}
   mc_mat = as.matrix(mc_mat)

	return(mc_mat)
}

#' Compute backward and forward flow propgation of metacell probability from time t
#'
#' @param mct mct network object
#' @param t flows will be computed for the (time,time+1) interval
#' @param mc_p probabilities at time t
#'
#' @return a list with two elements: probs is a matrix of probabilities over metacells (rows)  and time (columns). step_m is a list of sparse matrices inferred flows between metacells per time.
#' @export

mctnetwork_propogate_from_t = function(mct, t, mc_p)
{
	max_t = ncol(mct@mc_t)
	step_m = list()
	probs = matrix(0, nrow = nrow(mct@mc_t), ncol=ncol(mct@mc_t))
	probs[,t] = mc_p
	if(t > 1) {
		for(i in (t-1):1) {
			step_m[[i]] = Matrix(t(t(as.matrix(mct@mc_backward[[i]])) * probs[,i+1]), sparse=T)

			probs[,i] = as.matrix(mct@mc_backward[[i]]) %*% probs[,i+1]
		}
	}
	if(t < max_t) {
		for(i in (t+1):max_t) {
			step_m[[i-1]] = Matrix(as.matrix(mct@mc_forward[[i-1]]) * probs[,i-1], sparse=T)
			probs[,i] = t(probs[,i-1]) %*% as.matrix(mct@mc_forward[[i-1]])
		}
	}
	return(list(probs=probs, step_m=step_m))
}

#' Given a list of genes and a matrix, this compute mean umi per metacell (rows) and time (column).
#'
#' @param mct_id  mct network object
#' @param mat_id  umi matrix object
#' @param genes list of gene names
#' @param min_percentile percentile value to use as minimum threshold (this is used to avoid very small values and regularize color scale, default 0.05)
#'
#' @return A matrix on metacells and time with mean umi fraction over the gene module
#' @export
#'
mctnetwork_gen_gmod_mc_t = function(mct_id, mat_id,  genes, min_percentile=0.05)
{
	mct = scdb_mctnetwork(mct_id)
	if(is.null(mct)) {
		stop("cannot find mctnet object ", mct_id, " when trying to plot net flows anchors")
	}
	mc = scdb_mc(mct@mc_id)
	mat = scdb_mat(mat_id)
	genes = intersect(genes, rownames(mat@mat))
	gmod_tot = colSums(mat@mat[genes,names(mc@mc)])/colSums(mat@mat[,names(mc@mc)])
	gmod_df = data.frame(mc = mc@mc,
								t = mct@cell_time[names(mc@mc)],
								gmod = gmod_tot)
	mc_time_gmod = summarise(group_by(gmod_df, mc, t), gmod=mean(gmod))
	mc_t_gmod_m = sparseMatrix(i=mc_time_gmod$mc,
									j=mc_time_gmod$t,
									x=mc_time_gmod$gmod)
	mc_t_gmod_m = pmax(mc_t_gmod_m, quantile(mc_time_gmod$gmod, min_percentile))
	return(mc_t_gmod_m)
}

#' This generate two large matrices showing expression of genes per metacell ad time point, as well as the expression of the gene in inferred ancestral states given the flow model
#'
#' @param mct_id  mct network object
#' @param mat_id  umi matrix object
#' @param genes list of gene names
#'
#' @return A matrix on metacells and time with mean umi fraction over the gene module
#' @export
#'
mctnetwork_gen_e_gmt_p = function(mct_id, mat_id,  genes)
{
	mct = scdb_mctnetwork(mct_id)
	if(is.null(mct)) {
		stop("cannot find mctnet object ", mct_id, " when trying to plot net flows anchors")
	}
	mc = scdb_mc(mct@mc_id)
	mat = scdb_mat(mat_id)
	genes = intersect(genes, rownames(mat@mat))

	max_t = length(mct@mc_backward) + 1

	csize = colSums(mat@mat)
	e_gm_t = list()
	tot_m_t = list()
	for(t in 1:max_t) {
		cell_t = intersect(names(mc@mc), names(which(mct@cell_time==t)))
		message("at ", t, " with ", length(cell_t), " cells")
		mgt = as.matrix(mat@mat[genes, cell_t])
#		tot_gm = t(tgs_matrix_tapply(mgt, mc@mc[cell_t], sum))
		tot_gm = t(apply(mgt,1, function(x) tapply(x,mc@mc[cell_t], sum)))
		tot_c = tapply(csize[cell_t], mc@mc[cell_t], sum)
		tot_m_t[[t]] = tot_c
		e_gm_t[[t]] = t(t(tot_gm)/as.vector(tot_c))
		rownames(e_gm_t[[t]]) = genes
	}
	e_gm_t_prev = list()
	for(t in 2:max_t) {
		t_mcs = colnames(e_gm_t[[t-1]])
		t_mcs2= colnames(e_gm_t[[t]])
		e_gm_t_prev[[t]] = Matrix(e_gm_t[[t-1]] %*% as.matrix(mct@mc_backward[[t-1]][t_mcs, t_mcs2]), sparse=T)
	}

	e_gm_t_prev2 = list()
	for(t in 3:max_t) {
	  t_mcs0 = colnames(e_gm_t[[t-2]])
	  t_mcs = colnames(e_gm_t[[t-1]])
	  t_mcs2= colnames(e_gm_t[[t]])
	  e_gm_t_prev2[[t]] = Matrix(e_gm_t[[t-2]] %*% as.matrix(mct@mc_backward[[t-2]][t_mcs0, t_mcs]) %*% as.matrix(mct@mc_backward[[t-1]][t_mcs, t_mcs2]), sparse=T)
	}

	return(list(e_gm_t = e_gm_t, e_gm_t_prev = e_gm_t_prev, e_gm_t_prev2 = e_gm_t_prev2, tot_m_t = tot_m_t))
}

#' Compute matrix of flows over cell types
#'
#' @param mct mct network object
#' @param min_time minimum time point
#' @param max_time maximum time point
#'
#' @return a list of matrices show flows from type t to t'
#' @export

mctnetwork_get_type_flows = function(mct, time, max_time)
{
	net = mct@network
	mc = scdb_mc(mct@mc_id)

	all_types = unique(mc@colors)
	mct_mats = list()
	for(t in time:(max_time-1)) {
		f_t = net$time1 == t & net$time2 == t+1 &
					net$type1 != "growth" & net$type2!="growth"

		net_t = net[f_t,]
		net_t$mc_t1 = mc@colors[as.numeric(net_t$mc1)]
		net_t$mc_t2 = mc@colors[as.numeric(net_t$mc2)]
		flow = as.data.frame(summarize(group_by(net_t, mc_t1, mc_t2),
													tot_flow = sum(flow)))

	   mct_mat = pivot_wider(data = flow,
				names_from = mc_t2,
				values_from = tot_flow,
				values_fill = list(tot_flow = 0))

	   mct_mat = as.data.frame(mct_mat)
		rownames(mct_mat) = mct_mat$mc_t1
	   mct_mat = mct_mat[,-1]
		max_mc = ncol(mct_mat)
		mct_mat = mct_mat[all_types, all_types]
		mct_mat = as.matrix(mct_mat)
		mct_mats[[t]] = mct_mat
	}

	return(mct_mats)
}

mctnetwork_get_egc_on_cluster_transition = function(mct, min_time, max_time, type1, type2, mc_type=NULL)
{
	mc = scdb_mc(mct@mc_id)
	e_gc = mc@e_gc
	net = mct@network

	if(is.null(mc_type)) {
		mc_type = mc@colors
		names(mc_type) = as.character(1:length(mc_type))
	}

#	flow_mm = mctnetwork_get_flow_mat(mct, time, max_time=time)

	f_t = net$time1 >= min_time & net$time2 <= max_time &
					net$time1 == net$time2-1 &
					net$type1 != "growth" & net$type2!="growth"

	net = net[f_t,]
	f_types = mc_type[as.numeric(net$mc1)]==type1 & mc_type[as.numeric(net$mc2)]==type2

	net = net[f_types,]

	src_mc_wgt = tapply(net$flow, net$mc1, sum)
	targ_mc_wgt = tapply(net$flow, net$mc2, sum)
	src_mc_wgt_n = as.vector(src_mc_wgt/sum(src_mc_wgt))
	names(src_mc_wgt_n) = names(src_mc_wgt)
	targ_mc_wgt_n = as.vector(targ_mc_wgt/sum(targ_mc_wgt))
	names(targ_mc_wgt_n) = names(targ_mc_wgt)

	src_e_gc = colSums(t(e_gc[,names(src_mc_wgt_n)]) * src_mc_wgt_n)
	targ_e_gc = colSums(t(e_gc[,names(targ_mc_wgt_n)]) * targ_mc_wgt_n)

	return(data.frame(src = src_e_gc, targ = targ_e_gc, lf = log2(1e-5+targ_e_gc)-log2(1e-5+src_e_gc)))
}


library(ggplot2)
library(reshape2)
library(cowplot)

args <- commandArgs(trailingOnly = TRUE)

figWidth<-25
figHeight<-4
textFont<-10
#Basedir="D:\\Study\\Research Project\\ISSTA19\\RQ3\\"
Basedir="/DeepFaultLocalization/ResultAnalysis/Rdata/"
Subs<-c("Overall")
losses<-c("epairwise","softmax")
if (args[1] == "Cross"){
	losses<-c("DeepFL","CrossDeepFL","CrossValidation")
}

model<-"dfl2"
epochs=seq(from = 2, to = 60, by = 2)   # X axis
#epochs=seq(from = 1, to = 2, by = 1)   # X axis
Metrics<-c("Top1","Top3","Top5","MFR","MAR")

for(sub in Subs){
	plot_list = list()
	count=1
	pdf(paste(c(Basedir,"RQ3",".pdf"),collapse=""), width=figWidth, height=figHeight)

		for(me in Metrics){

			combinemet=cbind(epochs)
			for(loss in losses){
				datafile=paste(Basedir,loss,"/",sub,"_",model,".txt",sep="")
				datamodel<-read.table(datafile,sep = ",")
				colnames(datamodel) <- c("Top1","Top3","Top5","MFR","MAR")
				combinemet=cbind(combinemet,datamodel[,me])
			}
			combinemet=data.frame(combinemet)
			colnames(combinemet) <- c("epochs","pairwise","softmax")
			if (args[1] == "Cross"){
				colnames(combinemet) <- c("epochs","within-project","cross-project","cross-validation")
			}
			combinemet <- melt(combinemet, id.vars='epochs')
			colnames(combinemet) <- c("epochs","model","value")
			p<-ggplot(combinemet, aes(x=epochs, y=value, group=model, colour=model,shape=model)) +
				geom_line()+geom_point(size=2)+ ylab(me)+scale_x_continuous(breaks=seq(5,61,by=5), limits=c(2,60))
				#geom_line()+geom_point(size=2)+ ylab(me)+scale_x_continuous(breaks=seq(1,2,by=1), limits=c(0,2))
			plot_list[[count]] = p
			count=count+1

		}

		prow<-plot_grid(plot_list[[1]]+theme(legend.position="none"),
						plot_list[[2]]+theme(legend.position="none"),
						plot_list[[3]]+theme(legend.position="none"),
						plot_list[[4]]+theme(legend.position="none"),
						plot_list[[5]]+theme(legend.position="none"),
						#nrow = 1, align = 'h',labels = sub)
						nrow = 1, align = 'h')
		legend_b <- get_legend(plot_list[[1]] + theme(legend.position=c(0.933,4.94)))
		p <- plot_grid( prow, legend_b, ncol = 1, rel_heights = c(1, .2))
		print(p)
		dev.off()

}


install.packages("AdhereR")
library(AdhereR)

# what does the data need to look like?
#fetch medicines data from CDMInstances
all_MED<-list.files(path_dir, pattern="^MEDICINES")

MED_tables<-lapply((paste0(path_dir, all_MED)), read.csv)

for (i in 1:length(MED_tables)){
MED_tables[[i]]$disp_date<-as.Date(as.character(MED_tables[[i]]$date_dispensing), format="%Y%m%d")
MED_tables[[i]]$duration<-30
  # sample(c(10, 30, 60), nrow(MED_tables[[i]]))
MED_tables[[i]]$end_date<-((MED_tables[[i]]$disp_date)+(MED_tables[[i]]$duration))
}

dir.create(paste0(output_dir,"treatment_episodes"))

for (i in 1:length(MED_tables)){

  my_treat_episode<-compute.treatment.episodes(data= MED_tables[[i]],
  ID.colname = "person_id",
  event.date.colname = "disp_date",
  event.duration.colname = "duration",
  event.daily.dose.colname = NA,
  medication.class.colname = "medicinal_product_atc_code",
  carryover.within.obs.window = TRUE,
  carry.only.for.same.medication = TRUE,
  consider.dosage.change = TRUE,
  medication.change.means.new.treatment.episode = TRUE,
  dosage.change.means.new.treatment.episode = FALSE,
  maximum.permissible.gap = 0,
  maximum.permissible.gap.unit = c("days", "weeks", "months", "years", "percent")[1],
  maximum.permissible.gap.append.to.episode = FALSE,
  followup.window.start = 0,
  followup.window.start.unit = c("days", "weeks", "months", "years")[1],
  followup.window.duration = 365 * 2,
  followup.window.duration.unit = c("days", "weeks", "months", "years")[1],
  event.interval.colname = "event.interval",
  gap.days.colname = "gap.days",
  date.format = "%Y-%m-%d",
  parallel.backend = c("none", "multicore", "snow", "snow(SOCK)", "snow(MPI)",
                       "snow(NWS)")[1],
  parallel.threads = "auto",
  suppress.warnings = FALSE,
  return.data.table = FALSE
  )
  table_name<-substr(all_MED[[i]], 1,nchar(all_MED[[i]])-8)
  myname<-paste0("treatment_episode_",table_name,".rds")
  saveRDS(my_treat_episode, (paste0(output_dir,"treatment_episodes/")), myname)
}

summary(my_treat_episode)
#does write work for you?


dyn.load('/Library/Java/JavaVirtualMachines/jdk1.8.0_131.jdk/Contents/Home/jre/lib/server/libjvm.dylib')

setwd("/Users/mengmengjiang/all datas/voltage")

#对单个内容进行画图分析，尝试记录单个内容的pdf图片格式
#文件名：voltage_stable , OV电压与BV电压之差，即stable 稳定电压与三种液体之间随流量、极间距离、针头直径变化的影响

library(xlsx)

#读取v~Q的数据
eq<-read.xlsx("voltage.xls",sheetName="ethanol_q",header=TRUE)
aq<-read.xlsx("voltage.xls",sheetName="acetone_q",header=TRUE)
iq<-read.xlsx("voltage.xls",sheetName="iso_q",header=TRUE)

plot(eq$f, eq$va,  col=0, xaxs="i", xlim=c(-0.002, 0.032), ylim=c(1, 3),
     xlab=expression(italic(Q)(nl/min)),mgp=c(1, 0, 0),tck=0.01,cex.lab=1.1,
     ylab=expression(italic(V)(kv)))

mtext("Flowrate",col="black",3,line=-1,font=2,cex=1)

###error bar####
error.bar <- function(x, y, upper, coll,lower=upper, length=0.05,...){
  if(length(x) != length(y) | length(y) !=length(lower) | length(lower) != length(upper))
    stop("vectors must be same length")
  arrows(x,y+upper, x, y-lower,col=coll, angle=90, code=3, length=length, ...)
}

###lines##
yan<-c("red","red","blue","blue","green3","green3")
pch<-c(1,2,1,2,1,2)

lines(eq$f,eq$vaeva,col=yan[1],pch=1,lwd=2,lty=4,type="b")
lines(eq$f,eq$vbeva,col=yan[2],pch=2,lwd=2,lty=4,type="b")
lines(aq$f,aq$vaeva,col=yan[3],pch=1,lwd=2,lty=4,type="b")
lines(aq$f,aq$vbeva,col=yan[4],pch=2,lwd=2,lty=4,type="b")
lines(iq$f,iq$vaeva,col=yan[5],pch=1,lwd=2,lty=4,type="b")
lines(iq$f,iq$vbeva,col=yan[6],pch=2,lwd=2,lty=4,type="b")

error.bar(eq$f,eq$vaeva,eq$vastd/2,col=yan[1])
error.bar(eq$f,eq$vbeva,eq$vbstd/2,col=yan[2])

error.bar(aq$f,aq$vaeva,aq$vastd/2,col=yan[3])
error.bar(aq$f,aq$vbeva,aq$vbstd/2,col=yan[4])

error.bar(iq$f,iq$vaeva,iq$vastd/2,col=yan[5])
error.bar(iq$f,iq$vbeva,iq$vbstd/2,col=yan[6])

leg<-c("ethanol-Von","ethanol-Vbr","acetone-Von","acetone-Vbr","iso-Von","iso-Vbr")

legend("bottomleft",legend=leg, col=yan, pch=c(1,2,1,2,1,2),bty="n",lwd=2,lty=2,inset=.01,cex=0.8)