Step2plus_Celltype_marker_inference_new_LowReso<-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)
{
        #have two sets of parameters for BCV t tests
        #1. For testing total rank and determining adding the base of a new cell type (strong condition)
        #2. For the linear model based cell type specific marker selected (weak condition)
        #3. Parameter set includes: number of BCV bins, number of rounds for t test and msep cut
	  #4. Add a new step, select top K R1 bases by using hclust, and add R1 bases by a mixed score of (1) three combination linear dependency and (2) cell type uniqueness
        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)
        #remove the leave one out step and add a hclust pre-filtering step
	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))
	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

        print("Linking graph based cell type selection")
        ddd<-combn(length(tgs),3)
        comp_ids<-c()
        stat_all<-rep(0,length(tgs))
        stat_2total<-rep(0,length(tgs))
        names(stat_all)<-1:length(tgs)
        names(stat_2total)<-1:length(tgs)

        data_c<-data_CORS_cancer

	stat_all2<-stat_all
	stat_2total2<-stat_2total

	Base_all<-c()
	for(i in 1:length(tgs))
	{
        tg_data_c<-data_c[tgs[[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(tgs)

for(i in 1:ncol(ddd))
{
	  st<-0
	  indi_c<--1
	  if(length(table(IM_low_reso_group_indi[rownames(Base_all)[ddd[,i]]]))==1)
	  {
		st<-1
		indi_c<-IM_low_reso_group_indi[rownames(Base_all)[ddd[,i]]][1]
	  }
        tg_genes<-unique(c(tgs[[ddd[1,i]]],tgs[[ddd[2,i]]],tgs[[ddd[3,i]]]))
     	  pp<-sum(BCV_ttest2(data_c[tg_genes,],rounds=20,maxrank0=5,msep_cut=0.01)<0.001)
        if(pp==2)
        {
		comp_ids<-c(comp_ids,i)
            #print(i)
           lm0<-lm(Base_all[ddd[1,i],]~Base_all[ddd[2,i],]+Base_all[ddd[3,i],]+0)
		if(st==0)
		{
                        if(sum(is.na(coefficients(lm0)))==0)
                        {
                                stat_2total[ddd[,i]]<-stat_2total[ddd[,i]]+1
                        	if((sign(coefficients(lm0))[1]==1)&(sign(coefficients(lm0))[2]==1))
                        	{
                                stat_all[ddd[2,i]]<-stat_all[ddd[2,i]]+1
                                stat_all[ddd[3,i]]<-stat_all[ddd[3,i]]+1
                        	}
                        	if((sign(coefficients(lm0))[1]==-1)&(sign(coefficients(lm0))[2]==1))
                        	{
                                stat_all[ddd[2,i]]<-stat_all[ddd[2,i]]+1
                                stat_all[ddd[1,i]]<-stat_all[ddd[1,i]]+1
                        	}
                        	if((sign(coefficients(lm0))[1]==1)&(sign(coefficients(lm0))[2]==-1))
                        	{
                                stat_all[ddd[3,i]]<-stat_all[ddd[3,i]]+1
                                stat_all[ddd[1,i]]<-stat_all[ddd[1,i]]+1
                        	}
                        }
		}
		if(st==1)
		{
                  	if(sum(is.na(coefficients(lm0)))==0)
                        {
                              stat_2total2[ddd[,i]]<-stat_2total2[ddd[,i]]+1
                        	if((sign(coefficients(lm0))[1]==1)&(sign(coefficients(lm0))[2]==1))
                        	{
                                stat_all2[ddd[1,i]]<-stat_all2[ddd[1,i]]+1
                        	}
                        	if((sign(coefficients(lm0))[1]==-1)&(sign(coefficients(lm0))[2]==1))
                        	{
                                stat_all2[ddd[3,i]]<-stat_all2[ddd[3,i]]+1
                        	}
                        	if((sign(coefficients(lm0))[1]==1)&(sign(coefficients(lm0))[2]==-1))
                        	{
                                stat_all2[ddd[2,i]]<-stat_all2[ddd[2,i]]+1
                        	}
                        }
		}
       }
         if(i%%100==1)
        {
                print(i)
        }
}

ooo<-stat_all2[which(stat_2total2!=0)]/stat_2total2[which(stat_2total2!=0)]
sort(ooo,decreasing=T)[24:29]
names(tg_R1_lists_selected)[as.numeric(names(sort(ooo,decreasing=T)))]

ppp<-as.numeric(names(sort(stat_all2[which(stat_2total2!=0)]/stat_2total2[which(stat_2total2!=0)],decreasing=T)))[1:20]
qqq<-setdiff(1:40,ppp)

stat_all0<-stat_all/stat_2total
scores10<-stat_all0
s1<-scores10[order(-scores10)]
ss<-rownames(Base_all)[order(-scores10)]
score_plus<-rep(0,length(ss))
names(score_plus)<-names(s1)
ss0<-unique(ss)
ss0_counts<-rep(1,length(ss0))
names(ss0_counts)<-ss0
for(i in 1:length(ss))
{
	score_plus[i]<-ss0_counts[ss[i]]
	ss0_counts[ss[i]]<-ss0_counts[ss[i]]+1
}
score_plus0<-(1/score_plus)^2
s2<-score_plus0+s1
s2<-s2[order(-s2)]

total_dim<-dim_tt
N<-0
tt_selected_genes<-c()
selected_p<-c()
selected_c<-c()
tg_d_stat<-c()
selected_id<-c()
for(i in 1:length(s2))
{
        if(N<=total_dim)
        {
                tg_id_c<-as.numeric(names(s2)[i])
                print(c(tg_id_c,tg_id_c))
                if(length(selected_p)==0)
                {
                        selected_p<-tgs[[tg_id_c]]
                        tg_d_stat<-1
                        selected_id<-c(tg_id_c)
                        N<-N+1
                        print(N)
                        print(selected_id)
                }
                else
                {
                        selected_c<-c(selected_p,tgs[[tg_id_c]])
                        selected_c<-unique(selected_c)
                        tg_data_ccc0<-data_CORS_cancer[selected_c,]
                        BCV_stat_c0<-BCV_ttest3(tg_data_ccc0,rounds=100,slice0=2,maxrank0=30,msep_cut=0.0001)
                        tg_d_c<-sum(BCV_stat_c0[[1]]<0.001)#which(BCV_stat_c0[[1]]>0.001)[1]-1
                        print(tg_d_c)
                        if(tg_d_c>tg_d_stat[length(tg_d_stat)])
                        {
                                tg_d_stat<-c(tg_d_stat,tg_d_c)
                                selected_id<-c(selected_id,tg_id_c)
                                selected_p<-selected_c
                                N<-N+1
                                print(N)
                                print(selected_id)
                        }
                        print("")
                }
        }
}

tg_2badded_cells<-setdiff(unique(names(tgs)),unique(names(tgs)[selected_id]))
add_R1_base_cut<-list()
#add_R1_base_full<-list()
if(length(tg_2badded_cells)>0)
{
        ccc<-rep(0,length(tg_2badded_cells))
        names(ccc)<-tg_2badded_cells
        ttt<-s2
        for(i in 1:length(ttt))
        {
                if(sum(names(tgs)[as.numeric(names(ttt[i]))]==tg_2badded_cells))
                {
                        tg<-names(tgs)[as.numeric(names(ttt[i]))]
                        if(ccc[tg]==0)
                        {
                                add_R1_base_cut[[which(tg_2badded_cells==tg)]]<-tgs[[as.numeric(names(ttt[i]))]]
                                #add_R1_base_full[[which(tg_2badded_cells==tg)]]<-tg_R1_lists[[as.numeric(names(ttt[i]))]]
                                ccc[tg]<-1
                        }
                }
        }
}
names(add_R1_base_cut)<-tg_2badded_cells

#############################
nn<-rep("",length(tg_R1_list_stat_selected))
for(i in 1:length(tg_R1_list_stat_selected))
{
        if(max(tg_R1_list_stat_selected[[i]][min(tg_R1_cut,nrow(tg_R1_list_stat_selected[[i]])),resolution_level])>cell_type_enrich_cut)
        {
                ccc<-tg_R1_list_stat_selected[[i]][min(tg_R1_cut,nrow(tg_R1_list_stat_selected[[i]])),resolution_level]
                nn[i]<-names(which(ccc==max(ccc))[1])
        }
}
selected_cell_types<-intersect(resolution_level,unique(nn))

cellreso_R1_base_cut<-list()
#cellreso_R1_base_full<-list()

for(i in 1:length(selected_cell_types))
{
        cc1<-c()
        #cc2<-c()
        for(j in 1:length(nn))
        {
                if(nn[j]==selected_cell_types[i])
                {
                        cc1<-c(cc1,tgs[[j]])
                        #cc2<-c(cc2,tg_R1_lists[[j]])
                }
        }
        cellreso_R1_base_cut[[i]]<-unique(cc1)
        #cellreso_R1_base_full[[i]]<-unique(cc2)
}
names(cellreso_R1_base_cut)<-selected_cell_types
#names(cellreso_R1_base_full)<-selected_cell_types

#############################
supp_results<-list(tg_R1_lists_selected,tg_R1_list_stat_selected,selected_id,tg_d_stat,dim_tt,stat_all,stat_2total,hclust_R1_screen,Base_hclust_screen_selected,R_bases_hclust_top_correlations)
names(supp_results)<-c("tg_R1_lists_selected","tg_R1_list_stat_selected","selected_id","tg_d_stat","total_cell_type_number","stat_all","stat_2total","hclust_R1_screen","Base_hclust_screen_selected","R_bases_hclust_top_correlations")

selected_R1_base_cut<-list()
#selected_R1_base_full<-list()

for(i in 1:length(selected_id))
{
        selected_R1_base_cut[[i]]<-tgs[[selected_id[i]]]
        #selected_R1_base_full[[i]]<-tg_R1_lists[[selected_id[i]]]
}
names(selected_R1_base_cut)<-names(tgs)[selected_id]
#names(selected_R1_base_full)<-names(tgs)[selected_id]

R2_selected_cell_type_markers<-list(selected_R1_base_cut,add_R1_base_cut,cellreso_R1_base_cut,supp_results)
names(R2_selected_cell_type_markers)<-c("selected_R1_base_cut","add_R1_base_cut","cellreso_R1_base_cut","supp_results")
return(R2_selected_cell_type_markers)
}


#' @title Calculate Likelihood based on Dirichlet-multinomial distribution estimated parameters
#'
#' @description
#' This function estimates parameters from Dirichlet-multinomial distribution.
#' @param FS_out An object from the FeatureSelection()
#' @param testSet A test set in data frame or matrix form. The colnames should have the same bacteria (features) as in the training set.
#' @param col_start An index indicating at which column is the beginning of bacteria (features) data. The default is the 3rd column.
#' @param type_col An index indicating at which column is group/type variable. The default is the 2nd column.
#' @param HighestRank The top number of features inclueded in model. The default is all the features left after filtering.
#' @return A data frame with 17 columns, each row represents a model estimation output.
#' @export
#' @examples
#' data(training)
#'
#' #### Take one row as testSet ####
#' idx <- sample(1:nrow(training),1)
#' test <- training[idx,]
#' train <- training[-idx,]
#'
#' CalPrb(FS(train),test) # This may take up to one minute

CalPrb <- function(FS_out=FS_out,testSet=testSet,col_start=3,type_col=2,HighestRank=nrow(FS_out$Feature)){

  Genus <- FS_out$CountData
  SortP <- FS_out$Feature

  Disease <- levels(Genus[,type_col])

  TotalType1 <- nrow(Genus[Genus[,type_col] == Disease[1], ])
  TotalType2 <- nrow(Genus[Genus[,type_col] == Disease[2], ])
  Prior1 <- TotalType1/(TotalType1+TotalType2)
  Prior2 <- TotalType2/(TotalType1+TotalType2)

  lh <- list()
  for(rank in 2:HighestRank) {
  #for(rank in 2:5) {
print(rank)
    ######## choose the signature taxa and merge the training data

    #NameList = as.vector(P_table[as.numeric(as.character(P_table$P_Wilcoxon))<0.2,]$Genera)
    #select the NameList based on the rank
    NameList <- as.vector(rownames(SortP)[1:rank])
    NewDF <- Genus[,colnames(Genus) %in% NameList]
    NewDF2 <- Genus[,!colnames(Genus)%in% NameList]

    col_end2 <- dim(NewDF2)[2]
    NewDF2$Others <- rowSums(NewDF2[, col_start:col_end2])
    #NewDFTotal = data.frame(NewDF2[, 1:(col_start-1)],NewDF, NewDF2$Others)
    NewDFTotal <- data.frame(NewDF2[, 1:(col_start-1)],NewDF)
    ###### merge in test row

    NewTestSignature <- testSet[, colnames(Genus) %in% NameList]
    NewTestNonSignature <- testSet[, !colnames(Genus)%in% NameList]
    NewTestNonSignature$Others <- rowSums(NewTestNonSignature[, col_start:col_end2])
    NewTestTotal <- data.frame(NewTestNonSignature[, 1:(col_start-1)],NewTestSignature)
    #NewTestTotal = data.frame(NewTestNonSignature[, 1:(col_start-1)],NewTestSignature, NewTestNonSignature$Others)

    rep2_Type1 <- NewDFTotal[NewDFTotal[,type_col] ==Disease[1],]
    rep2_Type2 <- NewDFTotal[NewDFTotal[,type_col] ==Disease[2],]

    ############Estimate Zero Inflated Generalized Dirchlet-Multinomial parameters
    tol <-0.0001
    max.iter<-1000

     ###### Estimate the parameters from the control data
    Xc <- as.matrix(rep(1, dim(rep2_Type1)[1]))
    Xa <- Xc
    Xb <- Xc
    c0 <- as.matrix(rep(1, dim(rep2_Type1)[2]-col_start))
    alpha0 <- c0
    beta0 <- c0

    ZIGDM_est1 <-ZIGDM.EM.PAR2(rep2_Type1[,-(1:(col_start-1))], Xc, Xa, Xb, c0, alpha0, beta0, tol=0.0001, max.iter=1000)

 #   ZIGDM_est1 <-ZIGDM.EM.PAR2(rep2_Type1[,-c((1:(col_start-1)), ncol(rep2_Type1))], Xc, Xa, Xb, c0, alpha0, beta0, tol=0.0001, max.iter=1000)
    ###p_Type1 <- ZIGDM_prob(rep2_Type1[,-(1:(col_start-1))], Xc, Xa, Xb, c0, alpha0, beta0, tol=0.0001, max.iter=1000)
    #fit3 <- dirmult(rep2_Type1[,-(1:(col_start-1))],epsilon=10^(-4),trace=FALSE)

    ###### Estimate the paramenters from the baseline data
    Xc <- as.matrix(rep(1, nrow(rep2_Type2)))
    Xa <- Xc
    Xb <- Xc
    c0 <- as.matrix(rep(1, ncol(rep2_Type1)-col_start))
    alpha0 <- c0
    beta0 <- c0

    ZIGDM_est2<-ZIGDM.EM.PAR2(rep2_Type2[,-(1:(col_start-1))], Xc, Xa, Xb, c0, alpha0, beta0, tol=0.0001, max.iter=1000)

    ##p_Type2 <- ZIGDM_prob(rep2_Type2[,-(1:(col_start-1))], Xc, Xa, Xb, c0, alpha0, beta0, tol=0.0001, max.iter=1000)
    #fit4 <- dirmult(rep2_Type2[,-(1:(col_start-1))],epsilon=10^(-4),trace=FALSE)

    #########Calculate the likelihood of the test sample being Type1 and Type2
######error p_Type1 has 7 number as 7 taxa? while only 2 taxa in
    #p_Type1 <- ZIGDM_prob(ZIGDM_est1, row = Xc[1,])
    #p_Type2 <- ZIGDM_prob(ZIGDM_est2, row = Xc[1,])

    testlist <- list()

    for (r in 1:nrow(testSet)){
      repeatlist <- list()
      for (rep in 1:10) {
        ##### Calculate zero inflated generalized Dirichlet multinomial probability mass function P(x|Type1)
        p_Type1 <- ZIGDM_prob(ZIGDM_est1, row = Xc[1,])
        p_Type2 <- ZIGDM_prob(ZIGDM_est2, row = Xc[1,])
        normalizeTest = NewTestTotal[r,-(1:(col_start-1))]/sum(NewTestTotal[r,-(1:(col_start-1))])*100
        if(length(normalizeTest) == 2) {
          probability_Type1 = apply(round(normalizeTest[1]),1,dbinom, 100, prob = p_Type1[1])
        }else{
        probability_Type1 = apply(normalizeTest,1,dmultinom, prob = p_Type1)
        }
        lhP_Type1 = probability_Type1*Prior1

        #pdfln_Type1 <- ddirmn(NewTestTotal[r,-(1:(col_start-1))], t(as.matrix(p_Type1)))
        #lh_Type1=exp(pdfln_Type1)
        #lhP_Type1 = lh_Type1*Prior1

        ##### Calculate log of Dirichlet multinomial probability mass function P(x|Type2)
        if(length(normalizeTest) == 2) {
          probability_Type2 = apply(round(normalizeTest[1]),1,dbinom, 100, prob = p_Type2[1])
        }else{
          probability_Type2 = apply(normalizeTest,1,dmultinom, prob = p_Type2)
        }

        lhP_Type2 = probability_Type2*Prior2

        #pdfln_Type2 <- ddirmn(NewTestTotal[r,-(1:(col_start-1))], t(as.matrix(p_Type2)))
        #lh_Type2=exp(pdfln_Type2)
        #lhP_Type2 = lh_Type2*Prior2

        #Pos_Type1 = lh_Type1/(lh_Type1+lh_Type2)
        #Pos_Type2 = lh_Type2/(lh_Type1+lh_Type2)

        PosP_Type1 = lhP_Type1/(lhP_Type1+lhP_Type2)
        PosP_Type2 = lhP_Type2/(lhP_Type1+lhP_Type2)

        #### Create truth labels ####

        if(testSet[r,type_col] == Disease[1]) {
          Type1Label = 1
          Type2Label = 0
        } else if (testSet[r,type_col] == Disease[2]) {
          Type1Label = 0
          Type2Label = 1
        }
      repeatlist[[rep]] <- as.matrix(t(c(Disease[1], Disease[2], rownames(testSet)[r], rank,  PosP_Type1, PosP_Type2, Type1Label, Type2Label,paste(NameList,collapse=";"))))

    }
      RandomRepeat = data.frame(t(sapply(repeatlist,'[')))
      PosP_Type1 = mean(as.numeric(as.character(RandomRepeat$X5)), na.rm = TRUE)
      PosP_Type2 = mean(as.numeric(as.character(RandomRepeat$X6)), na.rm = TRUE)

      testlist[[r]] <- as.matrix(t(c(Disease[1], Disease[2], rownames(testSet)[r], rank,  PosP_Type1, PosP_Type2, Type1Label, Type2Label,paste(NameList,collapse=";"))))

##    lh[[rank]] <- as.matrix(t(c(Disease[1], Disease[2], rownames(testSet), rank, Prior1, Prior2, lh_Type1, lh_Type2, Pos_Type1, Pos_Type2, lhP_Type1, lhP_Type2, PosP_Type1, PosP_Type2, Type1Label, Type2Label,paste(NameList,collapse=";"))))

    lh[[rank]] <- data.frame(t(sapply(testlist,'[')))

  } #end of rank

  lh_table <- data.frame(do.call(rbind,lh))
##  colnames(lh_table) = c("Type1", "Type2", "row", "feature_rank", "Prior1", "Prior2", "lh_Type1", "lh_Type2", "Poster_Type1", "Poster_Type2", "lhP_Type1", "lhP_Type2","Poster_Prio_Type1","Poster_Prio_Type2", "Type1Label", "Type2Label","SelectedFeatures" )

  colnames(lh_table) = c("Type1", "Type2", "row", "feature_rank", "Type1_Posterior_Prb","Type2_Postereior_Prb", "Type1Label", "Type2Label","SelectedFeatures" )
}
  return(lh_table)
}


# Find maximum daily temperature in OISST
# 1986-2005
# run on a workstation as it takes ~15 hours

require(ncdf4)
require(abind)

############
# Functions
############

# Returns maximum non-NA value if present, otherwise returns NA (instead of -Inf)
maxNA <- function(x) ifelse( !all(is.na(x)), max(x, na.rm=T), NA)

###############################
# Read in OISST netCDF files
# daily means at 0.25x0.25
# save the warmest day in each grid cell
# Run this on Amphpirion: takes ~ 15 hours
###############################
# find files
files <- list.files('oisst_daily', full.names=TRUE, pattern='.nc')
print(length(files))

# read in first file
	n = nc_open(files[1]) # Open the netCDF file
	# print(n) # get information about the file format

	# get data
	tosmaxday = ncvar_get(n, 'sst') # dim order: lon, lat, zlev, time. 0 lon is at date line.
		# dim(tempsarray) # 1440 x 720
		# range(as.numeric(tosmaxday), na.rm=TRUE)
	dimnames(tosmaxday)[[1]] <- ncvar_get(n, 'lon')
	dimnames(tosmaxday)[[2]] <- ncvar_get(n, 'lat')
	nc_close(n)

# read in rest of files and keep the warmest day
for(i in 2:length(files)){
	print(i)
	n = nc_open(files[i]) # Open the netCDF file
	tempsarray = ncvar_get(n, 'sst') # dim order: lon, lat, zlev, time. 0 lon is at date line.

	# keep the warmest day
	both <- abind(tosmaxday, tempsarray, along=3)
	tosmaxday <- apply(both, MARGIN=c(1,2), FUN=maxNA)

	print(range(as.numeric(tosmaxday), na.rm=TRUE)) # track progress. should increase

	# close file
	nc_close(n)

	# write out each X loops to save progress
	if(i %% 100 == 0) save(tosmaxday, file='tosmaxday.rdata')
}

# save final version
save(tosmaxday, file='tosmaxday.rdata')

# then go run climatology_OISST_maxday_process.r


#' knots2kmh
#'
#' Conversion speed from knots in kilometer per hour.
#'
#' @param numeric  knots Speed in knots.
#' @return
#'
#'
#' @author  Istituto di Biometeorologia Firenze Italy  Alfonso Crisci \email{a.crisci@@ibimet.cnr.it}
#' @keywords  knots2mph
#'
#' @export
#'
#'
#'
#'
knots2kmh<-function(knots)
{
  return(knots * 1.852);
}


#Save data linked to each river from the salmon dataset into a different '.txt'

river.names <- unique(salmon.data$river)
for(r in river.names){
  my.file.name <- paste(r, 'txt', sep = '.')
  my.data.to.save <- salmon.data[salmon.data$river == r , ]
  write.table(x = my.data.to.save, file = my.file.name, row.names = FALSE, sep = ',')
}

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

year.list <- sort(unique(salmon.data$year))

for(y in year.list){
  plot(salmon.data$length[salmon.data$year == y],
       salmon.data$weight[salmon.data$year == y],
       xlab = 'taille', ylab = 'poids', main = y)
}

# 6.2.3 ==========

col.seq <- 1:dim(salmon.data)[2]

#is.numeric(salmon.data[ , 1])

for(c in col.seq){
  test.numeric <- class(salmon.data[ , c]) %in% c('numeric', 'integer')
  if(test.numeric == TRUE){
    boxplot(salmon.data[ , c], main = colnames(salmon.data)[c])
  }else{
    #print(paste(colnames(salmon.data)[c], 'not numeric'))
    barplot(table(salmon.data[ , c]), main = colnames(salmon.data)[c])
  }
}

# save in txt if river is french
table(salmon.data$river, salmon.data$country, useNA = 'always')

list.rivers <- unique(salmon.data$river)
list.rivers <- list.rivers[!is.na(list.rivers)]

for(r in list.rivers){
  salmon.sub <- salmon.data[salmon.data$river == r, ]
  if(all(salmon.sub$country %in% c('fr', NA))){
    write.table(salmon.sub, file =  paste(r,'.txt', sep = ''))
  }else{
    print(paste(r,'pas francaise', sep = ' '))
  }
}


#!/usr/bin/Rscript

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

## markercount2pdf.r -- generates plot of marker counts versus number of bootstraps

usage <- function(){
  cat("usage: ./markercount2pdf.r <file>\n");
}

marker.counts <- read.table(commandArgs(TRUE)[1], row.names = 2);

counts.df <- as.data.frame(table(marker.counts));
counts.df$marker.counts <-
  as.numeric(levels(counts.df$marker.counts))[counts.df$marker.counts];
counts.df$marker.counts <-
  counts.df$marker.counts / max(counts.df$marker.counts);

par(mar=c(5,4.5,0.1,0.1));
pdf("output_marker_counts.pdf", paper = "a4r", width = 11, height = 8);
plot(counts.df$marker.counts, counts.df$Freq, cex.axis = 1.5, cex.lab = 1.5,
     xlab = "Proportion of bootstraps", ylab = "Number of Markers");
dummy <- dev.off();
pdf("output_marker_counts_log.pdf", paper = "a4r", width = 11, height = 8);
plot(counts.df$marker.counts, log(counts.df$Freq)/log(10),
     cex.axis = 1.5, cex.lab = 1.5,
     xlab = "Proportion of bootstraps", ylab = "log10(Number of Markers)");
dummy <- dev.off();


setwd("/home/yuanhao/github_repositories/DISC/reproducibility")
utilities_path = "./source/utilities.r"
source(utilities_path)
#### STEP 1
#Here, we use BONE_MARROW dataset. The detail information of this dataset can be seen at https://raw.githack.com/iyhaoo/DISC/master/reproducibility/data_preparation_and_imputation/data_preprocessing_BONE_MARROW.nb.html.</br>
#  We used the raw data after gene selection for cell identification.
gene_bc_mat = readh5_loom("./data/BONE_MARROW/raw.loom")
gene_bc_filt = gene_bc_mat[gene_selection(gene_bc_mat, 10), ]
dim(gene_bc_filt) #  13813, 6939
used_genes = rownames(gene_bc_filt)
output_dir = "./results/BONE_MARROW"
dir.create(output_dir, showWarnings = F, recursive = T)
#### STEP 2
#Following this script (https://github.com/Winnie09/imputationBenchmark/blob/master/data/code/process/07_hca_assign_celltype.R), we use the bulk-sequence data (https://www.ncbi.nlm.nih.gov/geo/query/acc.cgi?acc=GSE74246) of 13 normal hematopoietic cell types and 3 acute myeloid leukemia cell types for cell identification, the file is downloaded from https://www.ncbi.nlm.nih.gov/geo/download/?acc=GSE74246&format=file&file=GSE74246%5FRNAseq%5FAll%5FCounts%2Etxt%2Egz.
if(!file.exists("./data/BONE_MARROW/cell_type.rds")){
  library(scran)
  scran_normalization = function(gene_bc_mat){
    #  The source of this function is https://github.com/Winnie09/imputationBenchmark/blob/master/data/code/process/06_make_hca_MantonBM6.R
    dimnames_gene_bc_mat = dimnames(gene_bc_mat)
    dimnames(gene_bc_mat) = list()
    sce = SingleCellExperiment(list(counts = gene_bc_mat))
    no_cores = max(c(detectCores() - 1, 1))
    if(ncol(gene_bc_mat) < 21){
      sce = computeSumFactors(sce, BPPARAM = MulticoreParam(workers = no_cores), sizes = c(5, 10, 15, 20))
    } else {
      sce = computeSumFactors(sce, BPPARAM = MulticoreParam(workers = no_cores))
    }
    sf = sizeFactors(sce)
    dimnames(gene_bc_mat) = dimnames_gene_bc_mat
    return(log2(sweep(gene_bc_mat, 2, sf, "/") + 1))
  }
  scalematrix = function(data){
    cm = rowMeans(data)
    csd = apply(data, 1, sd)
    (data - cm) / csd
  }
  corfunc = function(m1, m2){
    scalematrix(t(m1)) %*% t(scalematrix(t(m2))) / (nrow(m1) - 1)
  }
  gene_bulk_all = as.matrix(read.table("./data/BONE_MARROW/original_data/GSE74246_RNAseq_All_Counts.txt.gz", header = T, row.names = 1))
  gene_bulk_mat = gene_bulk_all[, grep("^X", colnames(gene_bulk_all))]
  #  Use annotation information
  gz_path = "./data/hg19/Homo_sapiens.GRCh37.87.gtf.gz"
  annotation_mat = get_map(gz_path)
  tgngl = tapply(annotation_mat[, "gene_length"] / 1000, annotation_mat[, "gene_name"], max)
  gngl = as.vector(tgngl)
  names(gngl) = names(tgngl)
  gene_bulk_filt = gene_bulk_mat[row.names(gene_bulk_mat) %in% names(gngl),]
  gene_bulk_norm = sweep(gene_bulk_filt / gngl[rownames(gene_bulk_filt)], 2, colSums(gene_bulk_filt) / 1e6, "/")
  bulk_data = log2(gene_bulk_norm[rowSums(gene_bulk_norm) > 0,] + 1)
  bulk_cell_type = sapply(colnames(bulk_data), function(x){
    strsplit(x,"\\.")[[1]][2]
  }, USE.NAMES = F)
  sc_data = scran_normalization(gene_bc_filt)
  rownames(sc_data) = sub(".*:", "", rownames(gene_bc_filt))
  used_genes = intersect(rownames(bulk_data), rownames(sc_data))
  bulk_filt = bulk_data[used_genes, ]
  sc_filt = sc_data[used_genes, ]
  #  The expression level for each cell type in bulk sequencing
  bulk_mean = sapply(unique(bulk_cell_type),function(x) {
    rowMeans(bulk_filt[ , bulk_cell_type == x])
  })
  #  Find 100 top postive differentially expressed genes for each celltype pair.
  DEG_list = list()
  top_number = 100
  unique_celltype_pairs = combn(ncol(bulk_mean), 2)
  for(ii in seq(ncol(unique_celltype_pairs))){
    celltype_1 = colnames(bulk_mean)[unique_celltype_pairs[1, ii]]
    celltype_2 = colnames(bulk_mean)[unique_celltype_pairs[2, ii]]
    sort_result = sort(bulk_mean[ , celltype_1] - bulk_mean[ , celltype_2], decreasing = FALSE)
    DEG_list[[paste(celltype_2, celltype_1, sep = "-")]] = names(sort_result)[seq(top_number)]
    DEG_list[[paste(celltype_1, celltype_2, sep = "-")]] = names(sort_result)[seq(from = length(sort_result), to = length(sort_result) - (top_number - 1))]
  }
  #  Calculate the mean expression of these top-gene combinations across cell types (bulk) or cells (single-cell).
  expression_mean_function = function(gene_bc_norm, DEG_list){
    return(t(sapply(DEG_list, function(x){
      colMeans(gene_bc_norm[x, ])
    })))
  }
  bulk_DEG_expression_mean = expression_mean_function(bulk_mean, DEG_list)
  sc_DEG_expression_mean = expression_mean_function(sc_filt, DEG_list)
  #  Calculate the expression variation of these top-gene combinations across cell types (bulk) or cells (single-cell).
  expression_variation_function = function(x){
    return((x - rowMeans(x)) / apply(x, 1, sd))
  }
  bulk_DEG_expression_variation = expression_variation_function(bulk_DEG_expression_mean)
  sc_DEG_expression_variation = expression_variation_function(sc_DEG_expression_mean)
  #  Each top-gene combination correspond a cell type.
  bulk_DEG_combination_rank = apply(bulk_DEG_expression_variation, 2, rank)
  sc_DEG_combination_rank = apply(sc_DEG_expression_variation, 2, rank)
  #  Cell type identification.
  maxcorcut = 0.6
  difcorcut = 0
  cormat = corfunc(sc_DEG_combination_rank, bulk_DEG_combination_rank)
  maxcor = apply(cormat, 1, max)
  max2cor = apply(cormat, 1, function(x){
    sort(x, decreasing = T)[2]
  })
  cell_type = colnames(cormat)[apply(cormat, 1, which.max)]
  cell_type[maxcor < maxcorcut] = NA
  cell_type[maxcor - max2cor < difcorcut] = NA
  names(cell_type) = colnames(sc_data)
  saveRDS(cell_type, "./data/BONE_MARROW/cell_type.rds")
}else{
  cell_type = readRDS("./data/BONE_MARROW/cell_type.rds")
}
print("Cell Type ... OK!")
### Trajectory evaluation
#After cell identification, we evaluate the trajectory performance using monocle following these scripts(https://github.com/Winnie09/imputationBenchmark/blob/93f27e890a86fdc732257a4036bf38a52faf9f33/trajectory/code/hca/monocle2/01_get_score.R, https://github.com/Winnie09/imputationBenchmark/blob/93f27e890a86fdc732257a4036bf38a52faf9f33/trajectory/code/hca/tscan/01_get_score.R).
###  monocle2
library(monocle)
get_cds_monocle2 = function(gene_bc_mat){
  #  Make a new CDS and use DDRTree for dimension reduction.
  pd = new("AnnotatedDataFrame", data = data.frame(row.names = colnames(gene_bc_mat), cell = colnames(gene_bc_mat)))
  fd = new("AnnotatedDataFrame", data = data.frame(row.names = rownames(gene_bc_mat), gene_short_name = rownames(gene_bc_mat)))
  cds = newCellDataSet(gene_bc_mat, phenoData = pd, featureData = fd, expressionFamily = negbinomial.size())
  cds = estimateSizeFactors(cds)
  cds = estimateDispersions(cds)
  print("Reducing dimension...")
  cds = reduceDimension(cds)
  return(orderCells(cds))
}
###
cell_level_df = data.frame(level = c(1, 2, 3, 3, 4, 4, 4, 5, 5, 5, 5, 5, 5),
                           immunepath = c(1, 1, 1, 0, 1, 0, 0, 1, 1, 1, 1, 0, 0),
                           monopath = c(1, 1, 1, 1, 0, 1, 0, 0, 0, 0, 0, 1, 0),
                           erypath = c(1, 1, 0, 1, 0, 0, 1, 0, 0, 0, 0, 0, 1),
                           stringsAsFactors = F)
rownames(cell_level_df) = c("HSC", "MPP", "LMPP", "CMP", "CLP", "GMP", "MEP", "Bcell", "CD4Tcell", "CD8Tcell", "NKcell", "Mono", "Ery")
path_name = c("immunepath", "monopath", "erypath")
order_list = list(correct = list(), wrong = list(), cell_type = list())
wrong_order_list = list("1" = c(), "2" = c(), "3" = c(), "4" = c())
for(ii in path_name){
  path_celltype = rownames(cell_level_df)[cell_level_df[, ii] == 1]
  order_list[["cell_type"]][[ii]] = path_celltype
  cell_type_pair = as.matrix(apply(expand.grid(path_celltype, path_celltype), 2, as.character))
  cell_type_pair = cell_type_pair[cell_type_pair[, 1] != cell_type_pair[, 2], ]
  correct_mat = cell_type_pair[cell_level_df[cell_type_pair[, 1], "level"] < cell_level_df[cell_type_pair[, 2], "level"], ]
  wrong_mat = cell_type_pair[cell_level_df[cell_type_pair[, 1], "level"] > cell_level_df[cell_type_pair[, 2], "level"], ]
  order_list[["correct"]][[ii]] = apply(correct_mat, 1, paste, collapse = "_")
  order_list[["wrong"]][[ii]] = apply(wrong_mat, 1, paste, collapse = "_")
  for(jj in seq(max(cell_level_df[, "level"]) - min(cell_level_df[, "level"]))){
    this_mask = cell_level_df[cell_type_pair[, 1], "level"] == jj + cell_level_df[cell_type_pair[, 2], "level"]
    if(sum(this_mask) >=  1){
      if(sum(this_mask) ==  1){
        wrong_order_list[[as.character(jj)]] = c(wrong_order_list[[as.character(jj)]], paste(cell_type_pair[this_mask, ], collapse = "_"))
      }else{
        wrong_order_list[[as.character(jj)]] = c(wrong_order_list[[as.character(jj)]], apply(cell_type_pair[this_mask, ], 1, paste, collapse = "_"))
      }
    }
  }
}
type_level = as.character(cell_level_df[, "level"])
names(type_level) = rownames(cell_level_df)
correct_order_all = unique(unlist(order_list[["correct"]]))
wrong_order_all = unique(unlist(order_list[["wrong"]]))
get_score_monocle2 = function(cds, cell_type, correct_order, wrong_order = NULL, wrong_order_list = NULL, output_dir = NULL, type_level = NULL){
  if(is.null(wrong_order) + is.null(wrong_order_list) != 1){
    stop("One of wrong_order and wrong_order_list should be input.")
  }
  if(!is.null(wrong_order_list)){
    wrong_order = unique(unlist(wrong_order_list))
    result_mat = matrix(nrow = 0, ncol = 5, dimnames = list(c(), c("acc", "correct_number", "wrong_number", "pair_number", "distance_sum")))
  }else{
    result_mat = matrix(nrow = 0, ncol = 4, dimnames = list(c(), c("acc", "correct_number", "wrong_number", "pair_number")))
  }
  print("Looking for the root state...")
  used_cells = as.character(pData(cds)$cell)
  if(!is.null(output_dir)){
    dir.create(output_dir, recursive = T, showWarnings = F)
    p = plot_cell_trajectory(cds, color_by = "State")
    ggsave(paste0(output_dir, "/state.pdf"), p)
    pData(cds)$CellType = cell_type[used_cells]
    p = plot_cell_trajectory(cds, color_by = "CellType")
    ggsave(paste0(output_dir, "/celltype.pdf"), p)
    if(!is.null(type_level)){
      pData(cds)$Level = type_level[cell_type[used_cells]]
      p = plot_cell_trajectory(cds, color_by = "Level")
      ggsave(paste0(output_dir, "/level.pdf"), p)
    }
  }
  cell_states = as.numeric(as.character(pData(cds)$State))
  names(cell_states) = used_cells
  unique_states = unique(cell_states)
  checkroot = sapply(unique_states, function(x){
    cds = orderCells(cds, root_state = x)
    return(length(cds@auxOrderingData[[cds@dim_reduce_type]]$root_cell))
  })
  candidate_root_states = sort(unique_states[checkroot > 0])
  for(ii in candidate_root_states){
    cds = orderCells(cds, root_state = ii)
    this_output_dir = paste0(output_dir, "/rootstate_", ii)
    dir.create(this_output_dir, recursive = T, showWarnings = F)
    if(!is.null(output_dir)){
      p = plot_cell_trajectory(cds, color_by = "Pseudotime")
      ggsave(paste0(this_output_dir, "/pseudotime.pdf"), p)
    }
    all_branch_points = cds@auxOrderingData[[cds@dim_reduce_type]]$branch_points
    if(length(all_branch_points) > 0){
      for(jj in seq(length(all_branch_points))){
        cds_tmp = cds
        tryCatch({
          cds_reduced = buildBranchCellDataSet(cds_tmp, branch_point = jj)
          df = data.frame(pData(cds_reduced),stringsAsFactors = F)[used_cells, ]
          if(!is.null(output_dir)){
            pData(cds_tmp)$Pseudotime = df[, "Pseudotime"]
            pData(cds_tmp)$Branch = df[, "Branch"]
            pData(cds_tmp)$State = df[, "State"]
            p = plot_cell_trajectory(cds_tmp, color_by = "Pseudotime")
            ggsave(paste0(this_output_dir, "/branchpoint_", jj, "_pseudotime.pdf"), p)
            p = plot_cell_trajectory(cds_tmp, color_by = "Branch")
            ggsave(paste0(this_output_dir, "/branchpoint_", jj, "_branch.pdf"), p)
            p = plot_cell_trajectory(cds_tmp, color_by = "State")
            ggsave(paste0(this_output_dir, "/branchpoint_", jj, "_state.pdf"), p)
            pData(cds_tmp)$CellType = df[, "CellType"]
            p = plot_cell_trajectory(cds_tmp, color_by = "CellType")
            ggsave(paste0(this_output_dir, "/branchpoint_", jj, "_celltype.pdf"), p)
            if(!is.null(type_level)){
              pData(cds_tmp)$Level = df[, "Level"]
              p = plot_cell_trajectory(cds_tmp, color_by = "Level")
              ggsave(paste0(this_output_dir, "/branchpoint_", jj, "_level.pdf"), p)
            }
          }
          df = df[order(df$Pseudotime), ]
          score = rowSums(sapply(unique(df$Branch),function(x){
            branch_cell = as.character(df[df$Branch == x, 1])
            branch_celltype = cell_type[branch_cell]
            index_pair = combn(length(branch_cell), 2)
            if(min(index_pair[2,] - index_pair[1,]) < 0){
              stop("index_pair error")
            }
            branch_cellorder = sprintf("%s_%s",branch_celltype[index_pair[1, ]], branch_celltype[index_pair[2, ]])
            return_c = c(sum(branch_cellorder %in% correct_order), sum(branch_cellorder %in% wrong_order))
            sum(branch_cellorder %in% correct_order)
            if(!is.null(wrong_order_list)){
              distance_sum = 0
              for(kk in names(wrong_order_list)){
                distance_sum = distance_sum + sum(branch_cellorder %in% wrong_order_list[[kk]]) * as.numeric(kk)
              }
              return_c = c(return_c, distance_sum)
            }
            return(return_c)
          }))
          pair_number = sum(score[c(1, 2)])
          acc = score[1] / pair_number
          if(!is.null(wrong_order_list)){
            this_branch_point_results = matrix(c(acc, score[1], score[2], pair_number, score[3]), nrow = 1)
          }else{
            this_branch_point_results = matrix(c(acc, score[1], score[2], pair_number), nrow = 1)
          }
          rownames(this_branch_point_results) = paste0("RS_", ii, "_BP_", jj)
          result_mat = rbind(result_mat, this_branch_point_results)
        }, error = function(e){
          cat(ii, " - ", jj, "\n")
          print(e)
        })
      }
    }
  }
  return(result_mat)
}


subroutine addpt(j,nadj,madj,x,y,ntot,eps,ntri,nerror)
# Add point j to the triangulation.
# Called by master, dirseg.

implicit double precision(a-h,o-z)
dimension nadj(-3:ntot,0:madj), x(-3:ntot), y(-3:ntot)
logical didswp

# Put the new point in, joined to the vertices of its
# enclosing triangle.
call initad(j,nadj,madj,x,y,ntot,eps,ntri,nerror)
if(nerror > 0) return

# Look at each `gap', i.e. pair of adjacent segments
# emanating from the new point; they form two sides of a
# quadrilateral; see whether the extant diagonal of this
# quadrilateral should be swapped with its alternative
# (according to the LOP: local optimality principle).
now = nadj(j,1)
nxt = nadj(j,2)
ngap = 0

repeat {
	call swap(j,now,nxt,didswp,nadj,madj,x,y,ntot,eps,nerror)
	if(nerror > 0) return
        n = nadj(j,0)
        if(!didswp) {         # If no swap of diagonals
                now  = nxt    # move to the next gap.
                ngap = ngap+1
        }
        call succ(nxt,j,now,nadj,madj,ntot,nerror)
	if(nerror > 0) return
}
until(ngap==n)

return
end


# 사후 설계 분할표 - 데이터이 형식이 가공되어 있을 때

post <- read.csv("0303.post.csv",
                 header = T,
                 na.strings = ".")

str(post)

post$smoking <- factor(post$smoking,
                       levels = c(1,2),
                       labels = c("smok","nsmok"))
post$cancer <- factor(post$cancer,
                      levels = c(1,2),
                      labels = c("cancer","health"))

str(post)

# 여기서 observation 을 숫자가 아닌 데이터로 인식식켜줄 필요가 있다.

attach(post)

post.n <- xtabs(observation ~ cancer+smoking, data=post)

library("gmodels")

CrossTable(post.n) # 중간에 대문자임

post.n

detch(post)

ch03 - 기초통계/사후설계 분할표.r

ch03 - 기초통계/사후설계 분할표.r

ch03 - 기초통계/사후설계 분할표.r


source("read_data.R")
source("tools.r")
source("sql.r")

evaluateFunctionQuarityByPop <- function (dfn, popDist, Ns, Nsample = 100, popName="", fnName="", noise=NA) {
  KL <- numeric(length(Ns)) + NA
  L2 <- numeric(length(Ns)) + NA
  time <- numeric(length(Ns)) + NA
  for(i in seq(Ns)) {
    start <- Sys.time()
    cat("step:"); cat(i); cat(" start\n")
    KLTmp <- 0; L2Tmp <- 0
    for (j in 1:Nsample) {
      sampleDat <- sampleFromPopDist(Ns[i], popDist, seed=j)
      if (!is.na(noise)) {
        sampleDat <- addRandomNoise(sampleDat, noise)
      }
      sampleDist <- dfn(sampleDat)
      KLTmp <- KLTmp + KLdistance(sampleDist, popDist)
      L2Tmp <- L2Tmp + L2distance(sampleDist, popDist)
    }
    KL[i] <- KLTmp / Nsample
    L2[i] <- L2Tmp / Nsample
    time[i] <- (Sys.time() - start) / Nsample
    saveValue("evaluateFunctionQuarityByPop", list(fnName=fnName, popName=popName, N=Ns[i], KL=KL[i], L2=L2[i],time=time[i]))
  }
  return (list(KL=KL, L2=L2, time=time))
}

#deleteTable("evaluateFunctionQuarityByPop")
createTable("evaluateFunctionQuarityByPop", "method varchar, popName varchar, N number, KL number, L2 number, time number")

Ns <- c(10,20,40,80,100,200,400,800,1000,2000,4000,8000,10000,20000,40000,80000)
# evaluateFunctionQuarityByPop(sj, popDistList$sjOSM, Ns, popName="sjOSM", fnName="sj")
# evaluateFunctionQuarityByPop(botev, popDistList$sjOSM, Ns, popName="sjOSM", fnName="botev", Nsample = 100)
evaluateFunctionQuarityByPop(adeba, popDistList$sjOSM, Ns, popName="sjOSM", fnName="adeba", noise=2)

# deleteRow (c(38:42), "evaluateFunctionQuarityByPop")


## app.R ##
library(shinydashboard)

renderInputs <- function() {
  wellPanel(
    fluidRow(
        column(4,
        sliderInput("t", "nr of timesteps:", min = 10, max = 100, value = 100,step = 20),
        sliderInput("nrep", "nr of repetitions:", min = 1, max = 100, value = 50, step = 10),
        sliderInput("r", "Recombination rate:", min = 0.0, max = 0.5, value = 0.5, step = 0.05)
        ),
        column(4,
        sliderInput("AB0", "nr of AB individuals:", min = 0, max = 100, value = 0, step = 5),
        sliderInput("Ab0", "nr of Ab individuals:", min = 1, max = 10, value = 1, step = 1),
        sliderInput("aB0", "nr of aB individuals:", min = 1, max = 1000, value = 100, step = 10),
        sliderInput("ab0", "nr of ab individuals:", min = 0, max = 100, value = 0, step = 5)
        ),
        column(4,
        sliderInput("bA", "Birthrate of A", min = 0.0, max = 2.0, value = 1.1, step = 0.05),
        sliderInput("ba", "Birthrate of a:", min = 0.0, max = 2.0, value = 1.1, step = 0.05),
        sliderInput("dA", "Deathrate of A:", min = 0.0, max = 2.0, value = 1.05, step = 0.05),
        sliderInput("da", "Deathrate of a:", min = 0.0, max = 2.0, value = 1.15, step = 0.05)
        )
    ),
    p(actionButton("recalc","Run simulation", icon("random")))
  )
}

<<<<<<< HEAD
fluidPage(theme="simplex.min.css",
  tags$style(type="text/css",
    "label {font-size: 12px;}",
    ".recalculating {opacity: 1.0;}"
  ),

  # Application title
  tags$h2("Genetic rescue due to introgressive hybridization"),
  p("Simulations implemented in c++"),
  hr(),

  fluidRow(
    column(4,
    renderInputs()
    )
    ,
    column(4,
    plotOutput("plot_popdynamic")
    ),
    column(4,
    plotOutput("plot_introgression")
    )
  ),
  fluidRow(
    textOutput("write_fixation")
=======
ui <- dashboardPage(
  dashboardHeader(title = "Introgression"),
  dashboardSidebar(),
  dashboardBody(
    # Boxes need to be put in a row (or column)
      fluidRow(
          column(4,
          renderInputs()
          )
          ,
          column(4,
          plotOutput("plot_popdynamic")
          ),
          column(4,
          plotOutput("plot_introgression")
          )
        ),
        fluidRow(
          textOutput("write_fixation")
        )
>>>>>>> 48a400eb54892046e6d28b56d849f2f5f95e59fa
  )
)


library(ggvis)

# Make data set with categorical x
mtc <- mtcars
mtc$cyl <- factor(mtc$cyl)
mtc %>% ggvis(~cyl, ~mpg) %>% layer_boxplots()
# Set the width of the boxes to half the space between tick marks
mtc %>% ggvis(~cyl, ~mpg) %>% layer_boxplots(width = 0.5)

# Continuous x: boxes fill width between data values
mtcars %>% ggvis(~cyl, ~mpg) %>% layer_boxplots()
# Setting width=0.5 makes it 0.5 wide in the data space, which is 1/4 of the
# distance between data values in this particular case.
mtcars %>% ggvis(~cyl, ~mpg) %>% layer_boxplots(width = 0.5)


# The linkedin vector has already been defined for you
linkedin <- c(16, 9, 13, 5, 2, 17, 14)

# Code the for loop with conditionals
for (i in linkedin) {
    if (i>10) {print(paste("You're popular!"))}
    else if (i<10) {print(paste("Be more visible!"))}
print (i)
}


source("EigenMS.R")

for (j in 1:20){

ddata = read.table(paste(c("standard_",toString(j),"_old_processed.txt"),collapse=""), header=TRUE)
#ddata = ddata[,c(2,1,3:74)]
ddata[,1] <- seq.int(nrow(ddata))
m_logInts = ddata[,2:74]

m_prot.info = ddata[,1]

grps = as.factor(rep(1:24, times=1, each=3))
m_ints_eig1 = eig_norm1(m=m_logInts,treatment=grps,prot.info=m_prot.info)
m_ints_eig1$h.c
m_ints_norm1 = eig_norm2(rv=m_ints_eig1)

output <- m_ints_norm1$normalized[,2:74]
newcols <- c('#')
for (i in 2:73){
  newcols[i] <- unlist(strsplit(colnames(output)[i], '_'))[1]
}

colnames(output) <- newcols
write.table(output,paste(c("standard_eigenMS_",toString(j),".txt"),collapse=""),sep='\t', quote = FALSE, row.names=FALSE)

detach(TREAT)
}

for (j in 1:20){

  ddata = read.table(paste(c("double_noise_",toString(j),"_old_processed.txt"),collapse=""), header=TRUE)
  #ddata = ddata[,c(2,1,3:74)]
  ddata[,1] <- seq.int(nrow(ddata))
  m_logInts = ddata[,2:74]

  m_prot.info = ddata[,1]

  grps = as.factor(rep(1:24, times=1, each=3))
  m_ints_eig1 = eig_norm1(m=m_logInts,treatment=grps,prot.info=m_prot.info)
  m_ints_eig1$h.c
  m_ints_norm1 = eig_norm2(rv=m_ints_eig1)

  output <- m_ints_norm1$normalized[,2:74]
  newcols <- c('#')
  for (i in 2:73){
    newcols[i] <- unlist(strsplit(colnames(output)[i], '_'))[1]
  }

  colnames(output) <- newcols
  write.table(output,paste(c("double_noise_eigenMS_",toString(j),".txt"),collapse=""),sep='\t', quote = FALSE, row.names=FALSE)

  detach(TREAT)
}

for (j in 1:20){

ddata = read.table(paste(c("half_noise_",toString(j),"_old_processed.txt"),collapse=""), header=TRUE)
  #ddata = ddata[,c(2,1,3:74)]
  ddata[,1] <- seq.int(nrow(ddata))
  m_logInts = ddata[,2:74]

  m_prot.info = ddata[,1]

  grps = as.factor(rep(1:24, times=1, each=3))
  m_ints_eig1 = eig_norm1(m=m_logInts,treatment=grps,prot.info=m_prot.info)
  m_ints_eig1$h.c
  m_ints_norm1 = eig_norm2(rv=m_ints_eig1)

  output <- m_ints_norm1$normalized[,2:74]
  newcols <- c('#')
  for (i in 2:73){
    newcols[i] <- unlist(strsplit(colnames(output)[i], '_'))[1]
  }

  colnames(output) <- newcols
  write.table(output,paste(c("half_noise_eigenMS_",toString(j),".txt"),collapse=""),sep='\t', quote = FALSE, row.names=FALSE)

  detach(TREAT)
}

for (j in 1:20){

  ddata = read.table(paste(c("tenth_noise_",toString(j),"_old_processed.txt"),collapse=""), header=TRUE)
  #ddata = ddata[,c(2,1,3:74)]
  ddata[,1] <- seq.int(nrow(ddata))
  m_logInts = ddata[,2:74]

  m_prot.info = ddata[,1]

  grps = as.factor(rep(1:24, times=1, each=3))
  m_ints_eig1 = eig_norm1(m=m_logInts,treatment=grps,prot.info=m_prot.info)
  m_ints_eig1$h.c
  m_ints_norm1 = eig_norm2(rv=m_ints_eig1)

  output <- m_ints_norm1$normalized[,2:74]
  newcols <- c('#')
  for (i in 2:73){
    newcols[i] <- unlist(strsplit(colnames(output)[i], '_'))[1]
  }

  colnames(output) <- newcols
  write.table(output,paste(c("tenth_noise_eigenMS_",toString(j),".txt"),collapse=""),sep='\t', quote = FALSE, row.names=FALSE)

  detach(TREAT)
}


raw_cu = cu$cu(canonical_cds)
trna_gene_counts = data$trna_annotation(config) %>%
    filter(Anticodon != '???') %>%
    mutate(Codon = revcomp(Anticodon)) %>%
    group_by(Codon) %>%
    summarize(AA = n())
tai = cu$adaptation_tai(raw_cu, trna_gene_counts, canonical_cds)
hist(tai, breaks = 20)

# Use one replicate of healthy tissue.
#healthy_cu = codon_usage %>% filter(DO == 'do4152')
healthy_aa = aa %>% filter(DO == 'do388') %>% select(-AA) %>% rename(AA = Count)
#healthy_tai = cu$adaptation_tai(healthy_cu, healthy_aa, canonical_cds)
#hist(healthy_tai)

# Find optimal s-values
# Sample 1000 genes from across the range of expression
optim_mrna = inner_join(canonical_cds %>% select(Gene, Length),
                        mrna_counts %>% select(Gene, Expression = do4152),
                        by = 'Gene') %>%
    inner_join(raw_cu %>% tidyr::spread(Codon, CU), by = 'Gene') %>%
    arrange(Expression) %>%
    slice(seq(1, n(), length.out = 1000))
optim_trnas = setNames(healthy_aa$AA, healthy_aa$Codon)
set.seed(1440421485)
optim_s = cu$tai$find_optimal_s(select(optim_mrna, -Gene, -Length, -Expression),
                                optim_mrna$Expression,
                                optim_mrna$Length,
                                optim_trnas)
s = optim_s$par
optim_tai = cu$adaptation_tai(raw_cu, trna_gene_counts, canonical_cds, s)
hist(optim_tai, breaks = 20)
plot(optim_tai ~ tai)
cor(tai, optim_tai, method = 'spearman')
as.data.frame(optim_tai) %>% add_rownames('Gene') %>% inner_join(mrna_counts) %>%
    ggplot(aes(x = do4152 + 1, y = optim_tai)) +
    geom_point() +
    scale_x_log10() +
    geom_smooth(method = lm)
##########

healthy_tai = inner_join(mrna_counts,
                         data.frame(Gene = names(tai), raw_tAI = tai),
                         by = 'Gene') %>%
    mutate(tAI = raw_tAI * do4152) %>%
    mutate(tAI = tAI / max(tAI))

hist(healthy_tai$tAI, breaks = 20)

#hepg2_aa = aa %>% filter(DO == 'do1093') %>% select(-AA) %>% rename(AA = Count)

# Compare tAI with simple correlation
healthy_rcu = healthy_cu %>% `class<-`(c('codon_usage$cu', class(.))) %>% cu$rcu()
healthy_raa = raa %>% filter(DO == 'do388')
healthy_fit = cu$adaptation_no_wobble(healthy_rcu, healthy_raa) %>%
    mutate(Adaptation = ifelse(is.na(Adaptation), 0, Adaptation))
hist(healthy_fit$Adaptation)

healthy_compare = inner_join(healthy_tai, healthy_fit, by = 'Gene')
ggplot(healthy_compare, aes(x = Adaptation, y = tAI)) +
    geom_point()
with(healthy_compare, cor(Adaptation, tAI, method = 'spearman'))

ggplot(healthy_compare, aes(x = do4152, y = Adaptation)) +
    geom_point() +
    scale_x_log10()

ggplot(healthy_compare, aes(x = do4152, y = tAI)) +
    geom_point() +
    scale_x_log10()


cargarLattice<-function()
{
tryCatch({
  library(lattice)
  return(FALSE)
}, error = function(ex) {
  print("No se pudo cargar la libreria lattice")
  return(TRUE)
})
}

cargarExtremevalues<-function()
{
tryCatch({
  library(extremevalues)
  return(FALSE)
}, error = function(ex) {
  print("No se pudo cargar la libreria extremevalues")
  return(TRUE)
})
}

CargarDatos<-function(y){
tryCatch({
datos<-read.csv(y,enc="latin1")
return (list(FALSE,datos))
}, error = function(ex) {
print("No se pudo cargar el archivo de individuos")
return (TRUE)
})
}

IdentificarDistribucion<-function(x){
tryCatch({
Limit <- seq(0.15,0.95,0.01)
R2 <- numeric(length(Limit))
for ( i in 1:length(Limit) )
    R2[i] <- getOutliersII(datos$Biomasa, distribution=x,
FLim=c(0.1, Limit[i]) )$R2
A<-Limit
D1<-R2
return (list(FALSE,D1,A))
},error=function(ex){
print("Error identificacion la distribucion")
return(TRUE)
})
}

graficar<-function(){
tryCatch({
min_y<-min(c(D1,D2,D3,D4,D5))
max_y<-max(c(D1,D2,D3,D4,D5))
colores<-c("magenta","blue","red","brown","green")
png("C:/grafica.png")
plot(A,D1,type="l",col=colores[1],ylim=c(min_y,max_y),ann=FALSE)
lines(A,D2,type="l",pch=23,lty=1,col=colores[2])
lines(A,D3,type="l",pch=23,lty=1,col=colores[3])
lines(A,D4,type="l",pch=23,lty=1,col=colores[4])
lines(A,D5,type="l",pch=23,lty=1,col=colores[5])
title(main="Valores R2 y Fmax",col.main="black")
title(xlab= "Fmax",col.main="black")
title(ylab= "R2",col.main="black")
legend("bottomright",title="Distribucion",legend=c("Normal","Lognormal","Pareto","Weibull","Exponencial"),col=colores,lty=1)
dev.off()
})
}


library(phybase)
mptree1 = "(buffalo:9.181499,((yak:1.905599,(bison:1.014857,wisent:1.014857):0.890742):0.275900,(cattle:1,indicus:1):1.181499):7.000000);"

spname <- species.name(mptree1)
nodematrix <- read.tree.nodes(str=mptree1, name=spname)$nodes
nodematrix[,5]<-2

genetrees=1:200000
for(i in 1:200000)
genetrees[i]<-sim.coaltree.sp(rootnode=11, nodematrix=nodematrix,nspecies=6,seq=rep(1,6), name=spname)$gt

write(genetrees,"wisent_simulated.tre")


get_scores <- function(folder){
    data <- list.files(path=folder, pattern="*profile", full.names=TRUE) %>%
        lapply(fread) %>%
        rbindlist()
    data[, sum(SCORESUM), by = IID]
}

create_model <- function(col, data){
    glm(SHBG ~ array + sex + AGE + PC1 + PC2 + PC3 + PC4 + PC5 + PC6 + PC7 + PC8 + PC9 + PC10 + PC11 + PC12 + col, data=data)
}

temp_predict <- function(name, models, data){
    model <- models[[name]]
    setnames(data, name, "col")
    result <- predict(model, newdata=data)
    setnames(data, "col", name)
    result
}


#' p_local
#'
#' Estimate local value of air pressure in hPa.
#'
#' @param press numeric Air sea level pressure in hPa.
#' @param elev numeric Altitude or Elevation in meters.
#' @param t  numeric Mean Air temperature in degC.
#' @return local air pressure
#'
#'
#' @author Istituto per la Bioeconomia CNR Firenze Italy  Alfonso Crisci \email{alfonso.crisci@@ibe.cnr.it}
#' @keywords  p_local
#'
#' @export
#'
#'
#'
#'

p_local=function(press=1010,elev,t) {
                         ct$assign("press", as.array(press))
                         ct$assign("topo", as.array(elev))
                         ct$assign("temp", as.array(t))
                         ct$eval("var res=[]; for(var i=0, len=press.length; i < len; i++){ res[i]=p_local(press[i],topo[i],temp[i])};")
                         res=ct$get("res")
                         return(ifelse(res==9999,NA,res))
}


# Inspired by https://github.com/notesofdabbler
# Almost directly from the code demo rvest::zillow in help(package=rvest)
library(rvest)

url <- "http://www.zillow.com/homes/for_sale/VT/58_rid/any_days/45.537137,-69.062805,42.187829,-75.846863_rect/7_zm/"#2_p/"

more.urls <- read_html(url) %>%
  html_nodes(".zsg-pagination a") %>%
  html_attr("href")

more.urls <- more.urls[!is.na(more.urls)]
more.urls <- strsplit(more.urls, '/')
more.urls <- lapply(more.urls, function(x) x[length(x)])
more.urls <- as.numeric(gsub('[_p]','', more.urls))
more.urls <- max(more.urls)
urls <- c(url, paste0(url,2:more.urls,'_p/'))

zdata2 <- getZillow(urls)

zdata3 <- parseZillow(zdata2)
zdata4 <- zdata3[sapply(zdata3, function(x) length(x)>1)]
zdata4 <- do.call(rbind.data.frame, zdata4)
for(i in c('lat', 'long','price','beds','baths','sqft', 'acres', 'yr_built')) zdata4[i] <- as.numeric(as.character(zdata4[,i]))

library(rgdal)
library(sp)
library(raster)

vt <- rgdal::readOGR('/home/jon/Documents/AMElicitation/rasters/BoundaryState_VTBND', 'Boundary_VTBND_poly')

vt.twn <- rgdal::readOGR('/home/jon/Dropbox/AMharvest/shinyApps/AMHarvestSummary/data/spatial/Vermont/Boundary_TWNBNDS', 'Boundary_TWNBNDS_poly')

z.spat <- sp::SpatialPointsDataFrame(zdata4[,c('long', 'lat')], data=zdata4, proj4string=CRS("+init=epsg:4326"))

vt.wgs84 <- spTransform(vt, proj4string(z.spat))
plot(vt.wgs84)
plot(z.spat, add=TRUE, pch=19)

twn.w <- spTransform(vt.twn, proj4string(z.spat))
twn.sales <- over(z.spat, twn.w)

age <- aggregate(z.spat['yr_built'], by=twn.w['TOWNNAME'], mean, na.rm=TRUE)
count <- aggregate(z.spat['price'], by=twn.w['TOWNNAME'], length)
price <- aggregate(z.spat['price'], by=twn.w['TOWNNAME'], mean, na.rm=TRUE)
acres <- aggregate(z.spat['acres'], by=twn.w['TOWNNAME'], mean, na.rm=TRUE)
z.spat$pricepersqft <- z.spat$price/z.spat$sqft
pricepersqft <- aggregate(z.spat['pricepersqft'], by=twn.w['TOWNNAME'], mean, na.rm=TRUE)
twn.sales <- over(z.spat, as(twn.w,'SpatialPolygons'), fn=mean)
over(twn.w, z.spat)

# distance from urban center
# by school district
# distnace from water
# elevation?
# valuation of a home: price/sqft + 50*baths + 25*beds + price/acre/10 - age
z.spat$jonval <- z.spat$price/z.spat$sqft + 50*z.spat$baths + 25*z.spat$beds + z.spat$price/z.spat$acres/1000 - (2016-z.spat$yr_built)
jonval <- aggregate(z.spat['jonval'], by=twn.w['TOWNNAME'], median, na.rm=TRUE)

getZillow <- function(urls) {
    lapply(urls, function(u) {
        cat(u, '\n')

        houses <- read_html(u) %>%
          html_nodes("article")

        houses
    })
}

parseZillow <- function(zhouse.l, quiet=TRUE) {
    if(quiet) debugFun <- function(...){NULL}
    else debugFun <- cat
    len.h <-1:length(zhouse.l)
    lapply(1:length(zhouse.l), function(x) {
        houses <- zhouse.l[[x]]
        active <- tryCatch(houses %>% html_node(".property-data"), error=function(e) NULL)
        if(!is.null(active)) {
            debugFun(x, '\n')
            z_id <- houses %>% html_attr("id")

            debugFun('    address\n')
            address <- houses %>%
              html_node(".property-address a") %>%
              html_attr("href") %>%
              strsplit("/") %>%
              pluck(3, character(1))

            debugFun('    geo\n')
            geo <- houses %>%
              html_nodes(".property-address meta") %>%
              html_attr("content")

            geo <- data.frame(lat=geo[seq(1,length(geo), by=2)], long=geo[seq(2,length(geo), by=2)])

            debugFun('    price\n')
            price <- houses %>%
              html_node(".price-large") %>%
              html_text() #%>%
            #  tidyr::extract_numeric()

            price <- gsub('[^0-9]', '', price)

            params <- houses %>%
              html_node(".property-data") %>%
              html_text() %>%
              strsplit(", ")

            params.l <- lapply(params, function(x) {
                debugFun(x, '\n')
                if(length(x)) {
                    x <- gsub('Studio', '0.5 bds', x)

                    debugFun('    beds\n')
                    beds <- grepl('bds', x)
                    if(beds) {
                        beds <- x %>%
                        strsplit('bds')
                        beds <- beds[[1]][1]
                      }

                    debugFun('    baths\n')
                    baths <- grepl('ba', x)
                    if(baths) {
                        baths <- x %>%
                        strsplit('ba')
                        baths <- strsplit(baths[[1]], ' ')[[1]]
                        baths <- baths[length(baths)]
                    }

                    debugFun('    house_area\n')
                    house_area <- grepl('sqft [^a-z]+ ', x)
                    if(house_area) {
                        house_area <- x %>%
                        strsplit('sqft [^a-z]+ ')
                        house_area <- strsplit(house_area[[1]], ' ')[[1]]
                        house_area <- house_area[length(house_area)]
                    }

                    debugFun('    lot_ac\n')
                    lot_ac <- grepl('ac lot', x)
                    if(lot_ac) {
                        lot_ac <- x %>%
                        strsplit('ac lot')
                        lot_ac <- strsplit(lot_ac[[1]], ' ')[[1]]
                        lot_ac <- lot_ac[length(lot_ac)]
                    }

                    lot_sqft <- grepl('sqft lot', x)
                    if(lot_sqft) {
                        lot_ac <- x %>%
                        strsplit('sqft lot')
                        lot_ac <- gsub('[^0-9.]', '', lot_ac) %>%
                        as.numeric()
                        lot_ac <- lot_ac/43560
                    }

                    debugFun('    year_built\n')
                    year_built <- grepl('Built', x)
                    if(year_built) {
                        year_built <- x %>%
                        strsplit('Built')
                        year_built <- year_built[[1]][2]
                    }

                    out <- c(beds=beds, baths=baths, sqft=house_area, acres=lot_ac, yr_built=year_built)
                    out.vals <- gsub('[^0-9.]', '', out)
                    out.df <- data.frame(t(as.numeric(out.vals)))
                    names(out.df) <- names(out)
                    out.df
                } else data.frame(beds=NA, baths=NA, sqft=NA, acres=NA, yr_built=NA)
            })

            params.df <- do.call(rbind.data.frame, params.l)

            data.frame(z_id=z_id, address=address, geo, price=price, params.df)
        } else NA
    })
}

##beds <- params %>%
##  pluck(1, character(1)) #%>%
###  extract_numeric()
##
##baths <- params %>%
##  pluck(2, character(1)) #%>%
###  extract_numeric()
##
##house_area <- params %>%
##  pluck(3, character(1)) %>%
##  area()


source("init if necessary.r")

flog.info("Plotting distribution of gifts")

ggplot(gifts, aes(x=factor(round(GiftSize, 2)))) +
  geom_bar() +

  xlab("Gift size (litres of petrol)") +
  ylab("Count") +
  common_theme

for (ext in c("png", "pdf"))
  ggsave(file.path(plots.dir, paste0("distribution of gifts.", ext)), height=100, width=150, units="mm")


require(xgboost)
require(methods)

# we load in the agaricus dataset
# In this example, we are aiming to predict whether a mushroom is edible
data(agaricus.train, package='xgboost')
data(agaricus.test, package='xgboost')
train <- agaricus.train
test <- agaricus.test
# the loaded data is stored in sparseMatrix, and label is a numeric vector in {0,1}
class(train$label)
class(train$data)

#-------------Basic Training using XGBoost-----------------
# this is the basic usage of xgboost you can put matrix in data field
# note: we are putting in sparse matrix here, xgboost naturally handles sparse input
# use sparse matrix when your feature is sparse(e.g. when you are using one-hot encoding vector)
print("Training xgboost with sparseMatrix")
bst <- xgboost(data = train$data, label = train$label, max_depth = 2, eta = 1, nrounds = 2,
               nthread = 2, objective = "binary:logistic")
# alternatively, you can put in dense matrix, i.e. basic R-matrix
print("Training xgboost with Matrix")
bst <- xgboost(data = as.matrix(train$data), label = train$label, max_depth = 2, eta = 1, nrounds = 2,
               nthread = 2, objective = "binary:logistic")

# you can also put in xgb.DMatrix object, which stores label, data and other meta datas needed for advanced features
print("Training xgboost with xgb.DMatrix")
dtrain <- xgb.DMatrix(data = train$data, label = train$label)
bst <- xgboost(data = dtrain, max_depth = 2, eta = 1, nrounds = 2, nthread = 2,
               objective = "binary:logistic")

# Verbose = 0,1,2
print("Train xgboost with verbose 0, no message")
bst <- xgboost(data = dtrain, max_depth = 2, eta = 1, nrounds = 2,
               nthread = 2, objective = "binary:logistic", verbose = 0)
print("Train xgboost with verbose 1, print evaluation metric")
bst <- xgboost(data = dtrain, max_depth = 2, eta = 1, nrounds = 2,
               nthread = 2, objective = "binary:logistic", verbose = 1)
print("Train xgboost with verbose 2, also print information about tree")
bst <- xgboost(data = dtrain, max_depth = 2, eta = 1, nrounds = 2,
               nthread = 2, objective = "binary:logistic", verbose = 2)

# you can also specify data as file path to a LibSVM format input
# since we do not have this file with us, the following line is just for illustration
# bst <- xgboost(data = 'agaricus.train.svm', max_depth = 2, eta = 1, nrounds = 2,objective = "binary:logistic")

#--------------------basic prediction using xgboost--------------
# you can do prediction using the following line
# you can put in Matrix, sparseMatrix, or xgb.DMatrix
pred <- predict(bst, test$data)
err <- mean(as.numeric(pred > 0.5) != test$label)
print(paste("test-error=", err))

#-------------------save and load models-------------------------
# save model to binary local file
xgb.save(bst, "xgboost.model")
# load binary model to R
bst2 <- xgb.load("xgboost.model")
pred2 <- predict(bst2, test$data)
# pred2 should be identical to pred
print(paste("sum(abs(pred2-pred))=", sum(abs(pred2-pred))))

# save model to R's raw vector
raw = xgb.save.raw(bst)
# load binary model to R
bst3 <- xgb.load(raw)
pred3 <- predict(bst3, test$data)
# pred3 should be identical to pred
print(paste("sum(abs(pred3-pred))=", sum(abs(pred3-pred))))

#----------------Advanced features --------------
# to use advanced features, we need to put data in xgb.DMatrix
dtrain <- xgb.DMatrix(data = train$data, label=train$label)
dtest <- xgb.DMatrix(data = test$data, label=test$label)
#---------------Using watchlist----------------
# watchlist is a list of xgb.DMatrix, each of them is tagged with name
watchlist <- list(train=dtrain, test=dtest)
# to train with watchlist, use xgb.train, which contains more advanced features
# watchlist allows us to monitor the evaluation result on all data in the list
print("Train xgboost using xgb.train with watchlist")
bst <- xgb.train(data=dtrain, max_depth=2, eta=1, nrounds=2, watchlist=watchlist,
                 nthread = 2, objective = "binary:logistic")
# we can change evaluation metrics, or use multiple evaluation metrics
print("train xgboost using xgb.train with watchlist, watch logloss and error")
bst <- xgb.train(data=dtrain, max_depth=2, eta=1, nrounds=2, watchlist=watchlist,
                 eval_metric = "error", eval_metric = "logloss",
                 nthread = 2, objective = "binary:logistic")

# xgb.DMatrix can also be saved using xgb.DMatrix.save
xgb.DMatrix.save(dtrain, "dtrain.buffer")
# to load it in, simply call xgb.DMatrix
dtrain2 <- xgb.DMatrix("dtrain.buffer")
bst <- xgb.train(data=dtrain2, max_depth=2, eta=1, nrounds=2, watchlist=watchlist,
                 nthread = 2, objective = "binary:logistic")
# information can be extracted from xgb.DMatrix using getinfo
label = getinfo(dtest, "label")
pred <- predict(bst, dtest)
err <- as.numeric(sum(as.integer(pred > 0.5) != label))/length(label)
print(paste("test-error=", err))

# You can dump the tree you learned using xgb.dump into a text file
xgb.dump(bst, "dump.raw.txt", with_stats = T)

# Finally, you can check which features are the most important.
print("Most important features (look at column Gain):")
imp_matrix <- xgb.importance(feature_names = colnames(train$data), model = bst)
print(imp_matrix)

# Feature importance bar plot by gain
print("Feature importance Plot : ")
print(xgb.plot.importance(importance_matrix = imp_matrix))


library(tidyverse)
library(stringr)
library(foreach)

files <- foreach(filename = list.files("data", "*agents,d=*", full.names = TRUE), .combine = c) %do% {
  list(list(filename = filename,
            seed = filename %>% str_replace(".*s=(\\d+).*", "\\1") %>% as.numeric,
            lambda = filename %>% str_replace(".*l=(\\d+).*", "\\1") %>% as.numeric,
            dimensions = filename %>%
              str_replace(".*d=(\\d+),(\\d+),(\\d+),(\\d+).*", "\\1,\\2,\\3,\\4") %>%
              str_split(",") %>%
              unlist() %>%
              as.numeric
            ))
}

data <- foreach(file = files, .combine = rbind) %do% {
  with(file, {
    read_csv(filename, col_types = cols(.default = col_integer())) %>%
      mutate(seed = seed, lambda = lambda,
             X = dimensions[1], Y = dimensions[2], Z = dimensions[3],
             time_window = dimensions[4])
  })
}

write_csv(data, "data/agents,summary.csv.gz")

# data %>%
#   group_by(lambda, t) %>%
#   summarize(avg = mean(count), .groups = "drop") %>% {
#     ggplot(., aes(x = t, y = avg, color = lambda, group = lambda)) +
#       geom_line()
#   }

# data %>%
#   group_by(lambda) %>%
#   summarize(count = mean(count[-{1:10}]), .groups = "drop") %>% {
#     ggplot(., aes(x = lambda, y = count)) +
#       geom_line() +
#       geom_point()
#   }

# data %>%
#   filter(t > max(t) - 10) %>% {
#     ggplot(., aes(x = lambda, y = count, group = lambda, fill = lambda)) +
#       geom_boxplot()
#   }


coef.ivmodel<-function(object, ...){
  ivmodel<-object
  coefmat <- matrix(NA, ncol=5, nrow=0)
  colnames(coefmat) <- c("k", "Estimate", "Std. Error", "t value", "Pr(>|t|)")
  if(!is.null(ivmodel$kClass)){
    temp<-cbind(as.numeric(rownames(ivmodel$kClass$ci)), ivmodel$kClass$point.est,
            	ivmodel$kClass$std.err, ivmodel$kClass$test.stat, ivmodel$kClass$p.value)
	rownames(temp) <- rep("k-class", nrow(temp))
    rownames(temp)[temp[,1]==0] <- "OLS"
    rownames(temp)[temp[,1]==1] <- "TSLS"
    coefmat <- rbind(coefmat, temp)
  }
  if(!is.null(ivmodel$LIML)){
    temp<-cbind(ivmodel$LIML$k, ivmodel$LIML$point.est, ivmodel$LIML$std.err,
	            ivmodel$LIML$test.stat, ivmodel$LIML$p.value)
	rownames(temp) <- "LIML"
    coefmat <- rbind(coefmat, temp)
  }
  if(!is.null(ivmodel$Fuller)){
    temp<-cbind(ivmodel$Fuller$k, ivmodel$Fuller$point.est, ivmodel$Fuller$std.err, ivmodel$Fuller$test.stat, ivmodel$Fuller$p.value)
	rownames(temp) <- "Fuller"
    coefmat <- rbind(coefmat, temp)
  }

  coefmat<-coefmat[sort(coefmat[,1], index.return=T)$ix,]
  return(coefmat)
}


library(data.table)
library(stringr)

DATADIR <- "../../data"
SUBDATADIR <- "alsmmala"
OUTDIR <- "../output"

npars <- 4

nmcmc <- 110000
nburnin <- 10000
npostburnin <- nmcmc-nburnin

nmeans <- 10000
ci <- 5
pi <- 2

chains <- t(fread(
  file.path(DATADIR, SUBDATADIR, paste("chain", str_pad(ci, 2, pad="0"), ".csv", sep="")), sep=",", header=FALSE
))

chainmean = mean(chains[, pi])

pdf(file=file.path(OUTDIR, "logit_alsmmala_traceplot.pdf"), width=10, height=6)

plot(
  1:npostburnin,
  chains[, pi],
  type="l",
  ylim=c(-1.2, 3),
  col="steelblue2",
  xlab="",
  ylab="",
  cex.axis=1.8,
  cex.lab=1.7,
  yaxt="n"
)

axis(
  2,
  at=seq(-1, 3, by=1),
  labels=seq(-1, 3, by=1),
  cex.axis=1.8,
  las=1
)

lines(
  1:npostburnin,
  rep(chainmean, npostburnin),
  type="l",
  col="orangered1",
  lwd=2
)

dev.off()