#clean_rank1_module_new
#Step2plus_Celltype_marker_inference_fixedCT
#Step2plus_Celltype_marker_inference_Hclust
#Step2plus_Celltype_marker_inference_Hclust_plus
#Step2plus_Celltype_marker_inference_Hclust_CTES
#Explanation_BASE
#Extract_top_base_cor_ID
#Compute_Rbase_SVD

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<-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)
{
	 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)
	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
	hh<-hclust_R1_screen[[3]][[hcutn0]]
	Base_hclust_screen_result<-Base_screen(bbb_all0,hh,tg_R1_list_stat)
	Base_hclust_screen_selected<-as.numeric(Base_hclust_screen_result[[1]])

	tg_R1_lists_selected<-list()
	tg_R1_list_stat_selected<-list()
	nn<-c()
	for(i in 1:length(Base_hclust_screen_selected))
	{
		tg_R1_lists_selected[[i]]<- tg_R1_lists_st[[Base_hclust_screen_selected[[i]]]]
		tg_R1_list_stat_selected[[i]]<-tg_R1_list_stat[[Base_hclust_screen_selected[[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,R_bases_hclust_top_correlations,dim_tt,hcutn0,Base_hclust_screen_result)
	names(cc)<-list("tg_R1_selected_Hclust","R1Base_correlation_vs_hctn","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]))
        }
        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))
        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)
}

Explanation_BASE<-function(data_c0,tg_R1_list_c)
{
tg_R1_lists_selected<-tg_R1_list_c
tg_R1_lists_st_ccc<-tg_R1_lists_selected
data_c<-data_c0
Base_all<-c()
for(i in 1:length(tg_R1_lists_st_ccc))
{
       tg_data_c<-data_c[tg_R1_lists_st_ccc[[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)<-1:nrow(Base_all)
if(length(names(tg_R1_lists_selected))>1)
{
	rownames(Base_all)<-names(tg_R1_lists_selected)
}
	NN_ES_table<-matrix(0,length(tg_R1_list_c),length(tg_R1_list_c))
	for(i in 1:length(tg_R1_list_c))
	{
		tg_data_c<-data_c[tg_R1_list_c[[i]],]
		for(j in 1:length(tg_R1_list_c))
		{
			if(cor(Base_all[i,],Base_all[j,])>0)
			{
				 ttt_ccc<-Base_all[j,]%*%t(Base_all[j,])/sum((Base_all[j,])^2)
                         sss<-tg_data_c-tg_data_c%*%ttt_ccc
                         NN_ES_table[i,j]<-mean(apply(sss^2,1,mean))
			}
			else
			{
				NN_ES_table[i,j]<-1
			}
		}
	}
	rownames(NN_ES_table)<-names(tg_R1_list_c)
	colnames(NN_ES_table)<-names(tg_R1_list_c)
	return(NN_ES_table)
}

Extract_top_base_cor_ID<-function(ddd,K=5)
{
	ccc1<-c()
	ccc2<-c()
	for(i in 1:ncol(ddd))
	{
		ccc1<-cbind(ccc1,order(-ddd[,i])[1:K])
		ccc2<-cbind(ccc2,ddd[order(-ddd[,i])[1:K],i])
	}
	colnames(ccc1)<-colnames(ddd)
	colnames(ccc2)<-colnames(ddd)
	return(list(ccc1,ccc2))
}

Compute_Rbase_SVD<-function(bulk_data,tg_R1_lists_selected)
{
tg_R1_lists_st_ccc<-tg_R1_lists_selected
data_c<-bulk_data
Base_all<-c()
for(i in 1:length(tg_R1_lists_st_ccc))
{
       tg_data_c<-data_c[tg_R1_lists_st_ccc[[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)<-1:nrow(Base_all)
if(length(names(tg_R1_lists_selected))>1)
{
	rownames(Base_all)<-names(tg_R1_lists_selected)
}
return(Base_all)
}


#' Calculate SN measures from InterAct data
#'
#' Calculate social network measures for Veritas data collected from
#'  the InterAct research project.
#'  See [InterAct web site](https://teaminteract.ca) for more information.
#'
#' @param veritas_data Transformed data generated from [transformData()]
#'
#' @return Table of social network measures. See vignette (CREATE VIGNETTE).
#'
#' @export
interactSnMeasures <- function(veritas_data){

    calculateMeasures <- function(veritas_pid){

        # Extract people table
        people <- veritas_pid$people

        # Return if people is null
        if(is.null(people))
        {
            out <- c(spouse = 0, family = 0, friend = 0, colleague = 0,
                     other = 0, diversity = 0, chat = 0, meet = 0,
                     chat_no_spouse = 0, meet_no_spouse = 0,
                     live_house = 0, live_building = 0, live_neighborhood = 0,
                     live_outside_neighborhood = 0, live_unknown = 0,
                     age_mean = NA, age_cv = NA,
                     socialize_size = 0, socialize_meet = 0, socialize_chat = 0,
                     important_size = 0, important_meet = 0, important_chat = 0,
                     not_close_size = 0, not_close_meet = 0, not_close_chat = 0)

            out <- t(as.matrix(out))

            return(out)
        }

        #== Network size by relation type
        size <- c(spouse = sum(people$people_relation %in% 1),
                  family = sum(people$people_relation %in% c(2, 3, 4)),
                  friend = sum(people$people_relation %in% 5),
                  colleague = sum(people$people_relation %in% 6),
                  other = sum(people$people_relation %in% c(7, 99)))

        #== Calculate Shanon-Weber entropy
        ## Remove spouse as it does not add up like other relations
        ## (not living in a polygamous culture)
        size_sub <- size[names(size) != "spouse"]

        # Calculate probability distribution
        size_prob <- size_sub / sum(size_sub)

        # Calculate p * ln(p)
        entropy <- size_prob * log2(size_prob)

        # Replace NaN by 0 because limit of p*ln(p) when p-> 0 = 0
        entropy[is.na(entropy)] <- 0

        # Calculate diversity
        diversity <- -sum(entropy)

        #== Frequency of interactions
        ## With the spouse
        freq_interactions <- c(chat = sum(people$people_chat),
                               meet = sum(people$people_meet))

        ## Without the spouse
        people_sub <- people[people$people_relation != 1,]
        freq_no_spouse <- c(chat_no_spouse = sum(people_sub$people_chat),
                         meet_no_spouse = sum(people_sub$people_meet))

        #== Where people live
        living <- c(live_house = sum(people$people_where %in% 1),
                    live_building = sum(people$people_where %in% 2),
                    live_neighborhood = sum(people$people_where %in% 3),
                    live_outside_neighborhood = sum(people$people_where %in% 4),
                    live_unknown = sum(people$people_where %in% 5))

        #== Age
        age <- c(age_mean = mean(people$people_age, na.rm = TRUE),
                 age_cv = stats::sd(people$people_age, na.rm = TRUE) /
                          mean(people$people_age, na.rm = TRUE))

        #== Size and frequency by support, companionship and
        #   emotional proximity

        socialize_people <- subset(people, socialize == TRUE)
        important_people <- subset(people, important == TRUE)
        not_close_people <- subset(people, not_close == TRUE)

        socialize <- c(socialize_size = nrow(socialize_people),
                       socialize_meet = sum(socialize_people$people_meet),
                       socialize_chat = sum(socialize_people$people_chat))

        important <- c(important_size = nrow(important_people),
                       important_meet = sum(important_people$people_meet),
                       important_chat = sum(important_people$people_chat))

        not_close <- c(not_close_size = nrow(not_close_people),
                       not_close_meet = sum(not_close_people$people_meet),
                       not_close_chat = sum(not_close_people$people_chat))

        # Return
        return(cbind(t(size), diversity, t(freq_interactions),
        t(freq_no_spouse), t(living), t(age), t(socialize),
        t(important), t(not_close)))
    }

    # Create output table
    out <- do.call(rbind, lapply(veritas_data, calculateMeasures))

    # transform to data.frame and add pid as column
    out <- data.frame(out)
    out <- cbind(data.frame(pid = names(veritas_data)), out)

    # Return
    return(out)

}


  figure.timeseries.survey = function( p, outdir, variables, plotyears,type="biologicals", all.areas=T, minN=10, u=NULL, graphic='pdf', bg="white" ) {

    if (all.areas) {
      areas = c("cfa4x", "cfasouth", "cfanorth" )
      regions = c("4X", "S-ENS", "N-ENS")
    } else {
      areas = c("cfasouth", "cfanorth" )
      regions = c("S-ENS", "N-ENS")
    }

    n.regions = length(regions)
    n.areas = length(areas)

    # base data
    tdb = snowcrab.timeseries.db( DS=type, p=p )

    if(missing(variables)){
      variables =  c(
         bio.snowcrab::snowcrab.variablelist("all.to.model"),
         bio.snowcrab::snowcrab.variablelist("snowcrab.cw"),
         bio.snowcrab::snowcrab.variablelist("physical"),
         'sexratio.mat','sexratio.imm','sexratio.all'
      )
      variables = intersect( variables, unique(tdb$variable))
    }

    if(missing(plotyears))plotyears = unique(tdb$year)

    tdb = subset(tdb,variable%in%variables&year%in%plotyears)
    tdb$region = factor(tdb$region, levels=areas, labels =regions)

    #  load transformation tables associated with a given variable

    REPOS = snowcrab.db( DS="data.transforms", p=p)

    tvars = REPOS$varname[which(REPOS$transform=='log10')]

    for ( v in variables ) {
      td = tdb[ which( tdb$variable == v) ,]

      oo = which( td$mean > 0 | is.finite( td$mean ) )
      if (length(oo) < minN ) next()

      if(is.null(u))u=NULL # for variable specific units, needs a lookup table

      ylim=c(0,max(c(td$ub,td$mean),na.rm=T))
      #browser()
      if(length(grep('ratio',v))==1)ylim=c(0,1)

      xlim=range(td$year)
      if(v %in% tvars){
        ylab = list( paste("Geometric mean", u) , cex=1)
      } else {
        ylab = list( paste("Mean", u) , cex=1)
        ylim[1] = min(c(td$lb,td$mean),na.rm=T)
      }
      xlab = list("Year", cex=1)
      ylim[1] = ylim[1]-diff(ylim)*0.04
      ylim[2] = ylim[2]+diff(ylim)*0.04

      main = capwords(gsub("."," ",v,fixed=T),F,F)

      xlabels = seq(xlim[1], xlim[2], 1)
      ylabels = pretty(ylim,7)

      dir.create( outdir, recursive=T, showWarnings=F )

      fn = file.path( outdir, paste( v, graphic,  sep="." ) )
      if(type=='groundfish.t'){
        fn = file.path( outdir, paste( type, graphic,  sep="." ) )
        main = "Groundfish Survey Temperature"
        xlabels = seq(xlim[1], xlim[2], 2)
      }
      dline = ifelse(length(grep('ratio',v))==1,0.5,NA)
      if(graphic=='png')Cairo::Cairo( file=fn, type="png", bg=bg, units="in", dpi=350 )
      if(graphic=='pdf')pdf(file=fn, bg=bg )
      if(graphic=='R')plot.new()
      setup.lattice.options()
      pl = xyplot( mean~year|region, data=td, ub=td$ub, lb=td$lb, dline=dline,
            layout=c(1,n.regions),
            par.strip.text=list(
              plot.symbol=list(col='black', fill='darkgrey', cex=0.75, pch=21),
              axis.text=list(cex=0.7),
              par.main.text=list(cex=1),
              layout.heights=list(strip=1, panel=1, main=0.5),
              strip.background=list(col='lightgrey')),
              #xlim=xlim,
              ylim=ylim,
              scales=list(y=list(at=ylabels, labels=ylabels, cex=0.65), x=list(at=xlabels, labels=xlabels, rot=50, cex=0.65)),
                main=main, xlab=xlab, ylab=ylab,
                cex.axis=0.2,
                cex.main = 1.4,
                panel = function(x, y, subscripts, ub, lb, ...) {
               larrows(x, lb[subscripts], x, ub[subscripts], angle = 90, code = 3, length=0.05)
               panel.abline(h=median(y,na.rm=T), col="gray", ...)
               panel.abline(h=dline, col="gray", lty=2,...)
               panel.xyplot(x, y, type="b", lty=1, lwd=1.5, pch=21, fill='darkgrey', col="black", ...)
          }
        )

      print(pl)
      if(graphic!='R')dev.off()
    }
    print(fn)
     return("Done")
  }


# seqs <- unlist(c(covdir$Sequence, lapply(covdir$Sequence, revcomp)))
# write.table(seqs, paste0(parentdir, "/seqs.txt"),
#   col.names=F, row.names=F, quote=F, sep="\t")
#
# # Create fasta file from feature file
# # if(sum(dnmstmp$inside)>0){
# if(!file.exists(paste0(covbase, ".fa"))){
#
#   if(cov=="RR"){
#     modifybedcmd <- paste0("cut -f1-4 ", covbed, " | sed 's/chr//g' | ",
#       awkstr, " | sed /^X/d | sed /^Y/d > ", covbase, ".new.bed")
#   } else if (cov=="TIME"){
#     modifybedcmd <- paste0("cut -f1-3 ", covbed, " | sed 's/chr//g' | ",
#       awkstr, " | sed /^X/d | sed /^Y/d > ", covbase, ".new.bed")
#   } else if (cov=="GC"){
#     modifybedcmd <- paste0("cut -f1-5 ", covbed, " | sed 's/chr//g' | ",
#       awkstr, " | sed /^X/d | sed /^Y/d > ", covbase, ".new.bed")
#   } else {
#     modifybedcmd <- paste0("sed 's/chr//g' ", covbed,
#       " | sed /^X/d | sed /^Y/d > ", covbase, ".new.bed")
#   }
#
#   getfastacmd <- paste0("bedtools getfasta -fi ", parentdir,
#     "/reference_data/human_g1k_v37.fasta -bed ", covbase,
#     ".new.bed -fo ", covbase, ".fa")
#
#   system(modifybedcmd)
#   system(getfastacmd)
# }
#
# # Search feature fasta for motifs in list
# grepcmd <- paste0("grep -o -Ff ",
#   parentdir, "/seqs.txt ", covbase, ".fa | sort | uniq -c > ",
#   parentdir, "/testcounts.txt")
# system(grepcmd)
#
# motifcts <- read.table(paste0(parentdir, "/testcounts.txt"),
#   header=F, stringsAsFactors=F)
#
# names(motifcts) <- c("Count", "SEQ")
# motifcts$REVSEQ <- unlist(lapply(motifcts$SEQ, revcomp))
# motifcts$Sequence <- ifelse(substr(motifcts$SEQ,4,4) %in% c("A", "C"),
#   motifcts$SEQ, motifcts$REVSEQ)
#
# motifcts2 <- motifcts %>%
#   group_by(Sequence) %>%
#   summarise(Count=sum(Count))
# covdir2 <- merge(covdir, motifcts2, by=c("Sequence"))
#
# covdir3 <- merge(covdir2, motifdat, by=c("Category", "Sequence"))
# covdir3$exp <- covdir3$Count*covdir3$rel_prop*1.67e-06*1074
# covdir3$expa <- covdir3$Count*covdir3$rel_prop
# # covdir3$exp <- covdir3$Count*covdir3$rel_prop*(46802/35574420)
#
# exp <- sum(covdir3$exp)
# obs <- sum(dnmstmp$inside, na.rm=T)
#
# r2 <- ratelist[[4]] %>%
#   filter(Motif %in% dnmstmp$SEQ & Type %in% dnmstmp$Category) %>%
#   dplyr::select(Motif, nMotifs) %>%
#   distinct(nMotifs)
#
# t2 <- dnmstmp %>% group_by(inside) %>% tally
# obs_in <- t2[2,]$n
# obs_out <- t2[1,]$n
# total <- nrow(dnmstmp)
#
#
# motifs_in <- sum(covdir3$Count)
# motifs_out <- sum(r2$nMotifs)-motifs_in
#
# if(dir=="Up"){
#   test <- prop.test(c(obs, exp), c(total, total), alternative="greater")
#   # test <- prop.test(c(obs_in, obs_out), c(motifs_in, motifs_out), alternative="greater")
# } else {
#   test <- prop.test(c(obs, exp), c(total, total), alternative="less")
#   # test <- prop.test(c(obs_in, obs_out), c(motifs_in, motifs_out), alternative="less")
# }
# newrow <- data.frame(cov, dir=dir, n=total,
#   obs=obs, exp=exp,
#   propobs=test$estimate[1], propexp=test$estimate[2], pval=test$p.value)
# newrow


#' Comparing "back checks" in R (a clone of Stata's bcstats)
#'
#' @param surveydata The survey data
#' @param bcdata The back check data
#' @param id The unique ID
#' @param enumerator Display enumerators with high error rates and variables
#' with high error rates for those enumerators
#' @param enumteam Display the overall error rates of all enumerator teams
#' @param t1vars The list of "type 1" variables. See details.
#' @param t2vars The list of "type 2" variables. See details.
#' @param t3vars The list of "type 3" variables. See details.
#' @param ttest Run paired two-sample mean-comparison tests for varlist in the
#' back check and survey data using ttest
#' @param level Set confidence level for ttest; default is 0.95
#' @param signrank Run Wilcoxon matched-pairs signed-ranks tests in the back
#' check and survey data using signrank
#' @param lower Convert all string variables to lower case before comparing
#' @param upper Convert all string variables to upper case before comparing
#' @param nosymbol Replace symbols with spaces in string variables before
#' comparing
#' @param trim Remove leading or trailing blanks and multiple, consecutive
#' internal blanks in string variables before comparing
#' @param okrange Do not count a value in list in the back check data as a
#' difference if it falls within range of the survey data
#' @param nodiff Do not compare back check responses that equal # (for numeric
#' variables) or string (for string variables)
#' @param exclude Specifies that back check responses that equal values in list
#' will not be compared. These responses will not affect error rates and will
#' not appear in the comparisons data set.  Used when the back check data set
#' contains data for multiple back check survey versions.
#' @return A named list constaining the back check as a data.frame, error rates
#' by groups, and tests for differences
#' @details
#' Variable types:
#' \itemize{
#' \item Type 1 variables are expected to stay constant between the survey and
#' back check, and differences may result in action against the enumerator.
#' \item Type 2 variables may be difficult for enumerators to administer. For
#' instance, they may involve complicated skip patterns or many examples.
#' Differences may indicate the need for further training, but will not result
#' in action against the enumerator.
#' \item Type 3 variables are variables whose stability between the survey and
#' back check is of interest. Differences will not result in action against the
#' enumerator.
#' }
#' @export

bcstats <- function(surveydata,
                    bcdata,
                    id,
                    enumerator  = NA,
                    enumteam    = NA,
                    backchecker = NA,
                    bcteam      = NA,
                    t1vars      = NA,
                    t2vars      = NA,
                    t3vars      = NA,
                    ttest       = NA,
                    level       = 0.95,
                    signrank    = NA,
                    lower       = FALSE,
                    upper       = FALSE,
                    nosymbol    = FALSE,
                    trim        = FALSE,
                    okrange     = NA,
                    nodiff      = NA,
                    exclude     = NA) {

    # Create list that will store all the results
    results  <- list(backcheck    = NA,
                     enum1        = vector("list"),
                     enum2        = vector("list"),
                     enumteam1    = vector("list"),
                     enumteam2    = vector("list"),
                     backchecker1 = vector("list"),
                     backchecker2 = vector("list"),
                     bcteam1      = vector("list"),
                     bcteam2      = vector("list"),
                     ttest        = vector("list"),
                     signrank     = vector("list"))

    # Pre-process data when needed
    surveydata <- .bcstats.pre(pp.data  = surveydata,
                               lower    = lower,
                               upper    = upper,
                               trim     = trim,
                               nosymbol = nosymbol)

    bcdata     <- .bcstats.pre(pp.data  = bcdata,
                               lower    = lower,
                               upper    = upper,
                               trim     = trim,
                               nosymbol = nosymbol)

    pairwise <- merge(melt(surveydata, id = id),
                      melt(bcdata,     id = id),
                      by       = c(id,        "variable"),
                      suffixes = c(".survey", ".backcheck"))

    pairwise$variable <- as.character(pairwise$variable)

    # Categorize error types
    pairwise$type                                <- ""
    pairwise$type[pairwise$variable %in% t1vars] <- "type 1"
    pairwise$type[pairwise$variable %in% t2vars] <- "type 2"
    pairwise$type[pairwise$variable %in% t3vars] <- "type 3"
    pairwise                                     <- pairwise[which(pairwise$type != ""), ]

    # Create a logical value for whether or not the entry contains an error
    pairwise$error <- pairwise$value.survey != pairwise$value.backcheck
    pairwise$error <- !(pairwise$error %in% FALSE)
    pairwise$error[is.na(pairwise$value.survey) & is.na(pairwise$value.backcheck)] <- FALSE

    # No error for variables within okrange
    if (!is.na(okrange)) {
      for (name in names(okrange)) {
        ok.var   <- pairwise[which(pairwise$variable == name), ]
        ok.min   <- okrange[[name]][1]
        ok.max   <- okrange[[name]][2]
        ok.check <- as.numeric(ok.var$value.back_check) >= as.numeric(ok.var$value.survey) - ok.min &&
                    as.numeric(ok.var$value.survey) + ok.max >= as.numeric(ok.var$value.back_check)
        pairwise[which(pairwise$variable == name), ]$error <- ok.check
      }
    }

    # No error for nodiff group
    if (!is.na(nodiff)) {
      for (name in names(nodiff)) {
        pairwise$error[(pairwise$variable == name &
                        pairwise$value.survey %in% nodiff[[name]])] <- FALSE
      }
    }

    # Exclude some cases
    if (!is.na(exclude)) {
      for (name in names(exclude)) {
        pairwise$type[(pairwise$variable == name &
                       pairwise$value.survey %in% exclude[[name]])] <- ""
      }
      pairwise <- pairwise[which(pairwise$type != ""), ]
    }

    # Identifiers
    sid_vars <- c(id, enumerator, enumteam)
    bid_vars <- c(id, backchecker, bcteam)
    sid_vars <- sid_vars[!is.na(sid_vars)]
    bid_vars <- bid_vars[!is.na(bid_vars)]
    id_vars  <- unique(c(sid_vars, bid_vars))

    # Merge back in identifiers
    if (length(sid_vars) > 1) {
      pairwise <- merge(pairwise,
                        surveydata[, sid_vars],
                        all = FALSE,
                        by  = id)
    }

    if (length(bid_vars) > 1) {
      pairwise <- merge(pairwise,
                        bcdata[, bid_vars],
                        all = FALSE,
                        by  = id)
    }

    # Restrict the data to cases where there is an error
    backcheck           <- pairwise[which(pairwise$error == TRUE),
                                    c(id_vars,
                                      "type",
                                      "variable",
                                      "value.survey",
                                      "value.backcheck",
                                      "error")]
    rownames(backcheck) <- NULL
    # order_vars          <- c(id_vars, "type", "variable")
    # backcheck           <- backcheck %>% arrange_(.dots = order_vars)
    results$backcheck   <- backcheck[,
                                     c(id_vars,
                                       "type",
                                       "variable",
                                       "value.survey",
                                       "value.backcheck")]

    # Remove type 3 variables from error calculations that follow
    pairwise$error[pairwise$type == "type 3"] <- FALSE

    groups <- list(enum1        = c(enumerator,  all(is.na(t1vars)), "type 1"),
                   enum2        = c(enumerator,  all(is.na(t2vars)), "type 2"),
                   enumteam1    = c(enumteam,    all(is.na(t1vars)), "type 1"),
                   enumteam2    = c(enumteam,    all(is.na(t2vars)), "type 2"),
                   backchecker1 = c(backchecker, all(is.na(t1vars)), "type 1"),
                   backchecker2 = c(backchecker, all(is.na(t2vars)), "type 2"),
                   bcteam1      = c(bcteam,      all(is.na(t1vars)), "type 1"),
                   bcteam2      = c(bcteam,      all(is.na(t2vars)), "type 2"))

    for (name in names(groups)) {
      group.name  <- groups[[name]][1]
      isna.vars   <- as.logical(groups[[name]][2])
      group.error <- groups[[name]][3]

      if (is.na(group.name) | isna.vars) {
        results[[name]] <- NULL
      } else {
        calc.error.by.group     <- .calc.error.by.group(pairwise   = pairwise,
                                                        id         = id,
                                                        group.id   = group.name,
                                                        error.type = group.error)
        results[[name]]$summary <- calc.error.by.group$summary
        results[[name]]$each    <- calc.error.by.group$each
      }
    }

    # Run the t-tests (if none specified remove from results)
    if (is.na(ttest)) {
      results[["ttest"]] <- NULL
    } else {
        for (var in ttest) {
            pairwise.var         <- pairwise[which(pairwise$variable == var),  ]
            results$ttest[[var]] <- t.test(as.numeric(pairwise.var$value.survey),
                                           as.numeric(pairwise.var$value.backcheck),
                                           paired     = TRUE,
                                           conf.level = level)
        }
    }

    # Run the Wilcoxon signed rank test (if none specified remove from results)
    if (is.na(signrank)) {
      results[["signrank"]] <- NULL
    } else {
        for (var in signrank) {
            pairwise.var            <- pairwise[which(pairwise$variable == var),  ]
            results$signrank[[var]] <- wilcox.test(as.numeric(pairwise.var$value.survey),
                                                   as.numeric(pairwise.var$value.backcheck),
                                                   paired = TRUE)
        }
    }

    # Return the results
    return(results)
}

# Helper function that calculates error rates by group id (e.g., enumerator, team)
.calc.error.by.group <- function(pairwise,
                                 id,
                                 group.id,
                                 error.type) {

      results.by.group <- list(summary = NA,
                               each    = NA)

      pairwise  <- pairwise[which(pairwise$type == error.type), ]

      if (is.na(group.id)) {
        summary <- aggregate(pairwise[ , c("error")],
                             by  = list(pairwise$variable),
                             FUN = function(x) c(error.rate  = mean(x),
                                                 differences = sum(x),
                                                 total       = length(x)))
      } else {
        summary <- aggregate(pairwise[ , c("error")],
                             by  = list(pairwise[[group.id]]),
                             FUN = function(x) c(error.rate  = mean(x),
                                                 differences = sum(x),
                                                 total       = length(x)))
        each    <- aggregate(pairwise[ , c("error")],
                             by  = list(pairwise[[group.id]],
                                        pairwise$variable),
                             FUN = function(x) c(error.rate  = mean(x),
                                                 differences = sum(x),
                                                 total       = length(x)))
      }
      # Name the columns
      summary <- as.data.frame(as.list(summary))
      names(summary) <- c(group.id, "error.rate", "differences", "total")

      if (!is.na(group.id)) {
        each        <- as.data.frame(as.list(each))
        names(each) <- c(group.id, "variable", "error.rate", "differences", "total")
      }

      # Export results
      results.by.group$summary <- summary
      results.by.group$each    <- each
      return(results.by.group)
}

# Functions that pre-proccesses the data
.bcstats.pre <- function(pp.data, lower, upper, trim, nosymbol) {
    if (lower & upper) {
      stop("Cannot have both lower and upper case at the same time")
    } else if (lower) {
      pp.data <- data.frame(lapply(pp.data, .lower.ifchar), stringsAsFactors = FALSE)
    } else if (upper) {
      pp.data <- data.frame(lapply(pp.data, .upper.ifchar), stringsAsFactors = FALSE)
    }

    if (trim) {
      pp.data <- data.frame(lapply(pp.data, .trim.ifchar), stringsAsFactors = FALSE)
    }

    if (nosymbol) {
      pp.data <- data.frame(lapply(pp.data, .nosymbols.ifchar), stringsAsFactors = FALSE)
    }

    return(pp.data)
}

# Change to upper only if vector is character
.upper.ifchar <- function(x) {
  if (class(x) == "character") {
    toupper(x)
  } else {
    x
  }
}

# Change to lower only if vector is character
.lower.ifchar <- function(x) {
  if (class(x) == "character") {
    tolower(x)
  } else {
    x
  }
}

# Trim only if vector is character
.trim.ifchar <- function(x) {
  if (class(x) == "character") {
    trimws(x)
  } else {
    x
  }
}

# Remove symbols only if vector is character
.nosymbols.ifchar <- function(x) {
  if (class(x) == "character") {
    gsub("[[:punct:]]", "", x)
  } else {
    x
  }
}


r=0.78
https://sandbox.dams.library.ucdavis.edu/fcrepo/rest/collection/sherry-lehmann/catalogs/d7388t/media/images/d7388t-003/svc:tesseract/full/full/0.78/default.jpg Accept:application/hocr+xml


#Call this file from wrapper_modelRuns_sameEnv_trans_inriver.r
#This is the wrapper for running climate change projections for
# Crozier, Burke, Chasco, Widener and Zabel 2020
# Chinook salmon face climate change across multiple life stages putting iconic species in peril
# published in Communications Biology
####################################################
####################################################

library(mvtnorm)

set.seed(1000)

runSensitivity <- FALSE

load(files[1]) #It doesn't matter which file you load. They will all have the same environmental projection information
nvar <- length(myVars)

#These are the flow grid bins
flowSeq <- c(20,seq(50,350,50))
#Mapping to grid array
flowSeqID <- 1:length(flowSeq)
#Temperature bins
tempSeq <- 9:18
#Mapping to grid array
tempSeqID <- 1:length(tempSeq)

#Set up array for gridded data of flow and temp
gridData <- array(0,dim=c(2,length(1:80),365,length(flowSeq),length(tempSeq)),
                  dimnames=list(migrationType = c("inriver","transport"),
                                compassYears=1:80,
                                julian=1:365,
                                flow=flowSeq,
                                temp=tempSeq))

#Read in the gridded compass data
for(ff in flowSeq){
  for(tt in tempSeq){
    # ff <- flowSeq[1]
    # tt <- tempSeq[1]
if(NAA==TRUE)    cDat <- read.table(paste0(rootDir,"/DATA_COMPASS_FILES_NAA/ch1_BiOp-NAA-Flow-",ff,"_",tt,"deg_bonarrival_transport.out"), header = TRUE)
if(NAA==FALSE)   cDat <- read.table(paste0(rootDir,"/DATA_COMPASS_FILES_PA/ch1_Flow-",ff,"_",tt,"deg_bonarrival_transport.out"), header = TRUE)
    mcnt <- 1
    for(mm in c("inriver","transport")){
      # mm <- "inriver"
      tmpcDat <- cDat[cDat$MigrationType==mm,4:368]
      gridData[mcnt,,,flowSeqID[flowSeq==ff],tempSeqID[tempSeq==tt]] <- as.matrix(tmpcDat)
      mcnt <- mcnt + 1
    }
  }
}

#Marine and freshwater information
rcps <- matrix(c(c("stationary","2.6","4.5","8.5"), #sstARC
                 c("stationary","2.6","4.5","8.5"), #sstWA
                 c("stationary","","",""), #upw
                 c("stationary","2.6","4.5","8.5"), #T20
                 c("stationary","2.6","4.5","8.5")), #F
               5,4,byrow=TRUE)

quants <- c("25","50","75")

#The RCP files require a lookup table to match the projections with the correct marine variable
RCP_lu <- read.csv(paste0(rootDir,"/RCP/RCP_lookup.csv"), header = TRUE)
rcp_varNames_pre <- RCP_lu[1,]
rcp_varNames_suf <- RCP_lu[2,]

#RCP data holder
RCP_rqvy <- array(0,dim=c(ncol(rcps),length(quants),nvar,ny),
             dimnames=list(RCP=rcps[1,],quants=quants,vars=dimnames(data$env)[[2]],y=1:ny))

#RCP directory
rcpDir <- paste0(rootDir,"/RCP/")

#Marine variable inputs from individual files
for(i in marVars){ #marine variables in the var map
  rcnt <- 2 #Need this since rcp is a character
  for(r in c("2.6","4.5","8.5")){
    qcnt <- 1 #Used to map the quantile (25,50,75) to the array index
    for(q in quants){
      tmp <- read.csv(paste0(rcpDir,
                  rcp_varNames_pre[1,i],
                  ".",
                  q,
                  ".delta",
                  r,
                  ".",
                  rcp_varNames_suf[1,i],
                  ".csv"),
           header=TRUE)

      tmp <- tmp[tmp$year>=2015 & tmp$year<=(2015+74),2]

      RCP_rqvy[r,q,i,] <- tmp
    }
  }
}

#Freshwater variable inputs. This is a different file and rcp structure compared to the marine variables
fw <- read.csv(paste0(rcpDir,"LGR_quantiles06242019.csv"),header=TRUE)

#For the marine variables, we read in the lookup table
#For the freshwater variables it's easier to just write it here.
rcp_FWvarNames_pre <- as.data.frame(matrix(c("T20.","F."),1,2))
rcp_FWvarNames_suf <- as.data.frame(matrix(c("",""),1,2))
names(rcp_FWvarNames_pre) <- c('aprmayjunetempLGR','aprmayjuneflowLGR')
names(rcp_FWvarNames_suf) <- c('aprmayjunetempLGR','aprmayjuneflowLGR')

for(i in c('aprmayjunetempLGR','aprmayjuneflowLGR')){
  for(r in c("2.6","4.5","8.5")){
    for(q in quants){
      myCol <- paste0(rcp_FWvarNames_pre[1,i],
                             q,
                             ".delta",
                             r,
                             rcp_FWvarNames_suf[1,i])
      tmp <- fw[fw$year>=2015 & fw$year<=(2015+74),names(fw)==myCol]
      #Get the RCP values
      RCP_rqvy[r,q,i,] <- tmp
    }
  }
}

#Environmental projections
#Replace the simulated values for the first year with the 2000:2015 mean values that are observed
#These environmental projections include all years.
envProj_rqvys <- array(0,dim=c(ncol(rcps),length(quants),nvar+3,ny,nsim),
                  dimnames = list(RCP=rcps[1,], quants=quants,vars=c(dimnames(data$env)[[2]],"gridYear","gridFlow","gridTemp"),years=1:ny,sim=1:nsim))
#unscaled env projections
sc_envProj_rqvys <- array(0,dim=c(ncol(rcps),length(quants),nvar+3,ny,nsim),
                       dimnames = list(RCP=rcps[1,], quants=quants,vars=c(dimnames(data$env)[[2]],"gridYear","gridFlow","gridTemp"),years=1:ny,sim=1:nsim))
#unscaled env projections with added RCP
sc_RCP_envProj_rqvys <- array(0,dim=c(ncol(rcps),length(quants),nvar+3,ny,nsim),
                       dimnames = list(RCP=rcps[1,], quants=quants,vars=c(dimnames(data$env)[[2]],"gridYear","gridFlow","gridTemp"),years=1:ny,sim=1:nsim))

#random day effects
rday_frqjys <- array(0,dim=c(length(files),ncol(rcps),length(quants),length(minJ:maxJ),ny,nsim),
                              dimnames = list(file=files,RCP=rcps[1,], quants=quants,day=minJ:maxJ,1:ny,sim=1:nsim))

#random dayXyear effects
rdayXyear_frqjys <- array(0,dim=c(length(files),ncol(rcps),length(quants),length(minJ:maxJ),ny,nsim),
               dimnames = list(file=files,RCP=rcps[1,], quants=quants,day=minJ:maxJ,1:ny,sim=1:nsim))

#random mu and betas
r_muBeta_frqjys <- array(0,dim=c(length(files),ncol(rcps),length(quants),1+length(tmpMarVars),ny,nsim),
                          dimnames = list(file=files,RCP=rcps[1,], quants=quants,fixed=c("mu",paste("beta",1:length(tmpMarVars))),1:ny,sim=1:nsim))

#covariance matrix
Sigma <- rep$`Sigma_x.cov()`#*(rep$psi_x%o%rep$psi_x)

#initEnv data from 2000 to 2015
initEnv <- colMeans(data$env[2000:2015-startYr+1,])

for(rr in simRCP){
  for(qq in simQuants){
    for(ss in 1:nsim){
      for(y in 1:ny){
        #Initial year
        if(y==1){
          envProj_rqvys[rr,qq,dimnames(data$env)[[2]],1,ss] <-
            rmvnorm(1,rep(0,nvar),Sigma)
        }
        #Project the marine and freshwater env data. This is in the Z-score space
        if(y>1){
          envProj_rqvys[rr,qq,dimnames(data$env)[[2]],y,ss] <-
            rmvnorm(1,rep$rho_x*envProj_rqvys[rr,qq,dimnames(data$env)[[2]],y-1,ss],Sigma*sqrt(1-rep$rho_x^2))   #SCALE by correlation coefficient
        }

        # #Now we add the climate trends to these simulations
        flow <- envProj_rqvys[rr,qq,"aprmayjuneflowLGR",y,ss] * #Projection
                  data$env_sc[colnames(data$env)=="aprmayjuneflowLGR"] + #Scale
                  data$env_mu[colnames(data$env)=="aprmayjuneflowLGR"] + #mean
                  RCP_rqvy[rr,qq,"aprmayjuneflowLGR",y] #rcp

        temp <- envProj_rqvys[rr,qq,"aprmayjunetempLGR",y,ss] * #Projection
                      data$env_sc[colnames(data$env)=="aprmayjunetempLGR"] + #Scale
                      data$env_mu[colnames(data$env)=="aprmayjunetempLGR"] + #mean
                      RCP_rqvy[rr,qq,"aprmayjunetempLGR",y] #rcp
        #
        #
        #Get the flow and temp that are closest to the compass files
        gridFlow <- c(20,seq(50,350,50))[abs(flow -  c(20,seq(50,350,50)))==min(abs(flow -  c(20,seq(50,350,50))))]
        gridTemp <- (9:18)[abs(temp -  9:18)==min(abs(temp -  9:18))]

        #This is a random draw of 80 years within the flow and temp compass simulation
        gridYear <- round(runif(1,1,80))

        #Save the flow, temp and grid year
        envProj_rqvys[rr,qq,"gridYear",y,ss] <- gridYear
        envProj_rqvys[rr,qq,"gridFlow",y,ss] <- gridFlow
        envProj_rqvys[rr,qq,"gridTemp",y,ss] <- gridTemp
      }

      # #Now unZ-score everything and add the RCP
      sc_envProj_rqvys[rr,qq,myVars,,ss] <-
        envProj_rqvys[rr,qq,myVars,,ss] * rep$psi_x * #Scale by the process standard deviation
        data$env_sc[colnames(data$env)==myVars] +
        data$env_mu[colnames(data$env)==myVars] +
        RCP_rqvy[rr,qq,myVars,]

      #The re-scale by the 2000-2015 data
      sc_RCP_envProj_rqvys[rr,qq,myVars,,ss] <-
        ((sc_envProj_rqvys[rr,qq,myVars,,ss] + data$Stationary_baseline_difference * stationary_baseline_flag) - data$env_mu_2000_2015[colnames(data$env)==myVars])/
        data$env_sc_2000_2015[colnames(data$env)==myVars]

    }
  }
}

#Projected SAR output
sarProj_frqys <- array(0,
                  dim=c(length(files),ncol(rcps),length(quants),ny,nsim),
                  dimnames = list(file=files,rcps=rcps[1,],quants=quants,ny=1:ny,nsim=1:nsim))
sarBeta_frqvs <- array(NA,
                       dim=c(length(files),ncol(rcps),length(quants),length(marVars),nsim),
                       dimnames = list(file=files,rcps=rcps[1,],quants=quants,beta_mar=marVars,nsim=1:nsim))

# #Projected betas
for(f in files){
#   #Load the model
  load(f)
  #Number of env variables
  nvar <- ncol(data$env)
  for(rr in simRCP[1]){
    for(qq in simQuants[1]){
      #Get migration type
      ifelse(substr(f,25,25)=="T",
             migType <- "transport",
             migType <- "inriver")

      #project the environmental data
      for(ss in 1:nsim){
        print(paste(f))
        print(paste(rr,qq,ss))
        #If you are doing a sensitivity analysis, then you just use the same simulation for each model run
        sSens <- ss
        if(runSensitivity==TRUE){
          sSens <- SensitivitySimulation
        }

        #Get the env variables that are to be multiplied by the estimated beta parameters
        if(length(data$marVars)==1){
          tmp_env <- cbind(rep(1,ny),
                         sc_RCP_envProj_rqvys[rr,qq,marVars[tmpMarVars],,sSens])
        }
        if(length(data$marVars)>1){
          tmp_env <- cbind(rep(1,ny),
                           t(sc_RCP_envProj_rqvys[rr,qq,marVars[tmpMarVars],,sSens]))
        }

        #Names of the SD values
        sdNames <- names(SD$value)

        #Loop through all years and calculate the SAR
        for(y in 1:ny){
          #You need to find the flow, temperature and year that is most closely associated with the TMB simulation value
          temp <- envProj_rqvys[rr,qq,"gridTemp",y,sSens]
          temp <- tempSeqID[temp==tempSeq]
          flow <- envProj_rqvys[rr,qq,"gridFlow",y,sSens]
          flow <- flowSeqID[flow==flowSeq]
          year <- envProj_rqvys[rr,qq,"gridYear",y,sSens] #Grid year
          ifelse(migType=="inriver",mig <- 1, mig <- 2)

          #This is the timing based on the COMPASS model
          timing <- gridData[mig,y,,flow,temp]

          #random year
          ry <- round(runif(1,1,length(startYr:lastYr)))

          #Position of the covariates not including the dayXyear interaction
          sd_pos <- (1:length(names(SD$value)))[sdNames=="mu_s" |
                                                          sdNames=="beta_mar"]
          sd_pos_fixed <- (1:length(names(SD$value)))[sdNames=="mu_s" |
                                                  sdNames=="beta_mar"]
          if(data$re_j==1){
            sd_pos <- c(sd_pos,(1:length(names(SD$value)))[sdNames=="eps_j"])
            sd_pos_j <- (1:length(names(SD$value)))[sdNames=="eps_j"]
          }
          if(data$re_t==1){
            sd_pos <- c(sd_pos,(1:length(names(SD$value)))[sdNames=="eps_t"])
            sd_pos_t <- (1:length(names(SD$value)))[sdNames=="eps_t"]
          }
          if(data$re_jt==1){
            sd_pos <- c(sd_pos,(1:length(names(SD$value)))[sdNames=="eps_jt"][1:length(minJ:maxJ) + (ry-1)*length(minJ:maxJ)])
            sd_pos_jt <- (1:length(names(SD$value)))[sdNames=="eps_jt"][1:length(minJ:maxJ) + (ry-1)*length(minJ:maxJ)]
          }

          #Covariance matrix for all fixed and random effects
          COV <- SD$cov[sd_pos,
                        sd_pos]

          #Draw the random mu, beta, day, year, and dayXyear effect for a particular ry (random year)
          #Random draw
          # rd <- rmvnorm(1,
          #               mean=SD$value[sd_pos],
          #               sigma = COV)
          # rd <- as.data.frame(rd)

          #This scenario has no variability at all. Just the MLE estimate. This goes really, really fast
          rd_fix <- SD$value[sd_pos_fixed]
                        #rmvnorm(1,
                        #mean=SD$value[sd_pos_fixed],
                        #sigma = SD$cov[sd_pos_fixed,sd_pos_fixed])

          #This scenario assumes no covariance between parameters. This goes really fast
          # rd_fix <- rnorm(length(SD$value[sd_pos_fixed]),
          #     SD$value[sd_pos_fixed],
          #     diag(SD$cov[sd_pos_fixed,sd_pos_fixed]))

          #This scenario assumes full covariance between parameters. This goes really slow
          rd_fix <- rmvnorm(1,
                          SD$value[sd_pos_fixed],
                          SD$cov[sd_pos_fixed,sd_pos_fixed])

          rd_j <- rmvnorm(1,
                        mean=SD$value[sd_pos_j],
                        sigma = SD$cov[sd_pos_j,sd_pos_j]) #SD$value[sd_pos_j] #
          rd_jt <- rmvnorm(1,
                          mean=SD$value[sd_pos_jt],
                          sigma = SD$cov[sd_pos_jt,sd_pos_jt]) #SD$value[sd_pos_jt]#

          #Mean and marine covariates
          # rBeta <- rd_fix[names(rd_fix)=="beta_mar"]
          # rMu <- rd_fix[names(rd_fix)=="mu_s"]
          rBeta <- rd_fix[2:length(rd_fix)]
          rMu <- rd_fix[1]

          #Estimate the marine effect
          mar_ef <- tmp_env%*%as.matrix(unlist(c(rMu,rBeta)))

          #Save the random draws
          if(length(rBeta)==1){
            r_muBeta_frqjys[f,rr,qq,,y,ss] <- c(unlist(c(rMu,rBeta)),NA)
          }
          if(length(rBeta)==2){
            r_muBeta_frqjys[f,rr,qq,,y,ss] <- unlist(c(rMu,rBeta))
          }
          #*****************************
          #Random effects for day, year, and day X year
          #*****************************
          day_ef <- t(as.matrix(rep(0,length(minJ:maxJ))))
          if(data$re_j==1){
            # day_ef <- rd[names(rd)=="eps_j"] * exp(rep$fpsi_j)
            day_ef <- t(rd_j) * exp(rep$fpsi_j)
          }
          rday_frqjys[f,rr,qq,,y,ss] <- t(day_ef)

          #Random year effect
          year_ef <- t(as.matrix(rep(0,length(startYr:lastYr))))
          if(data$re_t==1){
            year_ef <- rd[names(rd)=="eps_t"]  * exp(rep$fpsi_t)
          }
          #Random day X year effect
          dayXyear_ef <- t(as.matrix(rep(0,length(minJ:maxJ))))
          if(data$re_jt==1){
            # dayXyear_ef <- rd[names(rd)=="eps_jt"]  * exp(rep$fpsi_jt)
            dayXyear_ef <- t(rd_jt)  * exp(rep$fpsi_jt)
          }
          rdayXyear_frqjys[f,rr,qq,,y,ss] <- t(dayXyear_ef)

          #The total effects of all fixed and random effects
          total_ef <- c(rep(mar_ef[y,1],length(1:(minJ-1))), #days before minJ
            (t(day_ef) + t(dayXyear_ef) + year_ef[1,ry] + mar_ef[y,1]), #minJ:maxJ
            rep(mar_ef[y,1],length((maxJ+1):365))) #after maxJ

          # total_ef <- c(rep(mar_ef[y,1],length(1:(minJ-1))),
          #               (t(day_ef) + t(dayXyear_ef) + year_ef[ry] + mar_ef[y,1]),
          #               rep(mar_ef[y,1],length((maxJ+1):365)))

          #SAR is the total effect
          sarProj_frqys[f,rr,qq,y,ss] <- sum(total_ef * timing/sum(timing))
        }
        #Because the number of betas will vary, you need to create a list of arrays
        sarBeta_frqvs[f,rr,qq,data$marVars+1,ss] <- as.matrix(rBeta)
      }
    }
  }
}

    filename<-paste0("sar_projections_",
      if(NAA==TRUE) "NAA_",
      if(NAA==FALSE) "PA_",
                     myTrans.tt[1],"_",myTrans.tt[2],"_","Nsim",nsim,"_Nmodel",length(files),"scenarios",length(simRCP)*length(simQuants),
                     ".rData")

save(sarProj_frqys
     ,sarBeta_frqvs
     ,envProj_rqvys
    ,sc_RCP_envProj_rqvys
     ,rday_frqjys
     ,rdayXyear_frqjys
     ,r_muBeta_frqjys
     ,gridData
     ,env_mu
     ,env_sc
     ,env_mu_2000_2015
     ,env_sc_2000_2015
     ,RCP_rqvy
     ,subData
     ,file=filename
  )