##############################################################################
# Negbin model processing functions
##############################################################################
# Run negbin model for each formula specified in formlist
runMod <- function(formlist, data){
	out <- lapply(formlist, function(x) glm.nb(x, data))
	names(out) <- names(formlist)
	return(out)
}

# Build list of fitted values (with CHR/BIN names) for each model
getFits <- function(modlist, data){
	out <- lapply(modlist,
		function(x){
			y <- fitted.values(x)
			names(y) <- paste0(data$CHR, ".", data$BIN)
			y
		})
	names(out) <- names(modlist)
	return(out)
}

# Build list of dataframes for each model
buildDF <- function(fitlist, data){
	out <- lapply(fitlist,
		function(x){
			data.frame(CHR, Category2=cat1, BIN,
				exp=x,
				obs=data$obs,
				# res=names(fitlist),
				stringsAsFactors=F)
		}
	)
	names(out) <- names(fitlist)
	return(out)
}

##############################################################################
# Compute standard error for correlations
##############################################################################
corSE <- function(corval, ct){
	sqrt((1-corval^2)/(ct-2))
}


#' Fractional airline model summary
#'
#' Generates a matrix with coefficient estimates from the fractional airline model, generated by the JDemtetra+ high dimension modeling R routines
#'
#' @param this_est A list object generated by the estimation procedure of the fractional airline model
#' @param xreg_names Character vector; Names of the user-defined regression variables.
#' @param this_week Numeric vector; Week of each observation. Default: NULL
#' @param this_year Numeric vector; Year of each observation. Default: NULL
#' @return Generate matrix of model parameters estimated for the fractional airline model
#' @examples
#' ic_default_est <-
#'    rjd3highfreq::fractionalAirlineEstimation(ic_obs, periods=c(365.25/7), x=ic_default_matrix)
#' ic_default_model <-
#'    gen_air_model_matrix(ic_default_est,
#'                         xreg_names = colnames(ic_default_matrix),
#'                         this_week = ic_week, this_year = ic_year)
#' @import stats
#' @export
gen_air_model_matrix <- function(this_est, xreg_names = NULL, this_week = NULL, this_year = NULL) {
    # Author: Brian C. Monsell (OEUS), Version 3.0, 2/2/2022

    # create variable for coefficient estimate, both regressors and ARMA parameters
    this_b <- c(this_est$model$b, this_est$estimation$parameters)

    # generate t-statistics, both regressors and ARMA parameters
    t1 <- t_values_air(this_est$model$b, this_est$model$bcov)
    t2 <- t_values_air(this_est$estimation$parameters, this_est$estimation$covariance)
    this_t <- c(t1, t2)

    if (is.null(xreg_names)) {
        # collect names of both regressors and ARMA parameters
        this_names <- c(this_est$model$variables, "theta_nonseas", "theta_seasonal")
    } else {
        # set length of regression names, regressors used in the model estimation
        i1 <- length(xreg_names)
        i2 <- length(this_est$model$variables)

        # Check if number of user provided names is less than the number of regressors actually used This
        # means that outliers have been automatically identified
        if (length(xreg_names) < length(this_est$model$variables)) {
            # If \code{this_week} and \code{this_year} are not specified, use the names provided for the
            # automatic outliers identified
            if (is.null(this_week) | is.null(this_year)) {
                this_names <- c(xreg_names, this_est$model$variables[(i1 + 1):i2], "theta_nonseas",
                  "theta_seasonal")
            } else {
                # Else change the names of the automatic outliers to be based on the dates of the outliers rather
                # than the absolute position of the observation First, initialize the vector
                # \code{this_xreg_names}
                this_xreg_names <- array(" ", dim = i2)
                for (i in 1:i1) {
                  this_xreg_names[i] <- xreg_names[i]
                }
                for (i in (i1 + 1):i2) {
                  # Then, split the name of each automatically identified outlier into a vector with the type of the
                  # outlier and the relative position of the outlier
                  this_reg <- strsplit(unlist(this_est$model$variables[i]), ".", fixed = TRUE)[[1]]
                  # create new outlier name pasting together the outlier type with the date of the outlier
                  this_xreg_names[i] <- paste0(this_reg[1], "(week ", this_week[as.numeric(this_reg[2])],
                    ", ", this_year[as.numeric(this_reg[2])], ")")
                }
                # collect parameter names into \code{this_names}
                this_names <- c(this_xreg_names, "theta_nonseas", "theta_seasonal")
            }
        } else {
            # collect parameter names into \code{this_names}
            this_names <- c(xreg_names, "theta_nonseas", "theta_seasonal")
        }
    }

    # Initialize vector for standard errors to zero
    this_se <- array(0, dim = length(this_b))

    # set \code{this_se} to estimate of standard errors from covariance matrices of the regression
    # and ARMA estimates
    for (i in 1:length(this_est$model$b)) {
        this_se[i] <- sqrt(this_est$model$bcov[i, i])
    }
    this_se[length(this_b) - 1] <- sqrt(this_est$estimation$covariance[1, 1])
    this_se[length(this_b)] <- sqrt(this_est$estimation$covariance[2, 2])

    # Create model matrix by binding vectors for model parameters, standard errors, and t-statistics.
    # Also set row and column names of the matrix
    this_model_matrix <- cbind(this_b, this_se, this_t)
    rownames(this_model_matrix) <- this_names
    colnames(this_model_matrix) <- c("Coefficient", "Std_Err", "T-value")

    # return model matrix
    return(this_model_matrix)
}


help_usage <- function()
{
	cat("\n+++++++++++++++++++++++++++++++++++++++++++++++++\n")
	cat("Usage:\n")
	cat("Rscript pca_analysis.r <rpkm> T <outdir>")
	cat("Example:\n/annoroad/share/software/install/R-3.2.2/bin/Rscript pca_analysis.R rpkm.trans.xls T ./ \n")
	cat("Note:\n")
	cat("rpkm.trans.xls: Group info of each sample must be included in this file ,and the columns are genes ,while the rows are samples; Group Info should be located in the first column\n")
	cat("************************************************\n")
	cat("++++++++++++++++++++++++++++++++++++++++++++++++++++++++++\n")
}

# install and load multiple R packages
ipak <- function(pkg)
{
#new_pkg <- pkg[!(pkg %in% installed.packages()[,"Pakcage"])]
	new_pkg <- pkg[!(pkg %in% installed.packages()[, "Package"])]
	if (length(new_pkg) != 0)
	{
		install.packages(new_pkg, dependencies=TRUE)
	}
	sapply(pkg, require, character.only=TRUE)
}

#create and set the output dir
mk_subdir <- function(parent_out_dir, result_dir)
{
	setwd(parent_out_dir)
	if(file.exists(result_dir))
	{
		unlink(result_dir, recursive=TRUE)
	}
	new_dir <- file.path(parent_out_dir,result_dir)
	dir.create(new_dir)
	setwd(new_dir)
}
###PCA Analysis
pca_analysis <- function(comm_input,parent_out_dir,label)
{
	mk_subdir(parent_out_dir,"pca_output")
	comm_counts <- comm_input[,-1]
	res_pca <- PCA(comm_counts,graph=FALSE)
	cat("[Running]:PCA function Analysis finished ... ...\n")
###+++++++++++++PCA_summary Output++++++++++++++++++++++
	Comp <- rownames(res_pca$eig)
	summary_pca <- cbind(Comp,res_pca$eig)
	write.table(summary_pca,"PCA_summary.xls",sep="\t",col.names=T,row.names=F,quote=F)

###+++++++++++++Dim Explanation for Variable(gene)++++++
	Variable <- rownames(res_pca$var$cos2)
	Var_exp <- cbind(Variable,res_pca$var$cos2)
	write.table(Var_exp,"Variable_gene_cos2.xls",sep="\t",col.names=T,row.names=F,quote=F)

###+++++++++++++Variable Contribute for Dim ++++++++++++++
	Var_contrib <- cbind(Variable,res_pca$var$contrib)
	write.table(Var_contrib,"Varable_gene_contrib.xls",sep="\t",col.names=T,row.names=F,quote=F)

###+++++++++++++Individual(Sample) Coordinates on the principle components+++++++++++++++++++
	Sample <- rownames(res_pca$ind$coord)
	Sample_cor <- cbind(Sample,res_pca$ind$coord)
	write.table(Sample_cor,"Sample_coordinate.xls",sep="\t",col.names=T,row.names=F,quote=F)
######++++++++++++++++++Table Output End++++++++++++++++++++
	cat("[Running]:Plot PCA_individual ... ...\n")
	pdf("PCA_individual_dim1_dim2.pdf")
	#fviz_pca_ind(res_pca, label="none", habillage=comm_input$group,addEllipses=TRUE, ellipse.level=0.95)
	#f <- factor(comm_input$group)
	a <- comm_input$group
	str(a)
	get_eig(res_pca)
	f <- factor(a)
	groups <- f
	#print(comm_input$group)
	if (label == "True")
	{
		pa <- fviz_pca_ind(res_pca, habillage=a)
	}else
	{
		#pa <- fviz_pca_ind(res_pca, label="none", habillage=comm_input$group)
		pa <- fviz_pca_ind(res_pca, label="none",habillage=f)
		pa<- pa +
		theme_classic() +
		scale_shape_manual(values=c(16,16,3,17,15,11,8,16,16,3,17,15,11,8,16,16,3,17,15,11,8)) +
		scale_color_manual(values=c("#ADFF2F","#EE2C2C","#EE2C2C","#EE2C2C","#EE2C2C","#EE2C2C","#EE2C2C","#EE00EE","#EEEE00","#EEEE00","#EEEE00","#EEEE00","#EEEE00","#EEEE00","#000000","#00FFFF","#00FFFF","#00FFFF","#00FFFF","#00FFFF","#00FFFF" )) +
		#theme(legend.position = "none") +
#		scale_shape_manual(values=c(16,16,3))+
#		scale_color_manual(values=c("#ADFF2F","#EE2C2C","#EE2C2C")) +
		labs(x="PC1", y = "PC2", title="PCA-Individuals factor map")
	}
	print(pa)
	dev.off()
######++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
	cat("[Running]:PCA_individual Plot finished ... ...\n")
	cat("[Running]:Plot PCA_variable ... ...\n")
	pdf("PCA_variable_dim1-dim2.pdf")
	select_var <- NULL
	if(ncol(comm_counts) >= 20){
		select_var <- list(contrib = 20)
	}
	#pb <-fviz_pca_var(res_pca,col.var="contrib",select.var=select_var)+scale_color_gradient2(low="white", mid="blue",high="red",midpoint=55)+theme_bw()
	pb <- fviz_pca_var(res_pca,col.var="contrib",select.var=select_var)+theme_bw()
	print(pb)
	dev.off()
	cat("[Running]:PCA_variable Plot finish ... ...\n")
############################++++++++3d plot+++++++++++++++++++++++++++++++++++++++++++++++
	cat("[Running]:PCA 3d plot ... ...\n")
	col<-c("#FFFF00","#FF00FF","#FF0000","#FA8072","#F4A460","#F08080","#EED2EE","#CAFF70","#B8B8B8","#AB82FF","#A0522D","#8E388E","#000000","#006400","#0000EE","#27408B","#636363","#5D478B","#218868","#00688B","#191970")
	#col<-c("#FFFF00","#FF00FF","#FF0000")
	beuty <- col
	sample<-rownames(comm_input)
	print(sample)
	group<-comm_input$group
	tmpdata<-cbind(group,sample)
	groupCol<-cbind(unique(comm_input$group),col[1:length(unique(comm_input$group))])
	sampleCol<-merge(groupCol,tmpdata,by.x=1,by.y=1)
	print(sampleCol)
	col<-sampleCol$V2
	pdf("PCA.3d.pdf",width=10,height=10)
	dim1<-paste("Dim1(",round(res_pca$eig[1,2],2),"%)",sep="")
	dim2<-paste("Dim2(",round(res_pca$eig[2,2],2),"%)",sep="")
	dim3<-paste("Dim3(",round(res_pca$eig[3,2],2),"%)",sep="")
	scatterplot3d(res_pca$ind$coord[,1],res_pca$ind$coord[,2],res_pca$ind$coord[,3],color=col,pch=19,xlab=dim1,ylab=dim2,zlab=dim3,cex.symbols=1.5,cex.lab=1.5,cex.axis=1.2)
	#legend("bottomright",col= c("#CAFF70","#FF00FF","#FF0000","#FA8072","#F4A460","#EED2EE","#F08080","#0000EE","#B8B8B8","#AB82FF","#A0522D","#8E388E","#006400","#000000","#27408B","#636363","#5D478B","#218868","#191970","#00688B","#FFFF00"),legend = c("CC","Invivo_1","Invivo_2","Invivo_4","Invivo_8","Invivo_B","Invivo_M","MEF","NTC_1","NTC_2","NTC_4","NTC_8","NTC_B","NTC_M","NTM_1","NTM_2","NTM_4","NTM_8","NTM_B","NTM_M","Oocyte"),pch=19)
	legend("bottomright",col= c("#CAFF70","#FF00FF","#FF0000","#FA8072","#F4A460","#EED2EE","#F08080","#0000EE","#B8B8B8","#AB82FF","#A0522D","#8E388E","#006400","#000000","#27408B","#636363","#5D478B","#218868","#191970","#00688B","#FFFF00"),legend = groups,pch=19)
	#print(s3d)
	dev.off()
	cat("[Running]:PCA 3d plot finish ... ...\n")
############################++++++++++++++++3d plot End+++++++++++++++++++++++++++++++++++
}

###Main Function
main_fun <- function()
{
	## input arguments
	input_file <- commandArgs(trailingOnly=TRUE)
	if (length(input_file) == 1 && input_file[1] == "--help")
	{
		help_usage()
		cat("Introduction:\n\n")
		quit(save="no", runLast=FALSE)
	}

	if (length(input_file) < 2)
	{
		help_usage()
		stop("At least 2 arguments is required!\n\n")
	}

	cat("Your input arguments are listed as follows:\n")
	print(input_file)
	## the concise packages are needed in the analysis
	#concise_packages <- c("FactoMineR","ade4","adegraphics","factoextra","devtools")
	#ipak(concise_packages)
	library("ade4")
	library("adegraphics")
	library("FactoMineR")
	library("factoextra")
	library("devtools")
	library("scatterplot3d")
	library("ggplot2")
	#library("ggthemes")
	#input file & read your rpkm table
	ori_input <- read.table(input_file[1],header=TRUE,sep="\t",row.names=1,stringsAsFactors=FALSE)

	#comm_input <- ori_input[, colSums(ori_input ^ 2) != 0]
	comm_input <- ori_input

	## define the output dir
	parent_out_dir <- getwd()
	if(length(input_file) == 3)
	{
		parent_out_dir <- input_file[3]
	}
	if(! file.exists(parent_out_dir))
	{
		dir.create(parent_out_dir)
	}

	## check and match the input files
	cat("PCA Begins ... ...\n")
	pca_analysis(comm_input,parent_out_dir,input_file[2])
}

main_fun()


setwd(inputDrive)
default.alpha <- read.csv("default.alpha.csv",header=T)
default.prop_coef <- read.csv("default.prop_coef.csv",header=T)
rownames(default.prop_coef) <- default.prop_coef$X
default.prop_coef <- default.prop_coef[,-c(1)]

alpha1 <- default.alpha$alpha1
alpha2 <- default.alpha$alpha2
alpha3 <- default.alpha$alpha3
alpha1.dush <- default.alpha$alpha1.dush
alpha2.dush <- default.alpha$alpha2.dush
beta.orth <- default.alpha$beta.orth

prop_coef <- default.prop_coef


# install (if necessary) and load data manipulation packages
install.packages("plyr")
install.packages("dplyr")
library(plyr)
library(dplyr)
library(reshape2)
library(stringr)

# read in the features
features <- read.table("UCI HAR Dataset\\features.txt")
# read in the test data
test_x <- read.table("UCI HAR Dataset\\test\\X_test.txt")
test_y <- read.table("UCI HAR Dataset\\test\\y_test.txt")
test_subjects <- read.table("UCI HAR Dataset\\test\\subject_test.txt")
train_x <- read.table("UCI HAR Dataset\\train\\X_train.txt")
train_y <- read.table("UCI HAR Dataset\\train\\y_train.txt")
train_subjects <- read.table("UCI HAR Dataset\\train\\subject_train.txt")

# 1) merge the training and test sets to create one data set
combined_data <- rbind(test_x, train_x)
combined_y <- rbind(test_y, train_y)
combined_subjects <- rbind(test_subjects, train_subjects)

# apply the features V2 column as the headers for the combined_data data frame
# clean up the names first to remove hyphens and parentheses
listOfNames <- as.character(features$V2)
listOfNames <- make.names(listOfNames, unique=TRUE)
names(combined_data) <- listOfNames

# add combined_y and combined_subjects as the first columns in the combined_data data frame
combined_data <- cbind(combined_y, combined_data)
names(combined_subjects) = c('subjects')
combined_data <- cbind(combined_subjects, combined_data)

# 2) extract only the measurements on the mean and standard deviation for each measurement
sub_data <- select(combined_data, subjects, V1, contains(".mean."), contains(".std."))

# convert the subject and activities columns to factors
sub_data$subjects <- as.factor(sub_data$subjects)
sub_data$V1 <- as.factor(sub_data$V1)

# 3) use descriptive activity names to name the activites in the data set
sub_data$V1 <- mapvalues(sub_data$V1, from = c("1", "2", "3", "4", "5", "6"),
                         to = c("Walking", "WalkingUpStairs", "WalkingDownStairs", "Sitting", "Standing", "Lying"))

# 4) appropriately label the data set with descriptive variable names
# (See codebook.md for an explanation of the variable names.)
names(sub_data) <- str_replace_all(names(sub_data), "[.][.]", "")
names(sub_data) <- str_replace_all(names(sub_data), "BodyBody", "Body")
names(sub_data) <- str_replace_all(names(sub_data), "tBody", "Body")
names(sub_data) <- str_replace_all(names(sub_data), "fBody", "FFTBody")
names(sub_data) <- str_replace_all(names(sub_data), "tGravity", "Gravity")
names(sub_data) <- str_replace_all(names(sub_data), "fGravity", "FFTGravity")
names(sub_data) <- str_replace_all(names(sub_data), "Acc", "Acceleration")
names(sub_data) <- str_replace_all(names(sub_data), "Gyro", "AngularVelocity")
names(sub_data) <- str_replace_all(names(sub_data), "Mag", "Magnitude")
for(i in 3:68) {if (str_detect(names(sub_data)[i], "[.]std"))
                {names(sub_data)[i] <- paste0("StandardDeviation", str_replace(names(sub_data)[i], "[.]std", ""))}}
for(i in 3:68) {if (str_detect(names(sub_data)[i], "[.]mean"))
                {names(sub_data)[i] <- paste0("Mean", str_replace(names(sub_data)[i], "[.]mean", ""))}}
names(sub_data) <- str_replace_all(names(sub_data), "[.]X", "XAxis")
names(sub_data) <- str_replace_all(names(sub_data), "[.]Y", "YAxis")
names(sub_data) <- str_replace_all(names(sub_data), "[.]Z", "ZAxis")

# 5) from the data set in step 4, create a second, independent tidy data set
#    with the average of each variable for each activity and each subject.
# Use a split/apply/combine method. First, split the data by the subject and activity factors.
split_set <- split(select(sub_data, 3:68), list(sub_data$subjects, sub_data$V1))
# Next, use lapply to iterate over each item in the resulting list, and use apply to calculate the mean of each column.
mean_set <- lapply(split_set, function(x) apply(x, 2, mean, na.rm=TRUE))
# The output from lapply is a list. Convert this back to a data frame.
tidy_set <- data.frame(t(sapply(mean_set,c)))
# The subject and activity factors are still combined, and are now row names instead of columns. Split them
# using strsplit, then add them to a separate data frame that can be combined with the tidy data set using cbind.
factors <- data.frame(t(sapply(strsplit(rownames(tidy_set), "[.]"),c)))
tidy_set <- cbind(factors, tidy_set)
# Give the subject and activity columns friendly names, and convert them to factors.
tidy_set <- dplyr::rename(tidy_set,TestSubject = X1, Activity = X2)
tidy_set$TestSubject <- as.factor(tidy_set$TestSubject)
tidy_set$Activity <- as.factor(tidy_set$Activity)
rownames(tidy_set) <- NULL

# DATA VERIFICATION - "manually" generate a couple test variables to verify that the calculated average values are correct.
# pull all of the data for subject = 1, activity = walking, variable = tBodyAcc.mean...X
test_set <- select(filter(sub_data, V1=="Walking" & subjects==1), MeanBodyAccelerationXAxis)
# calculate the mean, and compare it to the same calculation from the result set.
tidy_set_val <- select(filter(tidy_set, TestSubject==1 & Activity=="Walking"), MeanBodyAccelerationXAxis)$MeanBodyAccelerationXAxis
result <- all.equal(mean(test_set$MeanBodyAccelerationXAxis), tidy_set_val)
print("Data calculation verification--TRUE indicates the verification passed:")
print(result)

# second verification, with data from the middle of the matrix
test_set <- select(filter(sub_data, V1=="Sitting" & subjects==5), StandardDeviationFFTBodyAccelerationXAxis)
tidy_set_val <- select(filter(tidy_set, TestSubject==5 & Activity=="Sitting"), StandardDeviationFFTBodyAccelerationXAxis)$StandardDeviationFFTBodyAccelerationXAxis
result <- all.equal(mean(test_set$StandardDeviationFFTBodyAccelerationXAxis), tidy_set_val)
print(result)

# write the tidy data set to a file for project submission
write.table(tidy_set, "tidy_data_set.txt", row.names=FALSE)

# Environment clean up - tidy up the global environment by removing temporary variables to save memory
rm(combined_data)
rm(combined_subjects)
rm(combined_y)
rm(factors)
rm(features)
rm(sub_data)
rm(test_subjects)
rm(test_x)
rm(test_y)
rm(train_subjects)
rm(train_x)
rm(train_y)
rm(listOfNames)
rm(mean_set)
rm(split_set)


# 4. faza: Analiza podatkov

#osnovni grafi
graf1 <- ggplot(vse_nocitve, aes(x=leto)) + geom_point(aes(y=stevilo_slo, colour="Slovenija")) +  geom_line(aes(y=stevilo_slo, colour="Slovenija")) +
  geom_point(aes(y=stevilo_hrv, colour="Hrvaška")) + geom_line(aes(y=stevilo_hrv, colour="Hrvaška")) +
  scale_colour_manual("", values = c("Slovenija" = "blue", "Hrvaška" = "red")) + ylab('število nocitev') + ggtitle('Vse nočitve') +
  scale_y_continuous(labels=comma_format(big.mark=""))

graf2 <- ggplot(vsa_potovanja, aes(x=leto)) + geom_point(aes(y=stevilo_slo, colour="Slovenija")) + geom_line(aes(y=stevilo_slo, colour="Slovenija")) +
  geom_point(aes(y=stevilo_hrv, colour="Hrvaška")) + geom_line(aes(y=stevilo_hrv, colour="Hrvaška")) +
  scale_colour_manual("", values = c("Slovenija" = "blue", "Hrvaška" = "red")) + ylab('število potovanj') + ggtitle('Vsa potovanja') +
  scale_y_continuous(labels=comma_format(big.mark=""))

graf3 <- ggplot(vse_nocitve_na_povrsino, aes(x=leto)) + geom_point(aes(y=stevilo_slo, colour="Slovenija")) + geom_line(aes(y=stevilo_slo, colour="Slovenija")) +
  geom_point(aes(y=stevilo_hrv, colour="Hrvaška")) + geom_line(aes(y=stevilo_hrv, colour="Hrvaška")) +
  scale_colour_manual("", values = c("Slovenija" = "blue", "Hrvaška" = "red")) + ylab('število nočitev na km^2') + ggtitle('Vse nočitve na površino')

graf4 <- ggplot(vsa_potovanja_na_prebivalce, aes(x=leto)) + geom_point(aes(y=stevilo_slo, colour="Slovenija")) + geom_line(aes(y=stevilo_slo, colour="Slovenija")) +
  geom_point(aes(y=stevilo_hrv, colour="Hrvaška")) + geom_line(aes(y=stevilo_hrv, colour="Hrvaška")) +
  scale_colour_manual("", values = c("Slovenija" = "blue", "Hrvaška" = "red")) + ylab('število potovanj na prebivalca') + ggtitle('Vsa potovanja na prebivalstvo')

#podrobnejši grafi
graf5 <- ggplot(slo_nocitve, aes(x=leto)) + aes(y=vrednost, color=izvor_turistov, shape=prebivalisce) + geom_point() + geom_line() +
  ggtitle('Sestava turistov v Sloveniji') + ylab('število turistov') + theme(legend.position="bottom", legend.box = "vertical") +
  scale_y_continuous(labels=comma_format(big.mark=""))

graf5a <- ggplot(slo_nocitve_brez, aes(x=leto)) + aes(y=vrednost, color=izvor_turistov, shape=prebivalisce) + geom_point() + geom_line() +
  ggtitle('Sestava turistov v Sloveniji (brez vseh držav in brez Evrope)') + ylab('število turistov') + theme(legend.position="bottom", legend.box = "vertical") +
  scale_y_continuous(labels=comma_format(big.mark=""))

graf6 <- ggplot(hrv_nocitve, aes(x=leto)) + aes(y=vrednost, color=izvor_turistov, shape=prebivalisce) + geom_point() + geom_line() +
  ggtitle('Sestava turistov na Hrvaškem') + ylab('število turistov') + theme(legend.position="bottom", legend.box = "vertical") +
  scale_y_continuous(labels=comma_format(big.mark=""))

graf6a <- ggplot(hrv_nocitve_brez, aes(x=leto)) + aes(y=vrednost, color=izvor_turistov, shape=prebivalisce) + geom_point() + geom_line() +
  ggtitle('Sestava turistov na Hrvaškem (brez vseh držav in brez Evrope)') + ylab('število turistov') + theme(legend.position="bottom", legend.box = "vertical") +
  scale_y_continuous(labels=comma_format(big.mark=""))

graf7 <- ggplot(slo_potovanja_vse_drzave, aes(x=leto)) + aes(y=vrednost, color=dolzina, shape=namen) + geom_point() + geom_line() +
  ggtitle('Dolžina in namen potovanja Slovencev') + ylab('število turistov') + theme(legend.position="bottom", legend.box = "vertical") +
  scale_y_continuous(labels=comma_format(big.mark=""))

graf8 <- ggplot(hrv_potovanja_vse_drzave, aes(x=leto)) + aes(y=vrednost, color=dolzina, shape=namen) + geom_point() + geom_line() +
  ggtitle('Dolžina in namen potovanja Hrvatov') + ylab('število turistov') + theme(legend.position="bottom", legend.box = "vertical") +
  scale_y_continuous(labels=comma_format(big.mark=""))

#napredna analiza in grafi napovedi
vse_slo_nocitve_pr <- vse_slo_nocitve %>% filter(leto != "2018")
lin <- lm(data=vse_slo_nocitve_pr, stevilo ~ leto)
pr <- predict(lin, data.frame(leto=seq.int(2018, 2025, 1)))
vse_slo_nocitve1 <- vse_slo_nocitve_pr
vse_slo_nocitve1 <- data.frame(leto = c(2018, 2019, 2020, 2021, 2022, 2023, 2024, 2025), stevilo = c(pr[1], pr[2], pr[3], pr[4], pr[5], pr[6], pr[7], pr[8]))
vse_slo_nocitve_pr$vrsta <- "podatki"
vse_slo_nocitve1$vrsta <- "napoved"
vse_slo_nocitve_pr <- rbind(vse_slo_nocitve_pr, vse_slo_nocitve1)

vse_hrv_nocitve_pr <- vse_hrv_nocitve
lin1 <- lm(data=vse_hrv_nocitve_pr, stevilo ~ leto)
pr1 <- predict(lin1, data.frame(leto=seq.int(2019, 2025, 1)))
vse_hrv_nocitve1 <- vse_hrv_nocitve_pr
vse_hrv_nocitve1 <- data.frame(leto = c(2019, 2020, 2021, 2022, 2023, 2024, 2025), stevilo = c(pr1[1], pr1[2], pr1[3], pr1[4], pr1[5], pr1[6], pr1[7]))
vse_hrv_nocitve_pr$vrsta <- "podatki"
vse_hrv_nocitve1$vrsta <- "napoved"
vse_hrv_nocitve_pr <- rbind(vse_hrv_nocitve_pr, vse_hrv_nocitve1)

vse_nocitve_pr <- vse_slo_nocitve_pr
names(vse_nocitve_pr)[2] <- 'stevilo_slo'
vse_nocitve_pr['stevilo_hrv'] <- NA
vse_nocitve_pr$stevilo_hrv <- vse_hrv_nocitve_pr$stevilo

graf9 <- ggplot(vse_nocitve_pr, aes(x=leto)) + geom_point(aes(y=stevilo_slo, colour="Slovenija", shape=vrsta)) + geom_line(aes(y=stevilo_slo, colour="Slovenija")) +
  geom_point(aes(y=stevilo_hrv, colour="Hrvaška", shape=vrsta)) + geom_line(aes(y=stevilo_hrv, colour="Hrvaška")) +
  scale_colour_manual("", values = c("Slovenija" = "blue", "Hrvaška" = "red")) + ylab('predvideno število nocitev v prihodnosti') +
  ggtitle('Napoved vseh nočitev za prihodnost') + scale_x_continuous(breaks = 1*2010:2025) + scale_y_continuous(labels=comma_format(big.mark="")) +
  geom_smooth(method="lm", aes(y=stevilo_slo, colour="Slovenija")) + geom_smooth(method="lm", aes(y=stevilo_hrv, colour="Hrvaška"))

vsa_slo_potovanja_pr <- vsa_slo_potovanja
lin2 <- lm(data=vsa_slo_potovanja_pr, stevilo ~ leto)
pr2 <- predict(lin2, data.frame(leto=seq.int(2019, 2025, 1)))
vsa_slo_potovanja1 <- vsa_slo_potovanja_pr
vsa_slo_potovanja1 <- data.frame(leto = c(2019, 2020, 2021, 2022, 2023, 2024, 2025), stevilo = c(pr2[1], pr2[2], pr2[3], pr2[4], pr2[5], pr2[6], pr2[7]))
vsa_slo_potovanja_pr$vrsta <- "podatki"
vsa_slo_potovanja1$vrsta <- "napoved"
vsa_slo_potovanja_pr <- rbind(vsa_slo_potovanja_pr, vsa_slo_potovanja1)

vsa_hrv_potovanja_pr <- vsa_hrv_potovanja
lin3 <- lm(data=vsa_hrv_potovanja_pr, stevilo ~ leto)
pr3 <- predict(lin3, data.frame(leto=seq.int(2019, 2025, 1)))
vsa_hrv_potovanja1 <- vsa_hrv_potovanja_pr
vsa_hrv_potovanja1 <- data.frame(leto = c(2019, 2020, 2021, 2022, 2023, 2024, 2025), stevilo = c(pr3[1], pr3[2], pr3[3], pr3[4], pr3[5], pr3[6], pr3[7]))
vsa_hrv_potovanja_pr$vrsta <- "podatki"
vsa_hrv_potovanja1$vrsta <- "napoved"
vsa_hrv_potovanja_pr <- rbind(vsa_hrv_potovanja_pr, vsa_hrv_potovanja1)

vsa_potovanja_pr <- vsa_slo_potovanja_pr
names(vsa_potovanja_pr)[2] <- 'stevilo_slo'
vsa_potovanja_pr['stevilo_hrv'] <- NA
vsa_potovanja_pr$stevilo_hrv <- vsa_hrv_potovanja_pr$stevilo

graf10 <- ggplot(vsa_potovanja_pr, aes(x=leto)) + geom_point(aes(y=stevilo_slo, colour="Slovenija", shape=vrsta)) +  geom_line(aes(y=stevilo_slo, colour="Slovenija")) +
  geom_point(aes(y=stevilo_hrv, colour="Hrvaška", shape=vrsta)) + geom_line(aes(y=stevilo_hrv, colour="Hrvaška")) +
  scale_colour_manual("", values = c("Slovenija" = "blue", "Hrvaška" = "red")) + ylab('predvideno število potovanj v prihodnosti') +
  ggtitle('Napoved vseh potovanj za prihodnost') + scale_x_continuous(breaks = 1*2010:2025) + scale_y_continuous(labels=comma_format(big.mark="")) +
  geom_smooth(method="lm", aes(y=stevilo_slo, colour="Slovenija")) + geom_smooth(method="lm", aes(y=stevilo_hrv, colour="Hrvaška"))


setwd('./Documents/Comp Music/Cantometrics/ISMIR 2020/')

pairwise_partial_1 <- read.csv("./partial-distances/pairwise_partial_1.csv", header=FALSE)
pairwise_partial_2 <- read.csv("./partial-distances/pairwise_partial_2.csv", header=FALSE)
pairwise_partial_3 <- read.csv("./partial-distances/pairwise_partial_3.csv", header=FALSE)
pairwise_partial_4 <- read.csv("./partial-distances/pairwise_partial_4.csv", header=FALSE)
pairwise_partial_5 <- read.csv("./partial-distances/pairwise_partial_5.csv", header=FALSE)
pairwise_partial_6 <- read.csv("./partial-distances/pairwise_partial_6.csv", header=FALSE)

categories <- read.csv("Interpretations/categories.csv", header = FALSE)

group_main <- categories[,1]
instrumental_main <- categories[,2]

library(ggplot2)

mds<-cmdscale(pairwise_partial_1, eig=TRUE, k=2)
x <- mds$points[,1]
y <- mds$points[,2]
df<- as.data.frame(mds$points)
instrumental <- instrumental_main[0:5]
group <- group_main[0:5]
labels <- c("1","2","3","4","5")
p <- ggplot(df, aes(x=x, y=y, group=group, label=labels))
p + geom_point(aes(color=group, shape=instrumental, size=3))+ guides(size=FALSE)+ labs(title="Group 1", x="Component 1", y="Component 2", shape="Style", color="Group vs. Solo")+ geom_text(hjust=-1, vjust=1)
ggsave('./figs/mds/group-1.png', width=5.5, height=4.5)

labels <- c("6","7","8","9","10")
instrumental <- instrumental_main[6:10]
group <- group_main[6:10]
mds<-cmdscale(pairwise_partial_2, eig=TRUE, k=2)
x <- mds$points[,1]
y <- mds$points[,2]
df<- as.data.frame(mds$points)
p <- ggplot(df, aes(x=x, y=y, group=group, label=labels))
p+ geom_point(aes(color=group, shape=instrumental, size=3))+guides(size=FALSE) + labs(title="Group 2", x="Component 1", y="Component 2", shape="Style", color="Group vs. Solo")+geom_text(hjust=-1, vjust=1)
ggsave('./figs/mds/group-2.png', width=5.5, height=4.5)

labels <- c("11","12","13","14","15")
instrumental <- instrumental_main[11:15]
group <- group_main[11:15]
mds<-cmdscale(pairwise_partial_3, eig=TRUE, k=2)
df<- as.data.frame(mds$points)
x <- mds$points[,1]
y <- mds$points[,2]
p <- ggplot(df, aes(x=x, y=y, group=group, label=labels))
p+ geom_point(aes(color=group, shape=instrumental, size=3))+guides(size=FALSE) + labs(title="Group 3", x="Component 1", y="Component 2",  shape="Style", color="Group vs. Solo")+geom_text(hjust=1, vjust=1)
ggsave('./figs/mds/group-3.png', width=5.5, height=4.5)

labels <- c("16","17","18","19","20")
instrumental <- instrumental_main[16:20]
group <- group_main[16:20]
mds<-cmdscale(pairwise_partial_4, eig=TRUE, k=2)
df<- as.data.frame(mds$points)
x <- mds$points[,1]
y <- mds$points[,2]
p <- ggplot(df, aes(x=x, y=y, group=group, label=labels))
p+ geom_point(aes(color=group, shape=instrumental, size=3))+guides(size=FALSE) + labs(title="Group 4", x="Component 1", y="Component 2", shape="Style", color="Group vs. Solo")+geom_text(hjust=1, vjust=1)
ggsave('./figs/mds/group-4.png', width=5.5, height=4.5)

labels <- c("21","22","23","24","25")
instrumental <- instrumental_main[21:25]
group <- group_main[21:25]
mds<-cmdscale(pairwise_partial_5, eig=TRUE, k=2)
df<- as.data.frame(mds$points)
x <- mds$points[,1]
y <- mds$points[,2]
p <- ggplot(df, aes(x=x, y=y, group=group, label=labels))
p+ geom_point(aes(color=group, shape=instrumental, size=3))+guides(size=FALSE) + labs(title="Group 5", x="Component 1", y="Component 2", shape="Style", color="Group vs. Solo")+geom_text(hjust=1, vjust=1)
ggsave('./figs/mds/group-5.png', width=5.5, height=4.5)

labels <- c("26","27","28","29","30")
instrumental <- instrumental_main[26:30]
group <- group_main[26:30]
mds<-cmdscale(pairwise_partial_6, eig=TRUE, k=2)
df<- as.data.frame(mds$points)
x <- mds$points[,1]
y <- mds$points[,2]
p <- ggplot(df, aes(x=x, y=y, group=group, label=labels))
p+ geom_point(aes(color=group, shape=instrumental, size=3))+guides(size=FALSE) + labs(title="Group 6", x="Component 1", y="Component 2", shape="Style", color="Group vs. Solo")+geom_text(hjust=1, vjust=1)
ggsave('./figs/mds/group-6.png', width=5.5, height=4.5)


require(MASS)
require(lme4)
require(lmerTest)
require(ordinal)
require(nlme)

# Experiment 1, before seeing veracity prediction.
data = read.csv('exp1.csv')
data$HE = ordered(data$Human.Error)

m1 <- clmm(data = data, HE ~ 1 + Model.Correct + Model.Wrong + (1|Claim) +(1|participant))
summary(m1)

# Experiment 1, after seeing veracity prediction.

data1p = read.csv('exp1p.csv')
data1p$HE = ordered(data1p$Human.Error)
m1p <- clmm(data = data1p, HE ~ 1 + Model.Correct + Model.Wrong + (1|Claim) +(1|participant))
summary(m1p)

# Experiment 2.
data2 = read.csv('exp2.csv')
m2 <- lmer(data = data2, Points ~ 1 + Condition + (1|Claim) +(1|participant))
summary(m2)

# Experiment 3.
data3 = read.csv('exp3.csv')
m3 <- lmer(data = data3, Points ~ 1 + Condition + (1|Claim) +(1|participant))
summary(m3)

# Experiment 2 with outliers removed.
data2o <- read.csv('exp2_removed_outliers.csv')
m2o <- lmer(data = data2o, Points ~ 1 + Condition + (1|Claim) +(1|participant))
summary(m2o)


library(dplyr, warn.conflicts = FALSE)
library(utils)

# Setup is run once
setup <- function(data, spec){
  cat(paste("\nSETUP\n", names(data), "\n\n"), file=stderr())
}

# Helper functions used by annotations
eval_negative_gap <- function(doc, ndoc){
  rate <- doc/(ndoc+doc)
  return(dplyr::last(rate) < 0.9)
}

eval_positive_gap <- function(doc, ndoc){
  rate <- doc/(ndoc+doc)
  return(dplyr::last(rate) >= 0.9)
}

eval_positive_trend <- function(doc, ndoc){
  raw_rate <- doc/(ndoc+doc)
  rate <- ifelse(is.nan(raw_rate), 0, raw_rate)

  tail_sorted <- !is.unsorted(utils::tail(rate,3), strictly=T)
  is_tail_ascending <- !is.na(tail_sorted) && tail_sorted
  return(is_tail_ascending)
}

eval_negative_trend <- function(doc, ndoc){
  raw_rate <- doc/(ndoc+doc)
  rate <- ifelse(is.nan(raw_rate), 0, raw_rate)

  tail_rev_sorted <- !is.unsorted(rev(utils::tail(rate,3)), strictly=T)
  is_tail_descending <- !is.na(tail_rev_sorted) && tail_rev_sorted
  return(is_tail_descending)
}

# Annotation functions
annotate_negative_gap <- function(data, spek){
  data %>% group_by(id) %>%
    dplyr::filter(report_month == max(report_month)) %>%
    summarize(negative_gap = eval_negative_gap(documented, not_documented))
}

annotate_positive_gap <- function(data, spek){
  data %>% group_by(id) %>%
    dplyr::filter(report_month == max(report_month)) %>%
    summarize(positive_gap = eval_positive_gap(documented, not_documented))
}

annotate_positive_trend <- function(data, spek){
  data %>%
    group_by(id) %>%
    arrange(report_month) %>%
    summarize(positive_trend = eval_positive_trend(documented, not_documented))
}

annotate_negative_trend <- function(data, spek){
  data %>%
    group_by(id) %>%
    arrange(report_month) %>%
    summarize(negative_trend = eval_negative_trend(documented, not_documented))
}


#' @title UK oil investments between 1969 and 1992
#' @description Dataset on oil investment
#' @format A data frame with 53 rows and 12 variables:
#' \describe{
#'   \item{\code{dur}}{duration of the appraisal lag in months (time span between discovery of an oil field and beginning of development, i.e. approval of annex}
#'   \item{\code{size}}{size of recoverable reserves in millions of barrels}
#'   \item{\code{waterd}}{depth of the sea in metres}
#'   \item{\code{gasres}}{size of recoverable gas reserves in billions of cubic feet}
#'   \item{\code{operator}}{equity market value (in 1991 million pounds) of the company operating the oil field}
#'   \item{\code{p}}{real after–tax oil price measured at time of annex B approval}
#'   \item{\code{vardp}}{volatility of the real oil price process measured as the squared recursive standard errors of the regression of pt-pt-1 on a constant}
#'   \item{\code{p97}}{adaptive expectations (with parameter theta=0.97) for the real after–tax oil prices formed at the time of annex B approval}
#'   \item{\code{varp97}}{volatility of the adaptive expectations (with parameter theta=0.97) for real after tax oil prices measured as the squared recursive standard errors of the regression of pt on pte(theta)}
#'   \item{\code{p98}}{adaptive expectations (with parameter theta=0.98) for the real after–tax oil prices formed at the time of annex B approval}
#'   \item{\code{varp98}}{volatility of the adaptive expectations (with parameter theta=0.98) for real after tax oil prices measured as the squared recursive standard errors of the regression of pt on pte(theta)}
#'}
#' @docType data
#' @keywords datasets
#' @name oil
#' @usage oil
#' @details Data for oil investments between the period 1969 to 1992 in the United Kingdom.
#' @source Datasets from \href{https://vincentarelbundock.github.io/Rdatasets/datasets.html}{vincentarelbundock} on github.
#' @examples
#' summary(oil)
NULL


#!/usr/bin/Rscript

library(methods)
library(grDevices)
library(reshape2)
library(stats)
library(ggplot2)
library(plyr)
library(scales)
library(data.table)
library(gridExtra)
require(grid)
library(lattice)

hp <- read.csv('./data_random/GEE/hanaupah.csv')

d <- data.table(hp)

HPT_ref <- data.frame(Label=d$label, Surface=d$surface, B1=d$B1_BCET, B2=d$B2_BCET, B3=d$B3_BCET, B4=d$B4_BCET, B5=d$B5_BCET, B6=d$B6_BCET, B7=d$B7_BCET)

colours <- c('dodgerblue3', 'red3')

mean_surface <- aggregate(HPT_ref[,3:9], list(HPT_ref$Surface), mean)
min_surface <- aggregate(HPT_ref[,3:9], list(HPT_ref$Surface), min)
max_surface <- aggregate(HPT_ref[,3:9], list(HPT_ref$Surface), max)

HPT2 <- melt(HPT_ref,id=c("Label", "Surface"), variable.name = "Band")
HPT_mean <- melt(mean_surface,id=c("Group.1"), variable.name = "Band")
HPT_max <- melt(max_surface,id=c("Group.1"), variable.name = "Band")
HPT_min <- melt(min_surface,id=c("Group.1"), variable.name = "Band")

HPT_min_max <- merge(HPT_min, HPT_max, by=c("Band", "Group.1"))
HPT_all <- merge(HPT_min_max, HPT_mean, by=c("Band", "Group.1"))
colnames(HPT_all) <- c("Band", "Surface", "Min", "Max", "Mean")

HPT_all <- merge(HPT_all, HPT2, by=c("Band", "Surface"))

print(HPT_all)

p <- ggplot(HPT_all, aes_string(x='Band',y='Mean', ymax="Max", ymin="Min", group="Surface",colour="Surface")) +
	geom_ribbon(alpha=0.3,aes(fill=Surface),colour=NA,data=HPT_all) +
	geom_line(aes(size=.4)) +
	scale_colour_manual(values=colours)+
geom_point(aes_string(x="Band",y="value",group="Label",colour="Surface"),alpha=0.5)+
	geom_point(aes_string(x="Band",y="value",group="Label",colour="Surface"),alpha=0.5)+
	labs(title='Hanaupah Canyon Relative Surface Brightness', x=expression('Band'), y=expression('DN'['BCET']~'(GEE)')) +
	scale_fill_manual(values=c("blue", "red"), name="fill") +
	theme_bw()

ggsave('./plots/hanaupah.pdf', width = 7, height = 5, dpi = 220)


library( pxweb )
library( dplyr )
library( tidyr )

### StatFin >> Työmarkkinat >> Työvoimatutkimus >> 004 -- Palkansaajat ja yrittäjät, 15-74-vuotiaat
### http://pxnet2.stat.fi/PXWeb/pxweb/fi/StatFin/StatFin__tym__tyti/statfin_tyti_pxt_004.px/?rxid=34171367-a303-4674-b19b-5c7ea280cb59
###########################################################

employers_employees <-
    get_pxweb_data( url  = "http://pxnet2.stat.fi/PXWeb/api/v1/fi/StatFin/tym/tyti/statfin_tyti_pxt_004.px",
                    dims = list( Ajanjakso = c( '**' ),
                                 Sukupuoli = c( 'S' ),
                                 Tiedot    = c( 'Tyolliset',
                                                'Palkansaaja',
                                                'Yrittaja_pl_mmt',
                                                'Tyonantajayrittaja_pl_mmt',
                                                'Yksinyrittaja_pl_mmt' ),
                                 Vuosi     = c( '*' ) ),
                    clean = TRUE ) # "Clean and melt the data to R format."

# Drop unnecessary columns
ee <- employers_employees[-(1:2)]

# Remove ", 1000 henkeä" from 'Tiedot'
ee$Tiedot <- gsub( ', 1000 henkeä', '', ee$Tiedot )
# Replace info within "(...)" with "*"
# https://stackoverflow.com/questions/24173194/remove-parentheses-and-text-within-from-strings-in-r
ee$Tiedot <- gsub( '\\([^\\)]+\\)', '*', ee$Tiedot )

# Spread years to columns
ee <- spread( ee, Vuosi, values )

# Store for later use and write to CSV
ee_table <- ee
write.table( ee_table,
             file = paste0( png_dir, 'employers_employees.csv' ),
             row.names = FALSE,
             sep  = ';' )

# Remove possibly empty (all 'NA') columns
# (especially the current year might not have data)
ee <- Filter( function( x ) !all( is.na( x ) ), ee )

# Year 2000 = 100 (omit first column with the info texts)
ee[-(1)] <- round( ( ee[-(1)] / ee$`2000`[row( ee[-( 1 )] )] ) * 100, digits = 2 )

# Store for later use and write to CSV
ee_table_2000is100 <- ee
write.table( ee_table_2000is100,
             file = paste0( png_dir, 'employers_employees_2000-is-100.csv' ),
             row.names = FALSE,
             sep  = ';' )

# Gather back to long format
ee <- gather( ee, Tiedot, 'Indeksi' )
colnames( ee )[1] <- 'Ryhmat'
colnames( ee )[2] <- 'Vuosi'

# Use only data from 2000 and later
ee <- ee[ee$Vuosi >= 2000, ]

# Change the ordering of the "Tiedot" factor
# https://stackoverflow.com/questions/1296646/how-to-sort-a-dataframe-by-columns
# https://stackoverflow.com/questions/10074483/r-how-to-reorder-legend-key-in-ggplot2-line-plot-to-match-the-final-values-in-e
lastvalues = ee[ee$Vuosi == max( ee$Vuosi ), ]
lastvalues = lastvalues[with( lastvalues, order( -Indeksi, Ryhmat ) ), ]
ee$Ryhmät <- factor( ee$Ryhmat,
                     levels = lastvalues$Ryhmat,
                     ordered = TRUE )


stem <- c("甲", "乙", "丙", "丁", "戊", "己", "庚", "辛", "壬", "癸")
branch <- c("子", "丑", "寅", "卯", "辰", "巳", "午", "未", "申", "酉", "戌", "亥")
stembranch <- function(year) {
  return(paste0(stem[(year-3)%%10], branch[(year-3)%%12]))
}


context("Quantile binning")

test_that("Test computing breaks on one variable", {
        dat <- data.frame(x=-100:100, y=rep(1, 201))
        obj <- binR(y~x, dat, algorithm="quantile")
        expect_equal(obj$breaks$x, c(-Inf,-50,0,50,Inf))
})

test_that("Test computing breaks on one variable all pos", {
        dat <- data.frame(x=0:100, y=rep(1, 101))
        obj <- binR(y~x, dat, algorithm="quantile")
        expect_equal(obj$breaks$x, c(0,25,50,75,Inf))
})

test_that("Test computing breaks on one variable all neg", {
        dat <- data.frame(x=-100:0, y=rep(1, 101))
        obj <- binR(y~x, dat, algorithm="quantile")
        expect_equal(obj$breaks$x, c(-Inf,-75,-50,-25,0))
})

test_that("Test computing nonstandard breaks on one variable", {
        dat <- data.frame(x=0:100, y=rep(1, 101))
        obj <- binR(y~x, dat, algorithm="quantile", probs=c(0.1, 0.5, 0.9, 1))
        expect_equal(obj$breaks$x, c(0,50,90,Inf))
})


#!/usr/bin/env Rscript

options(stringAsfactors = FALSE, useFancyQuotes = FALSE)
# This script is used to map MS2 information to CAMERA features
# Taking the command line arguments
args <- commandArgs(trailingOnly = TRUE)

if(length(args)==0)stop("No parameters are given!\n")
rDataFilesMS2<-NA
inputCamera<-NA
output<-NA
ppm<-10
rt<-10
for(arg in args)
{
  argCase<-strsplit(x = arg,split = "=")[[1]][1]
  value<-strsplit(x = arg,split = "=")[[1]][2]

  if(argCase=="inputMS2")
  {
    input=as.character(value)
    if(file.info(input)$isdir & !is.na(file.info(input)$isdir))
    {
      rDataFilesMS2<-list.files(input,full.names = T)

    }else
    {

      rDataFilesMS2<-sapply(strsplit(x = input,split = "\\;|,| |\\||\\t"),function(x){x})

    }
  }
  if(argCase=="inputCAMERA")
  {

    inputCamera=as.character(value)

  }
  if(argCase=="ppm")
  {

    ppm=as.numeric(value)

  }
  if(argCase=="rt")
  {

    rt=as.numeric(value)

  }

  if(argCase=="output")
  {
    output=as.character(value)
  }
}

if(is.na(rDataFilesMS2) | is.na(inputCamera) | is.na(output)) stop("Both input (CAMERA and MS2 ) and output need to be specified!\n")

require(intervals)
ppmCal<-function(run,ppm)
{
  return((run*ppm)/1000000)
}
IntervalMerge<-function(cameraObject,MSMSdata, PlusTime,MinusTime,ppm,listOfMS2Mapped=list(),listOfUnMapped=list()){

  listofPrecursorsmz<-c()
  for(i in seq(1,length(MSMSdata)))
  {
    listofPrecursorsmz<-c(listofPrecursorsmz,MSMSdata[[i]]@precursorMz)
  }

  listofPrecursorsrt<-c()
  for(i in seq(1,length(MSMSdata)))
  {
    listofPrecursorsrt<-c(listofPrecursorsrt,MSMSdata[[i]]@rt)
  }

  CameramzColumnIndex<-which(colnames(cameraObject@groupInfo)=="mz")

  MassRun1<-Intervals_full(cbind(listofPrecursorsmz,listofPrecursorsmz))

  MassRun2<-Intervals_full(cbind(cameraObject@groupInfo[,CameramzColumnIndex]-
                                   ppmCal(cameraObject@groupInfo[,CameramzColumnIndex],ppm),
                                 cameraObject@groupInfo[,CameramzColumnIndex]+
                                   ppmCal(cameraObject@groupInfo[,CameramzColumnIndex],ppm)))

  Mass_iii <- interval_overlap(MassRun1,MassRun2)

  CamerartLowColumnIndex<-which(colnames(cameraObject@groupInfo)=="rtmin")
  CamerartHighColumnIndex<-which(colnames(cameraObject@groupInfo)=="rtmax")

  TimeRun1<-Intervals_full(cbind(listofPrecursorsrt,listofPrecursorsrt))

  TimeRun2<-Intervals_full(cbind(cameraObject@groupInfo[,CamerartLowColumnIndex]-MinusTime,
                                 cameraObject@groupInfo[,CamerartHighColumnIndex]+PlusTime))
  Time_ii <- interval_overlap(TimeRun1,TimeRun2)

  imatch = mapply(intersect,Time_ii,Mass_iii)

  for (i in 1:length(imatch)) {
    for(j in imatch[[i]])
    {
      MSMStmpObject<-MSMSdata[[i]]
      attributes(MSMStmpObject)$fileName<-attributes(MSMSdata)$fileName
      listOfMS2Mapped[[as.character(j)]]<-
        c(listOfMS2Mapped[[as.character(j)]],MSMStmpObject)
    }
  }
  for (i in 1:length(imatch)) {

    if(length(imatch[[i]])==0)
    {
      MSMStmpObject<-MSMSdata[[i]]
      attributes(MSMStmpObject)$fileName<-attributes(MSMSdata)$fileName
      listOfUnMapped<-c(listOfUnMapped,MSMStmpObject)
    }
  }
  return(list(mapped=listOfMS2Mapped,unmapped=listOfUnMapped))
}

load(file = inputCamera)

CameraObject<-get(varNameForNextStep)
preprocessingStepsTMP<-preprocessingSteps
mappingResult<-list(mapped=list(),unmapped=list())
for(MS2 in rDataFilesMS2)
{
  load(file = MS2)
  MSMSdata<-get(varNameForNextStep)
  mappingResult<-IntervalMerge(cameraObject = CameraObject,MSMSdata = MSMSdata,PlusTime = rt,
                     MinusTime = rt,ppm = ppm,listOfMS2Mapped = mappingResult$mapped,
                     listOfUnMapped = mappingResult$unmapped)
}

preprocessingSteps<-preprocessingStepsTMP
preprocessingSteps<-c(preprocessingSteps,"mappedMS2")

varNameForNextStep<-as.character("mappingResult")

save(list = c("mappingResult","preprocessingSteps","varNameForNextStep"),file = output)


BCV_ttest3<-function(data0,rounds=20,slice0=2,maxrank0=30,msep_cut=0.001)
{
          x<-data0
        fff_cc<-c()
        for(kk in 1:rounds)
        {
                cv_result <- bcv::cv.svd.gabriel(x, slice0, slice0, maxrank = maxrank0)
                fff_cc<-rbind(fff_cc,cv_result$msep)
        }
        pp<-c()
        ddd<-apply(fff_cc,2,mean)
          ddd<-ddd/sum(ddd)
        for(kk in 1:(ncol(fff_cc)-1))
        {
                pp_c<-1
                if(mean(fff_cc[,kk],na.rm=T)>mean(fff_cc[,kk+1],na.rm=T))
                {
                                if(ddd[kk]>msep_cut)
                                {
                          pp_c<-t.test(fff_cc[,kk],fff_cc[,kk+1])$p.value
                                }
                }
                pp<-c(pp,pp_c)
        }
         #boxplot(fff_cc)
        return(list(pp,fff_cc))
}

resolution_level0<-c("fibroblast","adipocytes","neuron","endothelial","Bcell","NKcell","CD4Tcell","CD8Tcell" ,"dendritic","monocytes","macrophage","neutrophils")

Step2plus_Celltype_marker_inference<-function(tg_R1_lists,data_CORS_cancer,tg_R1_cut=6,tg_R1_list_stat,cell_type_enrich_cut=0.5,resolution_level=resolution_level0)
{
	#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
	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!")
	tgs<-tg_R1_lists_st
	tg_all_genes<-c()
	for(i in 1:length(tgs))
	{
		tg_all_genes<-c(tg_all_genes,tgs[[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("Compute leave one base out residual rank!")	#time consuming
	BCV_stat_leave1out<-list()
	BCV_p_leave1out<-c()
	for(i in 1:length(tg_R1_lists))
	{
		print(i)
		tg_all_genes0<-c()
		for(j in 1:length(tgs))
		{
			if(j!=i)
			{
				tg_all_genes0<-c(tg_all_genes0,tgs[[j]])
			}
		}
		tg_all_genes0<-unique(tg_all_genes0)
		tg_data_ccc0<-data_CORS_cancer[tg_all_genes0,]
		BCV_stat_c0<-BCV_ttest3(tg_data_ccc0,rounds=100,slice0=4,maxrank0=30,msep_cut=0.0001)
		dim_tt0<-sum(BCV_stat_c0[[1]]<0.01)
		BCV_stat_leave1out[[i]]<-BCV_stat_c0
		BCV_p_leave1out<-c(BCV_p_leave1out,dim_tt0)
	}

	print("Linking graph based cell type selection")	#time consuming
	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)
	data_c<-data_CORS_cancer

	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)
	}

	for(i in 1:ncol(ddd))
	{
     		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)<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(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(i%%100==1) print(i)
	}

	stat_all0<-stat_all/stat_2total

	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(stat_all))
	{
		if(N<=total_dim)
		{
			tg_id_c<-order(-stat_all0)[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<-c(selected_p,tgs[[6]])
				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<-order(-stat_all0)
		for(i in 1:length(ttt))
		{
			if(sum(names(tgs)[ttt[i]]==tg_2badded_cells))
			{
				tg<-names(tgs)[ttt[i]]
				if(ccc[tg]==0)
				{
					add_R1_base_cut[[which(tg_2badded_cells==tg)]]<-tgs[[ttt[i]]]
					add_R1_base_full[[which(tg_2badded_cells==tg)]]<-tg_R1_lists[[ttt[i]]]
					ccc[tg]<-1
				}
			}
		}
	}
	names(add_R1_base_cut)<-tg_2badded_cells
	names(add_R1_base_full)<-tg_2badded_cells

	#############################
	nn<-rep("",length(tg_R1_list_stat))
	for(i in 1:length(tg_R1_list_stat))
	{
		if(max(tg_R1_list_stat[[i]][min(tg_R1_cut,nrow(tg_R1_list_stat[[i]])),resolution_level])>cell_type_enrich_cut)
		{
			ccc<-tg_R1_list_stat[[i]][min(tg_R1_cut,nrow(tg_R1_list_stat[[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(selected_id,tg_d_stat,BCV_p_leave1out,BCV_stat_leave1out,dim_tt,stat_all,stat_2total)
	names(supp_results)<-c("selected_id","tg_d_stat","BCV_p_leave1out","BCV_stat_leave1out","dim_tt","stat_all","stat_2total")

	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_full,selected_R1_base_cut,add_R1_base_cut,add_R1_base_full,cellreso_R1_base_cut,cellreso_R1_base_full,supp_results)
	names(R2_selected_cell_type_markers)<-c("selected_R1_base_full","selected_R1_base_cut","add_R1_base_cut","add_R1_base_full",
				"cellreso_R1_base_cut","cellreso_R1_base_full","supp_results")
	return(R2_selected_cell_type_markers)
}

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

Building_NMF_input_new<-function(tg_data,tg_list,tg_list_add=list(),module_selected)
{
S_indi<-c(rep(1,length(tg_list)),rep(2,length(tg_list_add)),rep(0,length(module_selected[[1]])))
dd<-c(names(tg_list),names(tg_list_add))
nn<-c(paste(dd,1:length(dd),sep="_"),paste("Cancer",1:length(module_selected[[1]]),sep="_"))
names(S_indi)<-nn
Cancer_Base_all<-c()
for(i in 1:length(module_selected[[1]]))
{
	tg_data_c<-tg_data[module_selected[[1]][[i]],]
	cc<-svd(tg_data_c)$v[,1]
	ccc<-cor(cc,t(tg_data_c))
	if(mean(ccc)<0)
      {
		cc<--cc
	}
	Cancer_Base_all<-rbind(Cancer_Base_all,cc)
}
pp_pre<-matrix(0,length(S_indi),ncol(tg_data))
pp_pre[which(S_indi==0),]<-Cancer_Base_all
colnames(pp_pre)<-colnames(tg_data)
rownames(pp_pre)<-nn
tg_all_genes<-c()
for(i in 1:length(tg_list))
{
	tg_all_genes<-c(tg_all_genes,tg_list[[i]])
}
if(length(tg_list_add)>0)
{
	for(i in 1:length(tg_list_add))
	{
		tg_all_genes<-c(tg_all_genes,tg_list_add[[i]])
	}
}
tg_all_genes<-unique(tg_all_genes)
NMF_indi_all<-matrix(0,length(tg_all_genes),length(S_indi))
colnames(NMF_indi_all)<-names(S_indi)
rownames(NMF_indi_all)<-tg_all_genes
N<-0
for(i in 1:length(tg_list))
{
	N<-N+1
	NMF_indi_all[tg_list[[i]],N]<-1
}
if(length(tg_list_add)>0)
{
	for(i in 1:length(tg_list_add))
	{
		N<-N+1
		NMF_indi_all[tg_list_add[[i]],N]<-1
	}
}
NMF_data<-tg_data[rownames(NMF_indi_all),]
NMF_P_pre<-pp_pre
NMF_inputs<-list(NMF_data,NMF_indi_all,NMF_P_pre,S_indi)
names(NMF_inputs)<-c("NMF_data","NMF_indi_all","NMF_P_pre","S_indi")
return(NMF_inputs)
}

###################
Building_NMF_input_no_cancer <- function(tg_data,tg_list,tg_list_add=list()){

S_indi<-c(rep(1,length(tg_list)),rep(2,length(tg_list_add)))

dd<-c(names(tg_list),names(tg_list_add))
nn<-c(paste(dd,1:length(dd),sep="_"))
names(S_indi)<-nn

pp_pre<-matrix(0,length(S_indi),ncol(tg_data))

colnames(pp_pre)<-colnames(tg_data)
rownames(pp_pre)<-nn

tg_all_genes<-c()
for(i in 1:length(tg_list))
{
	tg_all_genes<-c(tg_all_genes,tg_list[[i]])
}
if(length(tg_list_add)>0)
{
	for(i in 1:length(tg_list_add))
	{
		tg_all_genes<-c(tg_all_genes,tg_list_add[[i]])
	}
}
tg_all_genes<-unique(tg_all_genes)
NMF_indi_all<-matrix(0,length(tg_all_genes),length(S_indi))
colnames(NMF_indi_all)<-names(S_indi)
rownames(NMF_indi_all)<-tg_all_genes

N<-0
for(i in 1:length(tg_list))
{
	N<-N+1
	NMF_indi_all[tg_list[[i]],N]<-1
}
if(length(tg_list_add)>0)
{
	for(i in 1:length(tg_list_add))
	{
		N<-N+1
		NMF_indi_all[tg_list_add[[i]],N]<-1
	}
}

NMF_data<-tg_data[rownames(NMF_indi_all),]
NMF_P_pre<-pp_pre

NMF_inputs<-list(NMF_data,NMF_indi_all,NMF_P_pre,S_indi)
names(NMF_inputs)<-c("NMF_data","NMF_indi_all","NMF_P_pre","S_indi")

return(NMF_inputs)

}


library(parallel)
library(caret)
library(MASS)
library(xgboost)

library(OptimalCutpoints)
library(pROC)
library(ROCR)

library(ggplot2)
library(cowplot)
library(gridExtra)
library(viridis)

library(survival)
library(survminer)

setwd("/media/yuri/Data/home1/GNI_data/infection/ModelsSciRep")
load('CAP_sepsis_Ensemble.Rdat')
XGB_model_bst <- xgb.load('CAP_sepsis_Ensemble.model')

dtrain0 <- xgb.DMatrix(data = as.matrix(training0[,-1]), label = as.numeric(training0$Y)-1)
dvalid <- xgb.DMatrix(data = as.matrix(validation[,-1]), label = as.numeric(validation$Y)-1)

# predict discovery and validation cohorts (probs)
Ytrain_prob <- predict(XGB_model_bst, dtrain0, ntree = XGB_model_ntree, outputmargin=TRUE)
Yvalid_prob <- predict(XGB_model_bst, dvalid,  ntree = XGB_model_ntree, outputmargin=TRUE)

################################################################################
# Find optimal cutpoint from the ROC curve maximizing the product of Sensitivity and Specificity
p_cut <- optimal.cutpoints(y~x, status=Ytrain0, tag.healthy = 0, data= data.frame(y=Ytrain_prob, x = as.numeric(Ytrain0) -1),
methods="MaxProdSpSe", ci.fit=TRUE, control = control.cutpoints(ci.SeSp = "AgrestiCoull", ci.PV = "AgrestiCoull") )
cutoff <- p_cut$MaxProdSpSe$Global$optimal.cutoff$cutoff[1]

# predict discovery and validation cohorts (classes)
p_train_class <- factor(as.numeric(ifelse(Ytrain_prob <= cutoff, 0, 1)), levels = c(0,1))
p_valid_class  <- factor(as.numeric(ifelse(Yvalid_prob  <= cutoff, 0, 1)), levels = c(0,1))

# Model summary bACC - balanced accuracy, Sensitivity, Specificity
conf_train <- confusionMatrix(p_train_class, Ytrain0, "1")
conf_valid  <- confusionMatrix(p_valid_class, Yvalid, "1")

conf_table <- data.frame( bACC = c( conf_train$byClass[[11]], conf_valid$byClass[[11]] ),
Sensitivity = c( conf_train$byClass[[1]], conf_valid$byClass[[1]] ),
Specificity = c( conf_train$byClass[[2]], conf_valid$byClass[[2]] )
)
conf_table <- t(conf_table)
colnames(conf_table) <- c("discovery", "validation")
conf_table <- round(conf_table, 3)
################################################################################
# Variable importance

var_imp <- xgb.importance(dimnames(dtrain0)[[2]], model = XGB_model_bst)
var_imp <- var_imp[ order(as.numeric(gsub("x", "", var_imp$Feature))),]
var_imp$Feature <- ids[as.numeric(gsub("x", "", var_imp$Feature))]
var_imp <- var_imp[order(var_imp$Gain, decreasing=F),]
var_imp <- var_imp[-grep("Pr.cl.", var_imp$Feature),]
var_imp <- as.data.frame(var_imp)
rownames(var_imp) <- var_imp[,1]
var_imp <- var_imp[,-1]

################################################################################
# ROC analysis
Train_roc <- roc(Ytrain0, Ytrain_prob)
Train_auc <- lapply(pROC::ci(Ytrain0, Ytrain_prob), function(x) round(x, 3))

Valid_roc <- roc(Yvalid, Yvalid_prob)
Valid_auc <- lapply(pROC::ci(Yvalid, Yvalid_prob), function(x) round(x, 3))

################################################################################
setwd("/media/yuri/Data/home1/GNI_data/infection/ResultsSciRep/Figures/")
pdf("Figure3D.pdf", width=6, height=3.5)

par(mar=c(4,16,1,0.5))
barplot(var_imp[,1], horiz = T, names.arg = rownames(var_imp),
      xlab = "Gain", main = "variable importance",las=1, cex.axis=0.7, cex.names = 0.7)

dev.off()
################################################################################
pdf("Figure3B.pdf", width=6, height=6)

plot(Train_roc, lty = 1, lwd = 2, col=4, type="s")
plot(Valid_roc, add=TRUE, lty = 1, lwd = 2, col=2, type="s")
legend("bottomright", legend =
  c(paste("discovery cohort: AUC = ", Train_auc[[2]], " (", Train_auc[[1]], ", ", Train_auc[[3]], ")", sep=""),
    paste("validation cohort: AUC = ", Valid_auc[[2]], " (", Valid_auc[[1]], ", ", Valid_auc[[3]], ")", sep="")),
lty=1, lwd=2, col=c(2,4), bty="n")

dev.off()
################################################################################
pdf("Figure3A.pdf", width=6, height=6)

par(mfrow=c(1,2))
y.lim = range(c(Ytrain_prob, Yvalid_prob))
boxplot(Ytrain_prob ~ Ytrain0, pch="",
        col="#00000022", border=c("#4591CC", "#21A883"), lty=1, las=1, ylab = "model score (discovery)", xlab = NA, ylim=y.lim)
stripchart(Ytrain_prob ~ Ytrain0, vertical=T, method="jitter", pch=c(15,16), col=c("#4591CCAA", "#21A883AA"), add=T)
abline(h = cutoff, lty=2)

boxplot(Yvalid_prob ~ Yvalid, pch="", col="#00000022", border=c("#4591CC", "#21A883"), lty=1, las=1,
        ylab = "model score (validation)", xlab = NA, ylim=y.lim)
stripchart(Yvalid_prob ~ Yvalid, vertical=T, method="jitter", pch=c(15,16), col=c("#4591CCAA", "#21A883AA"), add=T)
abline(h = cutoff, lty=2)

dev.off()
################################################################################
ggsave(filename="Table2_CAP_sepsis_Ensemble_XGB.pdf", grid.arrange(tableGrob(conf_table)),
        width = 6, height = 4, units = "cm")
################################################################################

pheno_train <- pheno[inTraining,]
pheno_valid <- pheno[-inTraining,]

surv_df_train <- data.frame(time = pheno_train$time, cens = pheno_train$cens, pred_cl = p_train_class, true_cl = Ytrain0)
surv_train <- survfit(Surv(time, cens) ~ pred_cl, data=surv_df_train)

surv_df_valid <- data.frame(time = pheno_valid$time, cens = pheno_valid$cens, pred_cl = p_valid_class, true_cl = Yvalid)
surv_valid <- survfit(Surv(time, cens) ~ pred_cl, data=surv_df_valid)

p1 <- ggsurvplot(surv_train, data = surv_df_train, linetype = "strata", conf.int = TRUE, pval = TRUE, palette= c("#4591CC", "#21A883"))
p2 <- ggsurvplot(surv_valid, data = surv_df_valid, linetype = "strata", conf.int = TRUE, pval = TRUE, palette= c("#4591CC", "#21A883"))

pdf("Figure3C.pdf", paper="a4", width=3.5, height=3.7)
print(p1, newpage=F)
print(p2, newpage=T)
dev.off()


#	tg_R1_cut<-6
#	data.matrix
#	data_CORS_cancer
#	tg_R1_list_stat<-R1_filter_step1_results_new[[3]][[2]]
#	cell_type_enrich_cut=0.45

Step2plus_Celltype_marker_Hierarchical_CTES3<-function(tg_R1_lists,data_CORS_cancer,data.matrix,tg_R1_list_stat,cell_type_enrich_cut=0.45,tg_R1_cut=6,ext_cn=0,CT_balance=1)
{
	tg_selected_R4<-tg_R1_lists
	tg_R1_lists_st0<-tg_R1_lists
	for(i in 1:length(tg_R1_lists))
	{
   	  tg_R1_lists_st0[[i]]<-tg_R1_lists_st0[[i]][1:min(length(tg_R1_lists_st0[[i]]),tg_R1_cut)]
	}
	stat_selected_R4_RR<-compute_IM_stat(tg_list_c=tg_R1_lists_st0)
	stat_selected_R4_RR_max<-apply(stat_selected_R4_RR,1,max)
	names(tg_R1_lists_st0)<-names(stat_selected_R4_RR_max)

	tg_selected_R4<-tg_R1_lists_st0

	tg_genes_all<-c()
	for(i in 1:length(tg_selected_R4))
	{
		tg_genes_all<-c(tg_genes_all,tg_selected_R4[[i]])
	}
	tg_genes_all<-unique(tg_genes_all)
	data.matrix0 <- data.matrix
	data.matrix0_s<-data.matrix0[tg_genes_all,]
	data_23_s<-data_CORS_cancer[tg_genes_all,]

	BCV_stat_c<-BCV_ttest3(data_23_s,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_23_s,tg_selected_R4)
	tg_ES_scores<-diag(NN_ES_table_R4)

	root_leaf<-compute_CompRowspace_NN_selflist(tg_data=data_23_s,tg_data_ng=data.matrix0_s,tg_list=tg_selected_R4,ROUNDS=3)
	names(root_leaf)
	root_leaf[["Leaf_CT"]]
	root_leaf[["Root_CT"]]
	root_leaf[["Other_leat_CT"]]
	tg_possible_base_ids<-sort(root_leaf[["Leaf_CT"]])
	tg_selected_R4_DFB<-select_R_base(tg_selected_R4,tg_possible_base_ids)
	STAT_c<-list()
	for(i in 1:length(tg_possible_base_ids))
	{
		STAT_c[[i]]<-tg_R1_list_stat[[tg_possible_base_ids[i]]]
	}

	R1_selectedCM_step2_results_HCTES<-Step2plus_Celltype_marker_inference_Hclust_CTES(tg_selected_R4_DFB,data_23_s,tg_R1_cut=tg_R1_cut,tg_R1_list_stat=STAT_c,cell_type_enrich_cut=0.5,resolution_level=resolution_level0,hcutn0=40,hclust_cor_cut=0.9,IM_reso_level=IM_reso_level,extra_ctn=0)
	CTES0<-c(R1_selectedCM_step2_results_HCTES[[1]],R1_selectedCM_step2_results_HCTES[[2]])
	#c9_Hclust_CTES<-Compute_Rbase_SVD(data.matrix,CTES0)
	#d9<-cor(t(c9_Hclust_CTES),t(tProp))
	#apply(d9,2,max)
	#c9n_Hclust_CTES<-Compute_Rbase_SVD(data.matrix,tg_selected_R4_DFB)
	#d9n<-cor(t(c9n_Hclust_CTES),t(tProp))
	#apply(d9n,2,max)

	#############################################
	#dim_diff<-dim_tt-length(CTES0)+ext_cn
	#print(paste("old_version, dim_diff:", dim_diff, sep=""))
	dim_diff<-(dim_tt-length(CTES0))*((dim_tt-length(CTES0))>0)+ext_cn
	#dim_diff_new <-  (dim_tt-length(CTES0))*((dim_tt-length(CTES0))>0)+ext_cn
	#print(paste("new_version, dim_diff:", dim_diff_new, sep=""))

	#par(mfcol=c(2,6))
	ROUNDS<-3
	tg_list<-tg_selected_R4
	tg_selected_R4_SS<-CTES0
	Rbase_selected_R4<-Compute_Rbase_SVD(data_23_s,tg_selected_R4_SS)

	Base_c<-Rbase_selected_R4
	aaa<-matrix(0,length(tg_list),ROUNDS)
	bbb<-matrix(0,length(tg_list),ROUNDS)
	ddd<-matrix(0,length(tg_list),ROUNDS)
      for(j in 1:length(tg_list))
      {
                tg_data_c<-data_23_s[tg_list[[j]],]
                ccc<-c()
                ccc<-compute_CompRowspace_NN_uni(tg_data_c,module_RB=Base_c,ROUNDS=3)
               # print(ccc)
                if(length(ccc)>0)
                {
                        tg_id1<-ccc[1,]
                        aaa[j,1:length(tg_id1)]<-tg_id1
                        bbb[j,1:length(tg_id1)]<-ccc[2,]
                        ddd[j,1:length(tg_id1)]<-ccc[3,]
                }
      }
	tg_ids_c<-intersect(order(-bbb[,3]),which(bbb[,3]>0.1))#################
	tg_ids_c<-intersect(tg_ids_c,which(stat_selected_R4_RR_max>cell_type_enrich_cut))#############
	#hist(bbb[tg_ids_c,3])
	aaa<-names(tg_list)[tg_ids_c]
	stat_c<-table(aaa)
	aaa0<-rep(0,length(aaa))
	names(aaa0)<-aaa
	aaa1<-unique(aaa)
	sss_c<-rep(1,length(aaa1))
	names(sss_c)<-aaa1
	sss_b<-1/(table(names(tg_selected_R4_SS))+1)
	sss_c[intersect(names(sss_c),names(sss_b))]<-sss_b[intersect(names(sss_c),names(sss_b))]
	tg_scores_c<-bbb[tg_ids_c,3]
	for(i in 1:length(tg_ids_c))
	{
		tg_scores_c[i]<-tg_scores_c[i]+sss_c[names(tg_list)[tg_ids_c[i]]]
	}
	tg_ids_cs<-tg_ids_c[which(tg_scores_c==max(tg_scores_c))][1]
	#hist(tg_scores_c)
	NN<-0
	node_add<-c()
	while((NN<dim_diff)&(max(bbb[,3]>0.1)))
	{
		NN<-NN+1
		ii<-length(tg_selected_R4_SS)+1
		tg_selected_R4_SS[[ii]]<-tg_list[[tg_ids_cs]]
		names(tg_selected_R4_SS)[ii]<-names(tg_list)[tg_ids_cs]
		Rbase_selected_R4<-Compute_Rbase_SVD(data_23_s,tg_selected_R4_SS)
		node_add<-c(node_add,tg_ids_cs)
		Base_c<-Rbase_selected_R4
		aaa<-matrix(0,length(tg_list),ROUNDS)
		bbb<-matrix(0,length(tg_list),ROUNDS)
		ddd<-matrix(0,length(tg_list),ROUNDS)
      	for(j in 1:length(tg_list))
      	{
                tg_data_c<-data_23_s[tg_list[[j]],]
                ccc<-c()
                ccc<-compute_CompRowspace_NN_uni(tg_data_c,module_RB=Base_c,ROUNDS=3)
               # print(ccc)
                if(length(ccc)>0)
                {
                        tg_id1<-ccc[1,]
                        aaa[j,1:length(tg_id1)]<-tg_id1
                        bbb[j,1:length(tg_id1)]<-ccc[2,]
                        ddd[j,1:length(tg_id1)]<-ccc[3,]
                }
     		 }
		tg_ids_c<-intersect(order(-bbb[,3]),which(bbb[,3]>0.1))#################
		tg_ids_c<-intersect(tg_ids_c,which(stat_selected_R4_RR_max>0.45))#############

		#hist(bbb[tg_ids_c,3])
		aaa<-names(tg_list)[tg_ids_c]
		stat_c<-table(aaa)
		aaa0<-rep(0,length(aaa))
		names(aaa0)<-aaa
		aaa1<-unique(aaa)
		sss_c<-rep(1,length(aaa1))
		names(sss_c)<-aaa1
		sss_b<-1/(table(names(tg_selected_R4_SS))+CT_balance)
		sss_c[intersect(names(sss_c),names(sss_b))]<-sss_b[intersect(names(sss_c),names(sss_b))]
		tg_scores_c<-bbb[tg_ids_c,3]
		for(i in 1:length(tg_ids_c))
		{
			tg_scores_c[i]<-tg_scores_c[i]+sss_c[names(tg_list)[tg_ids_c[i]]]
		}
		tg_ids_cs<-tg_ids_c[which(tg_scores_c==max(tg_scores_c))][1]
		#hist(tg_scores_c)
	}

	#c12<-Compute_Rbase_SVD(data.matrix,tg_selected_R4_SS)
	#d12<-cor(t(c12),t(tProp))
	#apply(d12,2,max)
	ccc<-list(tg_selected_R4_SS,root_leaf,R1_selectedCM_step2_results_HCTES,node_add)
	names(ccc)<-c("Selected_Bases","First_step_leaf_nodes","Second_step_filtered_leaf_nodes","Further_added_other_leaves")
	return(ccc)
}


## script to develop neural cell type deconvolution algorithm
## uses houseman method with new ref data for purified brain cell populations
## editted original code from minfi to take a matrix rather than RGset - this means data is not preprocessed together.

source("FunctionsForBrainCellProportionsPrediction.r")
library(minfi)
library(genefilter)
library(rafalib)
library(IlluminaHumanMethylation450kanno.ilmn12.hg19)
source("rmdConfig.epigaba")
setwd(dataDir)

gfile.epi<-openfn.gds("gdsFiles/epigabaNorm.gds")
norm.epi<-read.gdsn(index.gdsn(gfile.epi, "celltypenormbeta"))
rownames(norm.epi)<-rownames(gfile.epi)
colnames(norm.epi)<-colnames(gfile.epi)

pheno.epi<-read.gdsn(index.gdsn(gfile.epi, "QCdata"))

pheno.epi$Cell.type<-gsub(" ", "", pheno.epi$Cell.type)

## parameters
probeSelect = "any" ## options "both" (select equal number of probes associated with hyper and hypo methylation) or "any" (just select probes based on significance regardless of direction)
cellTypes = c("GABAneurons","GLIA","GLUneurons")
cellTypes<-sort(cellTypes)
numProbes<-100
cellInd<-pheno.epi$Cell.type

## select probes as basis of algorithm
compData <- pickCompProbes(rawbetas=norm.epi, cellInd=cellInd, cellTypes = cellTypes, numProbes = numProbes, probeSelect = probeSelect)
braincelldata <- compData$coefEsts
save(braincelldata, file = "RefDataEpiGABAForCellCompEstimation.rdata")


# to install hastaLaVista package use the following:
# devtools::install_github("jwist/hastaLaVista")
# the simply load the library
library(hastaLaVista)

# we use the MetaboMate package for normalization
# and for multivariate analysis
# to install it use:
# devtools::install_github("kimsche/MetaboMate")
library(MetaboMate)
library(car)
library(corrplot)

# load demo dataset
data("bariatricRat")
metadata <- bariatricRat$metadata

# check that folers are there
# l = list.dirs("/run/media/jul/44B6-1E16/data/Julien Bariatric Rat", recursive = FALSE)
# l = as.numeric(unlist(lapply(l, function(x) strsplit(x, "/")[[1]][8])))
# length(match(metadata$Experiment.Number, l))

write.table(file = "./bariatricRatsMetadata.csv", metadata[, c(5, 1, 2, 3, 4, 6:ncol(metadata))], quote=FALSE, sep="\t", col.names = NA)

data("bariatricRat.binned.5")
metadata['JcampUrl'] <- paste0('http://127.0.0.1:5474/data/jcamp/', metadata$Experiment.Number, '-1.jdx')

Xn.binned <- bariatricRat.binned.5$binned.data
ppm.binned <- bariatricRat.binned.5$binned.ppm
matspec(ppm.binned, Xn.binned, shift=c(7,8))

ID <- metadata$Sample.Label
group <- metadata$Class
metadata <- data.frame(metadata)
x <- matrix(Xn.binned, dim(Xn.binned)[1], dim(Xn.binned)[2])
x_axis <- as.numeric( ppm.binned )
color = sapply(group, function(x) getColor2(as.character(x)))

d = list()
c <- data.frame(ID = ID,
                group = group,
                color = color,
                "_highlight" = seq_along(group) - 1,
                dataMatrix = I(matrix( c(rbind(repRow(x_axis, nrow(x)), x)), nrow(x), ncol(x)*2)),
                metadata = I(metadata),
                check.names = FALSE
)
# do not modify variableName, the view is expecting it!
d <- appendData(data = d, variableName = "data", variable = c, type = "table")
# do not modify variableName, the view is expecting it!
d <- appendData(data = d, variableName = "xAxis", variable = x_axis, type = "table")

corX <- abs(cor(x))
# do not modify variableName, the view is expecting it!
d <- appendData(data = d, variableName = "correlationMatrix", variable = corX, type = "table")

mod <- MetaboMate::pca(x)

chart12 <- data.frame("x" = mod@t[,1],
                      "y" = mod@t[,2],
                      "highlight" = seq_along(group) - 1,
                      "info"= ID,
                      "group" = as.numeric( group ),
                      "color" = color
)
# do not modify variableName, the view is expecting it!
d <- appendData( data = d, variableName = "score12", variable = chart12, type = "score")

d[['scores']] <- mod@t
d[['loadings']] <- cov(mod@t, x)
d[['loadingsColor']] <- abs(cor(mod@t, x))

ellipse <- dataEllipse(mod@t[,1], mod@t[,2], levels=0.80)

ellipseChart <- data.frame("x" = ellipse[,1],
                           "y" = ellipse[,2],
                           "color" = rep('black', length(ellipse[,1])))
# do not modify variableName, the view is expecting it!
d <- appendData( data = d, variableName = "ellipse", variable = ellipseChart, type = "color")

v <- new("visualization")
v@data <- "rat_bariatric_pcaExplorer.data.json"
v@view <- "scoresExplorer_2_0.view.json"
push(v, type="data", d)
visualize(v)


###################################################################################
#
# Mark Cembrowski, April 8 2015
#
# This script looks for correlated differences in gene expression across the
# dorsal-ventral axis for the elements of the trisynaptic loop.
#
# 100415: edited to allow for count data analysis.
# 110415: edited to proofread code.
#
# numRand=10: numeric.  Integer number of stochastic trials.
#
###################################################################################

correlatedDv <- function(fpkmThres=10,foldThres=2,numRand=10,quiet=T,export=F,
				countThres=20,doFpkm=T){
	if(doFpkm){
		theThres <- fpkmThres
	}else{
		theThres <- countThres
	}

	# Extract the lists that correspond to the dorsal and ventral enriched genes.
	toMask <- colnames(fpkmPoolMat)[!grepl('ca1_d|ca1_v',colnames(fpkmPoolMat))]
	ca1dE <- enrichedGenes('ca1_d',fpkmThres=theThres,foldThres=foldThres,
			avgPass=T,mask=toMask,doFpkm=doFpkm)
	ca1vE <- enrichedGenes('ca1_v',fpkmThres=theThres,foldThres=foldThres,
			avgPass=T,mask=toMask,doFpkm=doFpkm)

	toMask <- colnames(fpkmPoolMat)[!grepl('ca3_d|ca3_v',colnames(fpkmPoolMat))]
	ca3dE <- enrichedGenes('ca3_d',fpkmThres=theThres,foldThres=foldThres,
			avgPass=T,mask=toMask,doFpkm=doFpkm)
	ca3vE <- enrichedGenes('ca3_v',fpkmThres=theThres,foldThres=foldThres,
			avgPass=T,mask=toMask,doFpkm=doFpkm)

	toMask <- colnames(fpkmPoolMat)[!grepl('dg_d|dg_v',colnames(fpkmPoolMat))]
	dgdE <- enrichedGenes('dg_d',fpkmThres=theThres,foldThres=foldThres,
			avgPass=T,mask=toMask,doFpkm=doFpkm)
	dgvE <- enrichedGenes('dg_v',fpkmThres=theThres,foldThres=foldThres,
			avgPass=T,mask=toMask,doFpkm=doFpkm)

	if(doFpkm){
		theMat <- fpkmPoolMat
	}else{
		theMat <- cpmPoolMat
	}

	# Get total genes expressed in each group.
	ca1d <- rownames(theMat)[theMat$ca1_d>theThres]
	ca1v <- rownames(theMat)[theMat$ca1_v>theThres]

	ca3d <- rownames(theMat)[theMat$ca3_d>theThres]
	ca3v <- rownames(theMat)[theMat$ca3_v>theThres]

	dgd <- rownames(theMat)[theMat$dg_d>theThres]
	dgv <- rownames(theMat)[theMat$dg_v>theThres]

	# Get number enriched in >=2 comparisons.
	ca1ca3dE <- intersect(ca1dE,ca3dE)
	ca1ca3vE <- intersect(ca1vE,ca3vE)
	ca1dgdE <- intersect(ca1dE,dgdE)
	ca1dgvE <- intersect(ca1vE,dgvE)
	ca3dgdE <- intersect(ca3dE,dgdE)
	ca3dgvE <- intersect(ca3vE,dgvE)

	# Get number enriched in 3 comparisons.
	ca1ca3dgdE <- intersect(intersect(ca1dE,ca3dE),dgdE)
	ca1ca3dgvE <- intersect(intersect(ca1vE,ca3vE),dgvE)

	# Convert gene lists to numbers.
	nca1d <- length(ca1d)
	nca3d <- length(ca3d)
	ndgd <- length(dgd)
	nca1v <- length(ca1v)
	nca3v <- length(ca3v)
	ndgv <- length(dgv)

	print('The number of genes expressed at each location: DGd/CA3d/CA1d DGv/CA3v/CA1v')
	print(paste(ndgd,nca3d,nca1d,ndgv,nca3v,nca1v))

	nca1dE <- length(ca1dE)
	nca3dE <- length(ca3dE)
	ndgdE <- length(dgdE)
	nca1vE <- length(ca1vE)
	nca3vE <- length(ca3vE)
	ndgvE <- length(dgvE)

	print('The number of genes enrihed in each pairwise comparison: DGd/CA3d/CA1d DGv/CA3v/CA1v')
	print(paste(ndgdE,nca3dE,nca1dE,ndgvE,nca3vE,nca1vE))

	nca1ca3dE <- length(ca1ca3dE)
	nca1dgdE <- length(ca1dgdE)
	nca3dgdE <- length(ca3dgdE)
	nca1ca3vE <- length(ca1ca3vE)
	nca1dgvE <- length(ca1dgvE)
	nca3dgvE <- length(ca3dgvE)

	nca1ca3dgdE <- length(ca1ca3dgdE)
	nca1ca3dgvE <- length(ca1ca3dgvE)

	# Draw some guys by chance.
	theOut <- as.data.frame(matrix(nrow=numRand,ncol=8))
	colnames(theOut) <- c('ca1ca3d','ca1dgd','ca3dgd','ca1ca3dgd',
			      'ca1ca3v','ca1dgv','ca3dgv','ca1ca3dgv')

	for (ii in 1:numRand){
		theOut[ii,1] <- .randomOverlap(ca1d,nca1dE,ca3d,nca3dE)
		theOut[ii,2] <- .randomOverlap(ca1d,nca1dE,dgd,ndgdE)
		theOut[ii,3] <- .randomOverlap(ca3d,nca3dE,dgd,ndgdE)
		theOut[ii,4] <- .randomOverlap(ca1d,nca1dE,ca3d,nca3dE,dgd,ndgdE)

		theOut[ii,5] <- .randomOverlap(ca1v,nca1vE,ca3v,nca3vE)
		theOut[ii,6] <- .randomOverlap(ca1v,nca1vE,dgv,ndgvE)
		theOut[ii,7] <- .randomOverlap(ca3v,nca3vE,dgv,ndgvE)
		theOut[ii,8] <- .randomOverlap(ca1v,nca1vE,ca3v,nca3vE,dgv,ndgvE)
	}

	muOut <- apply(theOut,2,mean)
	sdOut <- apply(theOut,2,sd)
	errOut <- sdOut*2
	errLo <- muOut-errOut
	errHi <- muOut+errOut

	expData <- as.data.frame(
		c(nca1ca3dE,nca1dgdE,nca3dgdE,nca1ca3dgdE,
		  nca1ca3vE,nca1dgvE,nca3dgvE,nca1ca3dgvE))
	colnames(expData) <- 'expData'
	rownames(expData) <- colnames(theOut)

	if(!quiet){
		print(expData)
		for (ii in 1:8){
			# Print out p values for everything.
			print(sum(theOut[,ii]>expData[ii,1])/numRand)
		}
	}

return(theOut)

	df <- as.data.frame(cbind(rownames(expData),muOut,errLo,errHi,expData))
	colnames(df)[1] <- 'test'

	df$test <- factor(df$test,levels=c('ca3dgd','ca1ca3d','ca1dgd','ca1ca3dgd',
		'ca3dgv','ca1ca3v','ca1dgv','ca1ca3dgv'))

	gg <- ggplot(df,aes(x=test)) + geom_point(aes(y=expData),colour='red',size=12,shape=95)
	gg <- gg + geom_errorbar(aes(ymin=errLo,ymax=errHi),width=0.5)
	gg <- gg + geom_point(aes(y=muOut),colour='black',size=4,shape=95)
	gg <- gg + theme_bw()
	print(gg)

	if(!quiet){
		print('here are mean and standard deviation')
		print(muOut)
		print(sdOut)
	}

	if(!quiet){
		print('These are the genes enriched dorsally across all comparisons:')
		print(as.data.frame(sort(idToSym(ca1ca3dgdE))))
		print('These are the genes enriched ventrally across all comparisons:')
		print(as.data.frame(sort(idToSym(ca1ca3dgvE))))
	}

	theD <- theMat[ca1ca3dgdE,]
	theD <- cbind(theD,rep('dorsal',nrow(theD)))
	colnames(theD)[ncol(theD)] <- 'regionEnriched'
	theD <- theD[,c('regionEnriched','dg_d','ca3_d','ca1_d','dg_v','ca3_v','ca1_v')]
	rownames(theD) <- idToSym(rownames(theD))
	theD <- theD[order(rownames(theD)),]

	theV <- theMat[ca1ca3dgvE,]
	theV <- cbind(theV,rep('ventral',nrow(theV)))
	colnames(theV)[ncol(theV)] <- 'regionEnriched'
	theV <- theV[,colnames(theD)]
	rownames(theV) <- idToSym(rownames(theV))
	theV <- theV[order(rownames(theV)),]

	theOut <- rbind(theD,theV)

	# Export data for checking into DAVID, if desired.
	if(export){
		print('here')
		write.table(c(ca1ca3dgdE,ca1ca3dgvE),file='dvCorrGenes.txt',sep='\t',quote=F,row.names=F)
	}

	invisible(theOut)

#	print('Number of genes expressed in CA1 / enriched in CA1 (dorsal vs ventral):')
#	print(paste(length(ca1d),length(ca1dE),length(ca1v),length(ca1vE)))
#	print('Number of genes expressed in CA3 / enriched in CA3 (dorsal vs ventral):')
#	print(paste(length(ca3d),length(ca3dE),length(ca3v),length(ca3vE)))
#	print('Number of genes expressed in DG / enriched in DG (dorsal vs ventral):')
#	print(paste(length(dgd),length(dgdE),length(dgv),length(dgvE)))

}

# Draw numA genes from list geneA and numB genes from list geneB and
# calculate the number of intersections.  Optional arguments provide
# a third list to supply.
.randomOverlap <- function(geneA,numA,geneB,numB,geneC=c(),numC=-1){

	fromA <- sample(geneA,numA)
	fromB <- sample(geneB,numB)
	if(numC>0.1){
		fromC <- sample(geneC,numC)
		invisible(length(intersect(intersect(fromA,fromB),fromC)))
	}else{
		invisible(length(intersect(fromA,fromB)))
	}
}