#' Outlier adjustment estimation
#'
#' How much of the heterogeneity due to the outlier can be explained by alternative pathways?
#'
#' @param tryxscan Output from \code{tryx.scan}
#' @param id_remove List of IDs to exclude from the adjustment analysis. It is possible that in the outlier search a candidate trait will come up which is essentially just a surrogate for the outcome trait (e.g. if you are analysing coronary heart disease as the outcome then a variable related to heart disease medication might come up as a candidate trait). Adjusting for a trait which is essentially the same as the outcome will erroneously nullify the result, so visually inspect the candidate trait list and remove those that are inappropriate.
#'
#' @export
#' @return data frame of adjusted effect estimates and heterogeneity stats
tryx.adjustment <- function(tryxscan, id_remove=NULL)
{
	# for each outlier find the candidate MR analyses
	# if only exposure then ignore
	# if only outcome then re-estimate the snp-outcome association
	# if exposure and outcome then re-estimate the snp-exposure and snp-outcome association
	# outlier
	# candidate
	# what
	# old.beta.exposure
	# adj.beta.exposure
	# old.beta.outcome
	# adj.beta.outcome
	# candidate.beta.outcome
	# candidate.se.outcome
	# candidate.beta.exposure
	# candidate.se.exposure
	# old.deviation
	# new.deviation

	if(!any(tryxscan$search$sig))
	{
		return(tibble())
	}

	l <- list()
	sig <- subset(tryxscan$search, sig & !id.outcome %in% id_remove)
	sige <- subset(tryxscan$candidate_exposure_mr, sig & !id.exposure %in% id_remove)
	sigo <- subset(tryxscan$candidate_outcome_mr, sig & !id.exposure %in% id_remove)

	dat <- tryxscan$dat
	dat$qi <- cochrans_q(dat$beta.outcome / dat$beta.exposure, dat$se.outcome / abs(dat$beta.exposure))
	dat$Q <- sum(dat$qi)
	for(i in 1:nrow(sig))
	{
		a <- subset(dat, SNP == sig$SNP[i], select=c(SNP, beta.exposure, beta.outcome, se.exposure, se.outcome, qi, Q))
		if(sig$id.outcome[i] %in% sigo$id.exposure)
		{
			a$candidate <- sig$outcome[i]
			a$i <- i
			if(sig$id.outcome[i] %in% sige$id.exposure) {
				message("x<-p->y:  ", a$SNP, "\t- ", sig$outcome[i])
				a$what <- "p->x; p->y"
				a$candidate.beta.exposure <- sige$b[sige$id.exposure == sig$id.outcome[i]]
				a$candidate.se.exposure <- sige$se[sige$id.exposure == sig$id.outcome[i]]
				a$candidate.beta.outcome <- sigo$b[sigo$id.exposure == sig$id.outcome[i]]
				a$candidate.se.outcome <- sigo$se[sigo$id.exposure == sig$id.outcome[i]]
				b <- bootstrap_path(a$beta.exposure, a$se.exposure, sig$beta.outcome[i], sig$se.outcome[i], sige$b[sige$id.exposure == sig$id.outcome[i]], sige$se[sige$id.exposure == sig$id.outcome[i]])
				a$adj.beta.exposure <- b[1]
				a$adj.se.exposure <- b[2]
				b <- bootstrap_path(a$beta.outcome, a$se.outcome, sig$beta.outcome[i], sig$se.outcome[i], sigo$b[sigo$id.exposure == sig$id.outcome[i]], sigo$se[sigo$id.exposure == sig$id.outcome[i]])
				a$adj.beta.outcome <- b[1]
				a$adj.se.outcome <- b[2]
			} else {
				message("   p->y:  ", a$SNP, "\t- ", sig$outcome[i])
				a$what <- "p->y"
				a$candidate.beta.exposure <- NA
				a$candidate.se.exposure <- NA
				a$candidate.beta.outcome <- sigo$b[sigo$id.exposure == sig$id.outcome[i]]
				a$candidate.se.outcome <- sigo$se[sigo$id.exposure == sig$id.outcome[i]]
				b <- bootstrap_path(a$beta.outcome, a$se.outcome, sig$beta.outcome[i], sig$se.outcome[i], sigo$b[sigo$id.exposure == sig$id.outcome[i]], sigo$se[sigo$id.exposure == sig$id.outcome[i]])
				a$adj.beta.exposure <- a$beta.exposure
				a$adj.se.exposure <- a$se.exposure
				a$adj.beta.outcome <- b[1]
				a$adj.se.outcome <- b[2]
			}
			temp <- dat
			temp$beta.exposure[temp$SNP == a$SNP] <- a$adj.beta.exposure
			temp$se.exposure[temp$SNP == a$SNP] <- a$adj.se.exposure
			temp$beta.outcome[temp$SNP == a$SNP] <- a$adj.beta.outcome
			temp$se.outcome[temp$SNP == a$SNP] <- a$adj.se.outcome
			temp$qi <- cochrans_q(temp$beta.outcome / temp$beta.exposure, temp$se.outcome / abs(temp$beta.exposure))
			a$adj.qi <- temp$qi[temp$SNP == a$SNP]
			a$adj.Q <- sum(temp$qi)

			l[[i]] <- a
		}

	}
	l <- bind_rows(l)
	l$d <- (l$adj.qi / l$adj.Q) / (l$qi / l$Q)
	return(l)
}

tryx.adjustment.mv <- function(tryxscan, lasso=TRUE, id_remove=NULL, proxies=FALSE)
{
	# for each outlier find the candidate MR analyses
	# if only exposure then ignore
	# if only outcome then re-estimate the snp-outcome association
	# if exposure and outcome then re-estimate the snp-exposure and snp-outcome association
	# outlier
	# candidate
	# what
	# old.beta.exposure
	# adj.beta.exposure
	# old.beta.outcome
	# adj.beta.outcome
	# candidate.beta.outcome
	# candidate.se.outcome
	# candidate.beta.exposure
	# candidate.se.exposure
	# old.deviation
	# new.deviation

	if(!any(tryxscan$search$sig))
	{
		return(tibble())
	}

	l <- list()
	sig <- subset(tryxscan$search, sig & !id.outcome %in% id_remove)
	sige <- subset(tryxscan$candidate_exposure_mr, sig & !id.exposure %in% id_remove)
	sigo <- subset(tryxscan$candidate_outcome_mr, sig & !id.exposure %in% id_remove)

	id.exposure <- tryxscan$dat$id.exposure[1]
	id.outcome <- tryxscan$dat$id.outcome[1]

#	for each outlier SNP find its effects on

	sigo1 <- subset(sig, id.outcome %in% sigo$id.exposure) %>% group_by(SNP) %>% mutate(snpcount=n()) %>% arrange(desc(snpcount), SNP)
	snplist <- unique(sigo1$SNP)
	mvo <- list()
	dat <- tryxscan$dat
	dat$qi <- cochrans_q(dat$beta.outcome / dat$beta.exposure, dat$se.outcome / abs(dat$beta.exposure))
	dat$Q <- sum(dat$qi)
	dat$orig.beta.outcome <- dat$beta.outcome
	dat$orig.se.outcome <- dat$se.outcome
	dat$orig.qi <- dat$qi
	dat$outlier <- FALSE
	dat$outlier[dat$SNP %in% tryxscan$outliers] <- TRUE
	for(i in 1:length(snplist))
	{
		message("Estimating joint effects of the following trait(s) associated with ", snplist[i])
		temp <- subset(sigo1, SNP %in% snplist[i])
		candidates <- unique(temp$outcome)
		message(paste(candidates, collapse="\n"))
		if(lasso & length(candidates) == 1)
		{
			message("Only one candidate trait for SNP ", snplist[i], " so performing standard MVMR instead of LASSO")
		}
		mvexp <- suppressMessages(mv_extract_exposures(c(id.exposure, unique(temp$id.outcome)), find_proxies=proxies))
		mvout <- suppressMessages(extract_outcome_data(mvexp$SNP, id.outcome))
		mvdat <- suppressMessages(mv_harmonise_data(mvexp, mvout))
		if(lasso & length(candidates) > 1)
		{
			message("Performing shrinkage")
			b <- glmnet::cv.glmnet(x=mvdat$exposure_beta, y=mvdat$outcome_beta, weight=1/mvdat$outcome_se^2, intercept=0)
			c <- coef(b, s = "lambda.min")
			keeplist <- unique(c(rownames(c)[!c[,1] == 0], tryxscan$dat$id.exposure[1]))
			message("After shrinkage keeping:")
			message(paste(keeplist, collapse="\n"))
			mvexp2 <- subset(mvexp, id.exposure %in% keeplist)
			remsnp <- group_by(mvexp2, SNP) %>% summarise(mp = min(pval.exposure)) %>% filter(mp > 5e-8) %$% as.character(SNP)
			mvexp2 <- subset(mvexp2, !SNP %in% remsnp)
			mvout2 <- subset(mvout, SNP %in% mvexp2$SNP)
			mvdat2 <- suppressMessages(mv_harmonise_data(mvexp2, mvout2))
			mvo[[i]] <- mv_multiple(mvdat2)$result
		} else {
			mvo[[i]] <- mv_multiple(mvdat)$result
		}
		mvo[[i]] <- subset(mvo[[i]], !exposure %in% tryxscan$dat$exposure[1])
		temp2 <- with(temp, tibble(SNP=SNP, exposure=outcome, snpeff=beta.outcome, snpeff.se=se.outcome, snpeff.pval=pval.outcome))
		mvo[[i]] <- merge(mvo[[i]], temp2, by="exposure")
		boo <- with(subset(dat, SNP == snplist[i]),
			bootstrap_path(
				beta.outcome,
				se.outcome,
				mvo[[i]]$snpeff,
				mvo[[i]]$snpeff.se,
				mvo[[i]]$b,
				mvo[[i]]$se
			))
		dat$beta.outcome[dat$SNP == snplist[i]] <- boo[1]
		dat$se.outcome[dat$SNP == snplist[i]] <- boo[2]
	}
	mvo <- bind_rows(mvo)

	dat$qi[dat$mr_keep] <- cochrans_q(dat$beta.outcome[dat$mr_keep] / dat$beta.exposure[dat$mr_keep], dat$se.outcome[dat$mr_keep] / abs(dat$beta.exposure[dat$mr_keep]))
	return(list(mvo=mvo, dat=dat))
}

#' Analyse tryx results
#'
#' This returns various heterogeneity statistics, IVW estimates for raw,
#' adjusted and outlier removed datasets, and summary of peripheral
#' traits detected etc.
#'
#' @param tryxscan Output from \code{tryx.scan}
#' @param plot Whether to plot or not. Default is TRUE
#' @param id_remove List of IDs to exclude from the adjustment analysis. It is possible that in the outlier search a candidate trait will come up which is essentially just a surrogate for the outcome trait (e.g. if you are analysing coronary heart disease as the outcome then a variable related to heart disease medication might come up as a candidate trait). Adjusting for a trait which is essentially the same as the outcome will erroneously nullify the result, so visually inspect the candidate trait list and remove those that are inappropriate.
#' @param duplicate_outliers_method Sometimes more than one trait will associate with a particular outlier. TRUE = only keep the trait that has the biggest influence on heterogeneity
#'
#' @export
#' @return List of
#' - adj_full: data frame of SNP adjustments for all candidate traits
#' - adj: The results from adj_full selected to adjust the exposure-outcome model
#' - Q: Heterogeneity stats
#' - estimates: Adjusted and unadjested exposure-outcome effects
#' - plot: Radial plot showing the comparison of different methods and the changes in SNP effects ater adjustment
tryx.analyse <- function(tryxscan, plot=TRUE, id_remove=NULL, filter_duplicate_outliers=TRUE)
{

	analysis <- list()
	adj_full <- tryx.adjustment(tryxscan, id_remove)
	if(nrow(adj_full) == 0)
	{
		return(NULL)
	}
	analysis$adj_full <- adj_full
	if(filter_duplicate_outliers)
	{
		adj <- adj_full %>% arrange(d) %>% filter(!duplicated(SNP))
	} else {
		adj <- adj_full
	}
	analysis$adj <- adj

	# Detection
	# if("simulation" %in% names(tryxscan))
	# {
	# 	detection <- list()
	# 	detection$nu1_correct <- sum(adj$SNP %in% 1:tryxscan$simulation$nu1 & adj$what != "p->y")
	# 	detection$nu1_incorrect <- sum(adj$SNP %in% 1:tryxscan$simulation$nu1 & adj$what == "p->y")
	# 	detection$nu2_correct <- sum(adj$SNP %in% (1:tryxscan$simulation$nu2 + tryxscan$simulation$nu1) & adj$what == "p->y")
	# 	detection$nu2_incorrect <- sum(adj$SNP %in% (1:tryxscan$simulation$nu2 + tryxscan$simulation$nu1) & adj$what != "p->y")
	# 	detection$no_outlier_flag <- tryxscan$simulation$no_outlier_flag
	# 	analysis$detection <- detection
	# }

	cpg <- require(ggrepel)
	if(!cpg)
	{
		stop("Please install the ggrepel package\ninstall.packages('ggrepel')")
	}

	dat <- subset(tryxscan$dat, mr_keep, select=c(SNP, beta.exposure, beta.outcome, se.exposure, se.outcome))
	dat$ratio <- dat$beta.outcome / dat$beta.exposure
	dat$weights <- sqrt(dat$beta.exposure^2 / dat$se.outcome^2)
	dat$ratiow <- dat$ratio * dat$weights
	dat$what <- "Unadjusted"
	dat$candidate <- "NA"
	dat$qi <- cochrans_q(dat$beta.outcome / dat$beta.exposure, dat$se.outcome / abs(dat$beta.exposure))

	analysis$Q$full_Q <- adj$Q[1]
	analysis$Q$num_reduced <- sum(adj$adj.qi < adj$qi)
	analysis$Q$mean_d <- mean(adj$d)

	temp <- subset(adj, select=c(SNP, adj.beta.exposure, adj.beta.outcome, adj.se.exposure, adj.se.outcome, candidate))
	temp$qi <- cochrans_q(temp$adj.beta.outcome / temp$adj.beta.exposure, temp$adj.se.outcome / abs(temp$adj.beta.exposure))
	ind <- grepl("\\|", temp$candidate)
	if(any(ind))
	{
		temp$candidate[ind] <- sapply(strsplit(temp$candidate[ind], split=" \\|"), function(x) x[[1]])
	}
	names(temp) <- gsub("adj.", "", names(temp))
	temp$what <- "Adjusted"
	temp$weights <- sqrt(temp$beta.exposure^2 / temp$se.outcome^2)
	temp$ratio <- temp$beta.outcome / temp$beta.exposure
	temp$ratiow <- temp$ratio * temp$weights

	dat_adj <- rbind(temp, dat) %>% filter(!duplicated(SNP))
	dat_adj$qi <- cochrans_q(dat_adj$beta.outcome / dat_adj$beta.exposure, dat_adj$se.outcome / abs(dat_adj$beta.exposure))
	analysis$Q$adj_Q <- sum(dat_adj$qi)

	dat_rem <- subset(dat, !SNP %in% temp$SNP)
	dat_rem2 <- subset(dat, !SNP %in% tryxscan$outliers)
	# adjust everything that's possible remove remaining outliers
	dat_rem3 <- rbind(temp, dat_rem2) %>% filter(!duplicated(SNP))

	estimates <- tibble()

	# Raw IVW
	tt <- dat
	mod <- summary(lm(ratiow ~ -1 + weights, data=tt))
	estimates <- bind_rows(estimates,
		tibble(
			est="Raw",
			b=coefficients(mod)[1,1],
			se = coefficients(mod)[1,2],
			pval=coefficients(mod)[1,4],
			nsnp = nrow(tt),
			Q = sum(tt$qi),
			int = 0
		)
	)

	# Outliers removed (all)
	tt <- subset(dat, !SNP %in% tryxscan$outliers)
	mod <- try(summary(lm(ratiow ~ -1 + weights, data=tt)))
	if(class(mod) != "try-error")
	{
		estimates <- bind_rows(estimates,
			tibble(
				est="Outliers removed (all)",
				b=coefficients(mod)[1,1],
				se = coefficients(mod)[1,2],
				pval=coefficients(mod)[1,4],
				nsnp = nrow(tt),
				Q = sum(tt$qi),
				int = 0
			)
		)
	}

	# Outliers removed (candidates)
	tt <- subset(dat, !SNP %in% temp$SNP)
	mod <- try(summary(lm(ratiow ~ -1 + weights, data=tt)))
	if(class(mod) != "try-error")
	{
		estimates <- bind_rows(estimates,
			tibble(
				est="Outliers removed (candidates)",
				b=coefficients(mod)[1,1],
				se = coefficients(mod)[1,2],
				pval=coefficients(mod)[1,4],
				nsnp = nrow(tt),
				Q = sum(tt$qi),
				int = 0
			)
		)
	}

	# Outliers adjusted
	tt <- rbind(temp, dat) %>% filter(!duplicated(SNP))
	tt$qi <- cochrans_q(tt$beta.outcome / tt$beta.exposure, tt$se.outcome / abs(tt$beta.exposure))
	analysis$Q$adj_Q <- sum(tt$qi)
	mod <- try(summary(lm(ratiow ~ -1 + weights, data=tt)))
	if(class(mod) != "try-error")
	{
		estimates <- bind_rows(estimates,
			tibble(
				est="Outliers adjusted",
				b=coefficients(mod)[1,1],
				se = coefficients(mod)[1,2],
				pval=coefficients(mod)[1,4],
				nsnp = nrow(tt),
				Q = sum(tt$qi),
				int = 0
			)
		)
	}

	if("mvres" %in% names(tryxscan))
	{
		estimates <- bind_rows(estimates,
			tibble(
				est="Multivariable MR",
				b=tryxscan$mvres$result$b[1],
				se = tryxscan$mvres$result$se[1],
				pval = tryxscan$mvres$result$pval[1],
				nsnp = tryxscan$mvres$result$nsnp[1],
				Q = NA,
				int = 0
			)
		)
	}

	if("true_outliers" %in% names(tryxscan))
	{
		tt <- subset(dat, !SNP %in% tryxscan$true_outliers)
		mod <- try(summary(lm(ratiow ~ -1 + weights, data=tt)))
		if(class(mod) != "try-error")
		{
			estimates <- bind_rows(estimates,
				tibble(
					est=c("Oracle"),
					b=c(coefficients(mod)[1,1]),
					se=c(coefficients(mod)[1,2]),
					pval=c(coefficients(mod)[1,4]),
					nsnp=c(nrow(tt)),
					Q = c(sum(tt$qi)),
					int=0
				)
			)
		}
	}

	estimates <- bind_rows(estimates)
	estimates$Isq <- pmax(0, (estimates$Q - estimates$nsnp - 1) / estimates$Q)

	analysis$estimates <- estimates

	# est3 <- summary(lm(ratiow ~ -1 + weights, data=dat_adj))
	# est4 <- try(summary(lm(ratiow ~ -1 + weights, data=dat_rem2)))
	# est5 <- try(summary(lm(ratiow ~ -1 + weights, data=dat_rem3)))
	# if(class(est4) == "try-error")
	# {
	# 	est4 <- list(coefficients = matrix(NA, 2,4))
	# }

	# estimates <- data.frame(
	# 	est=c("Raw", "Outliers removed (candidates)", "Outliers removed (all)", "Outliers adjusted", "Mixed", "Multivariable MR"),
	# 	b=c(coefficients(est2)[1,1], coefficients(est1)[1,1], coefficients(est4)[1,1], coefficients(est3)[1,1], coefficients(est5)[1,1], tryxscan$mvres$result$b[1]),
	# 	se=c(coefficients(est2)[1,2], coefficients(est1)[1,2], coefficients(est4)[1,2], coefficients(est3)[1,2], coefficients(est5)[1,2], tryxscan$mvres$result$se[1]),
	# 	pval=c(coefficients(est2)[1,4], coefficients(est1)[1,4], coefficients(est4)[1,4], coefficients(est3)[1,4], coefficients(est5)[1,4], tryxscan$mvres$result$pval[1]),
	# 	nsnp=c(nrow(dat), nrow(dat_rem), nrow(dat_rem2), nrow(dat_adj), nrow(dat_rem3), tryxscan$mvres$result$nsnp[1]),
	# 	Q = c(sum(dat$qi), sum(dat_rem$qi), sum(dat_rem2$qi), sum(dat_adj$qi), sum(dat_rem3$qi), NA),
	# 	int=0
	# )
	# estimates$Isq <- pmax(0, (estimates$Q - estimates$nsnp - 1) / estimates$Q)

	# estimates$Isq <- pmax(0, (estimates$Q - estimates$nsnp - 1) / estimates$Q)

	# analysis$estimates <- estimates

	if(plot)
	{
		temp2 <- merge(dat, temp, by="SNP")
		labs <- rbind(
			data.frame(label=temp2$SNP, x=temp2$weights.x, y=temp2$weights.x * temp2$ratio.x),
			data.frame(label=temp$candidate, x=temp$weights, y=temp$weights * temp$ratio)
		)
		p <- ggplot(rbind(dat, temp), aes(y=ratiow, x=weights)) +
		geom_abline(data=estimates, aes(slope=b, intercept=0, colour=est)) +
		geom_label_repel(data=labs, aes(x=x, y=y, label=label), size=2, segment.color = "grey10") +
		geom_point() +
		geom_segment(data=temp2, colour="grey50", aes(x=weights.x, xend=weights.y, y=ratiow.x, yend=ratiow.y), arrow = arrow(length = unit(0.02, "npc"))) +
		labs(colour="") +
		xlim(c(0, max(dat$weights))) +
		ylim(c(min(0, dat$ratiow, temp$ratiow), max(dat$ratiow, temp$ratiow))) +
		scale_colour_brewer(type="qual")
		analysis$plot <- p
	}
	return(analysis)
}

#' Analyse tryx results
#'
#' This returns various heterogeneity statistics, IVW estimates for raw,
#' adjusted and outlier removed datasets, and summary of peripheral
#' traits detected etc.
#'
#' @param tryxscan Output from \code{tryx.scan}
#' @param plot Whether to plot or not. Default is TRUE
#' @param filter_duplicate_outliers Whether to only allow each putative outlier to be adjusted by a single trait (in order of largest divergence). Default is TRUE.
#'
#' @export
#' @return List of
#' - adj_full: data frame of SNP adjustments for all candidate traits
#' - adj: The results from adj_full selected to adjust the exposure-outcome model
#' - Q: Heterogeneity stats
#' - estimates: Adjusted and unadjested exposure-outcome effects
#' - plot: Radial plot showing the comparison of different methods and the changes in SNP effects ater adjustment

#' Adjust and analyse the tryx results
#'
#' Similar to tryx.analyse, but when there are multiple traits associated with a single variant then we use a LASSO-based multivariable approach
#'
#' @param tryxscan Output from \code{tryx.scan}
#' @param lasso Whether to shrink the estimates of each trait within SNP. Default=TRUE.
#' @param plot Whether to plot or not. Default is TRUE
#' @param id_remove List of IDs to exclude from the adjustment analysis. It is possible that in the outlier search a candidate trait will come up which is essentially just a surrogate for the outcome trait (e.g. if you are analysing coronary heart disease as the outcome then a variable related to heart disease medication might come up as a candidate trait). Adjusting for a trait which is essentially the same as the outcome will erroneously nullify the result, so visually inspect the candidate trait list and remove those that are inappropriate.
#' @param proxies Look for proxies in the MVMR methods. Default = FALSE.
#'
#' @export
#' @return List of
#' - adj_full: data frame of SNP adjustments for all candidate traits
#' - adj: The results from adj_full selected to adjust the exposure-outcome model
#' - Q: Heterogeneity stats
#' - estimates: Adjusted and unadjested exposure-outcome effects
#' - plot: Radial plot showing the comparison of different methods and the changes in SNP effects ater adjustment
tryx.analyse.mv <- function(tryxscan, lasso=TRUE, plot=TRUE, id_remove=NULL, proxies=FALSE)
{
	adj <- tryx.adjustment.mv(tryxscan, lasso=lasso, id_remove=id_remove, proxies=proxies)
	dat <- subset(adj$dat, mr_keep)
	dat$orig.ratio <- dat$orig.beta.outcome / dat$beta.exposure
	dat$orig.weights <- sqrt(dat$beta.exposure^2 / dat$orig.se.outcome^2)
	dat$orig.ratiow <- dat$orig.ratio * dat$orig.weights
	dat$ratio <- dat$beta.outcome / dat$beta.exposure
	dat$weights <- sqrt(dat$beta.exposure^2 / dat$se.outcome^2)
	dat$ratiow <- dat$ratio * dat$weights

	est_raw <- summary(lm(orig.ratiow ~ -1 + orig.weights, data=dat))
	est_adj <- summary(lm(ratiow ~ -1 + weights, data=dat))
	est_out1 <- summary(lm(orig.ratiow ~ -1 + orig.weights, data=subset(dat, !SNP %in% tryxscan$outliers)))
	est_out2 <- summary(lm(orig.ratiow ~ -1 + orig.weights, data=subset(dat, !SNP %in% adj$mvo$SNP)))

	estimates <- data.frame(
		est=c("Raw", "Outliers removed (all)", "Outliers removed (candidates)", "Outliers adjusted"),
		b=c(coefficients(est_raw)[1,1], coefficients(est_out2)[1,1], coefficients(est_out1)[1,1], coefficients(est_adj)[1,1]),
		se=c(coefficients(est_raw)[1,2], coefficients(est_out2)[1,2], coefficients(est_out1)[1,2], coefficients(est_adj)[1,2]),
		pval=c(coefficients(est_raw)[1,4], coefficients(est_out2)[1,4], coefficients(est_out1)[1,4], coefficients(est_adj)[1,4]),
		nsnp=c(nrow(dat), nrow(subset(dat, !SNP %in% tryxscan$outliers)), nrow(subset(dat, !SNP %in% adj$mvo$SNP)), nrow(dat)),
		Q = c(sum(dat$orig.qi), sum(subset(dat, !SNP %in% tryxscan$outliers)$qi), sum(subset(dat, !SNP %in% adj$mvo$SNP)$qi), sum(dat$qi)),
		int=0
	)
	estimates$Isq <- pmax(0, (estimates$Q - estimates$nsnp - 1) / estimates$Q)

	analysis <- list(
		estimates=estimates,
		mvo=adj$mvo,
		dat=adj$dat
	)

	if(plot)
	{
		dato <- subset(dat, SNP %in% tryxscan$outliers)
		datadj <- subset(dat, SNP %in% adj$mvo$SNP)
		datadj$x <- datadj$orig.weights
		datadj$xend <- datadj$weights
		datadj$y <- datadj$orig.ratiow
		datadj$yend <- datadj$ratiow

		mvog <- tidyr::separate(adj$mvo, exposure, sep="\\|", c("exposure", "temp", "id"))
		mvog$exposure <- gsub(" $", "", mvog$exposure)
		mvog <- group_by(mvog, SNP) %>% summarise(label = paste(exposure, collapse="\n"))
		datadj <- merge(datadj, mvog, by="SNP")

		labs <- rbind(
			tibble(label=dato$SNP, x=dato$orig.weights, y=dato$orig.ratiow, col="grey50"),
			tibble(label=datadj$label, x=datadj$weights, y=datadj$ratiow, col="grey100")
		)

		p <- ggplot(dat, aes(y=orig.ratiow, x=orig.weights)) +
		geom_abline(data=estimates, aes(slope=b, intercept=0, linetype=est)) +
		geom_label_repel(data=labs, aes(label=label, x=x, y=y, colour=col), size=2, segment.color = "grey50", show.legend = FALSE) +
		geom_point(data=dato, size=4) +
		# geom_label_repel(data=labs, aes(label=label, x=weights, y=ratiow), size=2, segment.color = "grey50") +
		geom_point(data=datadj, aes(x=weights, y=ratiow)) +
		geom_point(aes(colour=SNP %in% dato$SNP), show.legend=FALSE) +
		geom_segment(data=datadj, colour="grey50", aes(x=x, xend=xend, y=y, yend=yend), arrow = arrow(length = unit(0.01, "npc"))) +
		labs(colour=NULL, linetype="Estimate", x="w", y="beta * w")
		# xlim(c(0, max(dat$weights))) +
		# ylim(c(min(0, dat$ratiow, temp$ratiow), max(dat$ratiow, temp$ratiow)))
		analysis$plot <- p
	}
	return(analysis)

}

#' Cochran's Q statistic
#'
#' @param b vector of effecti
#' @param se vector of standard errors
#'
#' @return q values
#'
#' @export
cochrans_q <- function(b, se)
{
	xw <- sum(b / se^2) / sum(1/se^2)
	qi <- (1/se^2) * (b - xw)^2
	return(qi)
}

bootstrap_path1 <- function(gx, gx.se, gp, gp.se, px, px.se, nboot=1000)
{
	res <- rnorm(nboot, gx, gx.se) - rnorm(nboot, gp, gp.se) * rnorm(nboot, px, px.se)
	pe <- gx - gp * px
	return(c(pe, sd(res)))
}

bootstrap_path <- function(gx, gx.se, gp, gp.se, px, px.se, nboot=1000)
{
	nalt <- length(gp)
	altpath <- tibble(
		p = rnorm(nboot * nalt, gp, gp.se) * rnorm(nboot * nalt, px, px.se),
		b = rep(1:nboot, each=nalt)
	)
	altpath <- group_by(altpath, b) %>%
		summarise(p = sum(p))
	res <- rnorm(nboot, gx, gx.se) - altpath$p
	pe <- gx - sum(gp * px)
	return(c(pe, sd(res)))
}

radialmr <- function(dat, outlier=NULL)
{
	library(ggplot2)
	beta.exposure <- dat$beta.exposure
	beta.outcome <- dat$beta.outcome
	se.outcome <- dat$se.outcome
	w <- sqrt(beta.exposure^2 / se.outcome^2)
	ratio <- beta.outcome / beta.exposure
	ratiow <- ratio*w
	dat <- data.frame(w=w, ratio=ratio, ratiow=ratiow)
	if(is.null(outlier))
	{
		dat2 <- dat
	} else {
		dat2 <- dat[-c(outlier), ]
	}
	mod <- lm(ratiow ~ -1 + w, dat2)$coefficients[1]
	ggplot(dat, aes(x=w, y=ratiow)) +
	geom_point() +
	geom_abline(slope=mod, intercept=0)
}


context("Test reportingRateModel and associated functions")

# Create data
n <- 3000 #size of dataset
nyr <- 10 # number of years in data
nSamples <- 30 # set number of dates
nSites <- 15 # set number of sites
set.seed(1985)

# Create somes dates
first <- as.POSIXct(strptime("2010/01/01", "%Y/%m/%d"))
last <- as.POSIXct(strptime(paste(2010+(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(paste('A', 1:nSites, sep=''), size = n, TRUE)

# the date of visit is selected at random from those created earlier
time_period <- sample(rDates, size = n, TRUE)

# create a numeric vector of time periods to test for
num_period <- as.numeric(format(time_period,'%Y'))

# create additional dates with month and dat = 01 in to test if numeric and date format time_periods give equivalent results
dates <- as.POSIXct(strptime(paste0(num_period, "/01/01"), "%Y/%m/%d"))

# combine this to a dataframe (adding a final row of 'bad' data)
df <- data.frame(taxa = c(taxa,'bad'),
                 site = c(site,'A1'),
                 time_period = c(time_period, as.POSIXct(strptime("1200/01/01", "%Y/%m/%d"))),
                 num_period = c(num_period, 1200),
                 comparison_dates = c(dates, as.POSIXct(strptime("1200/01/01", "%Y/%m/%d"))))

######################
test_that("Test errors and warnings", {

  # outside errorChecks this is the only catch present in this set of functions

  # A couple in errorChecks for this function
  # warning when family is overridden by listlength
  expect_warning(RR_out <- reportingRateModel(df$taxa,
                               df$site,
                               df$time_period,
                               list_length = TRUE,
                               family = 'Binomial'),
                 "When list_length is TRUE family will default to Bernoulli")
  expect_error(suppressWarnings(RR_out <- reportingRateModel(df$taxa,
                                              df$site,
                                              df$time_period,
                                              list_length = 1)),
                 "list_length must be logical")
  expect_error(suppressWarnings(RR_out <- reportingRateModel(df$taxa,
                                              df$site,
                                              df$time_period,
                                              overdispersion = 1)),
                 "overdispersion must be logical")
  expect_error(suppressWarnings(RR_out <- reportingRateModel(df$taxa,
                                              df$site,
                                              df$time_period,
                                              verbose = 1)),
                 "verbose must be logical")
  expect_error(suppressWarnings(RR_out <- reportingRateModel(df$taxa,
                                              df$site,
                                              df$time_period,
                                              site_effect = 1)),
                 "site_effect must be logical")
  expect_warning(RR_out <- reportingRateModel(df$taxa,
                                            df$site,
                                            df$time_period,
                                            species_to_include = c('tom','a','b','c')),
               "The following species in species_to_include are not in your data: tom")
})

test_that("Test formulaBuilder", {

  family <- 'binomial'
  list_length <- FALSE
  site_effect <- FALSE
  overdispersion <- FALSE

  # Here we test thay the formula builder is prodicing the right responses under a range of conditions
  model_formula <- formulaBuilder(family,list_length,site_effect,overdispersion)
  expect_identical(model_formula, "cbind(successes, failures) ~ year")
  model_formula <- formulaBuilder('Bernoulli',list_length,site_effect,overdispersion)
  expect_identical(model_formula, "taxa ~ year")
  model_formula <- formulaBuilder(family,TRUE,site_effect,overdispersion)
  expect_identical(model_formula, "taxa ~ year + log(listLength)")
  model_formula <- formulaBuilder(family,TRUE,TRUE,overdispersion)
  expect_identical(model_formula, "taxa ~ year + log(listLength) + (1|site)")
  model_formula <- formulaBuilder(family,TRUE,TRUE,TRUE)
  expect_identical(model_formula, "taxa ~ year + log(listLength) + (1|site) + (1|obs)")
  model_formula <- formulaBuilder(family,list_length,TRUE,TRUE)
  expect_identical(model_formula, "cbind(successes, failures) ~ year + (1|site) + (1|obs)")

})

test_that("Check outputs are in the correct form", {

  expect_warning(RR_out <- reportingRateModel(df$taxa, df$site, df$time_period, species_to_include = c('a','b','c')),
                 "353 out of 3001 observations will be removed as duplicates")
  atts <- attributes(RR_out)
  expect_equal(atts$intercept_year, 2014)
  expect_equal(atts$min_year, -814)
  expect_equal(atts$max_year, 5)
  expect_equal(atts$nVisits, 450)
  expect_equal(atts$model_formula, "cbind(successes, failures) ~ year")
  expect_is(RR_out, "data.frame")
  expect_identical(c('a','b','c'), sort(as.character(RR_out$species_name)))
  ## check outputs are equal when time_periods are numeric or in date format
  expect_equal(reportingRateModel(df$taxa, df$site, df$num_period, species_to_include = c('a','b','c')),
               reportingRateModel(df$taxa, df$site, df$num_period, species_to_include = c('a','b','c')))

})


if(!require(foreach))
{
	print("You are missing the package 'foreach', we will now try to install it...")
	install.packages("foreach")
	#library(foreach)
}

if(!require(xtable))
{
	print("You are missing the package 'xtable', we will now try to install it...")
	install.packages("xtable")
	#library(xtable)
}

if(!require(igraph))
{
	print("You are missing the package 'igraph', we will now try to install it...")
	install.packages("igraph")
	#library(igraph)
}

library(coin)
library(multcomp)
library(colorspace)
library(foreach)
library(xtable)
library(igraph)

labels <- strsplit(row.names(output$PostHoc.Test), " - ")
matrix <- matrix(nrow = length(methods), ncol = length(methods), dimnames=list(methods, methods))
adjMatrix <- matrix #adjacency matrix

alpha <- 0.05

raw_ranks <- c()
foreach(p = 1:length(problems)) %do% {
    indexes <- seq((p-1)*(length(methods)-1) + p, p*(length(methods)-1) + p)
    p_ranks <- rank(Data$Table[indexes])
    raw_ranks <- rbind(raw_ranks, p_ranks)
}
# ranks consists of raw ranks now
#print(ranks)

# aggregate ranks
ranks = c()
foreach(m = 1:length(methods)) %do% {
    ranks[m] <- mean(raw_ranks[,m])
}
print(paste("Ranks: ", ranks))

foreach(i = 1:length(output$PostHoc.Test)) %do% {
	l1 <- unlist(labels[i])[1]
	l2 <- unlist(labels[i])[2]
	#print(paste("label1: ", l1, " label2: ", l2))

	l1Idx <- match(l1, methods)[1]
	l2Idx <- match(l2, methods)[1]
	#avg1 <- sum(Data$Table[seq(l1Idx, length(Data$Table), length(methods))]) / length(problems)
	#avg2 <- sum(Data$Table[seq(l2Idx, length(Data$Table), length(methods))]) / length(problems)

	#print(paste("avg1: ", avg1, " avg2: ", avg2))

	if (ranks[l1Idx] < ranks[l2Idx]) {
		if (output$PostHoc.Test[i] < alpha) {
			matrix[l1, l2] <- sprintf("\\textbf{%.3f}", output$PostHoc.Test[i])
			adjMatrix[l1, l2] <- 1
		}
		else
		{
			matrix[l1, l2] <- sprintf("%.3f", output$PostHoc.Test[i])
		}
	} else {
		if (output$PostHoc.Test[i] < alpha) {
			matrix[l2, l1] <- sprintf("\\textbf{%.3f}", output$PostHoc.Test[i])
			adjMatrix[l2, l1] <- 1
		}
		else
		{
			matrix[l2, l1] <- sprintf("%.3f", output$PostHoc.Test[i])
		}
	}
}

#print(matrix)
print(xtable(matrix, digits = 3), type="latex", sanitize.text.function = function(x){x})

graph <- graph.adjacency(adjMatrix)
V(graph)$label <- methods
V(graph)$label.cex <- 2 #font size
V(graph)$color <- "Lightgray"

#reset margin
par(mar=c(0,0,0,0))
plot(graph, layout=layout.circle, vertex.size=75, edge.color="Black")


library(dplyr)
library(ggplot2)
library(bootstrap)
library(lme4)

theme_set(theme_bw(18))
setwd("/Users/elisakreiss/Documents/stanford/study/overinformativeness/experiments/10_distributional_learning/results")
source("rscripts/helpers.r")

d = read.table(file="data/norming.csv",sep=",", header=T)#, quote="")
head(d)
nrow(d)
summary(d)
totalnrow = nrow(d)
d$Trial = d$slide_number_in_experiment - 1
length(unique(d$workerid))

typ = read.table(file="../../11_color_norming/results/data/meantypicalities.csv",sep=",",header=T)
row.names(typ) = paste(typ$Color,typ$Item)
head(typ)

# look at turker comments
unique(d$comments)

ggplot(d, aes(rt)) +
  geom_histogram() +
  scale_x_continuous(limits=c(0,15000))

ggplot(d, aes(log(rt))) +
  geom_histogram()

summary(d$Answer.time_in_minutes)
ggplot(d, aes(Answer.time_in_minutes)) +
  geom_histogram()

ggplot(d, aes(gender)) +
  stat_count()

ggplot(d, aes(asses)) +
  stat_count()

ggplot(d, aes(age)) +
  geom_histogram()
table(d$age)

ggplot(d, aes(education)) +
  stat_count()

ggplot(d, aes(language)) +
  stat_count()

ggplot(d, aes(enjoyment)) +
  stat_count()

# process typicality data
typicality = droplevels(d[!is.na(d$position_in_exposure),])
typicality <- typicality[,colSums(is.na(typicality))<nrow(typicality)]
typicality$NormedTypicality = typ[paste(typicality$color,typicality$item),]$Typicality
typicality$binaryTypicality = as.factor(ifelse(typicality$NormedTypicality > .5, "typical", "atypical"))

summary(production)
summary(typicality)
typicality$response = as.numeric(as.character(typicality$response))
table(typicality$item,typicality$proportion,typicality$binaryTypicality)

agr = typicality %>%
  group_by(item,color,proportion,binaryTypicality) %>%
  summarise(MeanTypicality = mean(response),ci.low=ci.low(response),ci.high=ci.high(response))
agr = as.data.frame(agr)
agr$YMin = agr$MeanTypicality - agr$ci.low
agr$YMax = agr$MeanTypicality + agr$ci.high

ggplot(agr, aes(x=proportion,y=MeanTypicality,color=color)) +
  geom_point() +
  geom_errorbar(aes(ymin=YMin,ymax=YMax),width=.25)  +
  facet_wrap(~item)
ggsave("graphs/png/meantypicality_byitem.png")

ggplot(agr, aes(x=proportion,y=MeanTypicality,color=binaryTypicality)) +
  geom_point() +
  geom_smooth(method="lm")
ggsave("graphs/png/meantypicality.png")

table(typicality$item,typicality$binaryTypicality,typicality$proportion)

# process production data
production = droplevels(d[is.na(d$position_in_exposure),])
production = production[production$target_item != "orange",]
production$NormedTypicality = typ[paste(production$target_color,production$target_item),]$Typicality
production$binaryTypicality = as.factor(ifelse(production$NormedTypicality > .5, "typical", "atypical"))
production <- production[,colSums(is.na(production))<nrow(production)]
production$ColorMentioned = ifelse(grepl("green|purple|white|black|brown|purple|violet|yellow|gold|orange|silver|blue|pink|red", production$response, ignore.case = TRUE), T, F)
production$CleanedResponse = gsub("([bB]ananna|[Bb]annna|[Bb]annana)","banana",as.character(production$response))
production$ItemMentioned = ifelse(grepl("apple|banana|orange|carrot|tomato|pear", production$CleanedResponse, ignore.case = TRUE), T, F)
prop.table(table(production$ColorMentioned,production$ItemMentioned))
# 1% cases of neither type nor color mention (eg, bad location modifiers like "the first one" or taboo-like reference to item like "long skinny vegetable")
production[!production$ColorMentioned & !production$ItemMentioned,]$response
# another 15% where color is mentioned but not type -- this seems to be just 3 subject who are being contrarian
production[production$ColorMentioned & !production$ItemMentioned,c("response","condition")]
table(production[production$ColorMentioned & !production$ItemMentioned,]$target_item,production[production$ColorMentioned & !production$ItemMentioned,]$binaryTypicality)
table(production[production$ColorMentioned & !production$ItemMentioned,]$target_item,production[production$ColorMentioned & !production$ItemMentioned,]$workerid)

# read in the distribtion info
untyp = unique(typicality[,c("item","color","workerid","proportion")])
row.names(untyp) = paste(untyp$color,untyp$item,untyp$workerid)
production$Proportion = untyp[paste(production$target_color,production$target_item,production$workerid),]$proportion
head(production)

#exclude cases where locative modifiers were used
production = droplevels(production[!(!production$ColorMentioned & !production$ItemMentioned),])

table(production$Proportion,production$condition,production$binaryTypicality)
table(production$Proportion,production$condition,production$binaryTypicality,production$target_item)
agr = production %>%
  group_by(Proportion,condition,binaryTypicality) %>%
  summarise(PropColorMentioned=mean(ColorMentioned),ci.low=ci.low(ColorMentioned),ci.high=ci.high(ColorMentioned))
agr = as.data.frame(agr)
agr$YMin = agr$PropColorMentioned - agr$ci.low
agr$YMax = agr$PropColorMentioned + agr$ci.high

ggplot(agr, aes(x=Proportion,y=PropColorMentioned,color=condition)) +
  geom_point() +
  geom_errorbar(aes(ymin=YMin,ymax=YMax),width=.25) +
  facet_wrap(~binaryTypicality)
ggsave("graphs/png/excl_orange_distribution_effect_production.png",height=3.5)

# condition on whether or not item was mentioned
table(production$Proportion,production$condition,production$binaryTypicality)
agr = production %>%
  group_by(Proportion,condition,binaryTypicality,ItemMentioned) %>%
  summarise(PropColorMentioned=mean(ColorMentioned),ci.low=ci.low(ColorMentioned),ci.high=ci.high(ColorMentioned))
agr = as.data.frame(agr)
agr$YMin = agr$PropColorMentioned - agr$ci.low
agr$YMax = agr$PropColorMentioned + agr$ci.high

ggplot(agr, aes(x=Proportion,y=PropColorMentioned,color=condition)) +
  geom_point() +
  geom_errorbar(aes(ymin=YMin,ymax=YMax),width=.25) +
  facet_grid(ItemMentioned~binaryTypicality)
ggsave("graphs/png/excl_orange_distribution_effect_production_byitemmention.png",height=6.5)

agr = production %>%
  group_by(Proportion,condition,binaryTypicality,workerid) %>%
  summarise(PropColorMentioned=mean(ColorMentioned),ci.low=ci.low(ColorMentioned),ci.high=ci.high(ColorMentioned))
agr = as.data.frame(agr)
agr$YMin = agr$PropColorMentioned - agr$ci.low
agr$YMax = agr$PropColorMentioned + agr$ci.high

ggplot(agr, aes(x=Proportion,y=PropColorMentioned,color=condition)) +
  geom_jitter(width = 10,height=0) +
  geom_errorbar(aes(ymin=YMin,ymax=YMax),width=.25) +
  facet_grid(workerid~binaryTypicality)
ggsave("graphs/png/excl_orange_distribution_effect_production_bysubject.png",height=25)

agr = production %>%
  group_by(Proportion,condition,binaryTypicality,target_item) %>%
  summarise(PropColorMentioned=mean(ColorMentioned),ci.low=ci.low(ColorMentioned),ci.high=ci.high(ColorMentioned))
agr = as.data.frame(agr)
agr$YMin = agr$PropColorMentioned - agr$ci.low
agr$YMax = agr$PropColorMentioned + agr$ci.high

ggplot(agr, aes(x=Proportion,y=PropColorMentioned,color=condition)) +
  geom_jitter(width = 10,height=0) +
  geom_errorbar(aes(ymin=YMin,ymax=YMax),width=.25) +
  facet_grid(target_item~binaryTypicality)
ggsave("graphs/png/excl_orange_distribution_effect_production_byitem.png",height=10)

centered = cbind(production, myCenter(production[,c("binaryTypicality","Proportion","condition")]))
m = glmer(ColorMentioned ~ cProportion*cbinaryTypicality*ccondition + (1|workerid) , data=centered, family="binomial")
summary(m)

overinf = droplevels(production[production$condition == "overinformative",])
centered = cbind(overinf, myCenter(overinf[,c("binaryTypicality","Proportion","condition")]))
m = glmer(ColorMentioned ~ cProportion*cbinaryTypicality + (1|workerid) , data=centered, family="binomial")
summary(m)

m.simple = glmer(ColorMentioned ~ cProportion*binaryTypicality - cProportion + (1|workerid) , data=centered, family="binomial")
summary(m.simple)

m = glm(ColorMentioned ~ Proportion*cbinaryTypicality , data=centered, family="binomial")
summary(m)

m = glm(ColorMentioned ~ Proportion*binaryTypicality - Proportion, data=centered, family="binomial")
summary(m)


#!/usr/bin/env Rscript

cargs = commandArgs(trailingOnly=TRUE)

infile = cargs[1]
outfile = cargs[2]

x = read.table(infile)
x[, 3] = x[sample(1:nrow(x), nrow(x), FALSE), 3]

write.table(x, outfile, sep='\t', col.names=FALSE, row.names=FALSE,
            quote=FALSE)


#' Get Patient Report
#' @param PatientID - The patient identifier string associated with the patient's profile.
#' @param all_data - The entire data matrix loaded based on the diagnosis selected in the dropdown menu input$diagClass.
#' @return patientReport - a data table with the metabolites and z-scores associated with the selected patient ID.
#' @export getPatientReport
#'
#' @examples
#' data(Miller2015_Heparin)
#' # Input is supplied by R shiny app, but you can hard code parameters as a list object, too, to test functionality.
#' input = list()
#' input$ptIDs = colnames(Miller2015_Heparin)[4]
#' input$diagClass = "paa"
#' rpt = getPatientReport(input, Miller2015_Heparin)
#' head(rpt$patientReport)
getPatientReport = function(input, all_data) {
  print(input$diagClass)
  print(input$ptIDs)

  # MetaboliteName Zscore
  all_data = data.matrix(all_data)
  tmp.zscore = rownames(all_data)
  if (length(input$ptIDs)>1) {
    zscore.data = apply(all_data[ , which(colnames(all_data) %in% input$ptIDs)], 1, function(i) mean(na.omit(i)))
  } else {
    zscore.data = all_data[ , which(colnames(all_data)==input$ptIDs)]
  }
  names(zscore.data) = tmp.zscore
  print(head(zscore.data))

  ind = which(is.na(zscore.data))
  if (length(ind)>0) {
    zscore.data = zscore.data[-ind]
  }

  data = data.frame(Metabolite=character(), Zscore=numeric(), stringsAsFactors = FALSE)
  for (row in 1:length(zscore.data)) {
    data[row, "Metabolite"] = names(zscore.data)[row]
    data[row, "Zscore"] = round(zscore.data[names(zscore.data)[row]], 2)
  }

  # Remove mets that were NA in zscore
  ind0 = which(is.na(data[,"Zscore"]))
  if (length(ind0)>0) {
    data = data[-ind0,]
  }
  print(dim(data))

  # Order by abs(Zscore)
  class(data[,"Zscore"]) = "numeric"
  data = data[order(abs(data[,"Zscore"]), decreasing = TRUE), ]
  names(data) = c("Metabolite", "Z-score")

  return(list(patientReport=data))
}


#' @title gaphunter
#' @name gaphunter
#' @param object a matrix or object of class: "GenomicRatioSet", "GenomicMethylSet", "MethylSet", or"RatioSet"
#' @param threshold (default = 0.05)
#' @param keepOutliers (default = FALSE)
#' @param outCutoff (default = 0.01)
#' @param verbose (default = TRUE)
#' gaphunter() function from:
#' https://epigeneticsandchromatin.biomedcentral.com/articles/10.1186/s13072-016-0107-z
#' copied with minor modification from https://raw.githubusercontent.com/kasperdanielhansen/minfi/master/R/gaphunter.R (2018-03-23)
#' @export
gaphunter <- function(object, threshold = 0.05, keepOutliers = FALSE,
					  outCutoff = 0.01, verbose = TRUE) {
	if ((threshold <= 0) || (threshold >= 1))
		stop("[gaphunter] 'threshold' must be between 0 and 1.")
	if ((outCutoff <= 0) || (outCutoff >= 0.5))
		stop("[gaphunter] 'outCutoff' must be between 0 and 0.5.")
	if (is(object, "GenomicRatioSet") || is(object, "GenomicMethylSet") ||
		is(object, "MethylSet") || is(object,"RatioSet")) {
		if(verbose)
			message("[gaphunter] Calculating beta matrix.")
		Beta <- getBeta(object)
	} else {
		if(is(object,"matrix")) {
			test <- matrixStats::rowRanges(object)
			if(sum(test[,1] < 0,na.rm = TRUE) == 0 && sum(test[,2] > 1,na.rm = TRUE) == 0) {
				Beta <- object } else { stop("[gaphunter] Matrix must be of Beta values with range from 0 to 1") }
		} else {
			stop("[gaphunter] Object must be one of (Genomic)RatioSet, (Genomic)MethylSet, or matrix")
		}
	}
	nacheck <- rowSums(is.na(Beta))
	if (sum(nacheck > 0) > 0) {
		if(verbose)
			message("[gaphunter] Removing probes containing missing beta values.")
		Beta <- Beta[which(nacheck == 0),]
	}

	if (verbose) {
		message("[gaphunter] Using ",prettyNum(nrow(Beta),big.mark = ",",scientific = FALSE),
				" probes and ",prettyNum(ncol(Beta),big.mark = ",",scientific = FALSE)," samples.")
		message("[gaphunter] Searching for gap signals.")
	}

	sorting <- t(apply(Beta, 1, sort.int, method = "quick", index.return = TRUE))
	sortedindices <- lapply(sorting, function(n) { return(n$ix) })
	sortedbeta <- do.call("rbind", lapply(sorting, function(n) {return(n$x)} ))
	rownames(sortedbeta) <- rownames(Beta)
	diffs <- matrixStats::rowDiffs(sortedbeta)
	gapind <- rowSums(diffs > threshold)
	sortedindices <- lapply(which(gapind > 0), function(h) { return(sortedindices[[h]]) })
	sortedbeta <- sortedbeta[which(gapind > 0),]
	diffs <- diffs[which(gapind > 0),]
	gapind <- gapind[which(gapind > 0)]

	breakpoints <- apply(diffs,1,function(x) { return(which(x > threshold)) })

	returngroups <- function(x,y) {
		template <- rep(1, ncol(sortedbeta))
		count <- 2
		for (j in x) {
			template[y[(j+1):length(y)]] <- count
			count <- count+1
		}
		return(template)
	}

	groupanno <- t(mapply(returngroups, breakpoints, sortedindices))
	maxGroups <- max(groupanno)
	gapanno <- matrix(0, nrow = nrow(groupanno), ncol = maxGroups + 1)
	gapanno[,1] <- matrixStats::rowMaxs(groupanno)
	for(ii in 1:maxGroups) {
		gapanno[, ii + 1] <- matrixStats::rowCounts(groupanno, value = ii)
	}
	## gapanno <- apply(groupanno, 1, function(k) {
	##	 tempgap <- rep(0, max(gapind) + 2)
	##	 kl <- length(unique(k))
	##	 tempgap[1] <- kl
	##	 tempgap[1 + 1:kl] <- table(k)
	##	 return(tempgap)
	## })
	## gapanno <- t(gapanno)
	rownames(gapanno) <- rownames(sortedbeta)
	rownames(groupanno) <- rownames(sortedbeta)

	if(verbose)
		message("[gaphunter] Found ",
				prettyNum(nrow(gapanno),big.mark = ",",scientific = FALSE), " gap signals.")

	if (keepOutliers == FALSE) {
		if (verbose)
			message("[gaphunter] Filtering out gap signals driven by outliers.")
		markme <- unlist(lapply(1:nrow(gapanno), function(blah) {
			analyze <- gapanno[blah, -1]
			maxgroup <- which(analyze == max(analyze,na.rm=TRUE))
			if (length(maxgroup) == 1) {
				if(sum(analyze[-maxgroup],na.rm=TRUE) < outCutoff*ncol(Beta)) {
					return(blah)
				}
			}
		}))
		if (length(markme) > 0) {
			gapanno <- gapanno[-markme,]
			groupanno <- groupanno[-markme,]
		}
		if (verbose)
			message("[gaphunter] Removed ",prettyNum(length(markme),big.mark = ",",scientific = FALSE),
					" gap signals driven by outliers from results.")
	}
	gapanno <- data.frame(gapanno)

	colnames(gapanno) <- c("Groups", paste0("Group",1:(ncol(gapanno)-1)))

	algorithm <- list("threshold" = threshold, "outCutoff" = outCutoff, "keepOutliers" = keepOutliers)

	return(list("proberesults" = gapanno, "sampleresults" = groupanno, "algorithm" = algorithm))
}


#!/usr/bin/env Rscript

args = commandArgs(trailingOnly = TRUE)
#load required packages
library("IRanges")
library("GenomicRanges")
library("rtracklayer")
library("Rsamtools")
library("GenomicAlignments")
library("GenomicFeatures")

#USAGE:
#Rscript box_plot.r \
#<1. project directory> \
#<2. bam1, WT> \
#<3. bam1 name> \
#<4. bam2, Test> \
#<5. bam2 name> \
#<6. peaks1> \
#<7. peaks1 name> \
#<8. peaks2> \
#<9. peaks2 name> \
#<10. file out name>

dir <- args[1]
setwd(dir)

#read bams
bam1.name <- args[3]
bam1.bam <- readGAlignments(file.path(args[2]))
bam1.gr <- granges(bam1.bam)
bam1 <- bam1.gr
#find library size
library_bam1 <- NROW(bam1)

bam2.name <- args[5]
bam2.bam <- readGAlignments(file.path(args[4]))
bam2.gr <- granges(bam2.bam)
bam2 <- bam2.gr
#find library size
library_bam2 <- NROW(bam2)

#read peaks
peaks1.name <- args[7]
peaks1 <- import(file.path(args[6]), format = "BED")

peaks2.name <- args[9]
peaks2 <- import(file.path(args[8]), format = "BED")

outprefix <- args[10]

#Calculate RPKM, = numReads / ( geneLength/1000 * totalNumReads/1,000,000 )
rpkm_bam1_peaks1 <- countOverlaps(peaks1, bam1) / (width(peaks1)/1000 * library_bam1/1000000)
rpkm_bam2_peaks1 <- countOverlaps(peaks1, bam2) / (width(peaks1)/1000 * library_bam2/1000000)
rpkm_peaks1<- data.frame(rpkm_bam1_peaks1,rpkm_bam2_peaks1)

#write pdf
boxplot_file_peak1 <- paste(outprefix,peaks1.name,"box_plot.pdf", sep = "_")
pdf(file=boxplot_file_peak1)
par(pty = "s")
boxplot(rpkm_peaks1,col=(c("blue","red")), main=peaks1.name, ylab="RPKM",outline=F, notch=T,
        names=c(bam1.name,bam2.name),
        boxwex = 0.4,cex.axis=1,lwd=4,lty=1,ylim=c(0,12))
dev.off()

out_cox_peaks1.name <- paste(outprefix,peaks1.name,"wilcox_test.txt", sep = "_")
wilcox_peaks1 <- wilcox.test(rpkm_bam1_peaks1,rpkm_bam2_peaks1,conf.int=T)
write.table(wilcox_peaks1$p.value, file=file.path(dir, out_cox_peaks1.name), sep="\t", quote=F, row.names=F, col.names=F)

#Peak2
rpkm_bam1_peaks2 <- countOverlaps(peaks2, bam1) / (width(peaks1)/1000 * library_bam1/1000000)
rpkm_bam2_peaks2 <- countOverlaps(peaks2, bam2) / (width(peaks1)/1000 * library_bam2/1000000)
rpkm_peaks2<- data.frame(rpkm_bam1_peaks2,rpkm_bam2_peaks2)

#write pdf
boxplot_file_peak2 <- paste(outprefix,peaks2.name, "box_plot.pdf", sep = "_")
pdf(file=boxplot_file_peak2)
par(pty = "s")
boxplot(rpkm_peaks2,col=(c("blue","red")), main=peaks2.name, ylab="RPKM",outline=F, notch=T,
        names=c(bam1.name,bam2.name),
        boxwex = 0.4,cex.axis=1,lwd=4,lty=1,ylim=c(0,12))
dev.off()

out_cox_peaks2.name <- paste(outprefix,peaks2.name,"wilcox_test.txt", sep = "_")
wilcox_peaks2 <- wilcox.test(rpkm_bam1_peaks2,rpkm_bam2_peaks2,conf.int=T)
write.table(wilcox_peaks2$p.value, file=file.path(dir, out_cox_peaks2.name), sep="\t", quote=F, row.names=F, col.names=F)


# #-------------------------SVM analysis

## the code perform a svm analysis with 2 groups,
## inputs: Multi_datainput_m2, Multi_datainput_m (chosen via Projects_metadata$confound_by)
## 2 types of strategy depending on testvalidation, which depends on sample size.

##---testset validation if enough data
if (testvalidation){
  #---- Determine the trainset and testset of data, more complex if there is a confounding factor.

  if (!is.na(Projects_metadata$confound_by)) {
    Input = Multi_datainput_m2 #take the data with confounding variable

    L = levels(Input$groupingvar)
    L2 = levels(Input$confoundvar)
    Glass = Input %>% filter (groupingvar == L[1])
    Glass2 = Input %>% filter (groupingvar == L[2])
    # message if group of different size
    if (nrow (Glass) != nrow (Glass2))
      print("the groups do not have the same size !")

    # split each randomly over confoundvar

    Glass_1 = Glass %>% filter (confoundvar == L2[1])
    Glass_2 = Glass %>% filter (confoundvar == L2[2])
    Glass2_1 = Glass2 %>% filter (confoundvar == L2[1])
    Glass2_2 = Glass2 %>% filter (confoundvar == L2[2])

    # prepare datasets
    indexl = min(nrow(Glass), nrow(Glass2))
    index     <- 1:indexl
    trainlength = max(4,  trunc(length(index) / 3)) #max fct deprecated, this run only if there is enough data
    indexl2 = min(nrow(Glass_1),
                  nrow(Glass_2),
                  nrow(Glass2_1),
                  nrow(Glass2_2))
    index     <- 1:indexl2
    trainindex <- sample(index, trainlength)

    trainset  <-
      rbind(Glass_1[trainindex, ], Glass_2[trainindex, ], Glass2_1[trainindex, ], Glass2_2[trainindex, ])
    testset <-
      rbind(Glass_1[-trainindex, ], Glass_2[-trainindex, ], Glass2_1[-trainindex, ], Glass2_2[-trainindex, ])
    trainset  <- trainset %>% select (-confoundvar)
    testset <- testset %>% select (-confoundvar)

  } else { # if no counfounding variable, it is faster!
    Input = Multi_datainput_m
    L = levels(Input$groupingvar)
    Glass = Input %>% filter (groupingvar == L[1])
    Glass2 = Input %>% filter (groupingvar == L[2])
    if (nrow (Glass) != nrow (Glass2))
      print("the groups do not have the same size !")
    indexl = min(nrow(Glass), nrow(Glass2))

    # split each randomly
    index     <- 1:indexl
    trainindex <- sample(index, max(8, 2 * trunc(length(index) / 3)))
    trainset  <- rbind(Glass[trainindex,], Glass2[trainindex,])
    testset <- rbind(Glass[-trainindex,], Glass2[-trainindex,])
  }
  ## we now have trainset and  testset!!
 ######--------------------------------run SVM analysis

  ##---- getting rid of variables with no variability (all 0)
  temp = trainset %>% select (-groupingvar)
  cfreq <- colSums(temp)
  E1 = names(temp[, cfreq == 0])
  temp = testset %>% select (-groupingvar)
  cfreq <- colSums(temp)
  E2 = names(temp[, cfreq == 0])
  trainset = trainset [,!names(trainset) %in% c(E1, E2)]
  testset = testset [,!names(testset) %in% c(E1, E2)]
  Input = Input[,!names(Input) %in% c(E1, E2)]

  ##--- tuning: choose best kernel and parameters (error rate minimal), all data (accuracy on trainset maximal, use all if identical), this takes time!
  bestk= tune.svm2(trainset,groupingvar)
  best.parameters = bestk[[2]]
  ##--- train model with best parameters on trainset data
  svm.model <- svm(groupingvar ~ ., data = trainset, cost = best.parameters$cost, gamma = best.parameters$gamma, kernel = bestk[[1]])

  #-- run model on test data
  svm.pred <- predict(svm.model, testset %>% select(-groupingvar))
  #-- compare prediction with real data
  SVMprediction_res = table(pred = svm.pred, true = testset$groupingvar)
  #SVMprediction = as.data.frame(SVMprediction_res)

  #-- Accuracy of grouping and plot
  temp = classAgreement (SVMprediction_res)
  Accuracyreal = temp$kappa
  kernel = bestk[[1]]

}

#### 2-out cross-validation if sample size too low.
if (!testvalidation){
  ## set data to use for the svm
  if (!is.na(Projects_metadata$confound_by)) {
    out_sel = Multi_datainput_m2[order(Multi_datainput_m2$groupingvar, Multi_datainput_m2$confoundvar),]
    out_sel =out_sel %>% select (-confoundvar)
  }else {
    out_sel = Multi_datainput_m[order(Multi_datainput_m$groupingvar),]
  }

  # ## make same number of animal in each group, deprecated as svm is not running if this is the case.
  # out_sel_ori= out_sel
  # GP= out_sel$groupingvar
  # L =levels(GP)
  # out_sel1= out_sel [GP == L[1],]
  # out_sel2= out_sel [GP == L[2],]
  # NG = min (nrow (out_sel1),nrow (out_sel2))
  # out_sel =rbind (out_sel1[1:NG,],out_sel2[1:NG,])

  ## get rid of columns with NAs
  all_na <- function(x) any(!is.na(x))
  out_sel = out_sel %>% select_if(all_na)

  ## do the svm, with a radial kernel
  kernel ="radial"
  source ("Rcode/2_out_svm.r")
  Accuracyreal = temp$kappa

}

Accuracy = paste0(
  ncol(out_sel) - 1,
  " variables: Accuracy of the prediction with ",
  kernel,
  " kernel (Kappa index: 0 denotes chance level, maximum is 1):",
  Accuracyreal
)


require(tidyverse)
require(lubridate)
source("~/projects/maize.expression/src/me.fun.r")
dirw= '~/projects/wgc/Rmd'

dates = ymd('2018-11-3') + 0:6
ta = tibble(Date = dates, Freq = c(5,5,0,1,0,1,1)) %>%
    mutate(DateLabel = sprintf("%s %s", month(Date, label=T), mday(Date)))

p = ggplot(ta) +
    geom_bar(aes(x=Date, y=Freq, fill=as.character(Date)), stat='identity', width=.8) +
    scale_x_discrete(breaks = ta$Date, labels = ta$DateLabel) +
    scale_y_continuous(name = 'Frequency of Angry') +
    scale_fill_npg() +
    otheme(legend.pos = 'none',
    xtext=T, xtitle=T, ytext=T, ytitle=T, xgrid=F, ygrid=T,
    xtick = T, ytick = T)
fo = file.path(dirw, 'july1.pdf')
ggsave(p, file = fo, width = 5, height = 4)

tl = tibble(Date = rep(dates, times=c(5,5,1,1,1,1,1)),
            level = c(2,3,2,1,2, 2,3,1,4,4, 0, 4, 0, 3, 1))
tls = tl %>% group_by(Date) %>% summarise(level = mean(level)) %>%
    mutate(DateLabel = sprintf("%s %s", month(Date, label=T), mday(Date)))
irs_note = c(
"Not angry",
'Feel OK but a little bit angry',
'Feel not OK and a little bit angry',
'Feel somewhat angry and irritate insights',
'Feel very angry but can control actions',
'Feel extremely angry and cannot control actions'
)
irs = tibble(level=0:5, note=irs_note) %>%
    mutate(lab = sprintf("%d - %s", level, note))
p = ggplot(tls) +
    geom_point(aes(x=Date, y=level)) +
    geom_line(aes(x=Date, y=level)) +
    geom_point(data = tibble(x=ymd('2018-11-3'),y=0,level=0:5), aes(x=x, y=y, color=level), alpha = 0) +
    scale_x_date(breaks = tls$Date, labels = tls$DateLabel) +
    scale_color_viridis(name = "Individual Rating Scales (IRS)", breaks = irs$level, labels = irs$lab) +
    scale_y_continuous(name = 'Level of Angry', limits = c(0,5)) +
    otheme(legend.pos = 'right',, legend.dir = 'v',
    xtext=T, xtitle=T, ytext=T, ytitle=T, xgrid=F, ygrid=T,
    xtick = T, ytick = T) +
    theme(legend.title.align = 0,
          legend.title = element_text(size = 9),
          legend.key.size = unit(1, 'lines'),
          legend.text = element_text(size = 8))
fo = file.path(dirw, 'july2.pdf')
ggsave(p, file = fo, width = 9, height = 5)


library(plyr) # install.packages("plyr")

min_confidence = 0.5

# INPUTS
options(scipen=999) # disable scientific notation
data <- read.csv("../output.csv", sep=",")

tmp.go_projects <- data[data$language == "go" & data$confidence >= min_confidence,]
tmp.c_projects <- data[data$language == "c" & data$confidence >= min_confidence,]

# Convert project names
tmp.go_projects[] <- lapply(tmp.go_projects, as.character)
tmp.c_projects[] <- lapply(tmp.c_projects, as.character)

# Go
tmp.rules_equal_count = count(tmp.go_projects[tmp.go_projects$lhs_file==tmp.go_projects$rhs_file,], "project_name")
tmp.rules_diff_count = count(tmp.go_projects[tmp.go_projects$lhs_file!=tmp.go_projects$rhs_file,], "project_name")

par(mar=c(3,5,2,1)) # margin
boxplot(tmp.rules_equal_count$freq, tmp.rules_diff_count$freq , log = "y", at = c(1,2), names = c("Same file", "Different file"), ylab="Number of rules")
quantile(tmp.rules_equal_count$freq)
quantile(tmp.rules_diff_count$freq)

# C
tmp.rules_equal_count = count(tmp.c_projects[tmp.c_projects$lhs_file==tmp.c_projects$rhs_file,], "project_name")
tmp.rules_diff_count = count(tmp.c_projects[tmp.c_projects$lhs_file!=tmp.c_projects$rhs_file,], "project_name")

par(mar=c(3,5,2,1)) # margin
boxplot(tmp.rules_equal_count$freq, tmp.rules_diff_count$freq , log = "y", at = c(1,2), names = c("Same file", "Different file"), ylab="Number of rules")
quantile(tmp.rules_equal_count$freq)
quantile(tmp.rules_diff_count$freq)

rm(list = ls(pattern = "tmp.*"))


# Collect arguments
args <- commandArgs(trailingOnly = TRUE)

## Default setting when no arguments passed
if(length(args) < 1) {
  args <- c("--help")
}

## Help section
if("--help" %in% args) {
  cat("
      The R Script

      Arguments:
      --nobad.wg filename     - character, name of whole genome hg19.50k.k50.nobad.varbin.data file
      --nobad.short filename  - character, name of whole genome hg19.50k.k50.nobad.varbin.short.txt
      --help                  - print this text

      Example:
      Rscript copynumber.r --nobad.wg=sample1.hg19.50k.k50.nobad.varbin.data.txt --nobad.short=sample1.hg19.50k.k50.nobad.varbin.short.txt \n\n")

  q(save="no")
}

## Parse arguments (we expect the form --arg=value)
parseArgs <- function(x) strsplit(sub("^--", "", x), "=")

argsDF <- as.data.frame(do.call("rbind", parseArgs(args)))
argsL <- as.list(as.character(argsDF$V2))
names(argsL) <- argsDF$V1
argsL

## Arg1 default
if(! file.exists(argsL$nobad.wg)) {
    stop("`nobad.wg` file not found")
    q(save = "no")
}

## Arg2 default
if(! file.exists(argsL$nobad.short)) {
    stop("`nobad.short` file not found")
    q(save = "no")
}

source("cbsLib.R")

cellID <- gsub("(.*).hg19.*.txt", "\\1", argsL$nobad.wg)

df <- read.table(argsL$nobad.wg, header = TRUE)
dfs <- read.table(argsL$nobad.short, header = TRUE)

starts <- c()
ends <- c()
prevEnd <- 0
len <- nrow(dfs)
for (j in 1:len) {
	thisStart = prevEnd + 1
	thisEnd = thisStart + dfs$num.mark[j] - 1
	starts <- c(starts, thisStart)
	ends <- c(ends, thisEnd)
	prevEnd = thisEnd
}

amat <- matrix(data = 0, nrow = 1500000, ncol=1)
counter <- 1
for (j in 1:(len-1)) {
	for (k in (j+1):len) {
		N <- round((starts[j] - ends[j] + 1) * (starts[k] - ends[k] + 1)/1000)
		D <- abs(2^dfs$seg.mean[j] - 2^dfs$seg.mean[k])
		cat(N, "\t")
		if (N > 0) {
			amat[(counter:(counter+N-1)), 1] <- rep.int(D, N)
			counter <- counter+N
		}
	}
}
a3 <- amat[(1:counter),1]
a3.95 <- sort(a3)[round(.95*counter)]
a3d <- density(a3[which(a3 < a3.95)], n = 1000)
cn0 <- a3d$x[which(peaks(as.vector(a3d$y), span  =59))][1]
cn1 <- a3d$x[which(peaks(as.vector(a3d$y), span = 59))][2]

df$cn.ratio <- df$lowratio / cn1
df$cn.seg <- df$seg.mean.LOWESS / cn1
df$copy.number <- round(df$cn.seg)

write.table(df, sep = "\t", file = paste(cellID, ".hg19.50k.k50.varbin.data.copynumber.txt", sep = ""), quote = FALSE, row.names = FALSE)

png(paste(cellID, ".wg.cn.density.png", sep = ""), height = 148, width = 298, units = "mm", res = 350)
par(mar = c(5.1,4.1,4.1,4.1))
plot(a3d, main = paste(cellID, "seg.mean difference density"))
dev.off()

png(paste(cellID, ".wg.cn.png", sep=""), height = 148, width = 298, units = "mm", res = 350)
par(mar = c(5.1,4.1,4.1,4.1))
plot(x = df$abspos, y = df$cn.ratio, main=paste("CN profile: ", cellID, sep=""), xlab="Bin", ylab="Ratio", col="#CCCCCC")
lines(x = df$abspos, y = df$cn.ratio, col="#CCCCCC")
points(x = df$abspos, y = df$cn.seg, col="#0000DD")
lines(x = df$abspos, y = df$cn.seg, col="#0000DD")
points(x  = df$abspos, y = df$copy.number, col="#DD0000")
lines(x = df$abspos, y = df$copy.number, col="#DD0000")
dev.off()

for (a in 1:24) {
	png(paste(cellID, ".chr", a, ".cn.png", sep=""), height = 148, width = 298, units = "mm", res = 350)
	par(mar = c(5.1,4.1,4.1,4.1))
	plot(df$cn.ratio[df$chrom == a], main=paste(cellID, " chr", a, sep = ""), xlab = "Bin", ylab = "Ratio", col = "#CCCCCC")
	lines(df$cn.ratio[df$chrom == a], col = "#CCCCCC")
	points(df$cn.seg[df$chrom == a], col = "#0000DD")
	lines(df$cn.seg[df$chrom == a], col = "#0000DD")
	points(df$copy.number[df$chrom == a], col = "#DD0000")
	lines(df$copy.number[df$chrom == a], col = "#DD0000")
	dev.off()
}


library(ggplot2)
library(rjson)
library(dplyr)
library("RColorBrewer")

# New 100k thresholds
thresholds <- fromJSON(file = "201906_thresholds_grch38_v4.json")
dat <- read.delim("201908019_coverage_based_sex_thresholds.txt",
                  na.strings="None", header=FALSE, stringsAsFactors=FALSE)
colnames(dat) <- c("study", "sample", "deliveryId", "infKaryotype", "avg.X.auto", "avg.Y.auto")

# Selected samples (file)
# selected_samples <- scan("~/gel/cajondesastre/coverage_based_sex/robust_cbsc_samples.txt", what = "character")
# Selected samples (manual entry)
selected_samples <- c("LP3001659-DNA_E03")

# identify test samples
mycolours = c("")
dat$selected <- "notSelected"
dat[dat$sample %in% selected_samples, "selected"] <- "selected"

# Plot
dat$cbskaryotype <- ""
fil_xx <- which(dat$med.X.auto >= thresholds$xx.xmin & dat$med.X.auto <= thresholds$xx.xmax & dat$med.Y.auto >= thresholds$xx.ymin & dat$med.Y.auto <= thresholds$xx.ymax)
fil_xy <- which(dat$med.X.auto >= thresholds$xy.xmin & dat$med.X.auto <= thresholds$xy.xmax & dat$med.Y.auto >= thresholds$xy.ymin & dat$med.Y.auto <= thresholds$xy.ymax)
fil_xo <- which(dat$med.X.auto >= thresholds$xo_clearcut.xmin & dat$med.X.auto <= thresholds$xo_clearcut.xmax & dat$med.Y.auto >= thresholds$xo_clearcut.ymin & dat$med.Y.auto <= thresholds$xo_clearcut.ymax)
fil_xxy <- which(dat$med.X.auto >= thresholds$xxy.xmin & dat$med.X.auto <= thresholds$xxy.xmax & dat$med.Y.auto >= thresholds$xxy.ymin & dat$med.Y.auto <= thresholds$xxy.ymax)
fil_xxx <- which(dat$med.X.auto >= thresholds$xxx.xmin & dat$med.X.auto <= thresholds$xxx.xmax & dat$med.Y.auto >= thresholds$xxx.ymin & dat$med.Y.auto <= thresholds$xxx.ymax)
fil_xyy <- which(dat$med.X.auto >= thresholds$xyy.xmin & dat$med.X.auto <= thresholds$xyy.xmax & dat$med.Y.auto >= thresholds$xyy.ymin & dat$med.Y.auto <= thresholds$xyy.ymax)
fil_xxxy <- which(dat$med.X.auto >= thresholds$xxxy.xmin & dat$med.X.auto <= thresholds$xxxy.xmax & dat$med.Y.auto >= thresholds$xxxy.ymin & dat$med.Y.auto <= thresholds$xxxy.ymax)
fil_xyyy <- which(dat$med.X.auto >= thresholds$xyyy.xmin & dat$med.X.auto <= thresholds$xyyy.xmax & dat$med.Y.auto >= thresholds$xyyy.ymin & dat$med.Y.auto <= thresholds$xyyy.ymax)

dat[fil_xx, "cbskaryotype"] <- "XX"
dat[fil_xy, "cbskaryotype"] <- "XY"
dat[fil_xo, "cbskaryotype"] <- "XO"
dat[fil_xxx, "cbskaryotype"] <- "XXX"
dat[fil_xxy, "cbskaryotype"] <- "XXY"
dat[fil_xyy, "cbskaryotype"] <- "XYY"
dat[fil_xxxy, "cbskaryotype"] <- "XXXY"
dat[fil_xyyy, "cbskaryotype"] <- "XYYY"

p <- ggplot(data=dat, mapping = aes(x = avg.X.auto, y=avg.Y.auto, colour=selected)) +
    geom_point(alpha=0.7) +
    xlab("Median X / median autosomal coverage") +
    ylab("Median Y / median autosomal coverage") +
    scale_color_manual(values = c("#999999", "#FF0000")) +
    ggtitle(label = "Dragen CBS using median coverage per chromosome") +
    theme_bw(16)

p <- p +
    geom_rect(mapping = aes(xmin = thresholds$xy.xmin, xmax = thresholds$xy.xmax, ymin = thresholds$xy.ymin, ymax = thresholds$xy.ymax), alpha = 0, size = 0.2, color="#107aa7") +
    geom_rect(mapping = aes(xmin = thresholds$xx.xmin, xmax = thresholds$xx.xmax, ymin = thresholds$xx.ymin, ymax = thresholds$xx.ymax), alpha = 0, size = 0.2, color="#107aa7") +
    geom_rect(mapping = aes(xmin = thresholds$xo_clearcut.xmin, xmax = thresholds$xo_clearcut.xmax, ymin = thresholds$xo_clearcut.ymin, ymax = thresholds$xo_clearcut.ymax), alpha = 0, size = 0.2, color="#107aa7") +
    geom_rect(mapping = aes(xmin = thresholds$xyy.xmin, xmax = thresholds$xyy.xmax, ymin = thresholds$xyy.ymin, ymax = thresholds$xyy.ymax), alpha = 0, size = 0.2, color="#107aa7") +
    geom_rect(mapping = aes(xmin = thresholds$xxy.xmin, xmax = thresholds$xxy.xmax, ymin = thresholds$xxy.ymin, ymax = thresholds$xxy.ymax), alpha = 0, size = 0.2, color="#107aa7") +
    geom_rect(mapping = aes(xmin = thresholds$xxx.xmin, xmax = thresholds$xxx.xmax, ymin = thresholds$xxx.ymin, ymax = thresholds$xxx.ymax), alpha = 0, size = 0.2, color="#107aa7") +
    geom_rect(mapping = aes(xmin = thresholds$xxxy.xmin, xmax = thresholds$xxxy.xmax, ymin = thresholds$xxxy.ymin, ymax = thresholds$xxxy.ymax), alpha = 0, size = 0.2, color="#107aa7") +
    geom_rect(mapping = aes(xmin = thresholds$xyyy.xmin, xmax = thresholds$xyyy.xmax, ymin = thresholds$xyyy.ymin, ymax = thresholds$xyyy.ymax), alpha = 0, size = 0.2, color="#107aa7")
p


#NEON core-scale cross-validation.
#This has a massive amount of burnin, so takes a while to run.
#There was a problem in MAP values in prior that resulted in no convergence and wack values. Need to try again. All paths should work!
#Fit MULTINOMIAL dirlichet models to all groups of fungi from 50% of NEON core-scale observations.
#Not going to apply hierarchy, because it would not be a fair comparison to the Tedersoo model.
#Missing data are allowed.
#clear environment
rm(list = ls())
library(data.table)
library(doParallel)
source('paths.r')
source('NEFI_functions/ddirch_site.level_JAGS.r')
source('NEFI_functions/crib_fun.r')
source('NEFI_functions/tic_toc.r')

#detect and register cores.----
n.cores <- detectCores()
registerDoParallel(cores=n.cores)

#set output path.----
     output.path <- plot.CV_NEON_dmulti.ddirch_all.path
calval_data.path <- plot.CV_NEON_cal.val_data.path

#set cal-val split.----
cal.val_split <- 0.7 #70% calibration, 30% validation.

#load NEON plot-scale data.----
#NOTE: MAP MEANS AND SDS MUST BE DIVIDED BY 1000.
#WE SHOULD REALLY MOVE THIS TO DATA PRE-PROCESSING.
dat <- readRDS(hierarch_filled.path)
y <- readRDS(NEON_all.phylo.levels_plot.site_obs_fastq_1k_rare.path)

#get core-level covariate means and sd.----
core_mu <- dat$core.plot.mu
plot_mu <- dat$plot.plot.mu
site_mu <- dat$site.site.mu

#merge together.
plot_mu$siteID <- NULL
core.preds <- merge(core_mu   , plot_mu)
core.preds <- merge(core.preds, site_mu)
core.preds$relEM <- NULL
names(core.preds)[names(core.preds)=="b.relEM"] <- "relEM"

#get core-level SD.
core_sd <- dat$core.plot.sd
plot_sd <- dat$plot.plot.sd
site_sd <- dat$site.site.sd
#merge together.
plot_sd$siteID <- NULL
core.sd <- merge(core_sd   , plot_sd)
core.sd <- merge(core.sd, site_sd)
core.sd$relEM <- NULL
names(core.sd)[names(core.sd)=="b.relEM"] <- "relEM"
#IMPORTANT: Reduce magnitude of MAP!
#log transform map means and standard deviations, magnitudes in 100s-1000s break JAGS code.
core.preds$map <- core.preds$map / 1000
core.sd   $map <- core.sd   $map / 1000

#convert relEM back to 0-100 scale.
core.preds$relEM <- boot::inv.logit(core.preds$relEM)

#Split into calibration / validation data sets.----
set.seed(420)
#ID <- rownames(y$phylum$plot.fit$mean)
#cal.ID <- sample(ID, round(length(ID)/ 2))
#val.ID <- ID[!(ID %in% cal.ID)]
#Subset by plot and site.
plotID <- rownames(y$phylum$plot.fit$mean)
siteID <- substr(plotID,1, 4)
plots <- data.frame(plotID, siteID)
sites <- unique(plots$siteID)
cal <- list()
val <- list()
for(i in 1:length(sites)){
  sub <- plots[plots$siteID == sites[i],]
  cal_sub <- sub[sub$plotID %in% sample(sub$plotID, round(nrow(sub) * cal.val_split)),]
  val_sub <- sub[!(sub$plotID %in% cal_sub$plotID),]
  cal[[i]] <- cal_sub
  val[[i]] <- val_sub
}
cal <- do.call(rbind, cal)
val <- do.call(rbind, val)
cal.ID <- as.character(cal$plotID)
val.ID <- as.character(val$plotID)

#loop through y values. Wasn't an easy way to loop through levels of list.
y.cal <- list()
y.val <- list()
for(i in 1:length(y)){
  lev <- y[[i]]$plot.fit
  lev.cal <- list()
  lev.val <- list()
  lev.cal$mean <- lev$mean[rownames(lev$mean) %in% cal.ID,]
  lev.val$mean <- lev$mean[rownames(lev$mean) %in% val.ID,]
  lev.cal$lo95 <- lev$lo95[rownames(lev$lo95) %in% cal.ID,]
  lev.val$lo95 <- lev$lo95[rownames(lev$lo95) %in% val.ID,]
  lev.cal$hi95 <- lev$hi95[rownames(lev$hi95) %in% cal.ID,]
  lev.val$hi95 <- lev$hi95[rownames(lev$hi95) %in% val.ID,]
  #return to larger list.
  y.cal[[i]] <- lev.cal
  y.val[[i]] <- lev.val
}
names(y.cal) <- names(y)
names(y.val) <- names(y)

#Drop groups that just aren't observed frequently enough (>30% of samples) to fit a decent model (mostly zeros).
freq.filter <- list()
for(i in 1:length(y.cal)){
  check <- y.cal[[i]]$mean
  abundance.check <- list()
  for(j in 1:ncol(check)){
    z <- check[,j]
    abundance.check[[j]] <-  sum(z > 0.01)/ length(z)
  }
  abundance.check <- unlist(abundance.check)
  names(abundance.check) <- colnames(check)
  abundance.check <- abundance.check[abundance.check >= 0.3]
  freq.filter[[i]] <- abundance.check
}
names(freq.filter) <- names(y.cal)

#update your lists.
for(i in 1:length(y.cal)){
  z.cal <- y.cal[[i]]$mean
  z.val <- y.val[[i]]$mean
  z.cal <- z.cal[,colnames(z.cal) %in% names(freq.filter[[i]])]
  z.val <- z.val[,colnames(z.val) %in% names(freq.filter[[i]])]
  z.cal[,1] <- 1 - rowSums(z.cal[,2:ncol(z.cal)])
  z.val[,1] <- 1 - rowSums(z.val[,2:ncol(z.val)])
  if(mean(rowSums(z.cal)) != 1){cat('Warning: rowSums of calibration data do not sum to 1.')}
  if(mean(rowSums(z.val)) != 1){cat('Warning: rowSums of calibration data do not sum to 1.')}
  y.cal[[i]]$mean <- z.cal
  y.val[[i]]$mean <- z.val
}

#split x means and sd's.
x_mu.cal <- core.preds[core.preds$plotID %in% cal.ID,]
x_mu.val <- core.preds[core.preds$plotID %in% val.ID,]
x_sd.cal <- core.sd   [core.sd   $plotID %in% cal.ID,]
x_sd.val <- core.sd   [core.sd   $plotID %in% val.ID,]

#match the order.
x_mu.cal <- x_mu.cal[order(match(x_mu.cal$plotID, rownames(y.cal$phylum$mean))),]
x_sd.cal <- x_sd.cal[order(match(x_sd.cal$plotID, rownames(y.cal$phylum$mean))),]
x_mu.val <- x_mu.val[order(match(x_mu.val$plotID, rownames(y.val$phylum$mean))),]
x_sd.val <- x_sd.val[order(match(x_sd.val$plotID, rownames(y.val$phylum$mean))),]

#subset to predictors of interest, drop in intercept.----
rownames(x_mu.cal) <- rownames(y.cal$phylum$abundances)
intercept <- rep(1, nrow(x_mu.cal))
x_mu.cal <- cbind(intercept, x_mu.cal)
x_mu.cal <- x_mu.cal[,c('intercept','pH','pC','cn','relEM','map','mat','NPP','forest','conifer')]

#save calibration/valiation data sets.----
dat.cal <- list(y.cal, x_mu.cal, x_sd.cal)
dat.val <- list(y.val, x_mu.val, x_sd.val)
names(dat.cal) <- c('y.cal','x_mu.cal','x_sd.cal')
names(dat.val) <- c('y.val','x_mu.val','x_sd.val')
dat.out <- list(dat.cal, dat.val)
names(dat.out) <- c('cal','val')
saveRDS(dat.out, calval_data.path)

#fit model using function in parallel loop.-----
#for running production fit on remote.
cat('Begin model fitting loop...\n')
tic()
output.list<-
  foreach(i = 1:length(y)) %dopar% {
    y.group <- y.cal[[i]]$mean
    fit <- site.level_dirlichet_jags(y=y.group,x_mu=x_mu.cal, #x_sd=x_sd.cal,
                                     adapt = 200, burnin = 30000, sample = 6000,
                                     #adapt = 200, burnin = 200, sample = 200)#,   #testing
                                     parallel = T, parallel_method = 'parallel') #setting parallel rather than rjparallel.
    return(fit)                                                                     #allows nested loop to work.
  }
cat('Model fitting loop complete! ')
toc()

#name the items in the list
names(output.list) <- names(y.cal)

#save output.----
cat('Saving fit...\n')
saveRDS(output.list, output.path)
cat('Script complete. \n')


library(methylKit) #load files
file.list=list("pig_rrbs_METcall.CGmap.gz.Mkit")
myobj=methRead(file.list,sample.id=list("s1"),assembly="gg",treatment=c(0))
save.image()
#produce methylation histogram
pdf('Sample1_histogram.pdf')
getMethylationStats(myobj[[1]],plot=T,both.strands=F)
pdf('Sample1_cov.pdf')
getCoverageStats(myobj[[1]],plot=T,both.strands=F)
dev.off()


library(pbdPAPI)

system.cache(1+1, events="l1.all")


#' @export
#'
#' @title Plot M posterior distribution
#'
#' @description Plot method for the M estimates
#' (from \code{evoab}) posterior distribution.
#'
#' @param obj An object of class "Mest".  Usually output by the
#' routine \code{estimateM.EoA}.
#'
#' @param plot.like Logical for whether to plot the likelihood for M as
#' well as the posterior.
#'
#' @param plot.prior Logical for whether to plot the prior for M as well
#' as the posterior.
#'
#' @details  \code{plot.like} and \code{plot.prior} are additive. Set both
#' to TRUE and the prior, likelihood, and posterior will all three be plotted.
#' If neither \code{plot.like} nor \code{plot.prior} are TRUE, the posterior
#' distribution is plotted.
#'
#' @author Trent McDonald
#'
#' @seealso \code{\link{estimateM.EoA}}
#'
#'
plot.Mest <- function(obj, plot.like=FALSE, plot.prior=FALSE){

  x <- obj$M.margin$M
  fx <- obj$M.margin$pdf
  max.fx <- max(fx)
  ml <- obj$M.est$M.lo
  mh <- obj$M.est$M.hi
  M <- obj$M.est$M
  conf.level <- obj$M.est$ci.level*100

  old.par <- par()
  par(mar=c(5.1,4.1,1,1))

  rng.x <- range(x)

  if(plot.like & plot.prior){
    rng.fx <- range(fx, obj$M.margin$like.pdf, obj$M.margin$prior.pdf)
  } else if( !plot.like & plot.prior){
    rng.fx <- range(fx, obj$M.margin$prior.pdf)
  } else if( plot.like & !plot.prior){
    rng.fx <- range(fx, obj$M.margin$like.pdf)
  } else if( !plot.like & !plot.prior){
    rng.fx <- range(fx)
  }
  max.fx <- rng.fx[2]

  plot(rng.x, rng.fx, type="n", lwd=2,
       xlab="Mortalities (M)", ylab="",
       yaxt="n", ylim=c(0,max.fx*1.7), bty="n")
  axis(2, at=pretty(c(0,max.fx)))
  mtext(side=2, text="Prob. Density (pdf)", at=max.fx/2, line=2.5)

  ci.poly.x <- c(x,rev(x))
  ci.poly.y <- c(fx,rep(0,length(fx)))
  midInterval <- (ml <= ci.poly.x) & (ci.poly.x <= mh)
  ci.poly.x <- ci.poly.x[midInterval]
  ci.poly.y <- ci.poly.y[midInterval]

  doTheLegend <- FALSE
  legEntries <- c("Posterior")
  legCols <- c("black")
  if(plot.like){
    lines(x, obj$M.margin$like.pdf, lwd=2, col="blue")
    doTheLegend <- TRUE
    legEntries <- c("Likelihood",legEntries)
    legCols <- c("blue", legCols)
  }
  if(plot.prior){
    lines(x, obj$M.margin$prior.pdf, lwd=2, col="red")
    doTheLegend <- TRUE
    legEntries <- c("Prior",legEntries)
    legCols <- c("red", legCols)
  }
  if(!plot.prior & !plot.like){
    polygon(ci.poly.x, ci.poly.y, col="cornsilk", border=NA)
  }
  lines(x, fx, lwd=2 )

  oneLineHgt <- par("cxy")[2]
  segments(ml,max.fx+4*oneLineHgt,mh,max.fx+4*oneLineHgt,col='grey60',lwd=13)

  points(ml,max.fx+4*oneLineHgt,bg="red",pch=21,cex=1.8,xpd=T)
  points(mh,max.fx+4*oneLineHgt,bg="red",pch=21,cex=1.8,xpd=T)
  points(M,max.fx+4*oneLineHgt,bg='turquoise',pch=21,cex=2.2,xpd=T)

  segments(ml,max.fx,ml,0,lty=3,lwd=2,col='darkred')
  segments(mh,max.fx,mh,0,lty=3,lwd=2,col='darkred')

  text(M,max.fx+5.5*oneLineHgt,paste("Estimate:\n median=",format(M,big.mark=",")),
       cex=.8,font=2,family="sans",col='darkslategray')

  text(ml,max.fx+2*oneLineHgt,paste0("LOWER\n",conf.level,"% Conf\n",format(ml,big.mark=",")),
       cex=.7,col="darkred",font=2,family="sans",xpd=NA)

  text(mh,max.fx+2*oneLineHgt,paste0("UPPER\n",conf.level,"% Conf\n",format(mh,big.mark=",")),
       cex=.7,col="darkred",font=2,family="sans",xpd=NA)

  if(doTheLegend){
    legend("topright",legend=legEntries, lty=1, col=legCols, lwd=2,
           inset=c(0,1-(max.fx/(max.fx+6*oneLineHgt))), cex=0.75)
  }

}


# Define x
x = c(1, 2, 1, 4, 1, 3)

# What is going on here?
x[c(1, 2, 4, 6)][-2][c(3, 2, 1)][-3]

# Find an easier way to do it
x[___]


library(sentimentr)
library(stringr)
library(dplyr)
library(ggplot2)
library(tidytext)
library(tidyr)
library(wordcloud)

data <- readRDS("./deathrow.rds")

## ---- executions-per-year
executions_per_year <- data %>%
  group_by(year = format(date, "%Y")) %>%
  count() %>%
  ungroup() %>%
  mutate_at("year", as.numeric)

ggplot(executions_per_year, aes(x = year, y = n)) +
  geom_bar(stat = "identity") +
  labs(title = "Executions per year", x = "Year", y = "Executions")

## ---- average-age-by-year
year_avg <- data %>%
  group_by(year = format(date, "%Y")) %>%
  summarise(mean_age = mean(age)) %>%
  mutate_at("year", as.numeric)

ggplot(year_avg, aes(x = year, y = mean_age)) +
  geom_bar(stat = "identity") +
  labs(title = "Average age at execution by year", x = "Year", y = "Age")

## ---- average-age-by-race
age_by_race <- aggregate(age ~ race, data, mean)

ggplot(age_by_race, aes(x = race, y = age)) +
  geom_bar(stat = "identity", width = 0.5) +
  labs(title = "Average age at execution by race", x = "Year", y = "Race")

## ---- race-distribution-by-year
race_by_year <- data %>%
  group_by(year = format(date, "%Y")) %>%
  count(race) %>%
  ungroup() %>%
  mutate_at("year", as.numeric) %>%
  pivot_wider(names_from = race,
              values_from = n,
              values_fill = list(n = 0)) %>%
  select(-c("Other")) # Sample too small

race_by_year_long <- race_by_year %>%
  pivot_longer(-year, names_to = "race", values_to = "count")

ggplot(race_by_year_long, aes(x = year, y = count, fill = race)) +
  geom_bar(stat = "identity") +
  labs(title = "Race distribution by year", x = "Year", y = "Race") +
  theme_bw() +
  scale_fill_grey()

## ---- frequent-words
words <- data %>%
  select("statement") %>%
  unnest_tokens(word, statement) %>%
  anti_join(stop_words) %>%
  count(word, sort = TRUE) %>%
  slice(1:100)

wordcloud(words$word, words$n, random.order = FALSE, scale = c(10, 1))

## ---- frequent-phrases
trigrams <- data %>%
  select("statement") %>%
  unnest_tokens(trigram, statement, token = "ngrams", n = 3) %>%
  count(trigram, sort = TRUE) %>%
  slice(1:50)

wordcloud(trigrams$trigram, trigrams$n, random.order = FALSE, scale = c(10, 1))

## ---- sentiment-by-age
sentiment_by_age <- data %>%
  mutate(cuts = cut(age, seq(20, 80, 10))) %>%
  mutate(sentiment = sentiment_by(statement)$ave_sentiment) %>%
  group_by(cuts) %>%
  select(cuts, sentiment)

ggplot(sentiment_by_age, aes(x = cuts, y = sentiment)) +
  geom_boxplot() +
  labs(title = "Sentiment by age", x = "Age group", y = "Sentiment")

## ---- sentiment-by-race
sentiment_by_race <- data %>%
  mutate(sentiment = sentiment_by(statement)$ave_sentiment) %>%
  group_by(race) %>%
  filter(race != "Other") # Sample too small

ggplot(sentiment_by_race, aes(x = race, y = sentiment)) +
  geom_boxplot() +
  labs(title = "Sentiment by race", x = "Race", y = "Sentiment")


#
#
#
#
#
# # extract the important count information
# get_values <- function(taxon, strat, shelly) {
#   # which occurrences correspond to focal group
#   focus <- taxon[taxon$group == shelly, ]
#
#   # these occurrences are in collections
#   # collections are from units
#   # geologic units with fossils from focal
#   unitfocus <- cltn2unit[cltn2unit[, 1] %in% focus$collection_no, 2]
#   stratfocus <- strat[strat$unit_id %in% unitfocus, ]
#
#   # assign a bin
#   stratfocus$bin <- c()
#   for(ii in seq(nrow(brks))) {
#     mm <- stratfocus$m_age <= brks[ii, 1] & stratfocus$m_age > brks[ii, 2]
#     stratfocus$bin[mm] <- ii
#   }
#
#   oc <- stratfocus %>%
#     group_by(unit_id) %>%
#     dplyr::transmute(collections = sum(pbdb_collections))
#   stratfocus <- left_join(stratfocus, oc, by = 'unit_id')
#
#   unitdiv <- llply(split(focus, focus$unit),
#                    function(x) length(unique(x$genus)))
#   mm <- match(stratfocus$unit_id, names(unitdiv))
#   stratfocus$diversity <- unlist(unitdiv)[mm]
#
#   stratfocus
# }
#
# # export focus to walk on
# export_standata <- function(x, name, type = c('diversity', 'occurrence')) {
#   litmat <- strict.lithology(x)
#   bpod <- x[match(rownames(litmat), x$unit_id), ]
#
#   standata <- list()
#   if(type == 'diversity') {
#     standata$N <- length(bpod$diversity)
#     standata$y <- bpod$diversity
#   } else if(type == 'occurrence') {
#     standata$N <- length(bpod$collections)
#     standata$y <- bpod$collections
#   }
#
#   standata$t <- bpod$bin
#   standata$T <- max(bpod$bin)
#
#   # make X
#   K <- 4  # all plus intercept; initial
#   # initially just intercept
#   X <- matrix(1, nrow = standata$N, ncol = K)
#   X[, 2] <- arm::rescale(log1p(bpod$max_thick))
#   X[, 3] <- arm::rescale(log1p(bpod$col_area))
#
#   nt <- pmap_dbl(list(bln = bpod$b_plng,
#                       bpl = bpod$b_plat,
#                       tln = bpod$t_plng,
#                       tpl = bpod$t_plat),
#                  .f = function(bln, bpl, tln, tpl)
#                    geomean(rbind(c(bln, bpl), c(tln, tpl)))[2])
#   X[, 4] <- arm::rescale(nt)
#
#   X <- cbind(X, ilr(litmat))
#   K <- ncol(X)
#   standata$X <- X
#   standata$K <- K
#
#   if(name %in% c('Anthozoa', 'Bivalvia')) {
#     standata$prior_intercept_location <- 1
#     standata$prior_intercept_scale <- 2
#     standata$prior_phi_scale <- 3
#   } else {
#     standata$prior_intercept_location <- 2
#     standata$prior_intercept_scale <- 2
#     #standata$prior_phi_scale <- 5
#   }
#
#   if(type == 'occurrence') {
#     standata$prior_intercept_location <- 3
#     standata$prior_intercept_scale <- 3
#     #standata$prior_phi_scale <- 50
#   }
#
#
#   temp.name <- paste0('../data/data_dump/diversity_data_',
#                       name, '_', type, '.data.R')
#   with(standata, {stan_rdump(list = alply(names(standata), 1),
#                              file = temp.name)})
#   temp.name <- paste0('../data/data_dump/diversity_image_',
#                       name, '_', type, '.rdata')
#   save(standata, file = temp.name)
# }


library(jsonlite)
library(gtrendsR)
library(plyr)
library(dplyr)
library(ggplot2)
library(scales)
library(abind)
library(data.table)
library(tidyr)

#So the only real difference between this code and that of the fixgop.r file is that there were sources such as Wilson Perkins Allen polling that did not poll for the Democratic party. At the same time, there were alot less candidates for the Democratic party (as is the case much of the time for incumbant parties)

includeNA <- function(argDF) {
    returnDF <- data.frame(stringsAsFactors=FALSE)
    argDF <- as.data.frame(argDF, stringsAsFactors=FALSE)

    dateSeq <- seq(as.Date("2015-01-01"), as.Date("2015-12-31"), by="days")
    count = 1
    for(i in seq_along(dateSeq)){
        if(any(dateSeq[i] %in% argDF$dates)==TRUE){
            returnDF <- rbind(returnDF, argDF[match(dateSeq[i], argDF$dates),])
            colnames(returnDF) <- colnames(argDF)
        }else{
            naList <- data.frame(dateSeq[i], NA, NA, NA, NA, NA, stringsAsFactors=FALSE)
            colnames(naList) <- colnames(argDF)
            returnDF <- rbind(returnDF, naList)
            count <- count + 1}}
    rownames(returnDF) <- as.character(seq(as.Date("2015-01-01"), as.Date("2015-12-31"), by="days"))
    return(returnDF[1:nrow(returnDF), 2:ncol(returnDF)])
}

fixday <- function(argDF) {
    modDF<- data.frame(Start.Date=argDF$start, End.Date=argDF$end, Trump=argDF$Trump, Bernie=argDF$Bernie, Hillary=argDF$Hillary, Carson=argDF$Carson, Rand=argDF$Rand, stringsAsFactors=FALSE)
    modDF[1:2] <- lapply(modDF[1:2], as.Date)
    returnDF <- setDT(modDF)[, list(dates=seq(Start.Date, End.Date, by = '1 day'),
        Trump=Trump, Bernie=Bernie, Hillary=Hillary, Carson=Carson, Rand=Rand),
        by = 1:nrow(modDF)][, nrow:= NULL][]
    return(returnDF[order(dates),])
}

#Google Trends Package Set Up
usr <- "cs125fp@gmail.com"
psw <- "Abcd@1234"
gconnect(usr, psw)
pres_trend <- gtrends(c("Trump", "Bernie", "Hillary", "Carson", "Rand"))

pres_trendDF <- pres_trend[[3]][574:nrow(pres_trend[[3]]),]
pres_trendDF <- fixday(pres_trendDF)
pres_trendDF <- includeNA(pres_trendDF)
save(pres_trendDF, file="/Users/andrewlee/Documents/School/CS125/Final Project/pres_trendDF.RData")


#   __      _____             _              __        _
# <(o )___ |  _  |___ ___ ___| |_ ___ ___   |  |   ___| |_ ___
# ( ._> /  |   __|  _| -_|_ -|  _| -_|_ -|  |  |__| .'| . |_ -|
#  `---'   |__|  |_| |___|___|_| |___|___|  |_____|__,|___|___|
#==============================================================================
# Google Trends and R
#==============================================================================
# Title          : GoogleTrendsTS.r
# Description    : Analyzing Google Trends Data in R.
# Author         : Isaias V. Prestes <isaias.prestes@gmail.com>
# Date           : 20180412
# Version        : 0.0.1
# Usage          : Run in R 3.4
# Notes          : based on
#                  Jake Hoare (DisplayR)
# https://datascienceplus.com/analyzing-google-trends-data-in-r/
#                  gtrendsR documentation
# https://github.com/PMassicotte/gtrendsR
#                  Peer Christensen https://rpubs.com/PChristensen/307008
#
# R version      : 3.4
#==============================================================================

#==============================================================================
# PACKAGE INSTALATION
#==============================================================================
if(!require("devtools")) install.packages("devtools")
if(!require("gtrendsR")) install.packages("gtrendsR") # google data
# devtools::install_github('PMassicotte/gtrendsR', ref = 'new-api')
if(!require("ggplot2")) install.packages("ggplot2")
if(!require("forecast")) install.packages("forecast") # time series
if(!require("maps")) install.packages("maps") # map plots
if(!require("reshape2")) install.packages("reshape2")
if(!require("xxxxx")) install.packages("xxxxx")
if(!require("xxxxx")) install.packages("xxxxx")

#==============================================================================
# LIBRARY DEPENDENCE
#==============================================================================
library(devtools)
library(gtrendsR)
library(reshape2)
library(ggplot2)
library(forecast)
library(xxxxx)
library(xxxxx)
library(xxxxx)
library(xxxxx)

# Things that I like...
Sys.setenv(TZ = "UTC")
google.trends = gtrends(c("Fortran","Sudoku"), gprop = "web", time = "all")
plot(google.trends)
google.trends = gtrends(c("Fortran","Sudoku"), gprop = "web", time =  "today+5-y")
plot(google.trends)
google.trends = gtrends(c("Fortran"), gprop = "web", time =  "today+5-y")
windows() ; plot(google.trends)
google.trends = gtrends(c("Sudoku"), gprop = "web", time =  "today+5-y")
windows() ; plot(google.trends)

#==============================================================================
# Fire in the hole!
#==============================================================================

# Search Parameters -----------------------------------------------------------
search_terms <- c("Machine Learning", "Big Data", "R programming language", "Statitics")
# Countries codes https://en.wikipedia.org/wiki/ISO_3166-2
# detaild version http://www.unece.org/cefact/codesfortrade/codes_index.html
search_country <- c("BR") # default is worldwide
# Time interval - Time span between two dates (ex.: "2010-01-01 2010-04-03")
search_time <- "2004-01-01 2018-01-04"
# Options available are "news","images", "froogle", "youtube"
search_type <- c("web")
# A character denoting the category, defaults to “0”.
search_category <- 0
# ISO language code
search_language <- "pt-BR"

data_scientist <-
gtrends(search_terms, geo = search_country, time = search_time,
    gprop = search_type, category = search_category, hl = search_language)

## Playing with time format
search_terms <- c("Python", "Machine Learning")
gtrends(search_terms, time = "now 1-H") # Last hour
gtrends(search_terms, time = "now 4-H") # Last four hours
gtrends(search_terms, time = "now 1-d") # Last day
gtrends(search_terms, time = "now 7-d") # Last seven days
gtrends(search_terms, time = "today 1-m") # last 30 days
gtrends(search_terms, time = "today 3-m") # last 90 days
gtrends(search_terms, time = "today 12-m") # last 12 months
gtrends(search_terms, time = "today+5-y") # last 5 years (default)
gtrends(search_terms, time = "all") # Since the beginning of Google Trends (2004)

data_scientist$interest_over_time%>%
  as_tibble()%>%
  mutate(hits=as.numeric(hits))%>%
ggplot(aes(x=date,y=hits,colour=keyword))+
  geom_line()+theme_bw()+
  labs(y="Popularidade",x="Ano",colour="Termo de pesquisa:", title="Série temporal da popularidade dos termos de pesquisas")

# Gtrends function actually returns a list of data frames.
str(hurricanes)

#==============================================================================
# Time series analysis
#==============================================================================

#Decompondo a série para o termo Estatística
ts_Estatistica=data_scientist$interest_over_time%>%
  as_tibble()%>%
  mutate(hits=as.numeric(hits))%>%
  filter(keyword=="Estatística")%>%
  select(hits)%>%
  na.omit()%>%
  ts(freq=12)

ts_dec_Estatistica=decompose(ts_Estatistica)

#Decompondo a série para o termo Bigdata
ts_BigData=data_scientist$interest_over_time%>%
  as_tibble()%>%
  mutate(hits=as.numeric(hits))%>%
  filter(keyword=="Big Data")%>%
  select(hits)%>%
  na.omit()%>%
  ts(freq=12)
ts_dec_BigData=decompose(ts_BigData)

g1=ts_dec_Estatistica %>% autoplot+ theme_bw()
g2=ts_dec_BigData %>% autoplot+theme_bw()
gridExtra::grid.arrange(g1,g2,ncol=2)

# Trend test (Wald-Wolfowitz)
randtests::runs.test(ts_Estatistica)
randtests::runs.test(ts_BigData)

# SAZONALIDADE

data=data.frame(cbind(serie=as.numeric(ts_Estatistica),mes_ano=rep(seq(1,12),11)))
kruskal.test(data=data,serie~mes_ano)
data=data.frame(cbind(serie=as.numeric(ts_BigData),mes_ano=rep(seq(1,12),11)))
kruskal.test(data=data,serie~mes_ano)

# MÉTODO DE AMORTECIMENTO EXPONENCIAL DE HOLT-WINTERS (DADOS COM SAZONALIDADE)

ajuste_com_sazonalidade_Estatistica<-HoltWinters(ts_Estatistica)
plot(ajuste_com_sazonalidade_Estatistica)

ajuste_com_sazonalidade_BigData<-HoltWinters(ts_BigData)
plot(ajuste_com_sazonalidade_BigData)

suppressMessages(library(forecast))

#Para estatistica
previsao_com_sazonalidade_Estatistica<-forecast(ajuste_com_sazonalidade_Estatistica,h = 12)
plot(previsao_com_sazonalidade_Estatistica)

#Para BigData
previsao_com_sazonalidade_BigData<-forecast(ajuste_com_sazonalidade_BigData,h = 12)
plot(previsao_com_sazonalidade_BigData)

#==============================================================================
# Map plot
#==============================================================================
Fortran = gtrends(c("Fortran"), gprop = "web",time="2017-08-18 2017-08-25", geo = c("US"))
Fortran = Fortran$interest_by_region
Fortran$region = sapply(Fortran$location,tolower)
statesMap = map_data("state")
FortranMerged = merge(statesMap,Fortran,by="region")
FortranPlot=ggplot() +
  geom_polygon(data=FortranMerged,aes(x=long,y=lat,group=group,fill=hits),colour="white") +
  scale_fill_continuous(low="thistle2",high="darkred",guide="colorbar",trans="log10") +
  theme_bw() +
  labs(title="Google search interest for Fortran in each state")
FortranPlot

Fortran = gtrends(c("Fortran"), gprop = "web", time="2018-03-03 2018-04-03",geo = c("US"))
Fortran = Fortran$interest_by_region
statesMap = map_data("state")
Fortran$region = sapply(Fortran$location,tolower)
FortranMerged = merge(statesMap ,Fortran,by="region")

regionLabels <- aggregate(cbind(long, lat) ~ region, data=FortranMerged,
                          FUN=function(x) mean(range(x)))

FortranPlot=ggplot() +
  geom_polygon(data=FortranMerged,aes(x=long,y=lat,group=group,fill=hits),colour="white") +
  scale_fill_continuous(low="thistle1",high="darkblue",guide="colorbar",trans="log10") +
  geom_text(data=regionLabels, aes(long, lat, label = region), size=2) +
  theme_bw() +
  coord_fixed(1.3) +
  labs(title="Google search interest for Fortran language programming in each state\nfrom the week prior to landfall in the US")
FortranPlot


yahoo.statistics.scrape <- function(symbol) {

    ## https://stackoverflow.com/questions/40245464/web-scraping-of-key-stats-in-yahoo-finance-with-r
    url <- paste('https://finance.yahoo.com/quote/', symbol,
                 '/key-statistics?p=', symbol, sep='')
    webpage <- readLines(url)
    html             <- XML::htmlTreeParse(webpage, useInternalNodes = TRUE, asText = TRUE)
    tableNodes       <- XML::getNodeSet(html, "//table")

    valuation        <- XML::readHTMLTable(tableNodes[[1]])
    dates <- names(valuation)[3:ncol(valuation)]
    names(valuation) <- c('measure', 'current', dates)
    peg <- valuation[valuation$measure == 'PEG Ratio (5 yr expected)',]

    price            <- XML::readHTMLTable(tableNodes[[2]])
    share_statistics <- XML::readHTMLTable(tableNodes[[3]])
    dividends_splits <- XML::readHTMLTable(tableNodes[[4]])
    fiscal_year      <- XML::readHTMLTable(tableNodes[[5]])
    profitability    <- XML::readHTMLTable(tableNodes[[6]])
    effectiveness    <- XML::readHTMLTable(tableNodes[[7]])
    income_statement <- XML::readHTMLTable(tableNodes[[8]])
    balance_sheet    <- XML::readHTMLTable(tableNodes[[9]])
    cash_flow        <- XML::readHTMLTable(tableNodes[[10]])

    return(list(valuation        = valuation,
                price            = price,
                share_statistics = share_statistics,
                dividends_splits = dividends_splits,
                fiscal_year      = fiscal_year,
                profitability    = profitability,
                effectiveness    = effectiveness,
                income_statement = income_statement,
                balance_sheet    = balance_sheet,
                cash_flow        = cash_flow,
                peg              = peg))

}
## out <- yahoo.statistics.scrape('AAPL')
## peg <- out$valuation[out$valuation$measure == 'PEG Ratio (5 yr expected) 1',]

## ## this works but is a paid service; AAPL symbol is provided as a free example
## api.token   <- "OeAFFmMliFG5orCUuwAKQ8l4WWFQ67YX"
## symbol      <- "AAPL.US"
## ticker.link <- paste("http://nonsecure.eodhistoricaldata.com/api/eod/", symbol,
##                      "?api_token=", api.token, "&period=m&order=d", sep="")
## data        <- read.csv(url(ticker.link))
## head(data)

## ## this also works but not sure what it is doing
## url <- "http://finance.yahoo.com/webservice/v1/symbols/AAPL/quote?format=json&view=detail"
## url <- "https://yfapi.net/v6/finance/quote?region=US&lang=en&symbols=AAPL%2CBTC-USD%2CEURUSD%3DX"
## req <- curl::curl_fetch_memory(url)
## str(req)
## curl::parse_headers(req$headers)


portfolio.calc.print <- function(df) {
    ## df = output from portfolio.calc
    df <- df$perf
    ## change twrc, std, twrc.ann, and std.ann to character and apply % sign
    df[2:5]   <- sapply(df[2:5], function(x) scales::percent(x, accuracy=0.01))
    df$alpha  <- round(df$alpha , 3)
    df$beta   <- round(df$beta  , 3)
    df$weight <- round(df$weight, 2)
    df$value  <- scales::dollar(df$value)
    df
}