#' Create test LD object
#'
#' @param nsnp Number of SNPs
#' @param chunksize Chunksize for splitting
#'
#' @export
#' @return list of chunks, which each contain map and LD matrix
test_ldobj <- function(nsnp, chunksize)
{
	snp <- 1:nsnp
	nchunk <- ceiling(nsnp/chunksize)
	start <- 0:(nchunk-1) * chunksize + 1
	end <- pmin(1:nchunk * chunksize, nsnp)

	ldobj <- lapply(1:nchunk, function(i){
		n <- length(start[i]:end[i])
		p <- qr.Q(qr(matrix(rnorm(n^2), n)))
		Sigma <- crossprod(p, p*(5:1))
		denom <- sqrt(diag(Sigma)) %*% t(sqrt(diag(Sigma)))
		rho <- Sigma / denom
		map <- dplyr::tibble(
			snp=start[i]:end[i],
			chr=i,
			pos=1:n,
			ref="A",
			alt="C",
			af=runif(n, 0.01, 0.99)
		)
		rownames(rho) <- colnames(rho) <- map$snp
		return(list(map=map, ld=rho))
	})
	return(ldobj)
}

#' Get LD matrix for a specified region from bfile reference panel
#'
#' @param chr Chromosome
#' @param from from bp
#' @param to to bp
#' @param bfile LD reference panel
#' @param plink_bin Plink binary default=genetics.binaRies::get_plink_binary()
#' @param nref Sample size of reference panel
#'
#' @export
#' @return List of LD matrix and map info including MAF
get_ld <- function(chr, from, to, bfile, plink_bin=genetics.binaRies::get_plink_binary(), nref=NULL)
{
	# Make textfile
	shell <- ifelse(Sys.info()['sysname'] == "Windows", "cmd", "sh")
	fn <- tempfile()

	fun1 <- paste0(
		shQuote(plink_bin, type=shell),
		" --bfile ", shQuote(bfile, type=shell),
		" --chr ", chr,
		" --from-bp ", from,
		" --to-bp ", to,
		" --r square ",
		" --keep-allele-order ",
		" --make-just-bim ",
		" --freq ",
		" --out ", shQuote(fn, type=shell)
	)

	stat <- system(fun1, ignore.stdout=TRUE)

	if(stat==0)
	{
		x <- data.table::fread(paste0(fn, ".ld")) %>% as.matrix()
		y <- data.table::fread(paste0(fn, ".bim")) %>% dplyr::as_tibble()
		z <- data.table::fread(paste0(fn, ".frq")) %>% dplyr::as_tibble()
		names(y) <- c("chr", "snp", "gp", "pos", "alt", "ref")
		y <- dplyr::select(y, -gp)
		y$af <- z$MAF
		if(is.null(nref))
		{
			cmd <- paste0("cat ", bfile, ".fam | wc -l")
			nref <- system(cmd, intern=TRUE) %>% trimws() %>% as.numeric()
		}
		out <- list(ld=x, map=y, nref=nref)
	} else {
		out <- NULL
	}
	unlink(paste0(fn, c(".ld", ".bim", ".frq")))
	return(out)
}
# Also see https://github.com/explodecomputer/pic_haps/

#' Generate LD matrix objects from reference panel
#'
#' Creates a set of ldobj files, each corresponding to a single independent LD region from the reference panel. It also generates a map file.
#'
#' @param outdir Directory in which to store the ldobj files
#' @param bfile Binary plink dataset
#' @param regions A data frame containing the independent regions (see \code{data(ldetect)})
#' @param plink_bin Plink executable. Default=genetics.binaRies::get_plink_binary()
#' @param nthreads How many threads. Default=1
#'
#' @export
#' @return map file
generate_ldobj <- function(outdir, bfile, regions, plink_bin=genetics.binaRies::get_plink_binary(), nthreads=1)
{
	dir.create(outdir)
	codes <- paste0(gsub("chr", "", regions$chr), "_", regions$start, "_", regions$stop)
	cmd <- paste0("cat ", bfile, ".fam | wc -l")
	nref <- system(cmd, intern=TRUE) %>% trimws() %>% as.numeric()
	map <- parallel::mclapply(1:nrow(regions), function(i)
	{
		message(i, " of ", nrow(regions))
		out <- get_ld(
			chr=gsub("chr", "", regions$chr[i]),
			from=regions$start[i],
			to=regions$stop[i],
			bfile=bfile,
			plink_bin=plink_bin,
			nref=nref
		)
		if(!is.null(out))
		{
			fn <- file.path(outdir, paste0("ldobj_", codes[i], ".rds"))
			saveRDS(out, file=fn, compress=TRUE)
			out$map$region <- codes[i]
			return(out$map)
		} else {
			return(NULL)
		}
	}, mc.cores=nthreads) %>%
		dplyr::bind_rows()
	saveRDS(map, file.path(outdir, "map.rds"))
	return(map)
}

#' Determine regions from LD file
#'
#'
#' @param ldobjdir Directory containing output from \code{generate_ldobj}
#'
#' @export
#' @return Data frame
get_regions_from_ldobjdir <- function(ldobjdir)
{
	fn <- list.files(ldobjdir, full.names=TRUE) %>% grep("ldobj_", ., value=TRUE)
	regions <- fn %>%
		basename() %>%
		gsub("ldobj_", "", .) %>%
		gsub("\\.rds", "", .) %>%
		strsplit(split="_") %>%
		unlist() %>%
		as.numeric() %>%
		matrix(., nrow=3) %>%
		t() %>%
		dplyr::as_tibble(.name_repair="minimal") %>%
		`names<-`(c("chr", "start", "stop")) %>%
		dplyr::mutate(
			region=paste(chr, start, stop, sep="_"),
			file=fn
		)
	return(regions)
}

#' Read in LD objects into list
#'
#'
#' @param ldobjdir Directory containing output from \code{generate_ldobj}
#' @param nthreads Number of threads. Default=1
#'
#' @export
#' @return List of ldobj
read_ldobjdir <- function(ldobjdir, nthreads=1)
{
	regions <- get_regions_from_ldobjdir(ldobjdir)
	ldobjlist <- parallel::mclapply(1:nrow(regions), function(i){
		message(i, " of ", nrow(regions))
		readRDS(regions$file[i])
	}) %>%
		`names<-`(regions$region)
	return(ldobjlist)
}

#' Simulate two correlated binomial variables
#'
#' @param nid Number of samples
#' @param p1 Frequency 1
#' @param p2 Frequency 2
#' @param rho Target correlation
#' @param n Binomial parameter, should be 2 (default) for genotypes
#' @param round Round or not Default=TRUE
#' @param print Print or not Default=FALSE
#'
#' @export
#' @return Matrix
correlated_binomial <- function(nid, p1, p2, rho, n=2, round=TRUE, print=FALSE)
{
	# from https://stats.stackexchange.com/questions/284996/generating-correlated-binomial-random-variables
	p <- p1
	q <- p2
	a <- function(rho, p, q) {
		rho * sqrt(p*q*(1-p)*(1-q)) + (1-p)*(1-q)
	}

	a.0 <- a(rho, p, q)
	prob <- c(`(0,0)`=a.0, `(1,0)`=1-q-a.0, `(0,1)`=1-p-a.0, `(1,1)`=a.0+p+q-1)
	if (min(prob) < 0) {
		print(prob)
		stop("Error: a probability is negative.")
	}
	#
	# Illustrate generation of correlated Binomial variables.
	#
	n.sim <- nid
	u <- sample.int(4, n.sim * n, replace=TRUE, prob=prob)
	y <- floor((u-1)/2)
	x <- 1 - u %% 2
	x <- colSums(matrix(x, nrow=n)) # Sum in groups of `n`
	y <- colSums(matrix(y, nrow=n)) # Sum in groups of `n`

	if(round)
	{
		x <- round(x)
		y <- round(y)
	}

	if(print)
	{
		print(table(x, y))
		print(stats::cor(x, y))
	}
	return(cbind(x, y))

	#
	# Plot the empirical bivariate distribution.
	#
	# plot(x+rnorm(length(x), sd=1/8), y+rnorm(length(y), sd=1/8),
	#      pch=19, cex=1/2, col="#00000010",
	#      xlab="X", ylab="Y",
	#      main=paste("Correlation is", signif(cor(x,y), 3)))
	# abline(v=mean(x), h=mean(y), col="Red")
	# abline(lm(y ~ x), lwd=2, lty=3)
}

#' Estimate haplotype frequencies for two loci
#'
#' @param r Required LD r
#' @param p1 Freq 1
#' @param p2 Freq 2
#'
#' @export
#' @return vector
hap_freqs <- function(r, p1, p2)
{
	# d = pAB - p1p2
	# d = p1q2 - pAb
	# d = q1p2 - paB
	# d = pab - q1q2
	# r = d / denom
	denom <- sqrt(p1 * (1-p1) * p2 * (1-p2))
	p <- c(
		`(1,1)` = p1 * p2 + r * denom,
		`(0,0)` = (1-p1) * (1-p2) + r * denom,
		`(1,0)` = p1 * (1-p2) - r * denom,
		`(0,1)` = (1-p1) * p2 - r * denom
	)
	stopifnot(all(p >= 0))
	return(p)
}

test_hap_freqs <- function(r, p1, p2)
{
	a <- try(hap_freqs(r, p1, p2), silent=TRUE)
	return(ifelse(class(a)=='try-error', FALSE, TRUE))
}

#' Simulate haplotypes of two loci
#'
#' @param nid Number of samples
#' @param r Desired LD r
#' @param p1 Freq 1
#' @param p2 Freq 2
#'
#' @export
#' @return Matrix
simulate_haplotypes <- function(nid, r, p1, p2)
{
	p <- hap_freqs(r, p1, p2)
	n <- round(p * nid)
	diff <- sum(n) - nid
	i <- 1
	while(diff != 0)
	{
		if(diff > 0)
		{
			n[i] <- n[i] - 1
		} else {
			n[i] <- n[i] + 1
		}
		diff <- sum(n) - nid
		i <- ifelse(i == 4, 1, i + 1)
	}
	mat <- rbind(
		cbind(rep(1, n[1]), rep(1, n[1])),
		cbind(rep(0, n[2]), rep(0, n[2])),
		cbind(rep(1, n[3]), rep(0, n[3])),
		cbind(rep(0, n[4]), rep(1, n[4]))
	)
	ind1 <- sample(1:nid, nid, replace=FALSE)
	ind2 <- sample(1:nid, nid, replace=FALSE)
	haps <- cbind(
		A1 = mat[ind1, 1],
		A2 = mat[ind2, 1],
		B1 = mat[ind1, 2],
		B2 = mat[ind2, 2]
	)
	return(haps)
}

#' Simulate genotypes from haplotypes
#'
#' @param nid Number of samples
#' @param r Desired LD r
#' @param p1 Freq 1
#' @param p2 Freq 2
#'
#' @export
#' @return Matrix
simulate_geno <- function(nid, r, p1, p2)
{
	a <- simulate_haplotypes(nid, r, p1, p2)
	b <- cbind(a[,1]+a[,2], a[,3]+a[,4])
	return(b)
}


# 4. faza: Analiza podatkov

#PRENASELJENOST STANOVANJ

graf7 <- ggplot(tabelaV, aes(x=skupaj.x, y=skupaj.y)) +
  geom_point(col="black") +
  geom_smooth(method="lm", formula=y ~ x, col="cadetblue") +
  labs(x = "Število prebivalcev", y = "Število oseb v prenaseljenih stanovanjih",
       title = "Število oseb v prenaseljenih stanovanjih glede na število \nprebivalcev v istem letu") +
  theme_bw()


#' Get Edge Network
#'
#' Returns a modfied network where each edge in the original network is split in two and a new node is inserted in between and given the label of the original edge.
#'
#' @param g An igraph graph
#' @export
#' @examples
#' g <- graph.ring(10)
#' get.edge.network(g)

get.edge.network <- function(g) {
  el <- get.edgelist(g, names = F)
  el <- matrix(as.integer(el), nrow=nrow(el)) # convert to an integer matrix
  oel <- getEdgeNetworkCalc(el)
  return(oel)
}


\name{circlize}
\alias{circlize}
\title{
Convert to polar coordinate system
}
\description{
Convert to polar coordinate system
}
\usage{
circlize(x, y, sector.index = get.current.sector.index(),
    track.index = get.current.track.index())
}
\arguments{

  \item{x}{Data points on x-axis. The value can also be a two-column matrix/data frame if you put x and y data points into one variable.}
  \item{y}{Data points on y-axis.}
  \item{sector.index}{Index for the sector to convert the coordinates}
  \item{track.index}{Index for the track to convert the coordinates}

}
\details{
This is the core function in the package. It transform data points from data coordinate system (in a specific cell) to the polar coordinate system.
}
\value{
A matrix with two columns (\code{theta} and \code{rou}). \code{rou} is measured in degree.
}
\examples{
pdf(NULL)
factors = c("a", "b")
circos.initialize(factors, xlim = c(0, 1))
circos.track(ylim = c(0, 1))
# x = 0.5, y = 0.5 in sector a and track 1
circlize(0.5, 0.5, sector.index = "a", track.index = 1)
circos.clear()
dev.off()

}


#' Build edge data frame between documents
#'
#' Builds an edge list based on whether documents are similar based on their
#' shingles. Uses the candidates list to make comparing document much faster.
#'
#' @param candidates list of buckets with document ids from \code{lsh}
#' @param shingles list of documents and their shingles from \code{shingle}
#' @param threshold jaccard similarity threshold
build_edges <- function(candidates, shingles, threshold = 0.8) {
  edges <- lapply(candidates, function(bucket) {
    #for (bucket in results) {
    bucket <- sort(bucket) # to ensure a-b and b-a edges are always a-b
    len <- length(bucket)

    max_edges <- choose(len, 2)
    from <- integer(max_edges)
    to <- integer(max_edges)

    k <- 1L
    for (i in 1:(len - 1)) {
      for (j in (i + 1):len) {
        score <- jaccard_shingles(shingles[[bucket[i]]], shingles[[bucket[j]]])

        if (score >= threshold) {
          from[k] = bucket[i]
          to[k] = bucket[j]
          k <- k + 1L
        }
      }
    }

    # trim results
    from <- from[seq_len(k - 1)]
    to <- to[seq_len(k - 1)]
    tibble::tibble(from = from, to = to)
  })

  # combine bucket results
  edges <- do.call(rbind, edges)
  edges <- edges[!duplicated(edges),]
  edges
}

#' Group documents together into a cluster
#'
#' Similiar process to grouping vertices together that share edges into components
#'
#' @param edges data frame from \code{build_edges}
#' @param docs optional text data to include in results
group_edges <- function(edges, docs = NULL) {
  result <- groupEdges(edges$from, edges$to)
  result$group <- dense_rank(result$group)

  # order by group
  result <- tibble::as_tibble(result)
  result <- result[order(result$group, result$doc),]

  # add in docs
  if (!is.null(docs)) {
    result$text <- docs[result$doc]
  }
  # return result
  result
}

#' Tidy candidate results
#'
#' Uses \code{jaccard_shingles} to compare candidate pairs from \code{lsh} to determine
#' which documents are actually similar.
#'
#' @param candidates list of buckets with document ids from \code{lsh}
#' @param shingles list of documents and their shingles from \code{shingle}
#' @param docs optional text data to include in results
#' @param threshold jaccard similarity threshold
#' @export
tidy_candidates <- function(candidates, shingles, docs = NULL, threshold = 0.8) {
  edges <- build_edges(candidates, shingles, threshold)
  group_edges(edges, docs)
}


#continued from nlp_edge_doc1.R - where only one page, and manual images
#this attempts to get all the info from all pages of 1 doc, auto-capture
#all plots, and get it ready to run through my python creat_edge_list
#03/22/2022

rm(list=ls())
setwd("C:/Users/fikramulla/Desktop/_tiger")

library(dplyr)
library(stringr)
library(ggplot2)
library(tm)
library(wordcloud2)
library(syuzhet)
library(stringi)
library(sqldf)

#*************
#LOAD, READ, PROCESS, EXTRACT
#*************
#read structured csv of doc x (one row per page - doc1 has 52 rows)
text <- read.csv("doc1.csv")
txt <- data.frame(matrix(ncol = 1, nrow = 0))  #initialize
colnames(txt) <- c('text')

#special for docx
txt <- text[,3]
docs <- Corpus(VectorSource(txt))
docs <- tm_map(docs, removeNumbers)
docs <- tm_map(docs, removePunctuation)
docs <- tm_map(docs, stripWhitespace)
docs <- tm_map(docs, content_transformer(tolower))
docs <- tm_map(docs, removeWords, stopwords("english"))
docs <- tm_map(docs, removeWords, c("just", "many", "etc", "figure", "table", "chapter", "change", "no", "yes",
                                    "including", "total", "also"))

dtm <- TermDocumentMatrix(docs)
m <- as.matrix(dtm)
v <- sort(rowSums(m),decreasing=TRUE)
d <- data.frame(word = names(v),freq=v)

# for(i in 1:nrow(text)) {
#   txt[i,] <- text[i,3]  #select text column of doc1.csv (3rd column), per page
#   docs <- Corpus(VectorSource(txt))  #this does all pages at once
#   docs <- tm_map(docs, content_transformer(tolower))
#   docs <- tm_map(docs, removeNumbers)
#   docs <- tm_map(docs, removeWords, stopwords("english"))
#   docs <- tm_map(docs, removeWords, c("just", "many", "etc", "figure", "table", "chapter", "change", "no", "yes",
#                                       "including", "total", "also"))
#   docs <- tm_map(docs, removePunctuation)
#   docs <- tm_map(docs, stripWhitespace)
#   dtm <- TermDocumentMatrix(docs)
#   m <- as.matrix(dtm)
#   v <- sort(rowSums(m),decreasing=TRUE)
#   d <- data.frame(word = names(v),freq=v)
# }

#word count
d1 <- d[1:20,]

#sentiments per page (d3) and summed across whole document (d4)
#d2 <- as.character(txt)
d3 <-get_nrc_sentiment(txt)
d4 <- as.data.frame(colSums(d3))
#td<-data.frame(t(d3))
d4 <- cbind(rownames(d4), d4)
colnames(d4) <- c("sentiment","count")
rownames(d4) <- NULL

#*************
#search/count of sdgs
#*************
dim(d)[1]  #unique words in d

sdg <- read.csv("lcps_single.csv")
sdg['weight'] <- 0

i = grep("poverty", d$word) ; sdg[1,3] <- d[i[1],]$freq
i = grep("hunger", d$word) ; sdg[2,3] <- d[i[1],]$freq
i = grep("health", d$word) ; sdg[3,3] <- d[i[1],]$freq
i = grep("education", d$word) ; sdg[4,3] <- d[i[1],]$freq
i = grep("gender", d$word) ; sdg[5,3] <- d[i[1],]$freq
i = grep("clean", d$word) ; sdg[6,3] <- d[i[1],]$freq
i = grep("energy", d$word) ; sdg[7,3] <- d[i[1],]$freq
i = grep("work", d$word) ; sdg[8,3] <- d[i[1],]$freq
i = grep("industry", d$word) ; sdg[9,3] <- d[i[1],]$freq
i = grep("inequalities", d$word) ; sdg[10,3] <- d[i[1],]$freq
i = grep("cities", d$word) ; sdg[11,3] <- d[i[1],]$freq
i = grep("comsumption", d$word) ; sdg[12,3] <- d[i[1],]$freq
i = grep("climate", d$word) ; sdg[13,3] <- d[i[1],]$freq
i = grep("water", d$word) ; sdg[14,3] <- d[i[1],]$freq
i = grep("land", d$word) ; sdg[15,3] <- d[i[1],]$freq
i = grep("peace", d$word) ; sdg[16,3] <- d[i[1],]$freq

#********
#VISUALIZATIONS
#********
#word counts
png("counts_doc1.png")
barplot(d[1:20,]$freq, las = 2, names.arg = d[1:20,]$word,
        col ="lightblue", main ="Most frequent words (rank 1-20)",
        ylab = "Word frequencies")
dev.off()

#lollipops of top 20 word counts
png("lolli_doc1.png", width = 1080, height = 480)
ggplot(d1, aes(x=word, y=freq)) +
  geom_segment( aes(x=word, xend=word, y=0, yend=freq)) +
  geom_point( size=5, color="red", fill=alpha("orange", 0.3), alpha=0.7, shape=21, stroke=2)
dev.off()

#sentiment
td1<-d4[1:8,]
png("sentim_doc1.png")
ggplot(data=td1, aes(x=sentiment, y=count, fill=sentiment)) +
  geom_bar(stat="identity")
dev.off()
td2<-d4[9:10,]
png("posneg_doc1.png")
ggplot(data=td2, aes(x=sentiment, y=count, fill=sentiment)) +
  geom_bar(stat="identity")
dev.off()

#sdg's
#barplot of sdgs
png("sdglist_doc1.png", width = 1080, height = 480)
ggplot(data=sdg, aes(x=SDG, y=weight, fill=SDG)) +
  geom_bar(stat="identity")
dev.off()
#lollipops of sdgs in this page
png("lollisdglist_doc1.png", width = 1080, height = 480)
ggplot(sdg, aes(x=SDG, y=weight)) +
  geom_segment( aes(x=SDG, xend=SDG, y=0, yend=weight)) +
  geom_point( size=5, color="darkgreen", fill=alpha("green", 0.3), alpha=0.7, shape=21, stroke=2)
dev.off()

#********
#CSV OUTPUTS
#********
write.csv(d, "total_doc1.csv", row.names = FALSE)
write.csv(d1, "counts_doc1.csv", row.names = FALSE)
write.csv(td1, "sentim_doc1.csv", row.names = FALSE)
write.csv(td2, "posneg_doc1.csv", row.names = FALSE)
write.csv(sdg, "sdglist_doc1.csv", row.names = FALSE)

#now go to python to create edgelist...


library(ggplot2)
library(reshape2)
library(dplyr) # run install.packages('dplyr') to get this

topic_names <- read.csv("../topic_names/abs_ICFP_lda20_topics.txt",header=FALSE,as.is=TRUE)

src <- "../../out/2015-08-26_19:30/lda20.csv"

lda <- data.frame(read.csv(src, header=TRUE,sep=",",quote="\""))
names(lda)[4:23] <- topic_names[1:20,]

d <- melt(lda,seq(1,3))
names(d)[4:5] <- c("Topic","Weight")

# thanks to Noam Ross for the tip onin using dplyr/this bit of code
d2 = d %>% group_by(Topic, Conference) %>% summarize(Total = sum(Weight))

p <- ggplot(d2, aes(x=Topic,y=Total,fill=Conference))
p + geom_bar(stat="identity") + theme(strip.text=element_text(size=10),
                                      axis.text.x=element_text(angle=90, hjust=1))


# looking into the data from 2 cdts, the segments comparative approach is a complicated process since the segments are different for one cdt to another.
# We developed a workflow to make the comparative easier. We segmented the genome upon HL difference between 2 cdts and Intensity log2FC on the same way.
# The approach used to segment the genome is dynamic programming.
# HL is segmented using difference between 2 cdts. Intensity was segmented using log2FC.

source("score_fun_ave.r")
source("make_pen.r")
source("fragment_HL_pen.r")
source("fragment_inty_pen.r")

setwd("path_new_directory_data_comparison/")
load("data_combined_se.rda")
load("df_comb_se.rda")

#' Title
#'
#' @param data
#'
#' @return
#' @export
#'
#' @examples

penalties <- function(data){
# calculate the difference of half-life from both conditions.
# difference is referred to distance
data[,"distance_HL"] <-
    data[, "half_life.cdt1"] - data[, "half_life.cdt2"]

# find the best penalties set for half-life fragmentation using dynamic programming
# on half-life distance
pen_HL <- make_pen(
    probe = data,
    FUN = fragment_HL_pen,
    cores = 60,
    logs = as.numeric(rep(NA, 8)),
    dpt = 1,
    smpl_min = 10,
    smpl_max = 50,
    sta_pen = 0.5,
    end_pen = 4.5,
    rez_pen = 9,
    sta_pen_out = 0.5,
    end_pen_out = 3.5,
    rez_pen_out = 7
)

##########################DP for log2FC(intensity) penalties###################
#add log2FC(intensity) to the data frame
data[,"distance_int"] <- data[,"logFC_int"]

# dynamic programming on log2FC(intensity) to find the best penalties
pen_int <- make_pen(
    probe = data,
    FUN = fragment_inty_pen,
    cores = 60,
    logs = as.numeric(rep(NA, 8)),
    dpt = 1,
    smpl_min = 10,
    smpl_max = 50,
    sta_pen = 0.5,
    end_pen = 4.5,
    rez_pen = 9,
    sta_pen_out = 0.5,
    end_pen_out = 3.5,
    rez_pen_out = 7
)
return(list(pen_HL, pen_int))
}

pen_HL <- penalties(data)[[1]]
pen_int <- penalties(data)[[2]]
save(pen_HL, file="pen_HL.rda")
save(pen_int, file="pen_int.rda")


D=read.csv("USSES_climate.csv")
# how many missing values per month are allowed for temperature, ppt, and snow
# depth data? When these thresholds are exceeded, the monthly value is NA
TempNA=5
PptNA=5
SnwdNA=15

#--------------------------------------------------------
D=D[,c("year","month","day","Tmax","Tmin","Tmean","Prcp","Snow","Snwd")]

#make everything numeric
D$year=as.numeric(as.character(D$year))
D$month=as.numeric(as.character(D$month))
D$day=as.numeric(as.character(D$day))
D$Tmax=as.numeric(as.character(D$Tmax))
D$Tmin=as.numeric(as.character(D$Tmin))
D$Tmean=as.numeric(as.character(D$Tmean))
levels(D$Prcp)[length(levels(D$Prcp))]=0.005 # trace amounts
D$Prcp=as.numeric(as.character(D$Prcp))
levels(D$Snow)[length(levels(D$Snow))]=0.005 # trace amounts
D$Snow=as.numeric(as.character(D$Snow))
D$Snwd=as.numeric(as.character(D$Snwd))

# make missing observations=NA
tmp=D$year
D[D>999]=NA
D[,1]=tmp

# count missing observations in each month
missingD=aggregate(is.na(D[,4:NCOL(D)]),by=list("year"=D$year,"month"=D$month),FUN=sum)
missingD=missingD[order(missingD$year,missingD$month),]

# sum precip and snow by month
pptD=aggregate(D[,c("Prcp","Snow")],by=list("year"=D$year,"month"=D$month),FUN=sum,na.rm=T)
pptD=pptD[order(pptD$year,pptD$month),]
#average temperatures and snow depth by month
meanD=aggregate(D[,c("Tmax","Tmin","Tmean","Snwd")],by=list("year"=D$year,"month"=D$month),FUN=mean,na.rm=T)
meanD=meanD[order(meanD$year,meanD$month),]
names(meanD)[3:6]=paste("mean",names(meanD)[3:6],sep="")
# get min min temperature
minD=aggregate(D[,c("Tmin")],by=list("year"=D$year,"month"=D$month),FUN=min,na.rm=T)
minD=minD[order(minD$year,minD$month),]
Tmin=minD[,3]
#combine
monthlyD=cbind(meanD,pptD[,3:4],Tmin)

# put in missing values
monthlyD$meanTmax[missingD$Tmean>TempNA]=NA
monthlyD$meanTmin[missingD$Tmean>TempNA]=NA
monthlyD$meanTmean[missingD$Tmean>TempNA]=NA
monthlyD$meanSnwd[missingD$Snwd>SnwdNA]=NA
monthlyD$Prcp[missingD$Prcp>PptNA]=NA
monthlyD$Snow[missingD$Snow>PptNA]=NA
monthlyD$Tmin[missingD$Tmin>TempNA]=NA

#reshape and write monthly files
tmpOut=reshape(monthlyD[,c("year","month","Prcp")],timevar="month",idvar="year",
  direction="wide")
names(tmpOut)=c("YEAR","JAN","FEB","MAR","APR","MAY","JUN","JUL","AUG","SEP","OCT","NOV","DEC")
write.table(tmpOut,"total_monthly_ppt_v2.csv",row.names=F,sep=",")

tmpOut=reshape(monthlyD[,c("year","month","Snow")],timevar="month",idvar="year",
  direction="wide")
names(tmpOut)=c("YEAR","JAN","FEB","MAR","APR","MAY","JUN","JUL","AUG","SEP","OCT","NOV","DEC")
write.table(tmpOut,"total_monthly_snow_v2.csv",row.names=F,sep=",")

tmpOut=reshape(monthlyD[,c("year","month","meanSnwd")],timevar="month",idvar="year",
  direction="wide")
names(tmpOut)=c("YEAR","JAN","FEB","MAR","APR","MAY","JUN","JUL","AUG","SEP","OCT","NOV","DEC")
write.table(tmpOut,"total_monthly_snowdepth_v2.csv",row.names=F,sep=",")

tmpOut=reshape(monthlyD[,c("year","month","meanTmean")],timevar="month",idvar="year",
  direction="wide")
names(tmpOut)=c("YEAR","JAN","FEB","MAR","APR","MAY","JUN","JUL","AUG","SEP","OCT","NOV","DEC")
write.table(tmpOut,"monthly_mean_temp_v2.csv",row.names=F,sep=",")

tmpOut=reshape(monthlyD[,c("year","month","Tmin")],timevar="month",idvar="year",
  direction="wide")
names(tmpOut)=c("YEAR","JAN","FEB","MAR","APR","MAY","JUN","JUL","AUG","SEP","OCT","NOV","DEC")
write.table(tmpOut,"monthly_min_min_temp_v2.csv",row.names=F,sep=",")


tryCatch(
  {
    if(runif(1) > 0.5)
    {
      message("This doesn't throw an error")
    } else
    {
      stop("This is an error")
    }
  },
  error = function(e) message(paste("An error occured", e$message, sep = ": ")),
  finally = message("This is called whether or not an exception occured")
)


x <- seq(-pi, pi, 0.1)
plot(x, cos(x))


rankhospital <- function(state, outcome, num = "best") {
	data <- read.csv("outcome-of-care-measures.csv", na.strings = "Not Available", stringsAsFactors = FALSE)
	data <- data[,c(2, 7, 11, 17, 23)]
	names(data) <- c("hospital", "state", "heart attack", "heart failure", "pneumonia")

	outcomes <- c("heart attack"=3, "heart failure"=4, "pneumonia"=5)

	if (!state %in% data$state) {
		stop('invalid state')
	}
	if (!outcome %in% names(data)) {
		stop('invalid outcome')
	}
	if (num != "best" & num != "worst" & !is.numeric(num)) {
		stop('invalid rank')
	}

	df <- data[data$state == state, c(1, outcomes[outcome])]
	names(df) <- c("name", "deaths")
	df <- na.omit(df)

	nums <- c("best" = 1, "worst" = nrow(df))

	if (num == "best") {
		num <- 1
	}
	else if (num == "worst") {
		num <- as.numeric(nrow(df))
	}
	else if (num > nrow(df)) {
		return(NA)
	}

	return(df[order(df$deaths, df$name), 1][num])
}


#' Retrieve a U.S. county composite map, optionally with a projection, as a simplefeature
#'
#' The \code{proj} parameter is intende to simplify usage for those using base
#' plotting. If anything but \code{longlat} is specified the composite map
#' will be pre-projected to those
#'
#' This is what's in the object looks like:
#'
#' \preformatted{
#' Observations: 3,143
#' Variables: 9
#' $ fips        <fctr> 01001, 01009, 01017, 01021, 01033, 01045, 01051, 01065, 01079, 0...
#' $ state_fips  <fctr> 01, 01, 01, 01, 01, 01, 01, 01, 01, 01, 01, 01, 01, 05, 05, 06, ...
#' $ county_fips <fctr> 001, 009, 017, 021, 033, 045, 051, 065, 079, 083, 099, 107, 121,...
#' $ name        <fctr> Autauga, Blount, Chambers, Chilton, Colbert, Dale, Elmore, Hale,...
#' $ lsad        <fctr> County, County, County, County, County, County, County, County, ...
#' $ census_area <dbl> 594.436, 644.776, 596.531, 692.854, 592.619, 561.150, 618.485, 64...
#' $ state       <fctr> Alabama, Alabama, Alabama, Alabama, Alabama, Alabama, Alabama, A...
#' $ iso_3166_2  <fctr> AL, AL, AL, AL, AL, AL, AL, AL, AL, AL, AL, AL, AL, AR, AR, CA, ...
#' $ geometry    <simple_feature> MULTIPOLYGON(((-86.496774 3..., MULTIPOLYGON(((-86.577...#' }
#'
#' A reference GeoJSON file isprovided in the following location (i.e. you can use
#' it in any mapping program):
#'
#' \preformatted{
#' system.file("extdata/composite_us_counties.geojson.gz", package="albersusa")
#' }
#'
#' @param proj if anything but \code{longlat} is specified, the shapefile will
#'        be pre-projected before being returned
#' @export
#' @examples
#' library(sf)
#'
#' plot(counties_sf()) # these take a while to render
#' plot(counties_sf("laea"))
counties_sf <- function(proj=c("longlat", "laea", "lcc", "eqdc", "aeqd")) {

  # us <- readOGR(system.file("extdata/composite_us_counties.geojson", package="albersusa"),
  #               "OGRGeoJSON",
  #               stringsAsFactors=FALSE,
  #               verbose=FALSE)

  cty <- readRDS(system.file("extdata/counties_sf.rda", package="albersusa"))
  # saveRDS(cty, "inst/extdata/counties_sf.rda", version = 2)

  proj <- match.arg(proj, c("longlat", "laea", "lcc", "eqdc", "aeqd"))

  if (proj != "longlat") {

    proj <- switch(proj,
                   laea=us_laea_proj,
                   lcc=us_lcc_proj,
                   eqdc=us_eqdc_proj,
                   aeqd=us_aeqd_proj)

    cty <- sf::st_transform(cty, proj)

  }

  cty

}


# set up locations and reused functions

options(menu.graphics=FALSE)

#output.path
outfolder <- "out_dada"

# function to normalize subtables and re-merge
norm_esv <- function(st) {
    pt <- prop.table(st,margin=1)
    pt[is.nan(pt)] <- 0
    pt <- pt[!is.na(rownames(pt)),]
    pt
}

# function to add duplicates back in
# finds zero distances from distance matrix df.dist, adds de-duped rows from df.xy back into df.xy
addDups <- function(df.dist, df.xy) {
    #stackoverflow solution to insert row: https://stackoverflow.com/questions/11561856/add-new-row-to-dataframe-at-specific-row-index-not-appended/11562428#11562428
    insertRow2 <- function(existingDF, newrow, r) {
      existingDF <- rbind(existingDF,newrow)
      existingDF <- existingDF[order(c(1:(nrow(existingDF)-1),r-0.5)),]
      row.names(existingDF) <- 1:nrow(existingDF)
      return(existingDF)
    }

    mat <- as.matrix(df.dist)
    zeros <- which(mat==0,arr.ind=T)
    zeros <- zeros[zeros[,1]!=zeros[,2],]
    zg <- graph.data.frame(zeros,directed=FALSE)
    zc <- data.frame(components(zg)$membership)
    zc[,2] <- as.numeric(rownames(zc))
    zc <- zc[order(zc[,1],zc[,2]),]
    rownames(zc) <- NULL
    colnames(zc) <- c("group","row")

    dups <- NULL
    for(k in unique(zc$group)) {
        duped <- sort(zc$row[which(zc$group==k)])
        kept <- duped[1]
        duped <- duped[-1]
        dups <- rbind(dups, cbind(rep(kept,length(duped)),duped) )
    }
    dups <- as.matrix(dups[order(dups[,2]),])

    out.xy <- df.xy
    for(j in 1:nrow(dups)) {
        out.xy <- insertRow2(out.xy, out.xy[dups[j,1],], unname(dups[j,2]))
    }

    out.xy
}

# SPARCC correlation networks for sequences
# algorithm requires integer values
# replace sparcc function with parallel sparcc
parsparcc <- function (data, iter = 20, inner_iter = 10, th = 0.1, cores=5)
{
    sparccs <- mclapply(1:iter, function(i) parsparccinner(t(apply(data, 1, norm_diric)), iter = inner_iter, th = th), mc.cores=cores)
    cors <- array(unlist(lapply(sparccs, function(x) x$Cor)),
        c(ncol(data), ncol(data), iter))
    corMed <- apply(cors, 1:2, median)
    covs <- array(unlist(lapply(sparccs, function(x) x$Cov)),
        c(ncol(data), ncol(data), iter))
    covMed <- apply(cors, 1:2, median)
    covMed <- cor2cov(corMed, sqrt(diag(covMed)))
    list(Cov = covMed, Cor = corMed)
}
environment(parsparcc) <- asNamespace('SpiecEasi')

parsparccinner <- function (data.f, T = NULL, iter = 10, th = 0.1)
{
    if (is.null(T))
        T <- av(data.f)
    res.bv <- basis_var(T)
    Vbase <- res.bv$Vbase
    M <- res.bv$M
    cbase <- C_from_V(T, Vbase)
    Cov <- cbase$Cov
    Cor <- cbase$Cor
    excluded <- NULL
#    print(iter)
    for (i in 1:iter) {
        print(i)
        res.excl <- exclude_pairs(Cor, M, th, excluded)
        M <- res.excl$M
        excluded <- res.excl$excluded
#        print(res.excl)
        if (res.excl$break_flag)
            break
        res.bv <- basis_var(T, M = M, excluded = excluded)
        Vbase <- res.bv$Vbase
        M <- res.bv$M
        K <- M
        diag(K) <- 1
        cbase <- C_from_V(T, Vbase)
        Cov <- cbase$Cov
        Cor <- cbase$Cor
    }
    gc()
    list(Cov = Cov, Cor = Cor, i = i, M = M, excluded = excluded)
}
environment(parsparccinner) <- asNamespace('SpiecEasi')

#
# # function to add duplicates back in
# # finds zero distances from distance matrix df.dist, adds de-duped rows from df.xy back into df.xy
# addDups <- function(df.dist, df.xy) {
#     #stackoverflow solution to insert row: https://stackoverflow.com/questions/11561856/add-new-row-to-dataframe-at-specific-row-index-not-appended/11562428#11562428
#     insertRow2 <- function(existingDF, newrow, r) {
#       existingDF <- rbind(existingDF,newrow)
#       existingDF <- existingDF[order(c(1:(nrow(existingDF)-1),r-0.5)),]
#       row.names(existingDF) <- 1:nrow(existingDF)
#       return(existingDF)
#     }
#
#     mat <- as.matrix(df.dist)
#     zeros <- which(mat==0,arr.ind=T)
#     zeros <- zeros[zeros[,1]!=zeros[,2],]
#     zg <- graph.data.frame(zeros,directed=FALSE)
#     zc <- data.frame(components(zg)$membership)
#     zc[,2] <- as.numeric(rownames(zc))
#     zc <- zc[order(zc[,1],zc[,2]),]
#     rownames(zc) <- NULL
#     colnames(zc) <- c("group","row")
#
#     dups <- NULL
#     for(k in unique(zc$group)) {
#         duped <- sort(zc$row[which(zc$group==k)])
#         kept <- duped[1]
#         duped <- duped[-1]
#         dups <- rbind(dups, cbind(rep(kept,length(duped)),duped) )
#     }
#     dups <- as.matrix(dups[order(dups[,2,drop=F]),])
#
#     out.xy <- df.xy
#     for(j in 1:nrow(dups)) {
#         out.xy <- insertRow2(out.xy, out.xy[dups[j,1],,drop=F], unname(dups[j,2,drop=F]))
#     }
#
#     out.xy
# }

#write to fasta format
dada2fasta <- function(esvs,taxanames,taxon) {
    which.taxa <- grepl(taxon,taxanames)
    saved <- paste0(">",taxanames[which.taxa],"\n",colnames(esvs)[which.taxa],"\n")
    cat(saved,sep="")
}


#' Cell graph
#'
#' Representing a cell-to-cell similarity graph.
#'
#' @slot cell_names names of cells (Ids in edges relates to these)
#' @slot edges data frame specifiying the graph weighted edges as returned from tgs_cor_graph
#' @slot nodes vector of node names
#'
#' @import Matrix
#'
#' @export tgCellGraph
#' @exportClass tgCellGraph
tgCellGraph <- setClass(
   "tgCellGraph",
	slots = c(
	  cell_names = "vector",
	  edges	= "data.frame",
	  nodes = "vector")
)

#'
#'
#' This constructs graph object from a data frame on columns col1,col2, weight, (the format returened by tgs_cor_graph). Note this is not intended to serve natively complex graph algs etc, but is just a container for use by scdb and operaitons on scmats (creating a graph) and mcell (using the graph to compute graph covers)
#'
#' @param gr data frame with columns col1 (first node), col2 (second node), weight - float between 0 and 1.
#' @export

setMethod(
  "initialize",
  signature = "tgCellGraph",
  definition =
    function(.Object, gr, cnames) {
		.Object@cell_names = cnames
		.Object@edges = gr
		n1 = unique(as.character(gr$mc1))
		n2 = unique(as.character(gr$mc2))
		.Object@nodes = unique(c(n1,n2))
		if(length(cnames) != length(.Object@nodes)) {
			miss = setdiff(cnames, .Object@nodes)
			message("sim graph is missing ", length(miss), " nodes, out of ", length(cnames))
		}
      return(.Object)
    }
)


#' Jitter points to avoid overplotting
#'
#' Counterintuitively adding random noise to a plot can sometimes make it
#' easier to read. Jittering is particularly useful for small datasets with
#' at least one discrete position.
#'
#' @family position adjustments
#' @param width,height Amount of vertical and horizontal jitter. The jitter
#'   is added in both positive and negative directions, so the total spread
#'   is twice the value specified here.
#'
#'   If omitted, defaults to 40% of the resolution of the data: this means the
#'   jitter values will occupy 80% of the implied bins. Categorical data
#'   is aligned on the integers, so a width or height of 0.5 will spread the
#'   data so it's not possible to see the distinction between the categories.
#' @param seed A random seed to make the jitter reproducible.
#'   Useful if you need to apply the same jitter twice, e.g., for a point and
#'   a corresponding label.
#'   The random seed is reset after jittering.
#'   If `NA` (the default value), the seed is initialised with a random value;
#'   this makes sure that two subsequent calls start with a different seed.
#'   Use `NULL` to use the current random seed and also avoid resetting
#'   (the behaviour of \pkg{ggplot} 2.2.1 and earlier).
#' @export
#' @examples
#' # Jittering is useful when you have a discrete position, and a relatively
#' # small number of points
#' # take up as much space as a boxplot or a bar
#' ggplot(mpg, aes(class, hwy)) +
#'   geom_boxplot(colour = "grey50") +
#'   geom_jitter()
#'
#' # If the default jittering is too much, as in this plot:
#' ggplot(mtcars, aes(am, vs)) +
#'   geom_jitter()
#'
#' # You can adjust it in two ways
#' ggplot(mtcars, aes(am, vs)) +
#'   geom_jitter(width = 0.1, height = 0.1)
#' ggplot(mtcars, aes(am, vs)) +
#'   geom_jitter(position = position_jitter(width = 0.1, height = 0.1))
#'
#' # Create a jitter object for reproducible jitter:
#' jitter <- position_jitter(width = 0.1, height = 0.1)
#' ggplot(mtcars, aes(am, vs)) +
#'   geom_point(position = jitter) +
#'   geom_point(position = jitter, color = "red", aes(am + 0.2, vs + 0.2))
position_jitter <- function(width = NULL, height = NULL, seed = NA) {
  if (!is.null(seed) && is.na(seed)) {
    seed <- sample.int(.Machine$integer.max, 1L)
  }

  ggproto(NULL, PositionJitter,
    width = width,
    height = height,
    seed = seed
  )
}

#' @rdname ggplot2-ggproto
#' @format NULL
#' @usage NULL
#' @export
PositionJitter <- ggproto("PositionJitter", Position,
  required_aes = c("x", "y"),

  setup_params = function(self, data) {
    list(
      width = self$width %||% (resolution(data$x, zero = FALSE) * 0.4),
      height = self$height %||% (resolution(data$y, zero = FALSE) * 0.4),
      seed = self$seed
    )
  },

  compute_layer = function(self, data, params, layout) {
    trans_x <- if (params$width > 0) function(x) jitter(x, amount = params$width)
    trans_y <- if (params$height > 0) function(x) jitter(x, amount = params$height)

    with_seed_null(params$seed, transform_position(data, trans_x, trans_y))
  }
)


# penguins.csv downloaded from
# https://raw.githubusercontent.com/allisonhorst/palmerpenguins/master/inst/extdata/penguins.csv

# Load dataframe

dframe <- read.csv(file="penguins.csv", header=TRUE)

# Dimensions of dataframe

print(c("Dimensions of dataframe:"))
print(dim(dframe))

# Frequencies of species

print("Frequencies of species:")
print(table(dframe$species))

# Dimensions of dataframe without missing values

print("Dimensions of dataframe without missing values:")
print(dim(na.omit(dframe)))

# Frequency of diabetes cases without missing values

print("Frequencies of species without missing values:")
print(table(na.omit(dframe)$species))

# Missing values per column

print("Missing values per column:")
print(sapply(dframe, function(x) sum(is.na(x))))

# Keep only data without missing values

reduced_dframe <- na.omit(dframe)

# Convert factor variables to numeric variables

reduced_dframe$species <- as.numeric(reduced_dframe$species) - 1 # (Adelie, Chinstrap, Gentoo) = (1, 2, 3)
reduced_dframe$island <- as.numeric(reduced_dframe$island) - 1 # (Biscoe, Dream, Torgersen) = (1, 2, 3)
reduced_dframe$sex <- as.numeric(reduced_dframe$sex) - 1 # (female, male) = (1, 2)

# Write reduced dataframe to CSV

write.table(reduced_dframe[, -1], "x.csv", quote=FALSE, sep=",", row.names=FALSE)
write.table(reduced_dframe[c("species")], "y.csv", quote=FALSE, sep=",", row.names=FALSE)


library(mec)

str <- "abc"
str
bitprint(str)

enc <- encode(str)
enc
bitprint(enc)

dec <- decode(enc)
dec

all.equal(dec, str)


library( "rmacrolite" )

#   Path to an example par-file
par_file_path <- system.file( "par-files",
    "chat_winCer_GW-X_900gHa_d182.par",
    package = "rmacrolite" )

#   Import the example par-file
par_file <- rmacroliteImportParFile(
    file = par_file_path )

#   Find out simulation start and end dates
rmacroliteSimPeriod( x = par_file )

#   Clean-up
rm( par_file_path, par_file )


#####
# Called by Load_byParam_sub3_Load_Summary_Plots.r
#####

##### Box Plots by season:
xlimits <- c(0.5,4.5)

BoxData <- ParamData

# count detects by season
DetCount_Winter <- sum(BoxData[which(BoxData$Season == 1),]$nonDetect_Flag == FALSE)
DetCount_Spring <- sum(BoxData[which(BoxData$Season == 2),]$nonDetect_Flag == FALSE)
DetCount_Summer <- sum(BoxData[which(BoxData$Season == 3),]$nonDetect_Flag == FALSE)
DetCount_Fall   <- sum(BoxData[which(BoxData$Season == 4),]$nonDetect_Flag == FALSE)

# Create data frames for each season
Data_Winter <- BoxData[which(BoxData$Season == 1),]
Data_Spring <- BoxData[which(BoxData$Season == 2),]
Data_Summer <- BoxData[which(BoxData$Season == 3),]
Data_Fall   <- BoxData[which(BoxData$Season == 4),]

# Create data frames with seasonal data that only includes nondetects
ND_Winter <- Data_Winter[which(Data_Winter$nonDetect_Flag == TRUE),]
ND_Spring <- Data_Spring[which(Data_Spring$nonDetect_Flag == TRUE),]
ND_Summer <- Data_Summer[which(Data_Summer$nonDetect_Flag == TRUE),]
ND_Fall   <- Data_Fall[which(Data_Fall$nonDetect_Flag == TRUE),]

# Remove data if, in any given season, there are fewer than 5 detects
if (DetCount_Winter < 5 && any(BoxData$Season == 1)) {
    BoxData <- BoxData[-which(BoxData$Season == 1),]
}
if (DetCount_Spring < 5 && any(BoxData$Season == 2)) {
    BoxData <- BoxData[-which(BoxData$Season == 2),]
}
if (DetCount_Summer < 5 && any(BoxData$Season == 3)) {
    BoxData <- BoxData[-which(BoxData$Season == 3),]
}
if (DetCount_Fall < 5 && any(BoxData$Season == 4)) {
    BoxData <- BoxData[-which(BoxData$Season == 4),]
}

# Create a data frame of all non-detect data (across all seasons)
nonDetects <- BoxData[which(BoxData$nonDetect_Flag == TRUE),]
colorList <- c("blue", "blue", "blue", "blue")

# Only create a plot if at least one season has 5 or more detections
if (nrow(BoxData) == 0 ) {
  plot(x=c(1:10), y=c(1:10), type="n", xaxt="n", yaxt="n", xlab="", ylab="", bty="n")
  text(x=5,y=5,"Not Plotted\n(No season has 5 or more detections)")

} else if (nrow(nonDetects) > 0 ) {

  boxplot( sample_area_loads ~ Season,
           data   = BoxData,
           xaxt   = "n",
           border = colorList,
           col    = rgb(1,1,1, alpha = 0),
           log    = "y",
           xlim   = xlimits,
           ylim   = ylimits,
           las    = 2,
           cex.axis = 0.8,
           xaxs  = "i",
           yaxs  = "i",
           main  = "")

  if (nrow(ND_Winter) > 0 ) {
    max_nonDetect <- max(ND_Winter$sample_area_loads)
    min_nonDetect <- min(ND_Winter$sample_area_loads)
    rect(xleft=0.5,
         xright=1.5,
         ybottom=ylimits[1],
         ytop=max_nonDetect,
         col="gray93",
         border="white")
  }
  if (nrow(ND_Spring) > 0 ) {
    max_nonDetect <- max(ND_Spring$sample_area_loads)
    min_nonDetect <- min(ND_Spring$sample_area_loads)
    rect(xleft=1.5,
         xright=2.5,
         ybottom=ylimits[1],
         ytop=max_nonDetect,
         col="gray93",
         border="white")
  }
  if (nrow(ND_Summer) > 0 ) {
    max_nonDetect <- max(ND_Summer$sample_area_loads)
    min_nonDetect <- min(ND_Summer$sample_area_loads)
    rect(xleft=2.5,
         xright=3.5,
         ybottom=ylimits[1],
         ytop=max_nonDetect,
         col="gray93",
         border="white")
  }
  if (nrow(ND_Fall) > 0 ) {
    max_nonDetect <- max(ND_Fall$sample_area_loads)
    min_nonDetect <- min(ND_Fall$sample_area_loads)
    rect(xleft=3.5,
         xright=4.5,
         ybottom=ylimits[1],
         ytop=max_nonDetect,
         col="gray93",
         border="white")
  }

  par(new=TRUE)
  boxplot( sample_area_loads ~ Season,
           data   = BoxData,
           xaxt   = "n",
           border = colorList,
           col    = rgb(1,1,1, alpha = 0),
           lty    = "dashed",
           log    = "y",
           xlim   = xlimits,
           ylim   = ylimits,
           ylab   = "Kg/Ha",
           las    = 2,
           cex.axis=0.8,
           xaxs   = "i",
           yaxs   = "i",
           main   = "\nArea Loads\nby Season (kg/ha)")

  if (nrow(ND_Winter) > 0 ) {
    max_nonDetect <- max(ND_Winter$sample_area_loads)
    min_nonDetect <- min(ND_Winter$sample_area_loads)
    lines(x=c(0.5,1.5), y=c(min_nonDetect, min_nonDetect), lwd=1, col="red", lty="solid")
    lines(x=c(0.5,1.5), y=c(max_nonDetect, max_nonDetect), lwd=1, col="red", lty="dashed")
  }
  if (nrow(ND_Spring) > 0 ) {
    max_nonDetect <- max(ND_Spring$sample_area_loads)
    min_nonDetect <- min(ND_Spring$sample_area_loads)
    lines(x=c(1.5,2.5), y=c(min_nonDetect, min_nonDetect), lwd=1, col="red", lty="solid")
    lines(x=c(1.5,2.5), y=c(max_nonDetect, max_nonDetect), lwd=1, col="red", lty="dashed")
  }
  if (nrow(ND_Summer) > 0 ) {
    max_nonDetect <- max(ND_Summer$sample_area_loads)
    min_nonDetect <- min(ND_Summer$sample_area_loads)
    lines(x=c(2.5,3.5), y=c(min_nonDetect, min_nonDetect), lwd=1, col="red", lty="solid")
    lines(x=c(2.5,3.5), y=c(max_nonDetect, max_nonDetect), lwd=1, col="red", lty="dashed")
  }
  if (nrow(ND_Fall) > 0 ) {
    max_nonDetect <- max(ND_Fall$sample_area_loads)
    min_nonDetect <- min(ND_Fall$sample_area_loads)
    lines(x=c(3.5,4.5), y=c(min_nonDetect, min_nonDetect), lwd=1, col="red", lty="solid")
    lines(x=c(3.5,4.5), y=c(max_nonDetect, max_nonDetect), lwd=1, col="red", lty="dashed")
  }

} else {
  boxplot( sample_area_loads ~ Season,
           data = BoxData,
           xaxt = "n",
           border=colorList,
           log  = "y",
           xlim = xlimits,
           ylim = ylimits,
           ylab = "Kg/Ha",
           las  = 2,
           cex.axis=0.8,
           xaxs = "i",
           yaxs = "i",
           main = "\nBoxplot\nby Season",
           cex.axis=0.8
        )
}

### Axis labels and legend:
if (nrow(BoxData) > 0 ) {

  percentCensor <- c(nrow(ND_Winter), nrow(ND_Spring), nrow(ND_Summer), nrow(ND_Fall))
  percentCensor <- percentCensor / (
             c(nrow(ND_Winter), nrow(ND_Spring), nrow(ND_Summer), nrow(ND_Fall)) +
             c(DetCount_Winter, DetCount_Spring, DetCount_Summer, DetCount_Fall) )
  percentCensor <- round(100*percentCensor, 1)

  axislabels <- paste(c("Winter", "Spring", "Summer", "Fall"),
                      rep("\nDet=",4),
                      c(DetCount_Winter, DetCount_Spring, DetCount_Summer, DetCount_Fall),
                      rep("\n ND=",4),
                      c(nrow(ND_Winter), nrow(ND_Spring), nrow(ND_Summer), nrow(ND_Fall)),
                      rep("\n",4),
                      percentCensor,
                      rep("%",4),
                      sep="")
  axis(side=1, at=c(1:4), labels=rep("",4))
  mtext(side=1, line=3.5, at=c(1:4), text=axislabels, adj=0.5, padj=0, cex=0.6)

}


library(rgdal)
library(leaflet)

#Load state shape file
# states <- readOGR("data/shapefiles/cb_2014_us_state_500k/cb_2014_us_state_500k.shp",
#   layer = "cb_2014_us_state_500k", verbose = FALSE)

#Plot states on map
leaflet(states) %>% addTiles()%>%
  addPolygons(
    stroke = FALSE, fillOpacity = 0.1, smoothFactor = 0.5,
    color = ~colorQuantile("YlOrRd", as.numeric(as.character(states@data$STATEFP))) (as.numeric(as.character(STATEFP)))
 )


genome_index <- read.table("camp_sp_genome_filtered.fasta.fai", sep="\t", stringsAsFactors=F)
genome_index <- genome_index[,1:2]
chromosomes <- genome_index[1:31,]
options(scipen=999)

# read repeatmasker file
x <- read.table("camponotus_sp_genome_filtered.fasta.no_dups.out", sep="", stringsAsFactors=F, fill=T, header=T)

# total proportion genome
sum(x$q_end - x$q_start + 1) / sum(genome_index[,2])

window_size <- 100000
write(c("chromosome", "start", "end", "TE_bp", "mariner_bp", "gypsy_bp", "dna-unknown_bp", "dna_bp", "ltr_bp", "nonltr_bp"), file="per_window_TE_bp.txt", sep="\t", ncolumns=10)

# loop for each chromosome
for(a in 1:nrow(chromosomes)) {
	x_rep <- x[x[,5] == chromosomes[a,1], ]

	a_start <- 1
	a_end <- window_size

	n_windows <- floor(chromosomes[a,2] / window_size)

	# loop for each window
	for(b in 1:n_windows) {
		b_rep <- x_rep[(x_rep[,6] >= a_start & x_rep[,6] <= a_end) | (x_rep[,7] >= a_start & x_rep[,7] <= a_end), ]
		# remove portions that go on past the window
		b_rep$q_start[b_rep$q_start < a_start] <- a_start
		b_rep$q_end[b_rep$q_end > a_end] <- a_end

		# which match mariner or gypsy?
		mariner_rep <- b_rep[grep("DNA/Mariner_Tc1", b_rep[,11]),]
		gypsy_rep <- b_rep[grep("LTR/Gypsy", b_rep[,11]),]
		dna_unknown_rep <- b_rep[grep("DNA/Unknown", b_rep[,11]),]
		DNA_rep <- b_rep[sapply(strsplit(b_rep[,11], "/"), "[[", 1) == "DNA",]
		LTR_rep <- b_rep[sapply(strsplit(b_rep[,11], "/"), "[[", 1) == "LTR",]
		nonLTR_rep <- b_rep[sapply(strsplit(b_rep[,11], "/"), "[[", 1) == "nonLTR",]

		# sum the TEs
		b_rep <- sum(b_rep$q_end - b_rep$q_start + 1)
		mariner_rep <- sum(mariner_rep$q_end - mariner_rep$q_start + 1)
		gypsy_rep <- sum(gypsy_rep$q_end - gypsy_rep$q_start + 1)
		dna_unknown_rep <- sum(dna_unknown_rep$q_end - dna_unknown_rep$q_start + 1)
		DNA_rep <- sum(DNA_rep$q_end - DNA_rep$q_start + 1)
		LTR_rep <- sum(LTR_rep$q_end - LTR_rep$q_start + 1)
		nonLTR_rep <- sum(nonLTR_rep$q_end - nonLTR_rep$q_start + 1)

		# combine and then write the output
		b_output <- c(as.character(chromosomes[a,1]), a_start, a_end, b_rep, mariner_rep, gypsy_rep, dna_unknown_rep, DNA_rep, LTR_rep, nonLTR_rep)
		write(b_output, file="per_window_TE_bp.txt",
			sep="\t", ncolumns=10, append=T)

		# change the counters
		a_start <- a_start + window_size
		a_end <- a_end + window_size
	}
}


x_train <- read.csv("X_train.csv")
y_train <- read.csv("y_train.csv")
outl <- (read.csv("features_trainNO.csv"))

# GET INDEX of the OUTLIER
index <- c()
index_raw <- c()
for (i in 1:length(outl[,1])) {
  if (outl[i,1] == -1){
    index <- c(index, i)
    index_raw <- c(index_raw, i+1)
  }
}

index

#WRITE INDEX OUTLIER
write.csv(index, "outlier_index.csv", row.names = FALSE)

#DELETE SAMPLES OUTLIER
x_train <- x_train[-index_raw,, drop = FALSE]
x_train

y_train <- y_train[-index_raw,, drop = FALSE]
y_train

#WRITE
write.csv(x_train, "x_train_wo_outlier.csv", row.names = FALSE)
write.csv(y_train, "y_train_wo_outlier.csv", row.names = FALSE)

#APPLY KNN TO THESE NEW SET TO FILLING IN NAs
#KNN-imputation on x_train
x_train_knned <- impute::impute.knn(as.matrix(x_train))
x_train <- x_train_knned[["data"]]
x_train

#write to csv
write.csv(x_train, "x_train__wo_outlier_KNN.csv", row.names = FALSE)


require(readxl)
# factorGroups <- list(US = c("USVal", "USLVol", "USQual", "USSize", "USMom"),
#                      Intl = c("DxUVal", "DxULVol", "DxUQual", "DxUSize", "DxUMom"),
#                      EM = c("EMVal", "EMLVol", "EMQual", "EMMom"))
# factorReturns <- read_excel(".\\inst\\extdata\\8892_RAFI_factor_portfolio_returns_20190228.xlsx",
#                                      sheet = "Monthly Returns")
# colnames(factorReturns) <- c("date",
#                              unlist(factorGroups["US"]),
#                              unlist(factorGroups["Intl"]),
#                              unlist(factorGroups["EM"]))
# factorReturns$date <- as.Date(factorReturns$date)
# factorReturns.US <- factorReturns[,c("date", unlist(factorGroups["US"]))]
# factorReturns.Intl <- factorReturns[,c("date", unlist(factorGroups["Intl"]))]
# factorReturns.EM <- factorReturns[,c("date", unlist(factorGroups["EM"]))]
# factorReturns.US <- factorReturns.US[complete.cases(factorReturns.US),]
# factorReturns.Intl <- factorReturns.Intl[complete.cases(factorReturns.Intl),]
# factorReturns.EM <- factorReturns.EM[complete.cases(factorReturns.EM),]
# save(factorGroups, file=".\\data\\factorGroups.rdata")
# save(factorReturns, file=".\\data\\factorReturns.rdata")
# save(factorReturns.US, file=".\\data\\factorReturns.US.rdata")
# save(factorReturns.Intl, file=".\\data\\factorReturns.Intl.rdata")
# save(factorReturns.EM, file=".\\data\\factorReturns.EM.rdata")

factorGroups <- list(US = c("RADMFUVT", "RADMFULT","RADMFUQT", "RADMFSST", "RAFIUST", "RAFIUSST"),
                     Intl = c("RADMFXVT", "RADMFXLT", "RADMFXQT", "RADMFXST", "RAFIDXUT"),
                     EM = c("RADMFEVT", "RADMFELT", "RADMFEQT", "RAFIEMT"))

factorColNames<- read_excel(".\\inst\\extdata\\RAFI-Performance-Series-2019-08-31.xlsx",
                            sheet = "RAFI Indices Performance", range = "C11:AA11", col_names = FALSE)
factorColNames <- c("Date", unlist(factorColNames[1:sum(!is.na(factorColNames))]))

factorReturns <- read_excel(".\\inst\\extdata\\RAFI-Performance-Series-2019-08-31.xlsx",
                            sheet = "RAFI Indices Performance", skip = 12, col_names = factorColNames)

factorReturns.US <- factorReturns[,c("Date", unlist(factorGroups["US"]))]
factorReturns.Intl <- factorReturns[,c("Date", unlist(factorGroups["Intl"]))]
factorReturns.EM <- factorReturns[,c("Date", unlist(factorGroups["EM"]))]
factorReturns.US <- factorReturns.US[complete.cases(factorReturns.US),]
factorReturns.Intl <- factorReturns.Intl[complete.cases(factorReturns.Intl),]
factorReturns.EM <- factorReturns.EM[complete.cases(factorReturns.EM),]
save(factorGroups, file=".\\data\\factorGroups.rdata")
save(factorReturns, file=".\\data\\factorReturns.rdata")
save(factorReturns.US, file=".\\data\\factorReturns.US.rdata")
save(factorReturns.Intl, file=".\\data\\factorReturns.Intl.rdata")
save(factorReturns.EM, file=".\\data\\factorReturns.EM.rdata")