########################################################################################
## This file is a part of YAP package of scripts. https://github.com/shpakoo/YAP
## Distributed under the MIT license: http://www.opensource.org/licenses/mit-license.php
## Copyright (c) 2011-2013 Sebastian Szpakowski
########################################################################################

library(ggplot2)
library(grid)
library(scales)

multiplot <- function(..., plotlist=NULL, cols=1, layout=NULL)
{
	require(grid)

	# Make a list from the ... arguments and plotlist
	plots <- c(list(...), plotlist)
	numPlots = length(plots)

	# If layout is NULL, then use 'cols' to determine layout
	if (is.null(layout))
	{
		layout = grid.layout(ceiling(numPlots/cols), cols)
	}

	# create a panel that will be used to map ids later

	panel = matrix(1:(layout$nrow * layout$ncol), nrow = layout$nrow, ncol = layout$ncol, byrow=TRUE )

	if (numPlots==1)
	{
		print(plots[[1]])
	}
	else
	{
		# Set up the page
		grid.newpage()
		pushViewport(viewport(layout = layout))

		for (i in 1:numPlots)
		{
			matching <- as.data.frame(which(panel == i, arr.ind = TRUE))

			print ( plots[[i]], vp = viewport(	layout.pos.row = matching$row,
												layout.pos.col = matching$col)
			)
		}
	}
}

loadWeights <- function ()
{
	x = data.frame()
	for (file in dir (pattern=  glob2rx("*.weight")))
	{
		newfile = unlist(strsplit(file, "\\."))
		newfile = newfile[-length(newfile)]
		newfile = paste(paste(newfile, collapse=".", sep=""), "normweight", sep= ".")
		print (newfile)
		tmp = read.table(file, sep="\t", header = FALSE)
		names(tmp)<-c("orfid", "coverage")
		tmp$scaled = tmp$coverage / median(tmp$coverage)
		tmp$scaledlog2 = log2(tmp$coverage / median(tmp$coverage))
		###
		write.table(tmp, newfile, sep="\t", row.names=FALSE, col.names=TRUE, quote=FALSE)
		###

		tmp$file = rep(file, nrow(tmp))
		cat(file, median(tmp$coverage), mean(tmp$coverage), "\n", sep= "\t")
		if (nrow(x)==0)
		{
			x = tmp
		}
		else
		{
			x  = rbind(tmp, x)
		}
	}
	return (x)
}

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

 global = loadWeights()

 files = unique(global$file)

####### transforms

 y_trans_log10 = scale_y_log10(	breaks = trans_breaks("log10", function(x) 10^x),
 								labels = trans_format("log10", math_format(10^.x)))

 x_trans_log10 = scale_x_log10(	breaks = trans_breaks("log10", function(x) 10^x),
 								labels = trans_format("log10", math_format(10^.x)))

 y_trans_log2 = scale_y_log10(	breaks = trans_breaks("log2", function(x) 2^x),
 								labels = trans_format("log2", math_format(2^.x)))

 x_trans_log2 = scale_x_log10(	breaks = trans_breaks("log2", function(x) 2^x),
 								labels = trans_format("log2", math_format(2^.x)))

####### plots

 A1 = (ggplot(global,  aes(file, coverage, color=file))
 		+ geom_boxplot()
 		+ coord_flip()
 		+ theme(axis.ticks = element_blank(), axis.text.y = element_blank())
 		)
 A2 = (ggplot(global,  aes(file, scaled, color=file))
 		+ geom_boxplot()
 		+ coord_flip()
 		+ theme(axis.ticks = element_blank(), axis.text.y = element_blank())
 		)
 A3 = (ggplot(global,  aes(file, scaledlog2, color=file))
 		+ geom_boxplot()
 		+ coord_flip()
 		+ theme(axis.ticks = element_blank(), axis.text.y = element_blank())
 		)

 B1 = (ggplot(global,  aes(coverage, ..count..,  fill=file, group=file ))
 		+ stat_bin(aes(y=..count..), geom="area", position="stack", weight=2)
 		)
 B2 = (ggplot(global,  aes(scaled, ..count..,  fill=file, group=file ))
 		+ stat_bin(aes(y=..count..), geom="area", position="stack", weight=2)
 		)
 B3 = (ggplot(global,  aes(scaledlog2, ..count..,  fill=file, group=file ))
 		+ stat_bin(aes(y=..count..), geom="area", position="stack", weight=2)
 		)

 C1 = (ggplot(global,  aes(coverage, ..count..,  fill=file, group=file ))
 		+ stat_bin(aes(y=..count..), geom="area", position="dodge", alpha=0.5, weight=2)
 		)
 C2 = (ggplot(global,  aes(scaled, ..count..,  fill=file, group=file ))
 		+ stat_bin(aes(y=..count..), geom="area", position="dodge", alpha=0.5, weight=2)
 		)
 C3 = (ggplot(global,  aes(scaledlog2, ..count..,  fill=file, group=file ))
 		+ stat_bin(aes(y=..count..), geom="area", position="dodge", alpha=0.5, weight=2)
 		)

 D1 = (ggplot(global,  aes(coverage, fill=file, group=file ))
 		+ geom_bar(position="fill")
 		)
 D2 = (ggplot(global,  aes(scaled, fill=file, group=file ))
 		+ geom_bar(position="fill")
 		)
 D3 = (ggplot(global,  aes(scaledlog2, fill=file, group=file ))
 		+ geom_bar(position="fill")
 		)

################ rendered output files

 png("COVERAGE_GG.png", width=30, height = 2 + 4 * length(files), units="in", res=250)
 multiplot(	A1, A2, A3,
 			B1, B2, B3,
 			C1, C2, C3,
 			D1, D2, D3,
 			cols=3
 			)
 dev.off()

 png("COVERAGE_log10counts_GG.png", width=30, height = 2 + 4 * length(files), units="in", res=250)
 multiplot(	A1 + y_trans_log10, A2 + y_trans_log10, A2 + y_trans_log10,
 			B1 + y_trans_log10, B2 + y_trans_log10, B2 + y_trans_log10,
 			C1 + y_trans_log10, C2 + y_trans_log10, C2 + y_trans_log10,
 			D1 + y_trans_log10, D2 + y_trans_log10, D2 + y_trans_log10,
 			cols=3
 			)
 dev.off()

 png("COVERAGE_facet_GG.png", width=10, height = 2 + 2 * (4 * length(files)), units="in", res=250)
 multiplot(
 			B1 + facet_grid( file ~ .) , B2 + facet_grid( file ~ .), B3 + facet_grid( file ~ .) ,
 			cols=1
 			)
 dev.off()

 png("COVERAGE_log10counts_facet_GG.png", width=10, height = 2 + 2 * (4 * length(files)), units="in", res=250)
 multiplot(
 			B1 + y_trans_log10 + facet_grid( file ~ .) , B2 + y_trans_log10 + facet_grid( file ~ .), B3 + y_trans_log10 + facet_grid( file ~ .),
 			cols=1
 			)
 dev.off()


CC <- data_testing$avg_cc;

data_testing$target <- predictions/CC;

orderedData <- data_testing[order(-data_testing$target),];

orderedData$target <- NULL;

write.csv(orderedData,"E:\\STUDY\\THESIS\\STEP-WISE REGRESSION\\testDataOrderedByPredictions.csv",row.names=F);

cumulativeLOC <- cumsum(orderedData$loc);

cumulativeBugs <- cumsum(orderedData$bug);

totalLOC <- cumulativeLOC[NROW(cumulativeLOC)];
totalBugs <- cumulativeBugs[NROW(cumulativeBugs)];

percentLOC <- (cumulativeLOC/totalLOC)*100;
percentBugs <- (cumulativeBugs/totalBugs)*100;

lines(percentLOC,percentBugs,type="o",col="dark green",lwd=0.5,pch=".",cex=0.8)


for (num_cv in 3:3) {
  pdf(paste("bcf/plot1", ".pdf", sep = ""), width = 5, height = 5)
  results <- read.csv(paste("bcf/results/results/exp1_sigma0.1_ntrain50_nseq200_homo1_sequential1_", num_cv, ".csv", sep=""))
  for (k in 0:20) {
    n_seq <- k*10
    if (k==0) {
      bart_posterior <- load(paste("bcf/results/results/posterior_BART_synthetic_sequential1_", 1, "_", num_cv, ".RData", sep=""))
      plot(rep(50, length(posterior_samples$posterior_samples)), posterior_samples$posterior_samples,
           col="orangered", ylim=c(2.2,4), ylab = "ATE", xlim=c(50, 250),
           xlab = expression(italic(n)[ini] + italic(n)[seq]), cex.lab = 1.5, cex.axis = 1.5, cex=0.1)
      points(50, results$BARTMean[1], col = "orangered", bg='orangered', pch=21, lwd=3)

    } else {
      bart_posterior <- load(paste("bcf/results/results/posterior_BART_synthetic_sequential1_", n_seq, "_", num_cv, ".RData", sep=""))
      points(n_seq+50, results$BARTMean[n_seq], col = "orangered", bg='orangered', pch=21, lwd=3)
      points(rep(n_seq+50, length(posterior_samples$posterior_samples)),
             posterior_samples$posterior_samples,
             col = "orangered", bg='orangered', cex=0.1)
    }
  }
  abline(h=3)

  # random
  results <- read.csv(paste("bcf/results/results/exp1_sigma0.1_ntrain50_nseq200_homo1_sequential2_", num_cv, ".csv", sep=""))
  for (k in 0:19) {
    n_seq <- k*10 + 5
    if (k==0) {
      bart_posterior <- load(paste("bcf/results/results/posterior_BART_synthetic_sequential2_", 2, "_", num_cv, ".RData", sep=""))
      points(rep(50, length(posterior_samples$posterior_samples)), posterior_samples$posterior_samples,
           col="chartreuse4",  cex=0.1)
      points(50, results$BARTMean[2], col = "chartreuse4", bg='chartreuse4', pch=21, lwd=3)

    } else {
      bart_posterior <- load(paste("bcf/results/results/posterior_BART_synthetic_sequential2_", n_seq, "_", num_cv, ".RData", sep=""))
      points(n_seq+50, results$BARTMean[n_seq], col = "chartreuse4", bg='chartreuse4', pch=21, lwd=3)

      points(rep(n_seq+50, length(posterior_samples$posterior_samples)),
             posterior_samples$posterior_samples,
             col = "chartreuse4", bg='chartreuse4', cex=0.1)
    }
  }
  legend("topright", legend=c("BART Active", "BART Random"),
         col=c("orangered", "chartreuse4"), cex=1.3, lty = c(1,1), bty="n")
  dev.off()

  pdf(paste("bcf/plot2", ".pdf", sep = ""), width = 5, height = 5)
  results <- read.csv(paste("bcf/results/results/exp1_sigma0.1_ntrain50_nseq200_homo1_sequential1_", num_cv, ".csv", sep=""))
  plot(results$epochs+50, results$GPMean, ty="l", col="dodgerblue",
       ylim=c(2.2,3.5), ylab = "ATE", xlab = expression(italic(n)[ini] + italic(n)[seq]), cex.lab = 1.5, cex.axis = 1.5)
  polygon(c(results$epochs+50, rev(results$epochs+50)),
          c(
            results$GPMean + 2*results$GPsd,
            rev(results$GPMean - 2*results$GPsd)
          ),
          col = adjustcolor("dodgerblue", alpha.f = 0.10),
          border = "dodgerblue", lty = c("dashed", "solid"))
  abline(h=3)
  results <- read.csv(paste("bcf/results/results/exp1_sigma0.1_ntrain50_nseq200_homo1_sequential2_", num_cv, ".csv", sep=""))
  points(results$epochs+50, results$GPMean, ty="l", col="brown", ylim=c(2,4))
  polygon(c(results$epochs+50, rev(results$epochs+50)),
          c(
            results$GPMean + 2*results$GPsd,
            rev(results$GPMean - 2*results$GPsd)
          ),
          col = adjustcolor("brown", alpha.f = 0.10),
          border = "brown", lty = c("dashed", "solid"))
  legend("topright", legend=c("GP Active", "GP Random"),
         col=c("dodgerblue", "brown"), cex=1.3, lty = c(1,1), bty="n")
  dev.off()
}


significant_motifs<- function(sample.gr,control.gr,fimo.gr,cutoff=0.01,BH_correction=TRUE) {

motif_counts <- function(regions.gr, motifs.gr) {
  ol <- as.data.frame(findOverlaps(query=motifs.gr, subject=regions.gr, type="within", ignore.strand=TRUE))
  ol$motif <- mcols(motifs.gr)$name[ol$queryHits]
  ol$queryHits <- NULL
  hits.df <- ddply(ol, .(motif), plyr::summarize, with_motif=length(unique(subjectHits)))

  all.motifs <- unique(as.character(mcols(motifs.gr)$name))
  missing.motifs <- all.motifs[!all.motifs %in% hits.df$motif]

  if(length(missing.motifs) > 0) {
    missing.df <- data.frame(stringsAsFactors=FALSE, motif=missing.motifs, with_motif=0)
    hits.df <- rbind(hits.df, missing.df)
  }

  hits.df$without_motif <- length(regions.gr) - hits.df$with_motif
  hits.df[order(hits.df$with_motif, decreasing=TRUE), ]
}

proportion_test <- function(values, enrichment=TRUE) {
  stopifnot(is.logical(enrichment))
  m <- matrix(values, nrow=2, byrow=TRUE)
  alt.test <- ifelse(enrichment, "greater", "less")
  prop.test(m, alternative=alt.test)$p.value
}

single_motif_test <- function(row.df, enrichment) {
  proportion_test(as.numeric(c(row.df$s1_W, row.df$s1_WO, row.df$s2_W, row.df$s2_WO)), enrichment)
}

motif_count_comparison <- function(set1.df, set2.df) {
  stopifnot(nrow(set1.df) == nrow(set2.df))

  names(set1.df)[2:3] <- c("s1_W", "s1_WO")
  names(set2.df)[2:3] <- c("s2_W", "s2_WO")

  set.df <- merge(set1.df, set2.df)
  stopifnot(nrow(set.df) == nrow(set1.df))

  set_test.df   <- subset(set.df, s1_W > 0 | s2_W > 0)

  e_set_test.df <- set_test.df
  e_set_test.df$test_type <- "enrichment"

  e_set_test.df$pvalue <- as.vector(by(e_set_test.df, 1:nrow(e_set_test.df), single_motif_test, enrichment=TRUE))

  d_set_test.df <- set_test.df
  d_set_test.df$test_type <- "depletion"

  d_set_test.df$pvalue <- as.vector(by(d_set_test.df, 1:nrow(d_set_test.df), single_motif_test, enrichment=FALSE))

  set_test.df <- rbind(e_set_test.df, d_set_test.df)

  set_notest.df <- subset(set.df, s1_W == 0 & s2_W == 0)
  if(nrow(set_notest.df) > 0) {
    set_notest.df$pvalue <- 1
    e_set_notest.df <- set_notest.df
    e_set_notest.df$test_type <- "enrichment"

    d_set_notest.df$pvalue <- 1
    d_set_notest.df$test_type <- "depletion"

    set.df <- rbind(set_test.df, e_set_notest.df, d_set_notest.df)
  } else {
    set.df <- set_test.df
  }

  stopifnot(nrow(set.df) == 2 * nrow(set1.df))
  set.df <- transform(set.df, enrichment = (s1_W/(s1_W+s1_WO)) / (s2_W/(s2_W+s2_WO)) )
  set.df <- transform(set.df, enrichment = ifelse(test_type == "enrichment", enrichment, -1 / enrichment))
  set.df
}

counts.control <- motif_counts(control.gr, fimo.gr)
counts.sample <- motif_counts(sample.gr, fimo.gr)

results_test.df <- motif_count_comparison(counts.sample,counts.control)

if(BH_correction == TRUE){
results_test.df$padj <- p.adjust(results_test.df$pvalue, method="BH")

results_test.df <- arrange(results_test.df, motif, padj)
results_test.df <- results_test.df[!duplicated(results_test.df$motif), ]

sig_motifs_test.df <- subset(results_test.df, padj < cutoff)
sig_motifs_test.df <- arrange(sig_motifs_test.df, padj)
sig_motifs_test.df
	} else {
results_test.df <- arrange(results_test.df, motif, pvalue)
results_test.df <- results_test.df[!duplicated(results_test.df$motif), ]

sig_motifs_test.df <- subset(results_test.df, pvalue < cutoff)
sig_motifs_test.df <- arrange(sig_motifs_test.df, pvalue)
sig_motifs_test.df
}
}


context("Lists")

test_that("data frame variables converted to list names", {
  x <- dlply(esoph, .(alcgp), function(df) mean(df$ncases))
  expect_that(names(x), equals(levels(esoph$alcgp)))

  x <- dlply(esoph, .(alcgp, agegp), function(df) mean(df$ncases))
  y <- ddply(esoph, .(alcgp, agegp), function(df) mean(df$ncases))
  labs <- paste(y$alcgp, y$agegp, sep = ".")
  expect_that(names(x), equals(labs))

})

test_that("list names are preserved", {
  a <- 1:10
  expect_that(names(llply(a)), equals(NULL))

  names(a) <- letters[1:10]
  expect_that(names(llply(a)), equals(letters[1:10]))

})

# Test for #142
test_that(".n column can be renamed or dropped", {
  f <- function() data.frame(r=runif(1))

  out1 <- rdply(4, f)
  out2 <- rdply(4, f, .id='x')

  expect_equal(names(out1), c('.n', 'r'))
  expect_equal(names(out2), c('x', 'r'))

  # more testing
  expect_identical(out1$.n, seq_len(4))
  expect_identical(out2$x, seq_len(4))

  out <- rdply(4, f, .id=NULL)
  expect_equal(names(out), c('r'))
  expect_false(out$r[4] == 4)

  out <- rdply(4, f, .id='r') # names conflict
  expect_equal(names(out), c('r'))

  out <- rdply(4, f, .id='.n') # defaults
  expect_equal(names(out), c('.n', 'r'))
  expect_identical(out$.n, seq_len(4))
})


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

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

#create url to original jcamp files and append to metadata
# files have to be accessible to the web server
# a good idea is to put the jcamp in the folder following folder:
file.path( system.file(package = "hastaLaVista"), "visu", "data", "jcamp")
# if no jcamp are available, the tool will just work as expected
# except no original data will be displayed
metadata['JcampUrl'] <- paste0('http://127.0.0.1:5474/data/jcamp/', metadata$Experiment.Number, '-1.jdx')

# normalisation of data
Xn=MetaboMate::pqn(X)
MetaboMate::matspec(ppm, Xn, shift=c(7,8))

# preparation of the dataset to create the data.json file
ID <- metadata$Sample.Label
group <- metadata$Class
x <- matrix(Xn, dim(X)[1], dim(X)[2])
x_axis <- as.numeric( ppm )
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
)

# adding data and xAxis to the list
# 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")

# preparing for visualization
# display may take a while, since large amount of data
# is passed to the browser
v3 <- new("visualization")
v3@data <- "rat_bariatric_dataExplorer.data.json"
v3@view <- "dataExplorer_1_0_1.view.json"
push(v3, type="data", d)
visualize(v3)

# you may want to continue and add pca results...

# performing multivariate analysis
# this step is only required for dataExplorer 1.1
mod <- MetaboMate::pca(Xn)

chart12 <- data.frame("x" = mod@t[,1],
                      "y" = mod@t[,2],
                      "highlight" = seq_along(group) - 1,
                      "info"= ID,
                      "group" = as.numeric( group ),
                      "color" = color
)

# adding score plot to the list structure
# do not modify variableName, the view is expecting it!
d <- appendData( data = d, variableName = "score12", variable = chart12, type = "score")

# adding scores, loadings and colour-code
d[['scores']] <- mod@t
d[['loadings']] <- cov(mod@t, x)
d[['loadingsColor']] <- abs(cor(mod@t, x))

# calculating ellipse
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])))

# addit ellipse data to the list
# do not modify variableName, the view is expecting it!
d <- appendData( data = d, variableName = "ellipse", variable = ellipseChart, type = "color")

v4 <- new("visualization")
v4@data <- "rat_bariatric_dataExplorer.data.json"
v4@view <- "dataExplorer_1_1.view.json"
push(v4, type="data", d)
visualize(v4)


#' Data Diagnostics
#'
#' This function provides visualisations of how the number of records in the
#' dataset changes over time and how the number of species recorded on a
#' visit changes over time. For each of these an linear model is run to test
#' if there is a significant trend.
#'
#' @param taxa A character vector of taxon names, as long as the number of observations.
#' @param site A character vector of site names, as long as the number of observations.
#' @param time_period A numeric vector of user defined time periods, or a date vector,
#'        as long as the number of observations.
#' @param plot Logical, if \code{TRUE} plots and model results will be printed to
#'        the console
#' @param progress_bar If \code{TRUE} a progress bar is printed to console
#'
#' @return A list of filepaths, one for each species run, giving the location of the
#'         output saved as a .rdata file, containing an object called 'out'
#'
#' @examples
#' \dontrun{
#'
#' ### Diagnostics functions ###
#' # Create data
#' n <- 2000 # size of dataset
#' nyr <- 20 # number of years in data
#' nSamples <- 200 # set number of dates
#' useDates <- TRUE
#'
#' # Create somes dates
#' first <- as.POSIXct(strptime("2003/01/01", "%Y/%m/%d"))
#' last <- as.POSIXct(strptime(paste(2003+(nyr-1),"/12/31", sep=''), "%Y/%m/%d"))
#' dt <- last-first
#' rDates <- first + (runif(nSamples)*dt)
#'
#' # taxa are set as random letters
#' taxa <- sample(letters, size = n, TRUE)
#'
#' # three sites are visited randomly
#' site <- sample(c('one', 'two', 'three'), size = n, TRUE)
#'
#' # the date of visit is selected at random from those created earlier
#' if(useDates){
#'   time_period <- sample(rDates, size = n, TRUE)
#' } else {
#'   time_period <- sample(1:nSamples, size = n, TRUE)
#' }
#' # Using a date
#' dataDiagnostics(taxa, site, time_period)
#' # Using a numeric
#' dataDiagnostics(taxa, site, as.numeric(format(time_period, '%Y')))
#' }
#' @export
#' @importFrom dplyr distinct
#' @importFrom reshape2 dcast

## Change in List-length over time ##
dataDiagnostics <- function(taxa, site, time_period, plot = TRUE, progress_bar = TRUE){

  if(progress_bar) cat('Calculating diagnostics\n')
  if(progress_bar) pb <- txtProgressBar(min = 0, max = 10, style = 3)

  # Do error checks
  errorChecks(taxa = taxa, site = site, time_period = time_period)

  # Create dataframe from vectors
  taxa_data <- distinct(data.frame(taxa, site, time_period))
  if(progress_bar) setTxtProgressBar(pb, 2)

  if('POSIXct' %in% class(time_period) | 'Date' %in% class(time_period)){
    recOverTime <- as.numeric(format(time_period,'%Y'))
  } else {
    recOverTime <- time_period
  }
  if(progress_bar) setTxtProgressBar(pb, 3)

  # Model the trend in records over time
  bars <- table(recOverTime, dnn = 'RecordsPerYear')
  mData <- data.frame(time_period = as.numeric(names(bars)), count = as.numeric(bars))
  modelRecs <- glm(count ~ time_period, data = mData)
  modelRecsSummary <- summary(modelRecs)
  if(progress_bar) setTxtProgressBar(pb, 5)

  # Reshape the data
  space_time <- dcast(taxa_data, time_period + site ~ ., value.var='taxa',
                      fun.aggregate = function(x) length(unique(x)))
  names(space_time)[ncol(space_time)] <- 'listLength'
  if(progress_bar) setTxtProgressBar(pb, 9)

  # Model the trend in list length
  modelList <- glm(listLength ~ time_period, family = 'poisson', data = space_time)
  modelListSummary <- summary(modelList)
  if(progress_bar) setTxtProgressBar(pb, 10)
  if(progress_bar) cat('\n\n')

  if(plot){
    # Setup plot space
    par(mfrow = c(2,1))
    par(mar = c(0.1, 4.1, 4.1, 2.1))

    # Plot a simple histogram
    barplot(height = as.numeric(bars),
            ylab = 'Number of records',
            main = 'Change in records and list length over time')

    # Plot the change in list length over time
    par(mar = c(5.1, 4.1, 0.1, 2.1))

    if('POSIXct' %in% class(time_period) | 'Date' %in% class(time_period)){
      boxplot(listLength ~ as.numeric(format(space_time$time_period,'%Y')),
              data = space_time,
              xlab = 'Time Period',
              ylab = 'List Length',
              frame.plot=FALSE,
              ylim = c(min(space_time$listLength), max(space_time$listLength)))
      } else {
        boxplot(listLength ~ space_time$time_period,
                data = space_time,
                xlab = 'Time Period',
                ylab = 'List Length',
                frame.plot=FALSE,
                ylim = c(min(space_time$listLength), max(space_time$listLength)))
      }

    # Print the result to console
    cat('## Linear model outputs ##\n\n')
    cat(ifelse(modelRecsSummary$coefficients[2,4] < 0.05,
               'There is a significant change in the number of records over time:\n\n',
               'There is no detectable change in the number of records over time:\n\n'))
    print(modelRecsSummary$coefficients)
    cat('\n\n')
    cat(ifelse(modelListSummary$coefficients[2,4] < 0.05,
               'There is a significant change in list lengths over time:\n\n',
               'There is no detectable change in list lengths over time:\n\n'))
    print(modelListSummary$coefficients)

  }

  invisible(list(RecordsPerYear = bars, VisitListLength = space_time, modelRecs = modelRecs, modelList = modelList))

}


compute_best_matching_distance<-function(dataset,shapelets,shapelet_length,location=TRUE){
	similarity=shapeletSimilarity(dataset,shapelets,as.integer(shapelet_length))
	if(location){
		return(cbind(similarity$similarity,similarity$location))
	}else{
		return(similarity$similarity)
	}
}


library(plotly)

data<-read.csv("ElectricCarData_Clean.csv")
fig <- plot_ly(data,x =~Brand,y =~Seats,z =~Segment,color=~Brand,text = ~paste('Brand:', Brand, '
Seats:', Seats, '
Segment:', Segment))
fig <- fig %>% add_markers()
fig <- fig %>% layout(scene = list(xaxis = list(title = 'Brand'),
                                   yaxis = list(title = 'Seats'),
                                   zaxis = list(title = 'Segment')))

fig


context("Species level indices - test boot_specieslevel_n")

library(magrittr)
library(bipartite)
data(Safariland)

# Helper function to get the length of unique values from the last columns of
# each matrix of the given array.
get_length_unq <- function(test_array) {
  test_array %>%
    .[, dim(.)[2],] %>%
    apply(MARGIN = 1, FUN = function(x) length(unique(x))) %>%
    unique(.)
}

# Test d ------------------------------------------------------------------

# Note that "d" doesn’t have an weighted version.

index <- "d"

# For full reproducibility we need to reorder the Safariland matrix
# alphabetically. This is needed because in boot_specieslevel_once() we use the
# table() function to (re)construct/sample networks and the species names are
# ordered alphabetically, which is not the case for Safariland default matrix
# that comes with the bipartite package.
sf_sort <- Safariland[order(rownames(Safariland)), order(colnames(Safariland))]

set.seed(42)
test_both <- specieslevel(sf_sort, index = index, level = "both")

# ~ both levels -----------------------------------------------------------

test_that('"d" index output is ok for both levels', {
  sf_boot <- Safariland %>%
    web_matrix_to_df() %>%
    boot_specieslevel_n(col_lower = "lower",
                        col_higher = "higher",
                        index = index,
                        level = "both",
                        start = 100,
                        step = 100,
                        n_boot = 6,
                        n_cpu = 2)

  expect_true(inherits(sf_boot, 'list'))
  expect_true(length(sf_boot) == 2) # one array for each level

  expect_match(names(sf_boot)[1], "higher_level", fixed = TRUE)
  expect_match(names(sf_boot)[2], "lower_level", fixed = TRUE)

  expect_true(inherits(sf_boot[["higher_level"]], 'array'))
  expect_true(inherits(sf_boot[["lower_level"]], 'array'))

  expect_true(length(dim(sf_boot[["higher_level"]])) == 3)
  expect_true(length(dim(sf_boot[["lower_level"]])) == 3)

  expect_true(dim(sf_boot[["higher_level"]])[3] == 6) # because n_boot = 6
  expect_true(dim(sf_boot[["lower_level"]])[3] == 6) # because n_boot = 6

  expect_true(typeof(sf_boot[["higher_level"]]) == "double")
  expect_true(typeof(sf_boot[["lower_level"]]) == "double")

  # Are all last columns of the matrices identical?
  unq_length_hl <- get_length_unq(sf_boot[["higher_level"]])
  expect_equal(unq_length_hl, 1)

  unq_length_ll <- get_length_unq(sf_boot[["lower_level"]])
  expect_equal(unq_length_ll, 1)

  # Is the last bootstrap value correct? As per bipartite::specieslevel ?
  final_boot_val_hl <- sf_boot[["higher_level"]] %>% .[, ncol(.), 1] %>% as.data.frame
  expect_equivalent(final_boot_val_hl, test_both[["higher level"]])

  final_boot_val_ll <- sf_boot[["lower_level"]] %>% .[, ncol(.), 1] %>% as.data.frame
  expect_equivalent(final_boot_val_ll, test_both[["lower level"]])
})

# ~ higher level ----------------------------------------------------------

test_that('"d" index output is ok for higher level', {
  sf_boot <- Safariland %>%
    web_matrix_to_df() %>%
    boot_specieslevel_n(col_lower = "lower",
                        col_higher = "higher",
                        index = index,
                        level = "higher",
                        start = 100,
                        step = 100,
                        n_boot = 6,
                        n_cpu = 2)

  expect_true(inherits(sf_boot, 'list'))
  expect_true(length(sf_boot) == 1)

  expect_match(names(sf_boot), "higher_level", fixed = TRUE)

  expect_true(inherits(sf_boot[[1]], 'array'))

  expect_true(length(dim(sf_boot[[1]])) == 3)

  expect_true(dim(sf_boot[[1]])[3] == 6) # because n_boot = 6

  expect_true(typeof(sf_boot[[1]]) == "double")

  # Are all last columns of the matrices identical?
  unq_length <- get_length_unq(sf_boot[[1]])
  expect_equal(unq_length, 1)

  # Is the last bootstrap value correct? As per bipartite::specieslevel ?
  final_boot_val <- sf_boot[[1]] %>% .[, ncol(.), 1] %>% as.data.frame
  expect_equivalent(final_boot_val, test_both[["higher level"]])
})

# ~ lower level -----------------------------------------------------------

test_that('"d" index output is ok for lower level', {
  sf_boot <- Safariland %>%
    web_matrix_to_df() %>%
    boot_specieslevel_n(col_lower = "lower",
                        col_higher = "higher",
                        index = index,
                        level = "lower",
                        start = 100,
                        step = 100,
                        n_boot = 6,
                        n_cpu = 2)

  expect_true(inherits(sf_boot, 'list'))
  expect_true(length(sf_boot) == 1)

  expect_match(names(sf_boot), "lower_level", fixed = TRUE)

  expect_true(inherits(sf_boot[[1]], 'array'))

  expect_true(length(dim(sf_boot[[1]])) == 3)

  expect_true(dim(sf_boot[[1]])[3] == 6) # because n_boot = 6

  expect_true(typeof(sf_boot[[1]]) == "double")

  # Are all last columns of the matrices identical?
  unq_length <- get_length_unq(sf_boot[[1]])
  expect_equal(unq_length, 1)

  # Is the last bootstrap value correct? As per bipartite::specieslevel ?
  final_boot_val <- sf_boot[[1]] %>% .[, ncol(.), 1] %>% as.data.frame
  expect_equivalent(final_boot_val, test_both[["lower level"]])
})

# Test betweenness --------------------------------------------------------

# Note that "betweenness" has an weighted version. That is,
# bipartite::specieslevel() to return a two column data frame - "betweenness" &
# "weighted.betweenness" (see below).

index <- "betweenness"

# For full reproducibly is safer to reorder the Safariland matrix
# alphabetically.
sf_sort <- Safariland %>%
  .[, order(colnames(.))] %>%
  .[order(rownames(.)), ]

set.seed(42)
test_both <- specieslevel(sf_sort, index = index, level = "both")

# ~ both levels -----------------------------------------------------------

test_that('"betweenness" index output is ok for both levels', {
  sf_boot <- Safariland %>%
    web_matrix_to_df() %>%
    boot_specieslevel_n(col_lower = "lower",
                        col_higher = "higher",
                        index = index,
                        level = "both",
                        start = 100,
                        step = 100,
                        n_boot = 6,
                        n_cpu = 2)

  expect_true(inherits(sf_boot, 'list'))
  expect_true(length(sf_boot) == 4) # one array for each level

  expect_match(names(sf_boot)[1], "higher_level", fixed = TRUE)
  expect_match(names(sf_boot)[2], "higher_level_weighted", fixed = TRUE)
  expect_match(names(sf_boot)[3], "lower_level", fixed = TRUE)
  expect_match(names(sf_boot)[4], "lower_level_weighted", fixed = TRUE)

  expect_true(inherits(sf_boot[["higher_level"]], 'array'))
  expect_true(inherits(sf_boot[["higher_level_weighted"]], 'array'))
  expect_true(inherits(sf_boot[["lower_level"]], 'array'))
  expect_true(inherits(sf_boot[["lower_level_weighted"]], 'array'))

  expect_true(length(dim(sf_boot[["higher_level"]])) == 3)
  expect_true(length(dim(sf_boot[["higher_level_weighted"]])) == 3)
  expect_true(length(dim(sf_boot[["lower_level"]])) == 3)
  expect_true(length(dim(sf_boot[["lower_level_weighted"]])) == 3)

  expect_true(dim(sf_boot[["higher_level"]])[3] == 6) # because n_boot = 6
  expect_true(dim(sf_boot[["higher_level_weighted"]])[3] == 6)
  expect_true(dim(sf_boot[["lower_level"]])[3] == 6)
  expect_true(dim(sf_boot[["lower_level_weighted"]])[3] == 6)

  expect_true(typeof(sf_boot[["higher_level"]]) == "double")
  expect_true(typeof(sf_boot[["higher_level_weighted"]]) == "double")
  expect_true(typeof(sf_boot[["lower_level"]]) == "double")
  expect_true(typeof(sf_boot[["lower_level_weighted"]]) == "double")

  # Are all lastcolumns of the matrices identical?
  unq_length_hl <- get_length_unq(sf_boot[["higher_level"]])
  expect_equal(unq_length_hl, 1)

  unq_length_hlw <-  get_length_unq(sf_boot[["higher_level_weighted"]])
  expect_equal(unq_length_hlw, 1)

  unq_length_ll <-  get_length_unq(sf_boot[["lower_level"]])
  expect_equal(unq_length_ll, 1)

  unq_length_llw <-  get_length_unq(sf_boot[["lower_level_weighted"]])
  expect_equal(unq_length_llw, 1)

  # Is the last bootstrap value correct? As per bipartite::specieslevel ?
  final_boot_val_hl <- sf_boot[["higher_level"]] %>% .[, ncol(.), 1] %>% as.data.frame
  expect_equivalent(final_boot_val_hl, test_both[["higher level"]][, "betweenness", drop = FALSE])

  final_boot_val_hlw <- sf_boot[["higher_level_weighted"]] %>% .[, ncol(.), 1] %>% as.data.frame
  expect_equivalent(final_boot_val_hlw, test_both[["higher level"]][, "weighted.betweenness", drop = FALSE])

  final_boot_val_ll <- sf_boot[["lower_level"]] %>% .[, ncol(.), 1] %>% as.data.frame
  expect_equivalent(final_boot_val_ll, test_both[["lower level"]][, "betweenness", drop = FALSE])

  final_boot_val_llw <- sf_boot[["lower_level_weighted"]] %>% .[, ncol(.), 1] %>% as.data.frame
  expect_equivalent(final_boot_val_llw, test_both[["lower level"]][, "weighted.betweenness", drop = FALSE])
})

# ~ higher level ----------------------------------------------------------

test_that('"betweenness" index output is ok for higher level', {
  sf_boot <- Safariland %>%
    web_matrix_to_df() %>%
    boot_specieslevel_n(col_lower = "lower",
                        col_higher = "higher",
                        index = index,
                        level = "higher",
                        start = 100,
                        step = 100,
                        n_boot = 6,
                        n_cpu = 2)

  expect_true(inherits(sf_boot, 'list'))
  expect_true(length(sf_boot) == 2) # one array for each level

  expect_match(names(sf_boot)[1], "higher_level", fixed = TRUE)
  expect_match(names(sf_boot)[2], "higher_level_weighted", fixed = TRUE)

  expect_true(inherits(sf_boot[["higher_level"]], 'array'))
  expect_true(inherits(sf_boot[["higher_level_weighted"]], 'array'))

  expect_true(length(dim(sf_boot[["higher_level"]])) == 3)
  expect_true(length(dim(sf_boot[["higher_level_weighted"]])) == 3)

  expect_true(dim(sf_boot[["higher_level"]])[3] == 6) # because n_boot = 6
  expect_true(dim(sf_boot[["higher_level_weighted"]])[3] == 6)

  expect_true(typeof(sf_boot[["higher_level"]]) == "double")
  expect_true(typeof(sf_boot[["higher_level_weighted"]]) == "double")

  # Are all lastcolumns of the matrices identical?
  unq_length_hl <- get_length_unq(sf_boot[["higher_level"]])
  expect_equal(unq_length_hl, 1)

  unq_length_hlw <-  get_length_unq(sf_boot[["higher_level_weighted"]])
  expect_equal(unq_length_hlw, 1)

  # Is the last bootstrap value correct? As per bipartite::specieslevel ?
  final_boot_val_hl <- sf_boot[["higher_level"]] %>% .[, ncol(.), 1] %>% as.data.frame
  expect_equivalent(final_boot_val_hl, test_both[["higher level"]][, "betweenness", drop = FALSE])

  final_boot_val_hlw <- sf_boot[["higher_level_weighted"]] %>% .[, ncol(.), 1] %>% as.data.frame
  expect_equivalent(final_boot_val_hlw, test_both[["higher level"]][, "weighted.betweenness", drop = FALSE])
})

# ~ lower level -----------------------------------------------------------

test_that('"betweenness" index output is ok for lower level', {
  sf_boot <- Safariland %>%
    web_matrix_to_df() %>%
    boot_specieslevel_n(col_lower = "lower",
                        col_higher = "higher",
                        index = index,
                        level = "lower",
                        start = 100,
                        step = 100,
                        n_boot = 6,
                        n_cpu = 2)

  expect_true(inherits(sf_boot, 'list'))
  expect_true(length(sf_boot) == 2) # one array for each level

  expect_match(names(sf_boot)[1], "lower_level", fixed = TRUE)
  expect_match(names(sf_boot)[2], "lower_level_weighted", fixed = TRUE)

  expect_true(inherits(sf_boot[["lower_level"]], 'array'))
  expect_true(inherits(sf_boot[["lower_level_weighted"]], 'array'))

  expect_true(length(dim(sf_boot[["lower_level"]])) == 3)
  expect_true(length(dim(sf_boot[["lower_level_weighted"]])) == 3)

  expect_true(dim(sf_boot[["lower_level"]])[3] == 6)
  expect_true(dim(sf_boot[["lower_level_weighted"]])[3] == 6)

  expect_true(typeof(sf_boot[["lower_level"]]) == "double")
  expect_true(typeof(sf_boot[["lower_level_weighted"]]) == "double")

  # Are all lastcolumns of the matrices identical?
  unq_length_ll <-  get_length_unq(sf_boot[["lower_level"]])
  expect_equal(unq_length_ll, 1)

  unq_length_llw <-  get_length_unq(sf_boot[["lower_level_weighted"]])
  expect_equal(unq_length_llw, 1)

  # Is the last bootstrap value correct? As per bipartite::specieslevel ?
  final_boot_val_ll <- sf_boot[["lower_level"]] %>% .[, ncol(.), 1] %>% as.data.frame
  expect_equivalent(final_boot_val_ll, test_both[["lower level"]][, "betweenness", drop = FALSE])

  final_boot_val_llw <- sf_boot[["lower_level_weighted"]] %>% .[, ncol(.), 1] %>% as.data.frame
  expect_equivalent(final_boot_val_llw, test_both[["lower level"]][, "weighted.betweenness", drop = FALSE])
})


1
------
i <= 5
i >= 5 || j >= 5
i < 5
j != 10

2
------
i <= 5
i >= 5 || j >= 5
i < 5
i == 2 (or) j == 2
i == 2 (and) j == 2
j != 10
j == 5 || i == 2

3
------
i <= 5
i >= 5 || j >= 5
i < 5
j != 10

4
------
i <= 5
i >= 5 || j >= 5
i < 5
j != 10

5
------
i == 5 (or) i == 10
i <= 5
j >= 5
i >= 5 || j >= 5
j >= 5 && i <= 55
j != 10
j == 5 || i == 2

6
------
j >= 5
i >= 5 || j >= 5
j != 10

7
------
j >= 5
i >= 5 || j >= 5
j != 10

8
------
j >= 5
i >= 5 || j >= 5
j != 10

9
------
j >= 5
i >= 5 || j >= 5
j != 10

10
------
i == 5 (or) i == 10
j >= 5
i >= 5 || j >= 5
i == 10


do_job <- function(lo){

# snowfall job to simulate sampling
# Nuno Prista, SLU Aqua, 2019 @  Kustmonitoring

# simulates sampling
	dt_site<-as.data.frame(dt_site)
	sim_sampId <- do_sampling_stratified_timeseries(sampDes, sampOpt, dataset = dt_site, sampId = "sampId")

# fetches sampled rows from dataset based on sampId + creates variable with "SampSizeName"
	sim_samples<-lapply(sim_sampId, function(x, a1 = dt_site) lapply( x, function (y, a2 = a1) {y <- as.data.table(data.frame(SampSize = y[1], a2[y[-1],])) } ) )

# separates replicates into years
		# [[1]] - SampSize being tested
		# [[2]] - Replicate
		# [[3]] - Year
		sim_samples<-lapply(sim_samples, function(x) lapply(x, function(y) split(y, y$Year)))
			# demonstration
			# table(sim_samples[[1]][[1]][[3]][,c("Year","DepthStratum")])
			# table(sim_samples[[2]][[1]][[3]][,c("Year","DepthStratum")])
			# table(sim_samples[[2]][[1]][[1]][,c("Year","DepthStratum")])

# calculates the mean and its statistics
		# stratified mean of all stations
		# the following lapply runs "do_summary_stratified_mean" on each of target_vars
		res_stratified<-lapply(sim_samples, function(z) { lapply(z, function(y) {lapply(y, function (y1, target_vars1 = target_vars){
		a<-(lapply(target_vars1, function(x, x1 = y1)  {a<-do_summary_stratified_mean(x = x1, target_var = x, strata_var = "DepthStratum", strata_size_var = "NStations", klab=TRUE); res = list(pop_res = data.table(Area = x1$Area[1], Season = x1$Season[1], Year = x1$Year[1], SampSize = x1$SampSize[1], repl = lo, a$pop_res), stratum_res = data.table(Area = x1$Area[1], Season = x1$Season[1], Year = x1$Year[1], SampSize = x1$SampSize[1], repl = lo, a$stratum_res))} ))
		})})})
	a<-list(res = 	res_stratified, sim_samples = sim_samples)

}

do_job1 <- function(lo){

# forreach_mc job to simulate sampling
# Nuno Prista, SLU Aqua, 2019 @  Kustmonitoring

# simulates sampling
	dt_site<-as.data.frame(dt_site)
	sim_sampId <- do_sampling_stratified_timeseries(sampDes, sampOpt, dataset = dt_site, sampId = "sampId")

# fetches sampled rows from dataset based on sampId + creates variable with "SampSizeName"
	sim_samples<-lapply(sim_sampId, function(x, a1 = dt_site) lapply( x, function (y, a2 = a1) {y <- as.data.table(data.frame(SampSize = y[1], a2[y[-1],])) } ) )

# separates replicates into years
		# [[1]] - SampSize being tested
		# [[2]] - Replicate
		# [[3]] - Year
		sim_samples<-lapply(sim_samples, function(x) lapply(x, function(y) split(y, y$Year)))
			# demonstration
			# table(sim_samples[[1]][[1]][[3]][,c("Year","DepthStratum")])
			# table(sim_samples[[2]][[1]][[3]][,c("Year","DepthStratum")])
			# table(sim_samples[[2]][[1]][[1]][,c("Year","DepthStratum")])
	rm(sim_sampId, dt_site)
	gc()

# calculates the mean and its statistics

	# stratified mean of all stations
	# the following lapply runs "do_summary_stratified_mean" on each of target_vars
	res_stratified<-lapply(sim_samples, function(z) { z<-lapply(z, function(y) {y<-lapply(y, function (y1, target_vars1 = target_vars){

	a<- lapply(target_vars1, function(x, x1 = y1)
						{
						a<-do_summary_stratified_mean(x = x1, target_var = x, strata_var = "DepthStratum", strata_size_var = "NStations", klab=TRUE)

						res = list(
								pop_res = data.table(Area = x1$Area[1], Season = x1$Season[1], Year = x1$Year[1], SampSize = x1$SampSize[1], repl = lo, a$pop_res),
								stratum_res = data.table(Area = x1$Area[1], Season = x1$Season[1], Year = x1$Year[1], SampSize = x1$SampSize[1], repl = lo, a$stratum_res)
								)
						res
						}
				)
		list(pop_res = rbindlist(lapply(a, function(x) x<-x$pop_res)), stratum_res = rbindlist(lapply(a, function(x) x<-x$stratum_res)))

	})
	list(pop_res = rbindlist(lapply(y, function(x) x<-x$pop_res)), stratum_res = rbindlist(lapply(y, function(x) x<-x$stratum_res)))
	})
	list(pop_res = rbindlist(lapply(z, function(x) x<-x$pop_res)), stratum_res = rbindlist(lapply(z, function(x) x<-x$stratum_res)))
	})
	res_stratified<-list(pop_res = rbindlist(lapply(res_stratified, function(x) x<-x$pop_res)), stratum_res = rbindlist(lapply(res_stratified, function(x) x<-x$stratum_res)))

	res_stratified$pop_res$repl<-lo
	res_stratified$stratum_res$repl<-lo

	sim_samples <- rbindlist(lapply(sim_samples, function(y) {w<-rbindlist(y[[1]],idcol=TRUE); w}),idcol=TRUE)
	sim_samples$repl<-lo

	list(sim_res_pop = res_stratified$pop_res, 	sim_res_strata = res_stratified$stratum_res, sim_samples = sim_samples)

}


## script calculates combined fisher p for permutations
library(survcomp)
START <- date() # for outputfile naming
stime <- gsub(":",";",(substr(START,12,19))) #starttime in outputfile
cutoff=0.05

for (i in 0:19){ #parts

  hlist<-read.csv(paste("A:/R_stuff/u27_metafisher/overview/Overview_H25_p",i,".csv", sep=""))
  hlistsub<-subset(hlist, select =2)
  colnames(hlistsub) <- ("RefSeq|SNP|U133")
  rlist<-read.csv(paste("A:/R_stuff/u27_metafisher/overview/Overview_R56_p",i,".csv", sep=""))
  rlistsub<-subset(rlist, select =2)
  colnames(rlistsub) <- ("RefSeq|SNP|U133")
  fisherp<-data.frame()

  for (k in 1:20) { #20 perm files of 50P each

    setwd("A:/R_stuff/test22_BioX2_H25_output")
    hfiles<-list.files(pattern=paste("permatrixND_part",i,"_50P",sep=""))
    h<-read.csv(hfiles[k])
    hsub<-subset(h, select = 10:59)
    #colnames(hsub) <- c(1:50)
    hcombi<-cbind(hlistsub,hsub) #nb hcombi is dataframe
    setwd("A:/R_stuff/u26_BioX2_R56_output")
    rfiles<-list.files(pattern=paste("R56_permatrixND_part",i,"_50P",sep=""))
    r<-read.csv(rfiles[k])
    rsub<-subset(r, select = 10:59)
    #colnames(rsub) <- c("pgeno_R56","bgeno_R56","bage_R56","page_R56" ,"brace_R56","prace_R56","bsex_R56","psex_R56")
    rcombi<-cbind(rlistsub,rsub) #nb hcombi is dataframe

    if (nrow(hlistsub) != nrow(h) || nrow(rlistsub) != nrow(r)){
      stop("WARNING: UNEQUAL ROW nrs!")
      } else { #print("rows are equal")
        m1<-merge(hcombi,rcombi,by.x="RefSeq|SNP|U133",by.y="RefSeq|SNP|U133") #joins both tables on column with probeset identifiers
        x<-nrow(m1)

        for (j in 1:x){ #rows
          for (l in 2:51){ # 50P cols
            n<-(l+50)
              if(is.na(m1[j,l])==F && is.na(m1[j,n])==F){
                if ((m1[j,l])<cutoff && (m1[j,n])<cutoff){

                  p<-c(m1[j,l],m1[j,n])
                  fcp<-combine.test(p=p, method="fisher")
                  fisherp<-rbind(fisherp,fcp)
              }
            }
          }
        }
      }
      print (paste("NOW PARSING Perm50P file nr. ",k,sep=""))
      print(date())
    }

  print(paste("NOW PRINTING: fisher_perm_p",i,".csv",sep=""))
  print(date())
  setwd("A:/R_stuff/u30_metafisher_perm")
  write.csv(fisherp, file=paste("fisher_perm_p",i,".csv",sep=""))
}

print(warnings())
print(START) #START
print(date()) #END


require(R.filesets)
require(Seurat) #v3.1.1
require(Matrix)
require(foreach)
require(doParallel)
require(future)
require(dplyr)
require(data_mat)

`%+%` <- paste0

workDir = "./PCKOvsWT_mESCs/"
setwd(workDir)

options(stringsAsFactors=F)
options(future.globals.maxSize= 2048 * 1024^2)

create_dir = function(adirpath){
  if (!dir.exists(adirpath)){
    dir.create(adirpath, recursive = TRUE)
  }
}

load_10X_data = function(adirpath){
  tmp_files = list.files(adirpath)
  if (length(which(tmp_files %in% c("barcodes.tsv.gz","features.tsv.gz","matrix.mtx.gz")))==3){
    tmp_mm = Read10X(adirpath)
    return(tmp_mm)
  } else {
    print(adirpath %+% " contains no 10X counts.")
    return(NULL)
  }
}

pretreat_cellFiltration = function(raw_expr_mat, report=TRUE, report_dir="."){
  ## filter potential cells of library with simple components/poor library/doublets
  cS = data.frame(libSize=colSums(raw_expr_mat), geneDetect=apply(raw_expr_mat, 2, function(X) sum(X>0)))
  tB = with(cS, geneDetect < (libSize*0.1))

  p_hi <- 1e-3
  p_lo <- 1e-2
  ## library size threshold
  tempFitLS <- fitdistr(cS$libSize[!tB], "negative binomial")
  c_hiL <- qnbinom(p_hi, size=tempFitLS$estimate["size"], mu=tempFitLS$estimate["mu"], lower.tail=F)
  c_loL <- qnbinom(p_lo, size=tempFitLS$estimate["size"], mu=tempFitLS$estimate["mu"], lower.tail=T)
  ## gene detection threshold
  tempFitGD <- fitdistr(cS$geneDetect[!tB], "negative binomial")
  c_hiG <- qnbinom(p_hi, size=tempFitGD$estimate["size"], mu=tempFitGD$estimate["mu"], lower.tail=F)
  c_loG <- qnbinom(p_lo, size=tempFitGD$estimate["size"], mu=tempFitGD$estimate["mu"], lower.tail=T)
  ## marker dangerous cells
  temp_doublets <- (cS$libSize[!tB] > c_hiL) | (cS$geneDetect[!tB] > c_hiG)
  temp_crapLibs <- (cS$libSize[!tB] < c_loL) | (cS$geneDetect[!tB] < c_loG)
  ## count matrix filtration
  raw_expr_mat_f <- raw_expr_mat[,!tB]
  raw_expr_mat_f <- raw_expr_mat_f[,!(temp_doublets | temp_crapLibs)]
  raw_expr_mat_f <- raw_expr_mat_f[rowSums(raw_expr_mat_f)>0,]
  ## report QC results
  if (report){
    results = list(cS=cS, tB=tB, rmat=raw_expr_mat, rmat_f=raw_expr_mat_f, temp_doublets=temp_doublets, temp_crapLibs=temp_crapLibs)
    pcontaminated_glist = report_qc_figures(results=results, output_dir=report_dir, check_contaminated=TRUE)
    return(list(expr_mat = raw_expr_mat_f, pc_glist=pcontaminated_glist))
  }
  return(raw_expr_mat_f)
}

pretreat_mitoFiltration = function(raw_expr_mat, report=TRUE, report_dir=".", mito_glist=NULL, ratio=0.4){
  if (is.null(mito_glist)){
    mito_gind = grepl("^MT-",rownames(raw_expr_mat))
  } else {
    mito_gind = which(rownames(raw_expr_mat) %in% mito_glist )
  }
  cSf <- data.frame(libSize=colSums(raw_expr_mat),
                    geneDetect=apply(raw_expr_mat,2,function(X) sum(X>0)),
                    mitoPct=colSums(raw_expr_mat[mito_gind,])/colSums(raw_expr_mat))

  drop_mitoMads <- 4
  drop_mitoCut <- median(cSf$mitoPct) + mad(cSf$mitoPct)*drop_mitoMads ## quantile
  if (drop_mitoCut > ratio) { drop_mitoCut <- ratio}
  drop_mito <- cSf$mitoPct > drop_mitoCut

  raw_expr_mat_f <- raw_expr_mat[,!drop_mito]
  raw_expr_mat_f <- raw_expr_mat_f[apply(raw_expr_mat_f,1,sum) > 0,]

  if(report){
    results = list(cSf=cSf, drop_mito=drop_mito,
                   drop_mitoMads=drop_mitoMads,
                   drop_mitoCut=drop_mitoCut,
                   rmat=raw_expr_mat,
                   rmat_f=raw_expr_mat_f)
    report_mito_figure(results, output_dir=report_dir)
  }
  return(raw_expr_mat_f)
}

report_qc_figures = function(results, output_dir, check_contaminated=FALSE){

  cS = results$cS
  tB = results$tB
  rmat = results$rmat
  rmat_f = results$rmat_f
  temp_doublets = results$temp_doublets
  temp_crapLibs = results$temp_crapLibs

  ## cells filtration
  QC_filtration_file = paste(output_dir,"QualityControl","QC_cellsFiltration.pdf",sep="/")
  create_dir(dirname(QC_filtration_file))
  pdf(file = QC_filtration_file, width = 8.4, height = 4.2)
  layout(cbind(matrix(c(2,1,0,3),2),matrix(c(5,4,0,6),2)),widths=c(3.5,.7,3.5,.7),heights=c(.7,3.5))
  ## figure1-library per cell vs detected genes per cell
  par(mar=c(3,3,0,0),mgp=2:0)
  plot(geneDetect~libSize,data=cS[!tB,],
       xlim=range(cS$libSize),ylim=range(cS$geneDetect),
       pch=21,col=alpha("black",0.2),bg=alpha("black",0.1),cex=1.2,
       xlab="Library Size",ylab="Genes Detected")
  points(geneDetect~libSize,data=cS[tB,],
         pch=21,col=alpha("red",0.2),bg=alpha("red",0.1),cex=1.2)
  points(geneDetect~libSize,data=cS[!tB,][temp_doublets | temp_crapLibs,],
         pch=4,cex=1.2,col="red")
  mtext(paste("cell stats"),side=3,line=-1.5,font=2,cex=1.2)
  legend("topleft",bty="n",inset=c(-.02,.05),
         legend=c(paste("Total genes:",nrow(rmat)),
                  paste("Post-filter:",nrow(rmat_f)),
                  paste("Total cells:",ncol(rmat))))
  legend("bottomright",bty="n",
         pch=c(4,4,21,21),
         col=c("red","red","red","black"),
         pt.bg=alpha(c(NA,NA,"red","black"),0.3),
         y.intersp=1.3,
         legend=c(paste(sep="\n","Poor-quality libraries",
                  paste0("(p<",p_lo,"): ",sum(temp_crapLibs))),
                  paste(sep="\n","Predicted doublets",
                  paste0("(p<",p_hi,"): ",sum(temp_doublets))),
                  paste("Outlier cells:",sum(tB)),
                  paste("Remain cells:",ncol(rmat_f))))
  ## distribution for library per cell
  par(mar=c(0,3,1,0))
  tempD <- density(rnbinom(10000,size=tempFitLS$estimate["size"],mu=tempFitLS$estimate["mu"]))
  hist(cS$libSize,breaks=100,freq=F,col="grey",main=NULL,xaxt="n",ylab="Density")
  lines(tempD,lwd=2,col=alpha("red",0.5))
  abline(v=c_hiL,lty=2,lwd=2,col="darkred")
  abline(v=c_loL,lty=2,lwd=2,col="darkred")
  ## distribution for detected genes per cell
  par(mar=c(3,0,0,1))
  tempD <- density(rnbinom(10000,size=tempFitGD$estimate["size"],mu=tempFitGD$estimate["mu"]))
  tempH <- hist(cS$geneDetect,breaks=100,plot=F)
  tempB <- barplot(tempH$density,horiz=T,space=0,col="grey",main=NULL,xlab="Density")
  tempSF <- (max(tempB) - min(tempB)) / (max(tempH$mids) - min(tempH$mids))
  lines(y=tempD$x * tempSF + (min(tempB) - min(tempH$mids) * tempSF),
        x=tempD$y,lwd=2,col=alpha("red",0.5))
  abline(h=c_hiG * tempSF + (min(tempB) - min(tempH$mids) * tempSF),lty=2,lwd=2,col="darkred")
  abline(h=c_loG * tempSF + (min(tempB) - min(tempH$mids) * tempSF),lty=2,lwd=2,col="darkred")
  ## figure2-library per cell(log scale) vs detected genes per cell
  par(mar=c(3,3,0,0),mgp=2:0)
  plot(geneDetect~libSize,data=cS[!tB,],log="x",
       xlim=range(cS$libSize),ylim=range(cS$geneDetect),
       pch=21,col=alpha("black",0.2),bg=alpha("black",0.1),cex=1.2,
       xlab="Library Size (log scale)",ylab="Genes Detected")
  points(geneDetect~libSize,data=cS[tB,],
         pch=21,col=alpha("red",0.2),bg=alpha("red",0.1),cex=1.2)
  points(geneDetect~libSize,data=cS[!tB,][temp_doublets | temp_crapLibs,],
         pch=4,cex=1.2,col="red")
  mtext(paste("cell stats"),side=3,line=-1.5,font=2,cex=1.2)
  legend("topleft",bty="n",y.intersp=1.3,inset=c(0,.05),
         pch=c(4,4,21),col="red",pt.bg=alpha(c(NA,NA,"red"),0.3),
         legend=c(paste(sep="\n","Poor-quality libraries",
                  paste0("(p<",p_lo,"): ",sum(temp_crapLibs))),
                  paste(sep="\n","Predicted doublets",
                  paste0("(p<",p_hi,"): ",sum(temp_doublets))),
                  paste("Outlier cells:",sum(tB))))
  ## library per cell (log scale), histogram plot
  par(mar=c(0,3,1,0))
  hist(log10(cS$libSize),breaks=100,freq=F,col="grey",main=NULL,xaxt="n",ylab="Density")
  abline(v=log10(c_hiL),lty=2,lwd=2,col="darkred")
  abline(v=log10(c_loL),lty=2,lwd=2,col="darkred")
  ## detected genes per cell, histogram plot
  par(mar=c(3,0,0,1))
  tempH <- hist(cS$geneDetect,breaks=100,plot=F)
  tempB <- barplot(tempH$density,horiz=T,space=0,col="grey",main=NULL,xlab="Density")
  tempSF <- (max(tempB) - min(tempB)) / (max(tempH$mids) - min(tempH$mids))
  abline(h=c_hiG * tempSF + (min(tempB) - min(tempH$mids) * tempSF),lty=2,lwd=2,col="darkred")
  abline(h=c_loG * tempSF + (min(tempB) - min(tempH$mids) * tempSF),lty=2,lwd=2,col="darkred")
  dev.off()

  if (check_contaminated){
    ### pretreatment_contamFilt
    ## DR: detected ratio, MDTC: mean detected tx per cell, MTC: mean tx per cell
    gsOut <- data.frame(DR=apply(rmat[,tB],1,function(X) sum(X > 0)/length(X)),
                        MDTC=apply(rmat[,tB],1,function(X) mean(X[X>0])),
                        MTC=apply(rmat[,tB],1,mean))
    rownames(gsOut) <- rownames(rmat)
    gsIn <- data.frame(DR=apply(rmat_f,1,function(X) sum(X > 0)/length(X)),
                       MDTC=apply(rmat_f,1,function(X) mean(X[X>0])),
                       MTC=apply(rmat_f,1,mean))
    rownames(gsIn) <- rownames(rmat_f)
    ## contamination filtration
    QC_contamination_file = paste(output_dir,"QualityControl","QC_contaminationFiltration.pdf",sep="/")
    create_dir(dirname(QC_contamination_file))
    pdf(file = QC_contamination_file, width = 8.4, height = 4.2)
    ## figure1-outlier cells
    par(mfrow=c(1,2),mar=c(3,3,2,1),mgp=2:0)
    tempMGC <- 1e2
    plot(log10(MDTC)~DR,data=gsOut,
         pch=21,cex=1.2,xlab="Proportion of cells detecting gene",
         ylab=expression(Log[10]~"Mean non-zero gene count"),
         col=alpha(c("black","red"),0.3)[(gsOut$MTC > tempMGC)+1],
         bg=alpha(c("black","red"),0.1)[(gsOut$MTC > tempMGC)+1],
         main=paste("outlier cells"))
    text(log10(MDTC)~DR,data=gsOut[gsOut$MTC > tempMGC,],
         labels=rownames(gsOut)[gsOut$MTC > tempMGC],pos=2,col="darkred",cex=0.6)
    tempMGCnames <- rownames(gsOut[gsOut$MTC > tempMGC,])
    ## figure2-gene distribution of high expressed genes detected in outlier cells in hi-QC cells
    plot(log10(MDTC)~DR,data=gsIn[!rownames(gsIn) %in% tempMGCnames,],
         pch=21,cex=1.2,col=alpha("black",0.3),bg=alpha("black",0.1),
         xlab="Proportion of cells detecting gene",
         ylab=expression(Log[10]~"Mean non-zero gene count"),
         main=paste("main cell population"))
    points(log10(MDTC)~DR,data=gsIn[tempMGCnames,],
           pch=21,cex=1.2,col=alpha("red",0.5),bg=alpha("red",0.3))
    text(log10(MDTC)~DR,data=gsIn[tempMGCnames,],pos=4,col="red",cex=1.2,
         labels=rownames(gsIn)[rownames(gsIn) %in% tempMGCnames])
    dev.off()
    ## potential contaminated gene list
    QC_contaminationGene_file = paste(output_dir, "QualityControl", "potential_contamination_geneList.txt", sep="/")
    write.table(tempMGCnames, file=QC_contaminationGene_file, sep="\t", col.names=TRUE, row.names=TRUE)
    return(tempMGCnames)
  }
}

report_mito_figure = function(results, output_dir="."){

  cSf = results$cSf
  drop_mito = results$drop_mito
  drop_mitoMads = results$drop_mitoMads
  drop_mitoCut = results$drop_mitoCut
  rmat = results$rmat
  rmat_f = results$rmat_f

  QC_mitochondrion_file = paste(output_dir,"QualityControl","QC_mitoFiltration.pdf",sep="/")
  create_dir(dirname(QC_mitochondrion_file))
  pdf(file = QC_mitochondrion_file, width = 9.4, height = 4.7)
  layout(matrix(c(1,2,4,3,0,5),2),c(4.1,4.1,1),c(0.7,3.8))
  par(mar=c(0,3,3,1),mgp=2:0)
  plot.new()
  title(main=paste("Filtered on mitochondrial\ngene expression proportion"))
  ## figure1-highlight cells with high mitochondrial gene ratio
  par(mar=c(3,3,0,1))
  plot(geneDetect~libSize,data=cSf,log="x",
       pch=21,cex=1.2,col=alpha("black",0.2),bg=alpha("black",0.1),
       xlab="Library Size (log scale)",ylab="Genes detected",
       xlim=range(cSf$libSize),ylim=range(cSf$geneDetect))
  points(geneDetect~libSize,data=cSf[drop_mito,],pch=4,cex=1.2,col=alpha("red",.5))
  legend("topleft",bty="n",pch=c(4,NA,NA,NA,NA),col=alpha(c("red",NA,NA,NA,NA),0.5),
         legend=c(paste(drop_mitoMads,"MADs above median"),
                  paste(sum(drop_mito),"cells removed"),
                  paste(ncol(rmat_f),"cells remain"),
                  paste(nrow(rmat)-nrow(rmat_f),"genes removed"),
                  paste(nrow(rmat_f),"genes remain")))
  ## figure2-highlight cells with high mitochondrial reads
  par(mar=c(3,3,0,0))
  plot(mitoPct~libSize,data=cSf,log="x",
       pch=21,cex=1.2,col=alpha("black",0.2),bg=alpha("black",0.1),
       xlab="Library Size (log scale)",ylab="Mitochondrial Transcript Proportion")
  abline(h=drop_mitoCut,lwd=2,lty=2,col=alpha("red",0.5))
  legend("topright",bty="n",lty=c(2,NA,NA,NA,NA),lwd=c(2,NA,NA,NA,NA),col=alpha(c("red",NA,NA,NA,NA),0.5),
         legend=c(paste(drop_mitoMads,"MADs above median"),
                  paste(sum(drop_mito),"cells removed"),
                  paste(ncol(rmat_f),"cells remain"),
                  paste(nrow(rmat)-nrow(rmat_f),"genes removed"),
                  paste(nrow(rmat_f),"genes remain")))
  ## figure3-distribution of library
  par(mar=c(0,3,0,0))
  hist(cSf$libSize,freq=T,breaks=50,col="grey",main=NULL,xaxt="n")
  ## figure4-distribution of mitochondrial proportion
  par(mar=c(3,0,0,0))
  barplot(hist(cSf$mitoPct,breaks=50,plot=F)$counts,
          horiz=T,space=0,col="grey",main=NULL,xlab="Frequency")
  dev.off()
}


setwd('/Users/Cam/Desktop/ds_practice/hockey_dat')
getwd()
ls()
options(prompt='R> ')
options(continue = '\t')

save.image('hockey_salary')
load('hockey_salary')
install.packages('ggplot2')
# load libraries
library('randomForest')
library('plyr')
library('stringr')
library('tidyverse')
library('magrittr')
library('scatterplot3d')
library('xgboost')

#3 Read in the data
train = read.csv('train.csv')
head(train)
test_x = read.csv('test.csv')
head(test_x)
test_y = read.csv('test_salaries.csv')
head(test_y)

#4 impute missing data and fix problem categorical columns
#to do this we merge the train and test data into a single set

#######
# add a column that labels data as members of the train or test populations.
# then work with the all_data for this section, and split after step 4.
######

#add train/test column
test_x$TrainTest = "test"
train$TrainTest =  "train"

test = cbind(test_y, test_x)
all_data = rbind(train,test)

#where are there missing values?

all_missing_list=  colnames(all_data)[colSums(is.na(all_data)) > 0]

#4aDONE
# make new column for undrafted

all_data$undrafted = is.na(all_data$DftRd)

#4cDONE fill the Pr.St column with 'INT' for international players

all_data$Pr.St = mapvalues(all_data$Pr.St, from = "", to="INT")
?mapvalues

#4dDONE Make team boolean columns
#get the unique list of team acronymns
teams = c()
for( i in levels(all_data$Team)){
	x = strsplit(i, "/")
	for(y in x){
		teams = c(teams, y)
	}
}
teams = unique(teams)

# add columns with the team names as the header and 0 as values
for(team in teams){
	all_data[,team] = 0
}

#iterate through and record the teams for each player
for(i in 1:length(all_data$Team)){
	teams_of_person = strsplit(as.character(all_data$Team[i]), "/")[[1]]
	for(x in teams_of_person){
		all_data[,x][i] = 1
	}
}

#4e Make position boolean columns
pos = c()
for( i in levels(all_data$Position)){
	x = strsplit(i, "/")
	for(y in x){
		pos = c(pos, y)
	}
}
pos = unique(pos)

# add columns with the pos names as the header and 0 as values
for(position in pos){
	all_data[,position] = 0
}

#iterate through and record the position(s) for each player
for(i in 1:length(all_data$Position)){
	pos_of_person = strsplit(as.character(all_data$Position[i]), "/")[[1]]
	for(x in pos_of_person){
		all_data[,x][i] = 1
	}
}

#4fDONE turn the born column into
# an age column
# 3 integer columns year:month:date

bday_parts = str_split_fixed(all_data$Born, "-",3)

#adjust year column to account for missing digits
table(birth_year)
birth_year = c()
for(year in bday_parts[,1]){
	if(as.numeric(year) < 10){
		yr = paste("20", year, sep="")
		birth_year = c(birth_year, yr)
	}else{
		yr = paste("19",year, sep="")
		birth_year = c(birth_year, yr)
	}
}

all_data$birth_year = as.numeric(birth_year)
all_data$birth_month = as.numeric(bday_parts[,2])
all_data$birth_day = as.numeric(bday_parts[,3])

#4gDONE split Cntry and Nat to boolean columns

birth_country = levels(all_data$Cntry)
# add columns with the country of birth options
# note the Estonia for Uncle Leo
for(country in birth_country){
	c = paste("born", country, sep="_")

	all_data[,c] = 0
}

#iterate through and record the birth country of each player
for(i in 1:length(all_data$Cntry)){
	birth_country = all_data$Cntry[i]
	c = paste("born", birth_country, sep="_")
	all_data[,c][i] = 1
}

nationality = levels(all_data$Nat)
for(country in nationality){
	c = paste("nation", country, sep="_")
	all_data[,c] = 0
}

#iterate through and record the birth country of each player
for(i in 1:length(all_data$Nat)){
	nationality = all_data$Nat[i]
	c = paste("nation", nationality, sep="_")
	all_data[,c][i] = 1
}

#4hDONE impute the missing value's median for numerical columns

#fill median values
#loop through the dataframe, filling each column with the median of
#the existing values for the entire dataset
#where are there still missing values?

all_missing_list =  colnames(all_data)[colSums(is.na(all_data)) > 0]
length(all_missing_list) == 0
#if above true all values are imputed!

for( i in 1:length(all_missing_list)){
	#get the global median
	median_all = median(all_data[,all_missing_list[i]], na.rm =TRUE)
	#imput the missing values with the column's median
	all_data[,all_missing_list[i]][is.na(all_data[,all_missing_list[i]])] = median_all
}

#5 Graphical analyses & fun hypotheses

#how many players from each country?
#Canadians are over half of the NHL!
barplot(sort(table(all_data$Nat),decreasing=TRUE), horiz=TRUE, las=1,col=c("red","blue4","blue","red3","skyblue"))

#age distribution
table(all_data$birth_year)
#behold the beaitiful outlier that is Jagr, note there are 15 nhl players born
#in 2000 or later! This makes me feel old
hist(all_data$birth_year, breaks=28, col="skyblue", xlab='Year of birth', main='Distribution of NHL player Age;\nAKA Jaromir Jagr the ancient outlier')

#jagr aside, there is some left skew to the plot, father time comes for us all but some seem better at delaying the effects!

#median birth year is 1992
median(all_data$birth_year)

#correlation of age and salary
#range of players making between 575,000 and 14,000,000
#that is quite the distribution!
summary(all_data$Salary)
hist(all_data$Salary)

#Does scoring more directly lead to getting more money?
plot(all_data$G, all_data$Salary, xlab='goals scored', ylab='money earned')
#few players with lots of goals and not much financial compensation

plot(all_data$G, all_data$Salary, xlab='goals scored', ylab='money earned', main="who are the outliers?")
text(all_data$G, all_data$Salary, labels=all_data$Last.Name, cex=0.7, pos = 3)
# big outliers in the bottom right are Auston Matthews and Patrick Laine. These were the first and second overall picks in the previous years entry draft. One could argue that they provide the most cost effective scoring in the league. This highlights the value of the entry draft in the salary cap era, it provides high quality players at rock bottom prices. There are clearly multiple factors that are affecting how much a player makes, and things like rookie contracts cause there to be strong interaction effects between on ice metrics of success (such as goals, corsi, +/-, time on ice, etc.) and other considerations such as the players age.

matthews_goal_price =925000/40
matthews_goal_price #only $23,125 a goal! what a deal!

crosby_goal_price = 10900000/44
crosby_goal_price
#Crosby was paid $247,727  a goal. The median house price in Pittsburgh is $123,500 so Sid could by two houses for every goal he scores.
Crosby_homes = 44*4
pittsburgh_households = 143739
Crosby_market_share = Crosby_homes/pittsburgh_households
Crosby_market_share
#So over his current 12 year contract he could easily by up 1% of the total pittsburgh housing market(before taxes)

##############
# 3-d plots
##############

color.gradient <- function(x, colors=c("green", "yellow", "red"), colsteps=100) {
  return( colorRampPalette(colors) (colsteps) [ findInterval(x, seq(min(x),max(x), length.out=colsteps)) ] )
}

sd3 = scatterplot3d(all_data$G, all_data$birth_year,  all_data$Salary, # x y and z
                 pch=19,
                 type="h",
			cex.axis=0.5,
			las=1,
			lty.hplot=2,
                	color=color.gradient(all_data$Salary,c("black","salmon")),
			main="Interaction of age, goals and salary",
                 zlab="Salary",
                xlab="Goals",
			ylab="Birth Year",
			grid=TRUE)

sd3.coords = sd3$xyz.convert(all_data$G, all_data$birth_year,  all_data$Salary) # convert 3D coords to 2D projection
text(sd3.coords$x, sd3.coords$y,labels=all_data$Last.Name,cex=.5, pos=4)

#Few interesting things we can pull from the noise here, besides the already noted Laine-Matthews proximity look at the proximity of Malkin and Ovechkin in the middle. These were the #1 and #2 draft picks in the 2004 draft! So as one may expect, if Laine and Matthews don't get horribly injured then their contracts and on ice productivity may remain highly correlated as they age ( this makes sense when you consider contract negotiation would invovle agents and teams putting large weight on the contracts of 'comparable players')

#note how close Subban and Weber are in 3-d space (top left) these are two players that were traded for one another in the previous off season

#Also, Towes and Kane (the twin towers of Chicago's salary cap hell) stick far above everyone else! Kopitar is also looking pretty overpaid considering his numbers line him up with the defencemen and not the goal scorers on the graph!

# two main classes of players seem to stick out from the glob in the middle, vetran defenceman in the top left (Seabrook, Suter, Weber, Suban) and young goal scorers in the bottom right (McDavid, Laine, Matthews, Kucherov). I suspect the random forest regression will be able to accomplish what I just did by eye, using the large number of on ice metrics we have (not just goals!) and developing bins that we could in plain english think of as 'vetran defenceman', 'young goal scorer', 'aging star', 'goon' etc. With these player profiles modelled. I suspect we will be able to get some extremly accurate salary predictions.

score_3d = scatterplot3d(all_data$TOI, all_data$SCF,  all_data$Salary, # x y and z
                 pch=19,
                 type="h",
			cex.axis=0.5,
			las=1,
			lty.hplot=2,
                	color=color.gradient(all_data$Salary, colors=c("black","skyblue")),
			main="More linear relationships:\nSalary, time on ice, and scoring chances",
                 zlab="Salary",
                xlab="Time on ice(s)",
			ylab="scoring chances while player on ice",
			grid=TRUE)

score_3d.coords = score_3d$xyz.convert(all_data$TOI, all_data$SCF,  all_data$Salary) # convert 3D coords to 2D projection
text(score_3d.coords$x, score_3d.coords$y,labels=all_data$Last.Name,cex=.5, pos=4)

#here we see a much more strong relationship, guys spending more time on the ice, and helping their teams generate scoring chances are getting paid more. Apologies to Anze Kopitar for my earlier dig, looks like he provides more value than the goals analysis alone indicated!

#Toronto Maple leafs fans look at Nikita Zaitsev lurking at a low salary in the high minutes/high scoring chances region of the graph! That is a young defencemen giving quality minutes on a level that is approaching some of the top vetran d men in the league.

#6 Split train/test into two dfs again

#Remove the columns we replaced in step 4 (don't want 'Sidney' to be best predictor of salary), city for same reason, Cole Harbour NS and sililar small towns could cause overfit
#write the whole adjusted dataframe to a file
write.csv(all_data,'all_data_manipulated.csv')
all_data = all_data[, !(colnames(all_data) %in% c("Last.Name","First.Name","Cntry","Nat","Born","Team","City","Position"))]
head(all_data)

train_dat = all_data[all_data$TrainTest == "train",]

test_dat = all_data[all_data$TrainTest == "test",]
#we lose anyone?
length(test_dat$TrainTest) + length(train_dat$TrainTest) == length(all_data$TrainTest)

#drop the train/test split columns
train_dat = train_dat[, !(colnames(train_dat) %in% c("TrainTest"))]
test_dat = test_dat[, !(colnames(test_dat) %in% c("TrainTest"))]

#7 feature selection
#now lets run an iterative rf regression

############
# iterative randomforest drop
############
#this function will perform a random forest regression on the data, drop the lowest
#predictor, and then repeat the process until the best predictor is identified
#it will return a dataframe with the pseudo-rsquared
#note the ntree parameter in the loop, tune this to the desired size

y_column = c("Salary")
all_columns = names(train_dat)
predictor_columns = all_columns[all_columns != y_column]
predictor_columns

# % Var explained: 64.19 by all predictors on first run
rf_result = randomForest(Salary~., data = train_dat, ntree = 1000, importance = TRUE)
first_importance_list = importance(rf_result)
first_importance_list  = sort(first_importance_list[,1], decreasing=TRUE)
first_importance_list

#####################
# R random forest cross validation for feature selection
#####################

#This function shows the cross-validated prediction performance of models with sequentially reduced number of predictors (ranked by variable importance) via a nested cross-validation procedure.

?rfcv
rf_cv_feature_selection =  rfcv(train_dat[,predictor_columns],train_dat[,y_column], cv.fold=5,scale='log', step=.25, recursive=TRUE ,ntree=1000)

#this provides a good range of where we should be looking for the optimal MSE
#with these data we can then target the range  my feature selection below.
#starting with x number of top predictors and iteratively dropping them.
rf_cv_feature_selection$n.var
rf_cv_feature_selection$error.cv

# step=10 , recursive=TRUE)
#step can be a fraction if scale='log' or a number to drop if scale!='log'

#####################
# my feature selection through continued reduction
#####################

#function to run random forest, then drop worst predictor and repeat

rf_train_test_feature_selection = function(train_df, test_df, y_column , predictor_columns){
	outdf = data.frame(size=numeric(),t_mse=numeric(),lowest_predictor=character())
	cols_to_use = c(y_column, predictor_columns)
	rf_input=select(train_df,one_of(cols_to_use))
	while(length(names(rf_input)) > 2){
		#train the model
		#I can't find the cause of the bug but I have to hard code in salary :/
		rf_result = randomForest(Salary~., data = rf_input, ntree = 10000, importance = TRUE)
		test_prediction	= predict(rf_result, test_df[,predictor_columns])
		test_mse = mean((test_prediction - test_df[, y_column])^2)

		#find the worst predictor, add its name to the dataframe and drop column
		importance_dat = rf_result$importance
		sorted_predictors = sort(importance_dat[,1], decreasing=TRUE)
		worst_pred = names(sorted_predictors[length(sorted_predictors)])
		out_line = data.frame(size=length(sorted_predictors), t_mse=test_mse, lowest_predictor=worst_pred)
		print(out_line)
		outdf = rbind(outdf,out_line)
		rf_input = rf_input[, !colnames(rf_input) %in% worst_pred]
		}
	return(outdf)
	}

#run the iterative dropfunction, performing a rf regression for each feature set
model_selection = rf_train_test_feature_selection(train_dat, test_dat, y_column , predictor_columns)
save.image('hockey_salary')
#look at the plot, which number of features gives the best mse on the test data?
plot(model_selection$size, model_selection$t_mse)
#improve this plot
min(model_selection$t_mse)
#2.476437e+12

# Optimal model at size of row:
#67   153 2.476437e+12       nation_DEU
#select these features down and retrain the model to get the list of best predictors and the model produced.

## 2nd place the team's unblocked shot attempts (Fenwick, USAT) while this player was on the ice!
# be sure tho not lose the top predictor

'%!in%' = function(x,y)!('%in%'(x,y))
all_columns[all_columns %!in% model_selection$lowest_predictor]
#last predictor standing was SF

# final model predictors
x = model_selection$lowest_predictor[67:length(model_selection$lowest_predictor)]
write.csv(x,"temp.txt")
all_top_preds= append(as.character(x),'SF' )

?randomForest
?rfcv
test_final_input=select(test_df,one_of(all_top_preds))
trian_final_input=select(train_df,one_of("Salary",all_top_preds))

#final rf run
final_rf_result = randomForest(Salary~., data = trian_final_input, ntree = 10000, importance = TRUE)
final_rf_result
x=sqrt(1.75511e+12)
x
final_importance_list  = sort(importance(final_rf_result)[,1], decreasing=TRUE)
final_importance_list

test_prediction	= predict(final_rf_result, test_df[,predictor_columns])

test_rmse = sqrt(mean((test_prediction - test_df[, y_column])^2))
test_rmse