#  James Rekow

uniqueSet = function(vList, select = c("ran", "first")){

  #  ARGS: vList - list of numerical vectors
  #        select - if ran, for each group of vectors whose set of elements is identical, select one at
  #                 random. If first, select the one the appears first in vList. Defaults to "ran".
  #
  #  RETURNS: uniquevList - a list of elements of vList such that exactly one vector from vList
  #                         corresponding to each unique set of numbers

  #  NOTE: this function assumes that each vector in vList contains no duplicate elements
  #  NOTE: this function is exceedingly SLOW!

  #  default to "ran" if select is not specified
  if(length(select) == 2){
    select = "ran"
  } #  end if

  #  check that the given method for select is supported
  if(!(select %in% c("ran", "first"))){
    stop("Invalid method chosen for select.")
  } #  end if

  #  sort the elements of vList so they can be compared to the sorted sets in the list of unique sets
  sortedVList = lapply(vList, sort)

  #  create a list of unique sets present in vList
  uniqueSets = unique(lapply(vList, sort))

  selectRep = function(set){

    #  ARGS: n - the index of the set in uniqueSets for which a representative is to be chosen
    #
    #  RETURNS: repr - a representative of the set chosen from vList according to the method specified
    #                  by the value of the select variable

    #  create vector of indices of the elements in vList which correspond to set
    potentialRepIxs = which(sortedVList %in% list(set))

    ##  select index (in vList) of set representative
    if(select == "ran"){
      repIx = sample(potentialRepIxs, 1)
    } #  end if

    if(select == "first"){
      repIx = potentialRepIxs[1]
    } #  end if

    rep = vList[[repIx]]

    return(rep)

  } #  end selectRep function

  #  select a representative for each unique set
  uniqueVList = lapply(uniqueSets, selectRep)

  return(uniqueVList)

} #  end uniqueSet function


# Quick script to plot wordpress theme complexity over time
# Author: Edward Benson <eob@csail.mit.edu>

library(ggplot2)
library(xts)

makeChart <- function(input.file, value.column, output.file) {
  data <- read.csv(file=input.file, header=TRUE, sep=",")
  min <- " 00:00:01"
  data$Date = as.POSIXct(paste(data$Date, min))
  data$valueColumn = with(data, get(value.column))

  # Remove ponts more than two standard deviations outside the mean.
  data <- data[!abs(scale(data$valueColumn)) > 2,]

  # Aggregate into month buckets
  summ <- aggregate(
            list(value = data$valueColumn),
            list(month = cut(data$Date, "1 month")),
            mean)

  # Remove ponts more than two standard deviations outside the mean.
  #summ <- summ[!abs(scale(summ$value)) > 2,]

  # Generate labels for the x axis so we don't get crowding
  # WARNING: I'm lazy and generated the start and end date by peeking at the
  # data file. If the data changes these need to change as well.
  x_breaks <- seq(as.Date("2008/7/1"), as.Date("2013/7/1"), by="6 months")
  x_labels <- as.character(x_breaks, format="%h-%y")

  # And then re-parse the dates so for our axis
  summ$month = as.Date(summ$month)
  pdf(output.file)

  # `print` is necessary when inside a function (because the default is to
  # suppress output.
  print(ggplot(data = summ, aes(x=month, y=value)) +
    theme_bw() +
    geom_point() +
    geom_smooth() +
    scale_x_date(breaks=x_breaks, labels=x_labels))
  dev.off()
}

makeChart("YearVersusBytesNoImages.csv", "BytesNoImages", "year-versus-bytes-no-images.pdf")
makeChart("YearVersusNumFiles.csv", "NumFiles", "year-versus-num-files.pdf")


context("Formatters")

test_that("comma format always adds commas", {
  expect_equal(comma(1e3), "1,000")
  expect_equal(comma(1e6), "1,000,000")
  expect_equal(comma(1e9), "1,000,000,000")
})

test_that("scientific format shows specific sig figs", {
  expect_equal(scientific(123456, digits = 1), "1e+05")
  expect_equal(scientific(123456, digits = 2), "1.2e+05")
  expect_equal(scientific(123456, digits = 3), "1.23e+05")

  expect_equal(scientific(0.123456, digits = 1), "1e-01")
  expect_equal(scientific(0.123456, digits = 2), "1.2e-01")
  expect_equal(scientific(0.123456, digits = 3), "1.23e-01")
})

test_that("wrap correctly wraps long lines", {
  expect_equal(wrap_format(10)("this is a long line"),
               "this is a\nlong line")
  expect_equal(wrap_format(10)(c("this is a long line", "this is another long line")),
               c("this is a\nlong line", "this is\nanother\nlong line"))
  expect_equal(wrap_format(10)("a_very_long_word_without_spaces"),
               "a_very_long_word_without_spaces")
  expect_equal(wrap_format(10)("short line"), "short\nline")
  expect_equal(wrap_format(15)("short line"), "short line")
})

test_that("ordinal format", {
  expect_equal(ordinal(1),  "1st")
  expect_equal(ordinal(2),  "2nd")
  expect_equal(ordinal(3),  "3rd")
  expect_equal(ordinal(4),  "4th")
  expect_equal(ordinal(11), "11th")
  expect_equal(ordinal(12), "12th")
  expect_equal(ordinal(21), "21st")
})

test_that("ordinal format maintains order", {
  expect_equal(ordinal(c(21, 1, 11)), c("21st", "1st", "11th"))
})

test_that("formatters don't add extra spaces", {
  has_space <- function(x) any(grepl("\\s", x))
  x <- 10 ^ c(-1, 0, 1, 3, 6, 9)

  expect_false(has_space(comma(x)))
  expect_false(has_space(dollar(x)))
  expect_false(has_space(percent(x)))
  expect_false(has_space(percent(x)))
  expect_false(has_space(scientific(x)))
})

test_that("formats work with 0 length input", {
  x <- numeric()
  expected <- character()
  expect_identical(comma(x), expected)
  expect_identical(dollar(x), expected)
  expect_identical(percent(x), expected)
  expect_identical(scientific(x), expected)
  expect_identical(comma_format()(x), expected)
  expect_identical(date_format()(as.Date(character(0))), expected)
  expect_identical(dollar_format()(x), expected)
  expect_identical(math_format()(x), list())
  expect_identical(parse_format()(x), list())
  expect_identical(percent_format()(x), expected)
  expect_identical(scientific_format()(x), expected)
  expect_identical(trans_format(identity)(x), expected)
})

test_that("unit format", {
  expect_equal(
    unit_format(unit = "km", scale = 1e-3)(c(1e3, 2e3)),
    c("1 km", "2 km")
  )
  expect_equal(
    unit_format(unit = "ha", scale = 1e-4)(c(1e3, 2e3)),
    c("0.1 ha", "0.2 ha")
  )
  expect_equal(
    unit_format()(c(1e3, 2e3)),
    c("1,000 m", "2,000 m")
  )
})

# Percent formatter -------------------------------------------------------

test_that("negative percents work", {
  expect_equal(percent(-0.6), "-60%")
})

test_that("Single 0 gives 0%", {
  expect_equal(percent(0), "0%")
})

# Dollar formatter --------------------------------------------------------

test_that("negative comes before prefix", {
  expect_equal(dollar(-1), "$-1")
})

test_that("missing values preserved", {
  expect_equal(dollar(NA_real_), "$NA")
})


#' Estimate r-square of each association
#'
#' Can be applied to exposure_dat, outcome_dat or harmonised_data. Note that it will be beneficial in some circumstances to add the meta data to the data object using \code{add_metadata()} before running this function. Also adds effective sample size for case control data
#'
#' @param dat exposure_dat, outcome_dat or harmonised_data
#'
#' @export
#' @return data frame
add_rsq <- function(dat)
{
	if("id.exposure" %in% names(dat))
	{
		dat <- 	plyr::ddply(dat, c("id.exposure"), function(x)
			{
				add_rsq_one(x, "exposure")
			})
	}
	if("id.outcome" %in% names(dat))
	{
		dat <- 	plyr::ddply(dat, c("id.outcome"), function(x)
			{
				add_rsq_one(x, "outcome")
			})
	}
	return(dat)
}

add_rsq_one <- function(dat, what="exposure")
{
	if(! paste0("units.", what) %in% names(dat))
	{
		dat[[paste0("units.", what)]] <- NA
	}
	stopifnot(length(unique(dat[[what]])) == 1)
	stopifnot(length(unique(dat[[paste0("units.", what)]])) == 1)

	if(! paste0("rsq.", what) %in% names(dat))
	{
		dat[[paste0("pval.", what)]][dat[[paste0("pval.", what)]] < 1e-300] <- 1e-300
		if(compareNA(dat[[paste0("units.", what)]][1], "log odds"))
		{
			# message("Estimating rsq.exposure for binary trait")
			# message("Ensure that beta.exposure, eaf.exposure, ncase.exposure, ncontrol.exposure are all specified with no missing values")
			if(! paste0("prevalence.", what) %in% names(dat))
			{
				dat[[paste0("prevalence.", what)]] <- 0.1
				warning(paste0("Assuming ", what, " prevalence of 0.1. Alternatively, add prevalence.", what, " column and re-run."))
			}
			ind1 <- !is.na(dat[[paste0("beta.", what)]]) &
				!is.na(dat[[paste0("eaf.", what)]]) &
				!is.na(dat[[paste0("ncase.", what)]]) &
				!is.na(dat[[paste0("ncontrol.", what)]]) &
				!is.na(dat[[paste0("prevalence.", what)]])
			dat[[paste0("rsq.", what)]] <- NA
			if(sum(ind1) > 0)
			{
				dat[[paste0("rsq.", what)]][ind1] <- get_r_from_lor(
					dat[[paste0("beta.", what)]][ind1],
					dat[[paste0("eaf.", what)]][ind1],
					dat[[paste0("ncase.", what)]][ind1],
					dat[[paste0("ncontrol.", what)]][ind1],
					dat[[paste0("prevalence.", what)]]
				)^2
				dat[[paste0("effective_n.", what)]][ind1] <- effective_n(dat[[paste0("ncase.", what)]][ind1], dat[[paste0("ncontrol.", what)]][ind1])
			} else {
				message("Try adding metadata with add_metadata()")
			}
		} else if(all(grepl("SD", dat[[paste0("units.", what)]])) & all(!is.na(dat[[paste0("eaf.", what)]]))) {
			dat[[paste0("rsq.", what)]] <- NA
			dat[[paste0("rsq.", what)]] <- 2 * dat[[paste0("beta.", what)]]^2 * dat[[paste0("eaf.", what)]] * (1-dat[[paste0("eaf.", what)]])
			dat[[paste0("effective_n.", what)]] <- dat[[paste0("samplesize.", what)]]
		} else {
			ind1 <- !is.na(dat[[paste0("pval.", what)]]) & !is.na(dat[[paste0("samplesize.", what)]])
			dat[[paste0("rsq.", what)]] <- NA
			if(sum(ind1) > 0)
			{
				dat[[paste0("rsq.", what)]][ind1] <- get_r_from_bsen(
					dat[[paste0("beta.", what)]][ind1],
					dat[[paste0("se.", what)]][ind1],
					dat[[paste0("samplesize.", what)]][ind1]
				)^2
				dat[[paste0("effective_n.", what)]] <- dat[[paste0("samplesize.", what)]]
			} else {
				message("Try adding metadata with add_metadata()")
			}
		}
	}
	return(dat)
}

#' @importFrom stats qchisq
get_r_from_pn_less_accurate <- function(p, n)
{
	# qval <- qf(p, 1, n-2, low=FALSE)
	p[p == 1] <- 0.999
	p[p == 0] <- 1e-200
	qval <- qchisq(p, 1, lower.tail = FALSE) / (qchisq(p, n-2, lower.tail = FALSE)/(n-2))
	r <- sqrt(sum(qval / (n - qval)))

	if(r >= 1)
	{
		warning("Correlation greater than 1, make sure SNPs are pruned for LD.")
	}
	return(r)
}

#' @importFrom stats coefficients cor lm rnorm
test_r_from_pn <- function()
{
	requireNamespace("ggplot2", quietly = TRUE)
	# requireNamespace("tidyr", quietly = TRUE) # not used

	param <- expand.grid(
		n = c(10, 100, 1000, 10000, 100000),
		rsq = 10^seq(-4,-0.5, length.out=30)
	)

	for(i in 1:nrow(param))
	{
		message(i)
		x <- scale(rnorm(param$n[i]))
		y <- x * sqrt(param$rsq[i]) + scale(rnorm(param$n[i])) * sqrt(1 - param$rsq[i])
		param$rsq_emp[i] <- cor(x, y)^2
		param$pval[i] <- max(coefficients(summary(lm(y ~ x)))[2,4], 1e-300)
		param$rsq1[i] <- get_r_from_pn_less_accurate(param$pval[i], param$n[i])^2
		param$rsq2[i] <- get_r_from_pn(param$pval[i], param$n[i])^2
	}

	param <- gather(param, key=out, value=value, rsq1, rsq2)

	p <- ggplot2::ggplot(param, ggplot2::aes(x=rsq_emp, value)) +
	  ggplot2::geom_abline(slope=1, linetype="dotted") +
	  ggplot2::geom_line(aes(colour=out)) +
	  ggplot2::facet_grid(. ~ n) +
	  ggplot2::scale_x_log10() +
	  ggplot2::scale_y_log10()
	return(list(dat=param, p=p))
}

#' Calculate p-value from rsq and sample size
#'
#' @param r2 Rsq
#' @param n Sample size
#'
#' @export
#' @return P-value
#' @importFrom stats pf df
get_p_from_r2n <- function(r2, n)
{
	fval <- r2 * (n-2) / (1 - r2)
	pval <- pf(fval, 1, n-1, lower.tail=FALSE)
	return(pval)
}

#' Calculate variance explained from p vals and sample size
#'
#' This method is an approximation, and may be numerically unstable.
#' Ideally you should estimate r directly from independent replication samples.
#' Use get_r_from_lor for binary traits.
#'
#' @param p Array of pvals
#' @param n Array of sample sizes
#'
#' @export
#' @return Vector of r values (all arbitrarily positive)
#' @importFrom stats optim qf
get_r_from_pn <- function(p, n)
{
	optim.get_p_from_rn <- function(x, sample_size, pvalue)
	{
		abs(-log10(suppressWarnings(get_p_from_r2n(x, sample_size))) - -log10(pvalue))
	}

	if(length(p) > 1 & length(n) == 1)
	{
		message("Assuming n the same for all p values")
		n <- rep(n, length(p))
	}

	Fval <- suppressWarnings(qf(p, 1, n-1, lower.tail=FALSE))
	R2 <- Fval / (n - 2 + Fval)
	index <- !is.finite(Fval)
	if(any(index))
	{
		index <- which(index)
		for(i in 1:length(index))
		{
			if(p[index[i]] == 0)
			{
				R2[index[i]] <- NA
				warning("P-value of 0 cannot be converted to R value")
			} else {
				R2[index[i]] <- suppressWarnings(optim(0.001, optim.get_p_from_rn, sample_size=n[index[i]], pvalue=p[index[i]])$par)
			}
		}
	}
	return(sqrt(R2))
}

#' Estimate Rsq from beta, standard error and sample size
#'
#' @param b Array of effect sizes
#' @param se Array of standard errors
#' @param n Array of (effective) sample sizes
#'
#' @export
#' @return Vector of signed r values
get_r_from_bsen <- function(b, se, n)
{
	Fval <- (b/se)^2
	R2 <- Fval / (n-2+Fval)
	return(sqrt(R2) * sign(b))
}

compareNA <- function(v1,v2) {
    same <- (v1 == v2) | (is.na(v1) & is.na(v2))
    same[is.na(same)] <- FALSE
    return(same)
}

#' Estimate proportion of variance of liability explained by SNP in general population
#'
#' This uses equation 10 in Lee et al. A Better Coefficient of Determination for Genetic Profile Analysis.
#' Genetic Epidemiology 36: 214–224 (2012) <https://doi.org/10.1002/gepi.21614>.
#'
#' @param lor Vector of Log odds ratio.
#' @param af Vector of allele frequencies.
#' @param ncase Vector of Number of cases.
#' @param ncontrol Vector of Number of controls.
#' @param prevalence Vector of Disease prevalence in the population.
#' @param model Is the effect size estimated from the `"logit"` (default) or `"probit"` model.
#' @param correction Scale the estimated r by correction value. The default is `FALSE`.
#'
#' @export
#' @return Vector of signed r values
get_r_from_lor <- function(lor, af, ncase, ncontrol, prevalence, model="logit", correction=FALSE)
{
	stopifnot(length(lor) == length(af))
	stopifnot(length(ncase) == 1 | length(ncase) == length(lor))
	stopifnot(length(ncontrol) == 1 | length(ncontrol) == length(lor))
	stopifnot(length(prevalence) == 1 | length(prevalence) == length(lor))
	if(length(prevalence) == 1 & length(lor) != 1)
	{
		prevalence <- rep(prevalence, length(lor))
	}
	if(length(ncase) == 1 & length(lor) != 1)
	{
		ncase <- rep(ncase, length(lor))
	}
	if(length(ncontrol) == 1 & length(lor) != 1)
	{
		ncontrol <- rep(ncontrol, length(lor))
	}

	nsnp <- length(lor)
	r <- array(NA, nsnp)
	for(i in 1:nsnp)
	{
		if(model == "logit")
		{
			ve <- pi^2/3
		} else if(model == "probit") {
			ve <- 1
		} else {
			stop("Model must be probit or logit")
		}
		popaf <- get_population_allele_frequency(af[i], ncase[i] / (ncase[i] + ncontrol[i]), exp(lor[i]), prevalence[i])
		vg <- lor[i]^2 * popaf * (1-popaf)
		r[i] <- vg / (vg + ve)
		if(correction)
		{
			r[i] <- r[i] / 0.58
		}
		r[i] <- sqrt(r[i]) * sign(lor[i])
	}
	return(r)
}

#' Obtain 2x2 contingency table from marginal parameters and odds ratio
#'
#' Columns are the case and control frequencies.
#' Rows are the frequencies for allele 1 and allele 2.
#'
#' @param af Allele frequency of effect allele.
#' @param prop Proportion of cases.
#' @param odds_ratio Odds ratio.
#' @param eps tolerance, default is `1e-15`.
#'
#' @export
#' @return 2x2 contingency table as matrix
contingency <- function(af, prop, odds_ratio, eps=1e-15)
{
	a <- odds_ratio-1
	b <- (af+prop)*(1-odds_ratio)-1
	c_ <- odds_ratio*af*prop

	if (abs(a) < eps)
	{
		z <- -c_ / b
	} else {
		d <- b^2 - 4*a*c_
		if (d < eps*eps)
		{
			s <- 0
		} else {
			s <- c(-1,1)
		}
		z <- (-b + s*sqrt(max(0, d))) / (2*a)
	}
	y <- vapply(z, function(a) zapsmall(matrix(c(a, prop-a, af-a, 1+a-af-prop), 2, 2)), matrix(0.0, 2, 2))
	i <- apply(y, 3, function(u) all(u >= 0))
	return(y[,,i])
}

#' Estimate allele frequency from SNP
#'
#' @param g Vector of 0/1/2
#'
#' @export
#' @return Allele frequency
allele_frequency <- function(g)
{
	(sum(g == 1) + 2 * sum(g == 2)) / (2 * sum(!is.na(g)))
}

#' Estimate the allele frequency in population from case/control summary data
#'
#' @param af Effect allele frequency (or MAF)
#' @param prop Proportion of samples that are cases
#' @param odds_ratio Odds ratio
#' @param prevalence Population disease prevalence
#'
#' @export
#' @return Population allele frequency
get_population_allele_frequency <- function(af, prop, odds_ratio, prevalence)
{
	stopifnot(length(af) == length(odds_ratio))
	stopifnot(length(prop) == length(odds_ratio))
	for(i in 1:length(odds_ratio))
	{
		co <- contingency(af[i], prop[i], odds_ratio[i])
		af_controls <- co[1,2] / (co[1,2] + co[2,2])
		af_cases <- co[1,1] / (co[1,1] + co[2,1])
		af[i] <- af_controls * (1 - prevalence) + af_cases * prevalence
	}
	return(af)
}

#' Estimate the effective sample size in a case control study
#'
#' Taken from https://www.nature.com/articles/nprot.2014.071
#'
#' @param ncase Vector of number of cases
#' @param ncontrol Vector of number of controls
#'
#' @export
#' @return Vector of effective sample size
effective_n <- function(ncase, ncontrol)
{
	return(2 / (1/ncase + 1/ncontrol))
}


require(Hmisc)

getHdata(pbc)
pbc <- upData(pbc, moveUnits = TRUE)
s <- summaryM(bili + albumin + alk.phos + copper + spiders + sex ~ drug, data=pbc, test=TRUE)

s
html(s)
options(grType='plotly')
a <- plot(s)
a$Categorical
a$Continuous
plot(s, which='con', nrows=2)


# # v2.0
# path = "D:/_tmp/20150402/sim2/"
# probs = read.table("D:/_tmp/20150402/sim2/probs.txt")$V1
# plot(probs, type = 'b', xlim = c(0, 300), cex = 0.7)
# abline(h = 0.15)
# #abline(h = 0.5/10)
# abline(h = 2/10)

three_plots <- function(perf1, perf2, probs, outf){
  HLIN  = 61
  perf1 = read.table(perf1, header = T, sep=',')
  d1 = perf1$Delay
  f1 = perf1$CorrectFA
  t1 = perf1$CorrectTP
  perf2 = read.table(perf2, header = T, sep=',')
  d2 = perf2$Delay
  f2 = perf2$CorrectFA
  t2 = perf2$CorrectTP
  maxdelay = 300
  probs = read.table(probs)$V1
  #pdf(outf) ############ EXPORT AS: 6 * 8 in, Landscape #####################################
  #layout(matrix(c(1,1,2,3), 2, 2, byrow = TRUE))
  layout(matrix(c(2,3,1,1), 2, 2, byrow = TRUE))
  ##################### 1st plot
  #par(oma=c(2,2,1,1), mar = c(3,3,1,1), mai = c(1, 0.1, 0.1, 0.1))
  #par( mar = c(4,4,1,1))
  #par(mai = c(0.7, 0.5, 0.7, 0.1), mar = c(4,4,2,1))
  plot(probs, type='l', xlim = c(0, maxdelay + 50), ann = F, ylim = c(-0.01, 0.5))
  par(mar=c(3.0, 4.5, 2.0, 0.1))
  lines(c(rep(NA,200),probs), lty = 2, lwd = 1.0)
  abline(h = 0.1, lwd = 2) # limit
  abline(v = HLIN, lwd = 2)
  lambda1 = 0.5 / 10; lambda2 = 2 / 10
  abline(h = c(lambda1, lambda2), lty = 2, lwd = 1.5)
  text(150, 0.25, expression(paste(lambda, " = 0.2")), cex = 1.2)
  text(150, 0.01, expression(paste(lambda, " = 0.05")), cex = 1.2)
  text(-3, 0.14, "L", cex = 1.5)
  mtext(side = 1, text = "Time", line = 2)
  mtext(side = 2, text = "Probability", line = 3.0)
  mtext(side = 3, text = "Confidence function", line = 0.3)
  ######################## 2nd plot
  # EROR RATE 0.2
  plot(d2, t2, ylim = c(0.3, 1.0), xlim =c(10, 150), lwd=2, axes = FALSE, col = "black", type = "l", cex = 0.7, ann = F)
  lines(d2, f2, lwd = 2, type='l', lty=2, ylim = c(0,1), cex = 0.7)
  lines(d2, f2, lwd = 0.3, col = "gray")
  #legend("topright", c("Changes","Errors"), lty = c(1,2), cex = 0.9)
  mtext(side = 3, text = "Delay", line = 0.5, cex = 0.8)
  mtext(side = 2, text = "Fraction", line = 3.0, cex = 1.0)
  text(120, 0.9, "FA"); text(120, 0.49, "TP")
  axis(1); axis(2)
  text(30, 0.4, expression(paste(lambda, " = 0.2")), cex = 1.2)
  abline(v = HLIN, lwd = 2)
  box()
  ######################### 3rd plot
  # ERROR RATE 0.05
  plot(d1, t1, ylim = c(0.3, 1.0), xlim =c(10, 150), axes = FALSE, lwd=2, col = "black", type = "l", cex = 0.7,ann=F)
  lines(d1, f1, lwd = 3, type='l', lty=3, ylim = c(0,1), cex = 0.7)
  lines(d1, f1, lwd = 0.3, col = "gray")
  mtext(side = 3, text = "Delay", line = 0.5, cex = 0.8)
  mtext(side = 2, text = "Fraction", line = 2.5, cex = 1.0)
  #mtext(side = 3, text = expression(paste(lambda "=0.05")), line = 2)
  text(30, 0.4, expression(paste(lambda, " = 0.05")), cex = 1.2)
  text(120, 0.5, "FA"); text(120, 0.88, "TP")
  axis(1); axis(2)
  box()
  #dev.off()
}
three_plots("D:/_tmp/20150402/sim2/Thr0.05Er0.5Mu10.0Std0.7.txt",
            "D:/_tmp/20150402/sim2/Thr0.2Er2Mu10.0Std0.7.txt",
            "D:/_tmp/20150402/sim2/probs.txt", "D:/_tmp/20150402/sim2/combined3.pdf")

pltresults <- function(flnm, outpdf=""){
  impr = read.table(flnm, header = T, sep=',')
  d = impr$Delay
  f = impr$CorrectFA
  t = impr$CorrectTP
  pdf(outpdf)
  plot(d, t, ylim = c(0.3, 1.0), xlim =c(10, 150), lwd=2, col = "black", type = "l", cex = 0.7, xlab = "Delay", ylab = "Fraction")
  lines(d, f, lwd = 2, type='l', lty=2, ylim = c(0,1), cex = 0.7)
  legend("topright", c("Changes","Errors"), lty = c(1,2), cex = 0.9)
  dev.off()
}
# v2.0
#pltresults("D:/_tmp/20150402/sim2/Thr0.05Er0.5Mu10.0Std0.7.txt", "D:/_tmp/20150402/sim2/lowLambda.pdf")
#pltresults("D:/_tmp/20150402/sim2/Thr0.2Er2Mu10.0Std0.7.txt", "D:/_tmp/20150402/sim2/highLambda.pdf")
## v1.0
#pltresults("D:/_tmp/20150330/sim1/Thr0.2Er0.5Mu10.0Std0.7.txt", "D:/_tmp/20150330/sim1/highThr.pdf")
#pltresults("D:/_tmp/20150330/sim1/Thr0.05Er0.5Mu10.0Std0.7.txt", "D:/_tmp/20150330/sim1/lowThr.pdf")

plotconf <- function(flnm, outpdf){
  errrate = 0.5/10
  maxdelay = 300
  threshold = 0.05
  probs = read.table(flnm)$V1
  pdf(outpdf)
  par(mar = c(5,5,4,2) + 0.1)
  plot(probs, type='l', xlim = c(0, maxdelay + 50), xlab = "Time", main = "PCCF function", ylab = "Probability",
       cex.lab = 1.9, cex.axis = 1.5, cex.main = 2)
  lines(c(rep(NA,200),probs), lty = 2, lwd = 1.2)
  abline(h = 0.1, lwd = 2)
  #
  abline(h = 0.2, lty = 2, lwd = 1.5)
  abline(h = 0.05, lty = 2, lwd = 1.5)
  text(150, 0.25, expression(paste(lambda, " = 0.2")), cex = 1.2)
  text(150, 0.01, expression(paste(lambda, " = 0.05")), cex = 1.2)
  text(93, 0.23, "D", cex = 2)
  text(-3, 0.14, "L", cex = 1.5)
  abline(v = 80)
  dev.off()
}
# v2.0
plotconf("D:/_tmp/20150402/sim2/probs.txt", "D:/_tmp/20150404/conff3.pdf")
# v1.0
#plotconf("D:/_tmp/sim/ProbsThr0.05Er0.5Mu10.0Std0.7.txt", "D:/_tmp/20150402/sim2/conff.pdf")
#abline(h = threshold)
#abline(h = errrate, col = "green")
#abline(v = maxdelay)


subroutine insrt(i,j,nadj,madj,x,y,ntot,nerror,eps)
# Insert i and j into each other's adjacency list.
# Called by master, initad, swap.

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

# Check whether i and j are in each other's adjacency lists.
call adjchk(i,j,adj,nadj,madj,ntot,nerror)
if(nerror > 0) return
if(adj) return

# If not, find where in each list they should respectively be.
call locn(i,j,kj,nadj,madj,x,y,ntot,eps)
call locn(j,i,ki,nadj,madj,x,y,ntot,eps)

# Put them in each other's lists in the appropriate position.
call insrt1(i,j,kj,nadj,madj,ntot,nerror)
if(nerror >0) return
call insrt1(j,i,ki,nadj,madj,ntot,nerror)
if(nerror >0) return

return
end


# Solution by Ismail Prada & Andreas Säuberli

# Lena Jäger
# Eyetracking: From experiment design to statistical and machine learning-based data analysis
# Assignment 4: Frequentist statistical analysis of a psycholinguistic eye-tracking-while-reading experiment

# Data set:
#    For a detailed description of the data set used in this assignment, please refer to:
#    Jäger, Mertzen, Van Dyke, & Vasishth: 'Interference patterns for subject-verb
#        agreement and reflexives revisited:  A large-sample study',
#        Journal of Memory and Language, 2020

# Experimental design:
#   2x2x2 fully crossed factorial desing:
#     Factor I: Dependency type: {subject-verb agreement; reflexive-antecedent binding}
#     Factor II: Grammaticality: {grammatical; ungrammatical}
#     Factor III: Similarity-based interference: {interference; no-intererence}

# Condition labels:
#   a  Agreement; grammatical; interference
#   b. Agreement; grammatical; no interference
#   c. Agreement; ungrammatical; no interference
#   d. Agreement; ungrammatical; interference
#   e. Reflexive; grammatical; interference
#   f. Reflexive; grammatical; no interference
#   g. Reflexive; ungrammatical; no interference
#   h. Reflexive; ungrammatical; interference

# Column names:
#   subj: subject id
#   item: item id
#   cond: condition id
#   acc: comprehension question response accuracy
#   roi: region of interest
#   FPRT: first-pass reading times in ms
#   TFT: total fixation times in ms
#   FPR: first-pass regression (binary)

library(coda)
library(plyr)
library(ggplot2)
library(xtable)
library(dplyr)
require(tidyr)
library(tidyverse)
extrafont::loadfonts()
library(reshape2)
require(lme4)

### RESEARCH QUESTIONS:
# 1. Are fixation times different in subject-verb agreement versus reflexive-antecedent dependencies?
# --> main effect of dependency type
# 2. Are fixation times different in ungrammatical versus grammatical conditions?
# --> main effect of grammaticality
# 3. Are fixation times affected by interference?
# --> main effect of interference
# 4. Does the grammaticality effect differ between the two dependency types?
# --> interaction between grammaticality and dependency type
# 5. Does the interference effect differ between grammatical and ungrammatical conditions?
# --> interaction between interference and grammaticality
# 6. Does the interference effect differ between dependency types?
# --> interaction between interference and dependency type
# 7. Does the (possible) difference in the sensitivity to the interference manipulation of
#     grammatical versus ungrammatical conditions differ between subject-verb agreement and reflexive-antecedent dependencies?
# --> 3-way interaction between interference, grammaticality and dependency type

# Critical region: were/was/himself/themselves (= roi 12)
# Dependent variable: total fixation times

#### Load and format the data
d <- read.table(file='dataJMVV.txt', sep = '\t')

#### Inspect the data and answer the following questions:
# How many conditions are there? How many instances of each condition?
# 8 conditions (+filler), counts:
# a      b      c      d      e      f  filler      g      h
# 22659  22659  22659  22596  22680  22638 482412  22680  22617
# How many subjects and items are there?
# 181 subjects
# 176 items
# NOTE: This could also be answered by converting these columns to factors first and then use str()
# How many times did each subject see each item? Hint: use xtabs() )
# 21 times
# What was the average response accuracy for each of the conditions? Hint: use tapply()
# a           b           c           d           e           f
# -0.05560704 -0.05838740 -0.05004634 -0.06133829 -0.07129630 -0.05751391
# filler           g           h
# -0.04718788 -0.05185185 -0.05292479
########################################################
head(d, 3)
d$cond <- factor(d$cond)
summary(d$cond)
length(unique(d$subj))
length(unique(d$item))
xtabs(~subj+item, d)
tapply(d$acc, d$cond, mean)
########################################################

### Convert the subj, item and cond columns to factors
########################################################
d$subj <- factor(d$subj)
d$item <- factor(d$item)
d$cond <- factor(d$cond)
str(d)
########################################################

# Exlcude filler trials and remove all rows from other than the critical region (roi 12)
########################################################
d_crit <- d[d$cond != "filler" & d$roi == 12, ]
########################################################

# Note: when removing all rows with a certain level of a factor, this level still exists, it simply has 0 instances:
summary(d$cond) # before removing the fillers
summary(d_crit$cond) # after removing the fillers
# We can fix this by simply conveting cond to a factor again:
########################################################
d_crit$cond <- factor(d_crit$cond)
########################################################

#### Define contrasts
# Create hypothesis matrix from the given research questions
# main effects of dependency and grammaticality and their interaction (applied in Model 1 and 2)
X_H <- matrix(c( 1/8,  1/8,  1/8,  1/8,  1/8,  1/8,  1/8,  1/8, # Intercept
                 1/4,  1/4,  1/4,  1/4, -1/4, -1/4, -1/4, -1/4, # Main effect dependency type
                -1/4, -1/4,  1/4,  1/4, -1/4, -1/4,  1/4,  1/4, # Main effect grammaticality
                 1/4, -1/4, -1/4,  1/4,  1/4, -1/4, -1/4,  1/4, # Main effect of interference
                -1/4, -1/4,  1/4,  1/4,  1/4,  1/4, -1/4, -1/4, # Grammaticality x Dependency
                -1/4,  1/4, -1/4,  1/4, -1/4,  1/4, -1/4,  1/4, # Interference x Grammaticality
                 1/4, -1/4, -1/4,  1/4, -1/4,  1/4,  1/4, -1/4, # Interference x Dependency type
                -1/4,  1/4, -1/4,  1/4,  1/4, -1/4,  1/4, -1/4  # Interference x Grammaticality x Dependency
), byrow=TRUE, nrow = 8)

# Compute the inverse of X_H
########################################################
library(MASS)  # need this for ginv()
X_C <- ginv(X_H)
########################################################

# For better readibility add column and row names:
rownames(X_C) <- c('a','b','c','d','e','f','g','h')
colnames(X_C) <- c('Intercept','Dep','Gram','Int','Gram_x_Dep','Int_x_Gram','Int_x_Dep','Int_x_Gram_x_Dep')

# Remove intercept column
########################################################
X_C_bar <- X_C[,2:ncol(X_C)]
########################################################

# Apply the contrasts to the cond column
########################################################
contrasts(d_crit$cond) <- X_C_bar
########################################################

#--------------------------------------------------------
#--------------------------------------------------------
# OR:
# Alternative: code contrasts as numerical columns in the dataframe and use these as predictors in the model

# NOTE: Why did they use d and not d_crit here?
d_crit$Dep <- ifelse(d_crit$cond %in% c('a', 'b', 'c', 'd'), .5, -.5) # main effect of dependency type: agr=0.5, refl=-0.5
d_crit$Gram <- ifelse(d_crit$cond %in% c('a', 'b', 'e', 'f'), -.5, .5) # main effect of grammaticality: gram=-.5, ungram=.5
# ... add the other contrasts
########################################################
d_crit$Int <- ifelse(d_crit$cond %in% c('a', 'd', 'e', 'h'), .5, -.5)
d_crit$Gram_x_Dep <- ifelse(d_crit$cond %in% c('c', 'd', 'e', 'f'), .5, -.5)
d_crit$Int_x_Gram <- ifelse(d_crit$cond %in% c('b', 'd', 'f', 'h'), .5, -.5)
d_crit$Int_x_Dep <- ifelse(d_crit$cond %in% c('a', 'd', 'f', 'g'), .5, -.5)
d_crit$Int_x_Gram_x_Dep <- ifelse(d_crit$cond %in% c('b', 'd', 'e', 'g'), .5, -.5)
########################################################

#--------------------------------------------------------
#--------------------------------------------------------

# Remove trials in which the dependent variable (TFT) is zero (i.e., trials in which the critical region was never fixated)
########################################################
d_crit_tft <- d_crit[d_crit$TFT != 0, ]
########################################################
# How many trials (=rows) in % are removed by selecting only the ones with TFT larger than 0?
# 0.07765415 => 7.77% of all trials were removed
########################################################
1 - nrow(d_crit_tft) / nrow(d_crit)
########################################################

# Fit a linear mixed model with log transformed total fixation times as dependent variable and the above defined contrasts as predictor variables (independent variables)
library(lme4)
########################################################
# With contrasts coded as columns:
m <- lmer(log(TFT)~
            Dep+
            Gram+
            Int+
            Gram_x_Dep+
            Int_x_Gram+
            Int_x_Dep+
            Int_x_Gram_x_Dep+
            (1|subj)+
            (1|item),
            data=d_crit_tft)
########################################################
# With contrasts coded using contrasts():
m <- lmer(log(TFT)~cond+(1|subj)+(1|item), data=d_crit_tft)
summary(m)

# Interpret the model output verbally.
########################################################
# t values for Dep and Gram are large enough to be significant,
# i.e. dependency type and grammaticality have a significant
# effect on logarithmic total fixation time.
# The estimated betas for these contrasts are positive, which means:
# - Subject-verb agreement has larger TFT than reflexive-antecedent binding
# - Ungrammatical items have larger TFT than grammatical ones
# The other contrasts do not show significant effects.
########################################################

# We have modeled log(TFT). However, for the conceptual interpretation, it is often easier to express the effect sizes on the ms-scale rather than the log-ms scale
# Compute the effect sizes of the predictors to the ms-scale. H

# Effect of dependency type on the ms scale
########################################################
# NOTE: Not sure if this is really what they mean...

# A change from "reflexive" to "agreement" dependency type increases log(TFT) by 0.2775904
# This corresponds to multiplying TFT by e^0.2775904 = 1.319945
ms_effects <- exp(fixef(m))
ms_effects["condDep"]

# For example, the average TFT for the "reflexive" dependency type is 553.5267 ms:
average_reflexive_tft <-
    d_crit_tft %>%
    filter(cond %in% c("e", "f", "g", "h")) %>%
    summarize(mean(TFT))

# Applying a factor of 1.319945 would mean an expected increase by 177.0983 ms
# when changing the dependency type to "agreement":
ms_increase <- average_reflexive_tft * ms_effects["condDep"] - average_reflexive_tft
########################################################


# Libraries
library(tidyverse)
#library(patchwork)
#library(hrbrthemes)
#library(circlize)
library(networkD3)
library(dplyr)

par(cex = 0.90, mar = c(0, 0, 0, 0))

#mat <- read.csv(file = 'final.csv',row.names = 1, header= TRUE)

# Define the "data" for the digram is "matrix" from above
data <- read.csv(file = 'cvd-os-ints-prot.csv',row.names = 1, header= TRUE)

data

# Reshape data to long format
data_long <- data %>%
  rownames_to_column %>%
  gather(key = 'key', value = 'value', -rowname) %>%
  filter(value > 0)

colnames(data_long) <- c("source", "target", "value")
data_long$target <- paste(data_long$target, " ", sep="")

# From these flows we need to create a node data frame: it lists every entities involved in the flow
nodes <- data.frame(name=c(as.character(data_long$source),
                           as.character(data_long$target)) %>%
                      unique()
)

# With networkD3, connection must be provided using id, not using real name like in the links dataframe.. So we need to reformat it.
data_long$IDsource=match(data_long$source, nodes$name)-1
data_long$IDtarget=match(data_long$target, nodes$name)-1

# Prepare colour scale (7-class Blues, 7-class Greens, 7-class YlOrRd)
ColourScal ='d3.scaleOrdinal() .range(["#084594","#2171b5","#4292c6",
"#6baed6","#9ecae1","#c6dbef","#238b45","#41ab5d","#74c476","#b10026", "#fc4e2a","#ffffb2"])'

# Make the Network
##### set "iterations=0" to avoid automatic assignment of the box order
sankeyNetwork(Links = data_long, Nodes = nodes,
              Source = "IDsource", Target = "IDtarget",
              Value = "value", NodeID = "name",
              sinksRight=FALSE, colourScale=ColourScal,
              nodeWidth=40, fontSize=13, nodePadding=20,
              iterations=0
)


cat("Load data; ")

library(tidyr)
library(reshape2)
# Read Data
ver="v6";
datapath <- "~/stat/nCoV_GA/data/";

raw.full <- read.csv("./data/pui_emory_extract_202007130845_imputed.csv",stringsAsFactors = F)
#raw.full <- read.csv("./data/pui_emory_extract_202006290845_imputed.csv",stringsAsFactors = F)
label.full <- read.csv("./data/pui_data_dict_202005300846.csv",stringsAsFactors = F)

#load counties list;
load(paste0("./counties3.RDA"))
counties3$counties[6] <- "NEWTON, ROCKDALE"

#select variables for the analysis
raw.sub <- raw.full[,c("QARESPONSEID","Q174631","Q174646","Q174652","Q175852","Q174655","Q174656","Q174664","Q174755","Q174833",
                       "Q175985","Q175987","Q178250","Q178251","Q178254","Q178270","Q178274","Q178275","Q178280")]

#clean county;
raw.sub$Q175852[which(raw.sub$Q175852=="" & raw.sub$Q174652!="")]<-raw.sub$Q174652[which(raw.sub$Q175852=="" & raw.sub$Q174652!="")]
raw.sub<-raw.sub[,-which(names(raw.sub)=="Q174652")]

#select only confirmed cases;
raw.sub <- raw.sub[which(raw.sub$Q174755=="Yes"),]

#clean close contact with known cases;
Numextract <- function(string){
  new.string <- unlist(regmatches(string,gregexpr("[[:digit:]]+\\.*[[:digit:]]*",string)))
  new.string <- new.string[which(nchar(new.string)==6)]
  return(paste(new.string,collapse = ","))
}
raw.sub$Q175987 <- unlist(lapply(raw.sub$Q175987,FUN=Numextract))

#clean outbreak ID;
raw.sub$Q178280 <- gsub(" ","",raw.sub$Q178280)

#create a days between onset date and reported date;
raw.sub$days.delay <- as.numeric(as.Date(raw.sub$Q174631,"%m/%d/%Y")) - as.numeric(as.Date(raw.sub$Q174656,"%m/%d/%Y"))

#cases without any date information and will be dropped for analysis;
raw.sub <- raw.sub[-which(raw.sub$Q174656==""),]

#select the information for analysis;
raw.GA <- raw.sub[,c("QARESPONSEID","Q174656","Q174646","Q175852","Q174655",
                     "Q174833","Q175987","Q178280","days.delay")]
names(raw.GA) <- c("ID","date.onset","gender","county","age",
                   "zip","contact","outbreak","days.delay")
raw.GA$days.delay[which(raw.GA$days.delay<0 | raw.GA$days.delay>100)] <- NA
rm(raw.sub)

k.state <- "Georgia"
raw.GA$date.onset <- as.numeric(as.Date(raw.GA$date.onset,"%m/%d/%Y"))
raw.GA$state <- k.state

#drop symptom onset date before 01/01/2020 and after 07/13/2020;
#subset time period;
raw.GA <- raw.GA[-which(raw.GA$date.onset<as.numeric(as.Date("01/01/2020","%m/%d/%Y")) |
                         raw.GA$date.onset>as.numeric(as.Date("07/13/2020","%m/%d/%Y"))),]

k.county <- unlist(strsplit(counties3$counties[ind.county],", "))
#subset for four counties;
raw.GA <- raw.GA[which(raw.GA$county %in% k.county),]
if (any(is.na(raw.GA$date.onset))){
  raw.GA <- raw.GA[-which(is.na(raw.GA$date.onset)),]
}

ID <- raw.GA$ID
time <- raw.GA$date.onset
state <- raw.GA$state
county <- raw.GA$county
gender <- raw.GA$gender
age <- raw.GA$age
outbreak <- raw.GA$outbreak
delay <- raw.GA$days.delay

tm <- time - min(time,na.rm=TRUE);

counties <- unique(county);
unit <- rep(NA,length(counties));
for(k in 1:length(counties)){
  unit[county==counties[k]] <- k;
}
type <- unit

ind <- order(tm);
ID <- ID[ind]
state <- state[ind]
county <- county[ind]
gender <- gender[ind]
age <- age[ind]
delay <- delay[ind]
timedata <- tm[ind];
unitdata <- unit[ind];
outbreakdata <- outbreak[ind];
typedata <- type[ind]

types <- typecount(typedata)[1,]

freqtype <- normalize(typecount(typedata)[2,])

typemask <- matrix(NA,ncol=length(typedata),nrow=length(typedata))
for (i in 1:length(typedata)){
  for (j in 1:length(typedata)){
    typemask[i,j] <- ifelse((typedata[i]==typedata[j]),1,0)
 }
}
unitmask <- matrix(1,ncol=length(unitdata),nrow=length(unitdata))

cont.mat <- matrix(0.01,nrow=length(time),ncol=length(time))
for (i in 1:length(time)){
  tmp0 <- as.numeric(unlist(strsplit(raw.GA$contact[i],",")))
  cont.mat[i,which(raw.GA$ID %in% tmp0)] <- 1
  cont.mat[which(raw.GA$ID %in% tmp0),i] <- 1
}
contmask <- cont.mat[ind,ind]

#outbreak mask;
outbreakdata[which(outbreakdata=="")] <- "0000000"
outbreakmask <- matrix(0.01,ncol=length(outbreakdata),nrow=length(outbreakdata))
for (i in 1:length(outbreakdata)){
  for (j in 1:length(outbreakdata)){
    if(outbreakdata[i]==outbreakdata[j]) outbreakmask[i,j] <- 1;
  }
}

unitmask <- unitmask * contmask * outbreakmask
rm(contmask); rm(outbreakmask); rm(cont.mat);


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

#Bottom two lines are custom RData files I created myself, the souce code which can be found at "http://www.clutchmemes.com/cs125/fixgop.r" and "http://www.clutchmemes.com/cs125/fixdem.r" respectively
load(url("http://www.clutchmemes.com/cs125/GOPArray.RData"))
load(url("http://www.clutchmemes.com/cs125/DEMArray.RData"))

# Plotting the GOP Average Data Frame
averagedGOPPoll <- as.data.frame(aaply(allGOP, 1:2, mean, na.rm=TRUE))
averagedGOPPoll$date = as.Date(rownames(averagedGOPPoll))
averagedGOPPoll.melt <- gather(averagedGOPPoll,candidate,percentage,-date)
plotaverageGOPPoll <- ggplot(averagedGOPPoll.melt,aes(x=date,y=percentage,colour=candidate))+
  geom_line() + ylab("Percentage out of 100") + xlab("Dates: January-December 2015") + scale_x_date(labels = date_format("%m/%d"), breaks = date_breaks("month")) + labs(title = "Plot of Averaged Polling Data for the Republicans")

ggsave(plotaverageGOPPoll, file="plotaverageGOPPoll.png")

#Plotting the Democratic Average Data Frame
averagedDEMPoll <- as.data.frame(aaply(allDEM, 1:2, mean, na.rm=TRUE))
averagedDEMPoll$date = as.Date(rownames(averagedDEMPoll))

averagedDEMPoll.melt <- gather(averagedDEMPoll,candidate,percentage,-date)
plotaverageDEMPoll <- ggplot(averagedDEMPoll.melt,aes(x=date,y=percentage,colour=candidate))+
  geom_line() + ylab("Percentage out of 100") + xlab("Dates: January-December 2015") + scale_x_date(labels = date_format("%m/%d"), breaks = date_breaks("month")) + labs(title = "Plot of Averaged Polling Data for the Democrats")

ggsave(plotaverageDEMPoll, file="plotaverageDEMPoll.png")

#Creating RData for the averaged frames
save(averagedDEMPoll.melt, file="avgDEM.RData")
#Also saving a non-melted form of the data
save(averagedDEMPoll, file="avgDEMNoMelt.RData")
save(averagedGOPPoll.melt, file="avgGOP.RData")
#Also saving a non-melted form of the data
save(averagedGOPPoll, file="avgGOPNoMelt.RData")

# Melting the GTrends Data Frame
load(url("http://www.clutchmemes.com/cs125/pres_trendDF.RData"))
pres_trendDF$date = as.Date(rownames(pres_trendDF))
pres_trendDF.melt <- gather(pres_trendDF,candidate,searched,-date)
plotpres_trendDF <- ggplot(pres_trendDF.melt,aes(x=date,y=searched,colour=candidate))+
  geom_line() + ylab("Total Search Volume") + xlab("Dates: January-December 2015") + scale_x_date(labels = date_format("%m/%d"), breaks = date_breaks("month")) + labs(title = "Plot of Search Volume Over for Candidates")

save(pres_trendDF.melt, file="pres_trendDF.melt.RData")


library(testthat)

source("../src/estimators.r")

test_that("Leaf",{

  expect_error(Leaf("not number"),"value is not a numeric or integer vector")

  leaf = Leaf(5)
  expect_equal(leaf$id,(0))
  expect_equal(leaf$value,(5))

  leaf = Leaf(10,2)
  expect_equal(leaf$id,(2))
  expect_equal(leaf$value,(10))

  leaf = Leaf(10,2,bool_id = c(TRUE,FALSE,TRUE))
  expect_equal(leaf$id,(2))
  expect_equal(leaf$value,(10))

  leaf = Leaf(10,bool_id = c(TRUE,FALSE,TRUE))
  expect_equal(leaf$id,(5))
  expect_equal(leaf$value,(10))
  expect_equal(length(leaf),(1))
  expect_equal(depth(leaf),(0))

})

test_that("Node",{

  node <- Node(c(TRUE,TRUE),4,7,Leaf(4),Leaf(5))
  expect_equal(node$id,3)
  expect_equal(node$feat_id,4)
  expect_equal(node$featval,7)
  expect_equal(node$left$value,4)
  expect_equal(node$right$value,5)
  expect_equal(length(node),2)
  expect_equal(depth(node),1)

  node2 <- Node(c(TRUE,FALSE),4,7,node,NULL)
  expect_equal(node2$id,1)
  expect_equal(node2$feat_id,4)
  expect_equal(node2$featval,7)
  expect_equal(node2$left$id,3)
  expect_equal(node2$left$left$value,4)
  expect_equal(node2$left$right$value,5)
  expect_equal(node2$right,NULL)
  expect_equal(length(node2),2)
  expect_equal(depth(node2),2)

  node2$right<- node
  expect_equal(length(node2),4)
  expect_equal(depth(node2),2)
})

test_that("predict_rt",{
  leaf <- Leaf(6)

  expect_error(predict_rt("dd",6),paste("is(object = tree, class2 = \"leaf\") is not",
               "TRUE or is(object = tree, class2 = \"node\") is not TRUE"),
               fixed=TRUE)
  expect_equal(predict_rt(leaf,1),6)

  node1 <- Node(c(TRUE,TRUE),1,NULL,Leaf(4),Leaf(5))

  expect_equal(predict_rt(node1,1),4)
  expect_equal(predict_rt(node1,1,TRUE),0)
  expect_equal(predict_rt(node1,1,FALSE),4)

  node2 <- Node(c(TRUE,TRUE),1,7,Leaf(4),Leaf(5))

  expect_equal(predict_rt(node2,1),4)
  expect_equal(predict_rt(node2,7),5)
  expect_equal(predict_rt(node2,10),5)
  expect_equal(predict_rt(node2,1,TRUE),0)
  expect_equal(predict_rt(node2,1,FALSE),4)

  node3 <- Node(c(TRUE,TRUE),2,7,Leaf(4,bool_id = c(TRUE)),Leaf(5))
  expect_equal(predict_rt(node3,c(1,1)),4)
  expect_equal(predict_rt(node3,c(1,10)),5)
  expect_equal(predict_rt(node3,c(1,1),TRUE),1)
  expect_equal(predict_rt(node3,c(1,1),FALSE),4)

  node4 <- Node(c(TRUE,TRUE),1,10,node2,Leaf(100,bool_id = c(TRUE,FALSE,TRUE)))
  expect_equal(predict_rt(node4,1),4)
  expect_equal(predict_rt(node4,7),5)
  expect_equal(predict_rt(node4,9),5)
  expect_equal(predict_rt(node4,10),100)
  expect_equal(predict_rt(node4,11),100)
  expect_equal(predict_rt(node4,50),100)
  expect_equal(predict_rt(node4,50,TRUE),5)
  expect_equal(predict_rt(node4,50,FALSE),100)
})

test_that("predict_rt_matrix",{

  tree<-Leaf(101)
  matrix <- rbind(c(1,2),c(3,4),c(5,6),c(7,8),c(9,10))
  values <- predict_rt_matrix(tree,matrix)

  expect_equal(length(values),5)
  expect_equal(values[1],101)

  tree<-Node(c(TRUE,TRUE),1,7,Leaf(4),Leaf(5))
  values <- predict_rt_matrix(tree,matrix)

  expect_equal(length(values),5)
  expect_equal(values[1:3],c(4,4,4))
  expect_equal(values[4:5],c(5,5))
})

test_that("predict_treated_dictionary",{
  estimator_pair<-TreatmentDictionary(5,6)

  expect_error(predict_treated_dictionary("string"),"is(object = estimator_pair, class2 = \"treatment_dictionary\") is not TRUE",
               fixed=TRUE)

  estimator_pair<-TreatmentDictionary(Leaf(100),Leaf(200))
  matrix <- rbind(c(1,2),c(3,4),c(5,6),c(7,8),c(9,10))

  treated <-predict_treated_dictionary(estimator_pair,matrix)

  expect_equal(length(treated$`FALSE`),5)
  expect_equal(treated$`FALSE`[1],200)
  expect_equal(length(treated$`TRUE`),5)
  expect_equal(treated$`TRUE`[1],100)
})

test_that("best_mse_loss",{
  X<-c(1,2,3,4,5)
  Y<-c(1,2,3,4,5)
  mse<-best_mse_loss(X,Y,X)

  expect_equal(mse[1],-2.5)
  expect_equal(mse[2],3)

  X<-c(1,2,3,4,5,6,7,8,9)
  Y<-c(0,0,0,0,0,0,0,0,5)
  mse<-best_mse_loss(X,Y,X)

  expect_equal(mse[1],0)
  expect_equal(mse[2],9)

})

test_that("split_mse",{

  X1<-c(rep(0,times=999),1)
  X2<-1:1000
  X<-cbind(X1,X2)
  Y<-1:1000
  S<-split_mse(X,Y)

  expect_equal(S[1],2)
  expect_equal(S[2],500.5)

  X1<-1:100
  X2<-c(rep(0,times=99),1)
  X<-cbind(X1,X2)
  Y<-seq(3,2314,length.out = 100)
  S<-split_mse(X,Y)

  expect_equal(S[1],1)
  expect_equal(S[2],51)
})

test_that("fit_regression_tree",{
  X1<-1:3
  X2<-rep(0,times=3)
  X<-cbind(X1,X2)
  Y<- X1+2

  tree<-fit_regression_tree(X,Y)

  expect_true(is(tree,"leaf"))
  expect_equal(tree$id,1)
  expect_equal(tree$value,4)
  expect_equal(predict_rt(tree,c(1,0)),4)
  expect_equal(predict_rt(tree,c(1,0),TRUE),1)

  X1<-1:1000
  X2<-rep(0,times=1000)
  X<-cbind(X1,X2)
  Y<- c(rep(0,times=999),1)

  tree<-fit_regression_tree(X,Y)

  expect_true(is(tree,"node"))
  expect_equal(tree$id,1)
  expect_equal(tree$featval,1000)

  expect_equal(predict_rt(tree,c(100,0)),0)
  expect_equal(predict_rt(tree,c(100,0),TRUE),3)

  expect_equal(predict_rt(tree,c(1000,0)),1)
  expect_equal(predict_rt(tree,c(1000,0),TRUE),2)

  expect_true(is(tree$left,"leaf"))
  expect_equal(tree$left$id,3)
  expect_equal(tree$left$value,0)

  expect_true(is(tree$right,"leaf"))
  expect_equal(tree$right$id,2)
  expect_equal(tree$right$value,1)

})

test_that("Test bool_vector_to_int",{
  expect_equal(bool_vector_to_int(TRUE), (1))
  expect_equal(bool_vector_to_int(FALSE), (0))
  expect_equal(bool_vector_to_int(c(FALSE,FALSE)), (0))
  expect_equal(bool_vector_to_int(c(TRUE,TRUE)), (3))
  expect_equal(bool_vector_to_int(c(TRUE,TRUE,FALSE)), (3))
  expect_equal(bool_vector_to_int(rep(TRUE,times=10)), (2^10-1))
  expect_error(bool_vector_to_int(2),"is.logical(bool_vect) is not TRUE",fixed=TRUE)
  expect_error(bool_vector_to_int(c(2,TRUE,FALSE)),"is.logical(bool_vect) is not TRUE",fixed=TRUE)
})


suppressPackageStartupMessages(library(float))

x = matrix(1:30, 10)
y = matrix(1:10, 10, 2)
z = crossprod(x)
w = z
w[1, 2] = -123456

xs = fl(x)
ys = fl(y)
zs = fl(z)
ws = fl(w)

test = isSymmetric(xs)
truth = isSymmetric(x)
stopifnot(identical(test, truth))

test = isSymmetric(ys)
truth = isSymmetric(y)
stopifnot(identical(test, truth))

test = isSymmetric(zs)
truth = isSymmetric(z)
stopifnot(identical(test, truth))

test = isSymmetric(ws)
truth = isSymmetric(w)
stopifnot(identical(test, truth))


rand.parens <- function(n) paste(sample(c("[","]"),2*n,replace=T),collapse="")

as.data.frame(within(list(), {
  parens <- replicate(10, rand.parens(sample.int(10,size=1)))
  balanced <- sapply(parens, balanced)
}))


library(parallel)
library(caret)
library(xgboost)
library(OptimalCutpoints)

setwd("/media/yuri/Data/home1/GNI_data/infection/ResultsSciRep/")
load("CAP_WGCNA.Rdat")

rm(adj, affyData, affyData_CAP, affyData_out, cex1, datExpr, dissTOM,
  dynamicMods, geneTree, minModuleSize, phenotype_CAP, powers,
  samples, samples_pData, samples_pData_subset, sft, softPower, TOM)

pheno <- pheno[pheno$d == "cap",]

################################################################################
# Split data into discovery and validation as in GSE65682
inTraining <- which(pheno$cohort == "discovery")

X <- data.frame(datME, age=pheno$age )
Y <- factor(pheno$mort)

# Split data into discovery and validation as in GSE65682
Xtrain0 <- X[inTraining,]
Ytrain0 <- Y[inTraining]
training0 <- data.frame(Y = Ytrain0, Xtrain0)

Xvalid <- X[-inTraining,]
Yvalid <- Y[-inTraining]
validation <- data.frame(Y = Yvalid, Xvalid)

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

################################################################################
# Hyperparameters grid (see xgboost for details)
params <- expand.grid(
  eta = seq(0.2,0.3,0.02),
  max_depth = c(10:20),
  gamma = seq(0.5, 3, 0.05),
  colsample_bytree = seq(0.1, 1, 0.1),
  min_child_weight = 1,
  subsample = seq(0.1, 1, 0.1)
)

# Find optimal hyperparameters from the grid using 5X cross-validation
cv_xgb <- lapply(seq(nrow(params)), function(i) {
  p <- split(t(params[i,]),
    factor(names(params[i,]),
    levels=c("eta", "max_depth", "gamma", "colsample_bytree", "min_child_weight", "subsample") )
  )
  cv <- xgb.cv(data = dtrain0, params = p, nrounds = 100, nthread = 5, nfold = 5, eval_metric='auc',
                     early_stopping_rounds = 10, objective = "binary:logistic")
  res <- cv$evaluation_log[ cv$best_iteration, 'test_auc_mean'][[1]]
  res
})

# Choose optimal hyperparameters from the grid using 5X cross-validation
params <- params[which.max(unlist(cv_xgb)),]
params <- split(t(params),
  factor(names(params),
  levels=c("eta", "max_depth", "gamma", "colsample_bytree", "min_child_weight", "subsample") )
)

# Train XGB models
XGB_model <- mclapply(c(1:1000), function(i) {

  cat(i, "\r")

  # keep 25% of data from the discovery cohort which will be used for early early_stopping
  # see Feature Engineering and Selection: A Practical Approach for Predictive Models by Max Kuhn and Kjell Johnson
  # 3.4.5 "Validation Sets" for the discussion of this approach
  # http://www.feat.engineering/
  inTrain <- createDataPartition(Ytrain0, p = .75, list = TRUE)$Resample1
  inTest <- seq(Ytrain0)[-inTrain]

  dtrain <- slice(dtrain0, inTrain)
  dtest  <- slice(dtrain0, inTest)

  sink(file="/dev/null")
    # Train the model with optimal hyperparameters (see above) and
    # dtest - 25% of data from the discovery cohort used to determine early stopping
    xgb <- xgb.train(data = dtrain, params = params, nround=100, early_stopping_rounds = 10, nthread = 1,
           watchlist = list(train=dtest), eval_metric='auc', maximize=T)
  sink()

  # predict discovery and validation cohorts (probabilities)
  Ytrain0_prob <- predict(xgb, dtrain0,  ntree=xgb$best_iteration, outputmargin=TRUE)
  Yvalid_prob <- predict(xgb, dvalid,  ntree=xgb$best_iteration, outputmargin=TRUE)

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

  # predict discovery and validation cohorts (classes)
  Ytrain0_class <- factor(as.numeric(ifelse(Ytrain0_prob <= cutoff, "0", "1")), levels = c(0,1))
  Yvalid_class  <- factor(as.numeric(ifelse(Yvalid_prob  <= cutoff, "0", "1")), levels = c(0,1))

  # ballanced accuracy for the discovery and validation cohorts
  bACC_train  <- confusionMatrix(Ytrain0_class, factor(as.numeric(Ytrain0) -1), "1")$byClass[[11]]
  bACC_valid  <- confusionMatrix(Yvalid_class, factor(as.numeric(Yvalid) -1), "1")$byClass[[11]]

  res <- list(model = xgb, auc_train=bACC_train, auc_valid = bACC_valid, nround = xgb$best_iteration, params = params)

  res

}, mc.cores=6 )

# Choose the model which generalize best the validation cohort
idx <- which.max(sapply(XGB_model, function(x) x$auc_valid))
XGB_model_bst <- XGB_model[[idx]]$model
# keep ntree of the selected model
XGB_model_ntree <- XGB_model[[idx]]$nround
# XGB_model_params <- XGB_model[[idx]]$params

rm(idx,cv_xgb, XGB_model, params, dtrain0, dvalid)

# Save results
setwd("/media/yuri/Data/home1/GNI_data/infection/ModelsSciRep")
save.image('CAP_WGCNA_XGB.Rdat')
xgb.save(XGB_model_bst, 'CAP_WGCNA_XGB.model')


#Objetivo1:  mostrar como la ganancia depende fuertemente de los parametros del rpart
#Objetivo2:  mostrar la imperiosa necesidad de optimizar hiperparametros

#Modelo con libreria  rpart
#Estimo la ganancia con  Repeated Random Sub Sampling Validation   (Monte Carlo Cross Validation)

#source("M:\\R\\elementary\\MiPrimerModelo_03.r")

#limpio la memoria
rm(list=ls())
gc()

setwd("E:/UBA/2019-II/DM en Finanzas/Dropbox Prof/datasets")

library("rpart")
library("data.table")
library("dplyr")
library("rpart.plot")
library("ROCR")

#Parametros entrada
karchivo_entrada      <-  "201902.txt"
kcampos_separador     <-  "\t"
kcampo_id             <-  "numero_de_cliente"
kclase_nomcampo       <-  "clase_ternaria"
kclase_valor_positivo <-  "BAJA+2"
kcampos_a_borrar      <-  c(kcampo_id)

ktraining_prob        <-  0.70
ksemilla_azar         <-  c(102191, 200177, 410551, 552581, 892237)

#constantes de la funcion ganancia del problema
kprob_corte           <-  0.025
kganancia_acierto     <-  19500
kganancia_noacierto   <-   -500

#------------------------------------------------------
#Esta funcion calcula la ganancia de una prediccion
#Quedarse solo con las predicciones con probabilidad mayor a  kprob_corte
#Si es un acierto  sumar  kganancia_acierto    (+19500)
#Si NO es acierto  sumar  kganancia_noacierto  (  -500)

fmetrica_ganancia_rpart  = function(probs, clases)
{

  return( sum(   (probs > kprob_corte ) *
                   ifelse(clases== kclase_valor_positivo, kganancia_acierto, kganancia_noacierto)
             )
        )

}
#------------------------------------------------------
#Esta funcion calcula AUC  Area Under Curve  de la Curva ROC

fmetrica_auc_rpart  = function(probs, clases)
{
  testing_binaria  <-  as.numeric(clases == kclase_valor_positivo )
  pred             <-  ROCR::prediction( probs, testing_binaria, label.ordering=c(0, 1))
  auc_testing      <-  ROCR::performance(pred,"auc");

  return(unlist(auc_testing@y.values))

}
#------------------------------------------------------
#Genera el modelo usando una semilla

modelo_rpart_uno = function(psemilla, pmaxdepth, pminbucket, pminsplit, pcp)
{
  #Divido el dataset en training 70% y testing 30%  , usando la libreria dplyr
  dataset  <- as.data.table(mutate(dataset, idtempo =  row_number()))

  set.seed(psemilla )
  dataset_training <- as.data.table(dataset %>%
  group_by(!!as.name(kclase_nomcampo)) %>%
  sample_frac(ktraining_prob) %>%
  ungroup)
  dataset_testing  <- as.data.table(anti_join(dataset, dataset_training, by = "idtempo"))

  dataset_training[ ,  idtempo := NULL    ]
  dataset_testing[ ,  idtempo := NULL    ]

  # generacion del modelo
  formula  <-  formula(paste(kclase_nomcampo, "~ ."))

  t0       <-  Sys.time()
  modelo   <-  rpart(formula,   data = dataset_training,  xval=0, maxdepth=pmaxdepth, minbucket=pminbucket, minsplit=pminsplit, cp=pcp)
  t1       <-  Sys.time()

  tiempo <-  as.numeric( t1 - t0, units = "secs")

  #aplico el modelo a datos nuevos
  testing_prediccion  <- predict( modelo, dataset_testing , type = "prob")

  # calculo la ganancia normalizada  en testing
  gan <-  fmetrica_ganancia_rpart(testing_prediccion[, kclase_valor_positivo ],  dataset_testing[ , get(kclase_nomcampo)]) / (1- ktraining_prob)

  # calculo el AUC en testing
  auc <- fmetrica_auc_rpart(testing_prediccion[ ,kclase_valor_positivo],  dataset_testing[ , get(kclase_nomcampo)])

  return( list("semilla"=psemilla, "ganancia"=gan,  "tiempo"= tiempo,  "auc"=auc) )

}

#------------------------------------------------------
#corre  rpart  usando  las semillas, y promedia el resultado

modelo_rpart_ganancia = function(dataset, pmaxdepth, pminbucket, pminsplit, pcp )
{

  res  <-   lapply(ksemilla_azar, modelo_rpart_uno, pmaxdepth=pmaxdepth,  pminbucket=pminbucket, pminsplit=pminsplit, pcp=pcp)

  return(rbindlist(res))

}
#------------------------------------------------------

#cargo los datos
dataset <- fread(karchivo_entrada, header=TRUE, sep=kcampos_separador)

#borro las variables que no me interesan
dataset[ ,  (kcampos_a_borrar) := NULL    ]

t0       <-  Sys.time()
res1  <-  modelo_rpart_ganancia(dataset, pmaxdepth=4, pminbucket=5, pminsplit=20, pcp=0 )
cat( "ganancia_promedio:", mean(res1$ganancia),  "\t",  "AUC_promedio:", mean(res1$auc),  "\n")
t1       <-  Sys.time()
tcorrida1 <-  as.numeric( t1 - t0, units = "secs")

t0       <-  Sys.time()
res2  <-  modelo_rpart_ganancia(dataset, pmaxdepth=8, pminbucket=5, pminsplit=20, pcp=0 )
cat( "ganancia_promedio:", mean(res2$ganancia),  "\t",  "AUC_promedio:", mean(res2$auc),  "\n")
t1       <-  Sys.time()
tcorrida2 <-  as.numeric( t1 - t0, units = "secs")

t0       <-  Sys.time()
res3  <-  modelo_rpart_ganancia(dataset, pmaxdepth=10, pminbucket=5, pminsplit=20, pcp=0 )
cat( "ganancia_promedio:", mean(res3$ganancia),  "\t",  "AUC_promedio:", mean(res3$auc),  "\n")
t1       <-  Sys.time()
tcorrida3 <-  as.numeric( t1 - t0, units = "secs")

t0       <-  Sys.time()
res4  <-  modelo_rpart_ganancia(dataset, pmaxdepth=12, pminbucket=5, pminsplit=20, pcp=0 )
cat( "ganancia_promedio:", mean(res4$ganancia),  "\t",  "AUC_promedio:", mean(res4$auc),  "\n")
t1       <-  Sys.time()
tcorrida4 <-  as.numeric( t1 - t0, units = "secs")

t0       <-  Sys.time()
res5  <-  modelo_rpart_ganancia(dataset, pmaxdepth=14, pminbucket=5, pminsplit=20, pcp=0 )
cat( "ganancia_promedio:", mean(res5$ganancia),  "\t",  "AUC_promedio:", mean(res5$auc),  "\n")
t1       <-  Sys.time()
tcorrida5 <-  as.numeric( t1 - t0, units = "secs")

tcorrida1
tcorrida2
tcorrida3
tcorrida4
tcorrida5
#Hacer Función Corrida con medicioión de tiempo

#Por favor notar la gran variabilidad que hay en la ganancia al generar el arbol con distintos parametros
#Cuales seran los parametros que optimizan la ganancia para rpart en este dataset ?


library(dplyr)
library(readr)
library(tidyr)
library(caret)

set.seed(123)

# reading in clean data
data <- read.csv('./data/clean/clean_train_predict.csv')

# one hot encoding
dmy <- dummyVars(" ~ elevel + car + zipcode", data = data)
encoded_columns <- data.frame(predict(dmy, newdata=data))
data_encoded <- bind_cols(encoded_columns, data[c('salary', 'age', 'credit', 'brand', 'predict')])

# # Scaling everything using values from both train and predict datasets
# scaler <- preProcess(select(data_encoded, select=-c('sony', 'predict')), method=c('center', 'scale'))
# data_encoded_scaled <- predict(scaler, data_encoded)

# Creating separate datasets for training, testing and predicting
pred <- data_encoded[data_encoded$predict == 1, !names(data_encoded) %in% c('predict')]
non_pred <- data_encoded[!data_encoded$predict == 1, !names(data_encoded) %in% c('predict')]

inTrain <- createDataPartition(non_pred$brand, p=.7, list=FALSE)
train <- non_pred[inTrain, ]
test <- non_pred[-inTrain, ]

write.csv(pred, file='./data/processed/processed_pred.csv', row.names = FALSE)
write.csv(train, file='./data/processed/processed_train.csv', row.names = FALSE)
write.csv(test, file='./data/processed/processed_test.csv', row.names = FALSE)


#!/usr/local/bin/Rscript --vanilla

###############################################################################
# METAREP : High-Performance Comparative Metagenomics Framework (http://www.jcvi.org/metarep)
# Copyright(c)  J. Craig Venter Institute (http://www.jcvi.org)
#
# Licensed under The MIT License
# Redistributions of files must retain the above copyright notice.
#
# link http://www.jcvi.org/metarep METAREP Project
# package metarep
# version METAREP v 1.3.2
# author Johannes Goll
# lastmodified 2010-07-09
# license http://www.opensource.org/licenses/mit-license.php The MIT License
###############################################################################

library(edgeR);
library(methods);

## get command line arguments
args 					= commandArgs(TRUE)

infile 					= args[1];
outfile 				= args[2];
propround 				= as.numeric(args[3]);
pvalround 				= as.numeric(args[4]);
startIndexPopulationB	= as.numeric(args[5]);
populationNameA			= args[6];
populationNameB			= args[7];

## get edgeR DGE List object
targets = read.delim(infile,stringsAsFactors=F);
dgeList = readDGE(targets);
features = rownames(dgeList$counts);
m  = as.matrix(dgeList$counts);

## get number of datasets
ncols = as.numeric(length(m[1,]));
nrows = as.numeric(length(m[,1]));

## get counts for each population
posA = seq(1,(startIndexPopulationB-1));

posB = seq(startIndexPopulationB,ncols);
cntA = apply(m[,posA],1,sum);
cntB = apply(m[,posB],1,sum);

## estimate common dispersion
commonDispersion = estimateCommonDisp(dgeList);

## execute exact negative binomial test
edgeResults = exactTest(commonDispersion,pair=c(populationNameA,populationNameB));
edgeResultTable = edgeResults$table;

## top ten results for smear plot
#topTenEdgeResults = topTags(edgeResults);
#pdf(outfile||".pdf");

## init metarep result matrix
columns  = c("id","count1","count2","logConc","logFC","disp","p_value","b_value","q_value");
metarepResults = data.frame(matrix(rep(NA,9*nrows),ncol=9),stringsAsFactors=F);
colnames(metarepResults) = columns;

## set metarep result values
metarepResults[,1] = features;
metarepResults[,2] = cntA;
metarepResults[,3] = cntB;
metarepResults[,4] = round(edgeResultTable$logConc,4);
metarepResults[,5] = round(edgeResultTable$logFC,4);
metarepResults[,6] = round(commonDispersion$common.dispersion,4);
metarepResults[,7] = round(edgeResultTable$p.value,pvalround);
metarepResults[,8] = round(p.adjust(edgeResultTable$p.value, method = "fdr"),pvalround);
metarepResults[,9] = round(p.adjust(edgeResultTable$p.value, method = "bonferroni"),pvalround);

## write results to tab delimites output file
write.table(metarepResults,file=outfile,row.names=F,sep ="\t",eol="\n",append=F,quote=F);

## exit
q(status=0)


# Code for eBird migration project, to prepare the full eBird dataset into an "effort" dataset
# developed by S. Supp and L. Graham for new analysis combining eBird data with remotely sensed environment

# DISCLAIMER: Code is under development
# 17 July 2019

# Inputs: Full eBird dataset for all species 2006-2018

# Outputs: Effort dataset with columns for DAY, YEAR, CELL, COUNT, assuming a dggridR resolution
#          of 6 (12452 km2) for the Fuller4H projection (not the default in ddgridR)

# Import libraries
library(tidyverse)
library(ggmap)
library(geosphere)
library(maps)
library(dggridR)
library(rgdal)

# read in full eBird data to be converted into effort data (downloaded on 22 August 2019)
effort = read_csv("") #FIXME, need full eBird to begin with

# clean up effort data by grouping aggregating the records from group record, and using the mean lat-longs in case of recorder error
effort <- effort %>%
  select(common_name, scientific_name, latitude, longitude, observation_date,
         time_observations_started, observer_id, protocol_type, project_code,
         duration_minutes, effort_distance_km, effort_area_ha, number_observers,
         sampling_event_identifier, group_identifier) %>%
  mutate(sampling_event_identifier =
           ifelse(is.na(group_identifier), sampling_event_identifier, group_identifier)) %>%
  group_by(common_name, observation_date, sampling_event_identifier) %>%
  mutate(latitude2 = mean(latitude), longitude2 = mean(longitude),
         latdiff = latitude-latitude2, londiff = longitude-longitude2) %>%
  distinct(sampling_event_identifier, .keep_all = TRUE)  %>%
  mutate(year = year(observation_date),
         month = month(observation_date),
         day = yday(observation_date))

# FAL suggests using Fuller grid with resolution=6 (12452 km2)
hex_6 <- dgconstruct(projection = "FULLER", aperture = 4, topology = "HEXAGON", res=6)

#Get the corresponding grid cells and center coordinates for all observations in the dataset (lat-long pair)
effort$cell <- dgGEO_to_SEQNUM(hex_6, effort$LONGITUDE, effort$LATITUDE)$seqnum
effort$cell_lat <- dgSEQNUM_to_GEO(hex_6, effort$cell)$lat_deg #FIXME: pretty sure this is accurate, check
effort$cell_lon <-dgSEQNUM_to_GEO(hex_6, effort$cell)$lon_deg #FIXME: pretty sure this is accurate, check

#Converting SEQNUM to GEO gives the center coordinates of the cells
cellcenters <- dgSEQNUM_to_GEO(hex_6, effort$cell)

#Get and plot the number of observations in each cell and in each year
ebirdcounts <- effort %>%
  group_by(cell, year) %>%
  summarise(count=n())

ggplot(ebirdcounts, aes(x=count)) +
  geom_histogram(binwidth=10) +
  facet_wrap(~year)

#Get the grid cell boundaries for cells which had bird observations #FIXME: Will it be a problem that cell is repeated here, across multiple years? If so, how fix?
grid <- dgcellstogrid(hex_6, ebirdcounts$cell, frame=TRUE, wrapcells=TRUE)

#Update the grid cells' properties to include the number of observations in each cell #FIXME: and in each year
grid <- merge(grid, ebirdcounts, by.x="cell", by.y="cell")

#Get polygons for the spatial range and make a map of bird observations
countries <- map_data("usa") #add Canada and Mexico

ggplot() +
  geom_polygon(data=countries, aes(x=long, y=lat, group=group), fill=NA, color="black")   +
  geom_polygon(data=grid,      aes(x=long, y=lat, group=group, fill=count), alpha=0.4)    +
  geom_path   (data=grid,      aes(x=long, y=lat, group=group), alpha=0.4, color="white") +
  #  geom_point  (aes(x=cellcenters$lon_deg, y=cellcenters$lat_deg), size=0.5) +
  scale_fill_gradient(low="blue", high="red") +
  facet_wrap(~year)

#dgearthgrid(hex_6, savegrid="cell_out-12.shp") # FIXME: Do I actually need this step or can I just pass the grid object directly onto the dataset, as with ISEA3H?

# TODO: FAL other code, to modify for our needs here:

#hex <- readOGR("cell_out-12.shp")
# hex_6@data$POLYFID <- 1:40962
#
# # eBirdData$SUB_ID <- ifelse(!is.na(eBirdData$GROUP_ID), eBirdData$GROUP_ID, eBirdData$SUB_ID)
# # eBirdData <- aggregate(cbind(LATITUDE, LONGITUDE) ~ PRIMARY_COM_NAME + YEAR + DAY + SUB_ID, data=eBirdData, FUN=mean, na.rm=TRUE)
#
# locs <- SpatialPoints(cbind(eBirdData$LONGITUDE, eBirdData$LATITUDE))
# proj4string(locs) <- proj4string(hex_6)
# ovr <- over(locs, hex_6)
#
# eBirdData$POLYFID <- ovr$POLYFID

eft <- aggregate(SUB_ID ~ POLYFID + YEAR + DAY, data=eBirdData, FUN=length)


###################################################################################################
#
# Mark Cembrowski, Janelia Farm, October 1 2015
#
# This script looks for enriched (or conversely, depleted) genes in a given
# sample or samples, relative to all other samples in the dataset.
#
# Note that this script requires ALL replicates to be at least X-fold enriched
# relative to ALL OTHER replicates.  This is stringent, but helps to eliminate
# outliers.  This can be circumvented by using the avgPass=T, which operates
# on the average values only.
#
# 111213: EDIT: it would be advantageous to be able to calculate enriched genes while masking
# some replicates from the comparison.  I've implemented a mask option to do this.
#
# 100115: EDIT: I've added functionality that allows enriched genes to be obtained from CPM,
# rather than FPKM, data.
#
# INPUT:
# sampleNames: a vector of one or more sample names.
# OPTIONAL ARGUMENTS:
# foldThres: fold difference to count as enriched [default=3]
# fpkmThres: require a threshold for minimum FPKM value in enriched popln [default=-1; ie off]
# depleted: search for depleted genes within this population instead? [default=F]
# avgPass: relax pass criteria by considering only averages (see header of this
# 	function for explanation)?  [default=F]
# mask: a vector of one or more sample names to mask from analysis (ie, they will not act in
#	determining the enrichment cutoff).  [default=c(); ie off]
# plotAvg: plot a graph of the average fold change between samples?  [default=F]
#
# OUTPUT:
# A list is returned with all XLOC value that fulfill the given criteria.
#
####################################################################################################

enrichedGenes <- function(sampleNames,foldThres=3,fpkmThres=-1,depleted=F,avgPass=F,mask=c(),plotAvg=F,shuffled=F,doFpkm=T){
	# Generate FPKM matrix to operate on.
	if(doFpkm){
		if(avgPass){
			theMat <- fpkmPoolMat
		}else{
			theMat <- fpkmRepMat
		}
	}else{
		if(avgPass){
			theMat <- cpmPoolMat
		}else{
			theMat <- cpmRepMat
		}
	}

	toMask <- c() # Set up a dummy variable that will remain blank if not using mask.

	# Identify replicates to mask, if selected.
		if(length(mask)>0.1){
			toMask <- grepl(paste(mask,collapse='|'),colnames(theMat))
			theMat <- theMat[,!toMask]
		}

	if (avgPass){
		sampleReps <- colnames(theMat)%in%sampleNames
	}else{
		# Extract features of samples and replicates.
		reps <- colnames(theMat)
		samples <- unique(substr(reps,1,nchar(reps)-2)) # Remove _X suffix from reps

		# Verify that supplied sample names are all from dataset.
		if( prod(sampleNames%in%samples)<0.1 ){
			stop('At least one supplied sample not in data set sample names.')
		}

		# Identify replicates that are part of samples to identify fold changes for.
		sampleReps <- ( (substr(reps,1,nchar(reps)-2) )%in%sampleNames)

	}

	if(shuffled){
		theMat <- .shuffleMat(theMat)
	}

	# Check if doing enrichment or depletion survey; proceed accordingly.
	if(!depleted){
		# Get minimum replicate FPKM in supplied population.
		minFpkm <- apply(as.matrix(theMat[,sampleReps]),1,min) #as.matrix prevents an error when theMat[,sampleReps] has one column and becomes a vector

		# Get maximum replicate FPKM in rest of population.
		maxFpkm <- apply(as.matrix(theMat[,!sampleReps]),1,max)

		# Mask FPKM values below cutoff.
		maskFpkm <- minFpkm>fpkmThres
		minFpkm <- minFpkm*maskFpkm

	}else{
		# Get maximum replicate FPKM in supplied population.
		maxFpkm <- apply(as.matrix(theMat[,sampleReps]),1,max)
		# Get minimum replicate FPM in rest of population.
		minFpkm <- apply(as.matrix(theMat[,!sampleReps]),1,min)

		# Mask FPKM values below cutoff.
		maskFpkm <- minFpkm>fpkmThres
		minFpkm <- minFpkm*maskFpkm
	}

	# Check if fold difference surpassed.
	theOut <- rownames(theMat)[ minFpkm > (maxFpkm*foldThres) ]

	# Plot graph illustrating fold change, if desired.
	if(plotAvg){
		# Reduce matrix to those entries crossing fold difference.
		plotMat <- theMat[ minFpkm > (maxFpkm*foldThres) , ]

		# From the above code, columns have already been assigned to being desired sample
		# reps (sampleReps) and masked samples (toMask).  Use this to generate the
		# mean FPKM values for desired samples and comparison samples, masking any
		# contributions from undesired comparisons.  Note that these have slightly different
		# formats -- sampleReps is a string of logicals equal to the numbe of columns,
		# whereas toMask gives the indices of masked columns.  This requires a
		# housekeeping step.
		#
		# In the below, I'll refer to the supplied samples and comparison samples as
		# pop1 and pop2, respectively -- this general naming is chosen because they could
		# corresponding to either the enriched or depleted sample, set by the 'depleted'
		# option.
		pop1 <- apply(as.matrix(plotMat[,sampleReps]),1,mean)
		sampleRepsToInd <- which(sampleReps>0.9)
		pop2 <- apply(as.matrix(plotMat[,-sort(c(sampleRepsToInd,toMask))]),1,mean)
		popEnr <- pmax(pop1/pop2,pop2/pop1) # Fold change, take >1
		compPops <- as.data.frame(cbind(pop1,pop2,popEnr))

		thePlot <- ggplot(compPops,aes(factor(pop1*0),popEnr))
		thePlot <- thePlot + geom_boxplot(outlier.size=0) + geom_jitter() # geom_jitter includes all outliers;
							 			  # otherwise left with two data points
										  # for each outlier.
		thePlot <- thePlot + expand_limits(y=0)

		print(thePlot)

		#return(compPops)
	}

	invisible(theOut)
}

# Shuffle a matrix.  Used for null hypothesis testing.
.shuffleMat <- function(theMat){
	trans <- t(apply(theMat,1,sample))
	colnames(trans) <- colnames(theMat)
	invisible(trans)
}


source("./load_libraries.r")

exec_eval_complexity <- function(MFtr){

  if(!dir.exists("./synthetic/"))
    dir.create("./synthetic/")

  vdist <- c("topsoe", "jensen_difference", "prob_symm", "ord", "sord")
  names(vdist) <- c("TS", "JD", "PS", "ORD", "SORD")

  var_perc <- seq(0,1,0.05) # positive class distribution
  var_size <- 1000#test set size
  n_tests  <- 10# replication
  MF       <- seq(0.05,0.95,0.05) # m parameter for MoSS model
  qnt      <- c("HDy-LP", "DyS-TS","DyS-JD", "DyS-ORD", "MS", "T50", "MAX", "X", "CC", "PCC", "ACC", "PACC", "SORD", "MS2", "SMM")

  results <- data.frame(MFtr=NA, MFte=NA, R_1=NA, P_1=NA, MAE=NA,Distance=NA, Value.dist=NA, Qnt=NA)
  for(mi in 1:length(MFtr)){
    scores  <- MoSS(2000, 0.5, MFtr[mi])
    TprFpr  <- apply(getTPRandFPRbyThreshold(scores), 2, as.numeric)
    colnames(TprFpr) <- c("thr", "tpr", "fpr")
    for(k in 1:length(var_size)){
      for(i in 1:length(var_perc)){
        print(paste0("Class distr. ", var_perc[i]))
        for(j in 1:n_tests){
          for(ti in 1:length(MF)){
            for(qi in qnt){
              test_set <- MoSS(var_size[k], var_perc[i], MF[ti])
              freq_REAL<- factor(test_set[,3], levels = c(1,2))
              freq_REAL<- table(freq_REAL)/length(freq_REAL)
              qntMethod<- qi
              if(qi!="HDy-LP"){
                ifelse(length(strsplit(qi, "-")[[1]]) > 1, qntMethod <- strsplit(qi, "-")[[1]][1], qntMethod <- qi)
                  nk <- as.numeric(strsplit(qntMethod, "_")[[1]][1])
                if(is.na(nk)){
                  nk <- 1
                }else{
                   nk <- nk
                   qntMethod <- "DySyn"
                  }
              }
              qnt_re <- apply.qntMethod(qntMethod = qntMethod,
                                        p.score = scores[scores[,3]==1,1],
                                        n.score = scores[scores[,3]==2,1],
                                        test = test_set[,1],
                                        TprFpr = TprFpr,
                                        thr = 0.5,
                                        measure = vdist[strsplit(qi,"-")[[1]][2]]
                                       )

              freq_PRE <- qnt_re[[1]]
              results  <- rbind(results, unlist(c(MFtr[mi],
                                                  MF[ti],
                                                  freq_REAL[1],
                                                  freq_PRE[1],
                                                  round(abs(freq_REAL[1]-freq_PRE[1]),2),
                                                  vdist[strsplit(qi,"-")[[1]][2]],
                                                  qnt_re[[2]],
                                                  qi)))
            }
          }
        }
      }
    }
    results <- results[-1,]
    #saveRDS(results, paste0("./synthetic/scorer_complexity_syn","_", MFtr[mi],".rds"))
  }
  return(1)
}

setwd(dirname(parent.frame(2)$ofile))
#%%%%%%%%%%%%%%%% IMPORTANT %%%%%%%%%%%%%%%

# Running this file will take a long time to get it concluded! Then you can only run the show_results_synthetic.r file
# for reploting or modified some analaysis.

#uncomment for running the evaluation of each quantifier
m_Tr <- seq(0.05, 0.95, 0.05)
print("############ - It will take a couple of minutes! - ############")
for(i in m_Tr)
  exec_eval_complexity(i)

#%%%%%%%%%%%%%%%% IMPORTANT %%%%%%%%%%%%%%%


# https://www.r-spatial.org/r/2018/10/25/ggplot2-sf.html
# https://covidtracking.com/api/
# https://covid.ourworldindata.org
library(R0)
library(plotly)
library(rnaturalearth)
library(rnaturalearthdata)
library(rgeos)
library(data.table)
library(countrycode)
library(viridis)
library(gganimate)
library(gifski)
library(tidyverse)
library(lmtest)
library(WDI)
library(plotly)
library(USAboundaries)
library(sf)
library(fuzzyjoin)
library(tigris)
library(scales)
library(ggthemes)
library(usmap)
library(cowplot)
library(RcppRoll)
library(sqldf)
library(albersusa)
library(RColorBrewer)
library(quantreg)
library(ggrepel)

# entity_name
# entity_type
# country
# date
# cases
# deaths
# FIPs (if available)
# latitude / longitude
#
# us_counties_shp = us_counties()
# us_states_shp = us_states()
# us_map = USAboundaries::us_boundaries()
# us_states_tigris = tigris::states()
# us_counties_tigris = tigris::counties()

## population by area ##

setwd("~/Public_Policy/Projects/COVID-19")

r0_window_size = 7
est_r0_window = function(new_cases, catch = F) {
  # https://www.ncbi.nlm.nih.gov/pmc/articles/PMC7014672/

  mGT <- generation.time("weibull", c(6.4, 2.3))
  # new_cases = a$the_cases
  if (!catch) {
    r0_est = est.R0.EG(new_cases, mGT, begin=as.integer(1), end=as.integer(length(new_cases)))$R
    return(r0_est)
  } else {
    r0_est = NA
    tryCatch({
      r0_est = est.R0.EG(new_cases, mGT, begin=as.integer(1), end=as.integer(length(new_cases)))$R
    }, error = function(e){
      return(r0_est)
    })

  }

}

# ### get state and US population data  ###
# fred_sqlite = dbConnect(SQLite(), dbname= "data/fred_sqlite.sqlite")
#
# state_economic_data = dbGetQuery(fred_sqlite, 'select * from state_economic_data') %>%
#   mutate(
#     date = as.Date(date, origin = '1970-01-01'),
#     title_clean = str_extract(title, '(.* in )|(.* for )') %>% str_replace('( in )|( for )', ''),
#     title_for_col = paste0("x_", str_replace_all(title_clean, '[ \\-%,]', '_'))
#   ) %>%
#   arrange(state_name, title_clean, date) %>%
#   data.table() %>%
#   # accidentally inserted duplicate records for Alabama, dedup here (need to index this db later)
#   unique(by = c('state_name', 'title_clean', 'date'))
#
#
# annual_population_by_state = filter(state_economic_data, title_clean == 'Resident Population') %>%
#   mutate(
#     year = year(date)
#   )

# population_by_state = filter(annual_population_by_state, date == max(date))
population_by_state = read_csv('data/state_pop_2018.csv', skip = 1) %>%
  rename(
    state_name = `Geographic Area Name`,
    value = `Estimate!!Total`
  )
us_population = sum(population_by_state$value)

latest_country_pop = read_csv('data/latest_country_pop.csv') %>%
  mutate(
    country = recode(country, `Korea, Rep.` = "South Korea")
  )

county_pops = read_csv('data/ACSDP5Y2018.DP05_data_with_overlays_2020-04-16T114550.csv', skip = 2, col_names = F)
county_pops_names = read_csv('data/ACSDP5Y2018.DP05_data_with_overlays_2020-04-16T114550.csv', n_max = 1, col_names = T)
names(county_pops) = names(county_pops_names)

county_pops_sub = select(county_pops, GEO_ID, NAME, county_pop = DP05_0033E) %>%
  mutate(
    fips = str_remove(GEO_ID, '0500000US')
  )

## get shapefile data ##
# us_counties_shp = us_counties()
# us_states_shp = us_states()
# us_map = USAboundaries::us_boundaries()
us_states_tigris = tigris::states()
# us_counties_tigris = tigris::counties()

# remotes::install_git("https://git.sr.ht/~hrbrmstr/albersusa")
# https://github.com/hrbrmstr/albersusa

# us_sf <- usa_sf("laea")
# cty_sf <- counties_sf("aeqd")

state_geo_center = us_states_tigris@data %>%
mutate(
  lat = as.numeric(INTPTLAT),
  long = as.numeric(INTPTLON)
) %>%
rename(
  state_abbr = STUSPS
)

### get lockdown dates ###
lockdown_dates = read_csv('data/lockdown_dates.csv') %>%
  rename(location = location_name,
         country = Country, level = Level) %>%
  mutate(
    level = recode(level, National = 'Country'),
    location = ifelse(is.na(location), country, location),
    location_type = ifelse(is.na(location), 'Country',
                           ifelse(location %in% state.name & level == 'State', 'US State', level))
  )

names(lockdown_dates) = names(lockdown_dates) %>% str_replace_all(' ', '_')

all_countries = unique(lockdown_dates$country)
countries_with_lockdown_dates = filter(lockdown_dates, location_type == 'Country') %>% pull(country)
countries_wo_lockdown_dates = setdiff(all_countries, countries_with_lockdown_dates)

lockdowns_by_country = lockdown_dates %>% filter(country %in% countries_wo_lockdown_dates) %>%
  group_by( country) %>%
  summarize(
    lockdown_start = min(lockdown_start, na.rm = T),
    lockdown_end = max(lockdown_end)
  ) %>%
  mutate(
    location_type = 'Country', location = country
  )

lockdown_dates_fin = bind_rows(lockdown_dates, lockdowns_by_country)

##### country data ####
johns_hopkins_cases = read_csv('https://raw.githubusercontent.com/CSSEGISandData/COVID-19/master/csse_covid_19_data/csse_covid_19_time_series/time_series_covid19_confirmed_global.csv') %>%
  pivot_longer(cols = matches('^([0-9])'), names_to = 'date', values_to = 'cases')

johns_hopkins_deaths = read_csv('https://raw.githubusercontent.com/CSSEGISandData/COVID-19/master/csse_covid_19_data/csse_covid_19_time_series/time_series_covid19_deaths_global.csv') %>%
  pivot_longer(cols = matches('^([0-9])'), names_to = 'date', values_to = 'deaths')

jh_joined = left_join(johns_hopkins_cases, johns_hopkins_deaths) %>%
  mutate(
    date = as.Date(date, format = '%m/%d/%y')
  ) %>%
  rename(
    state = `Province/State`,
    country = `Country/Region`,
    total_cases = cases,
    total_deaths = deaths,
    latitude = Lat,
    longitude = Long
  )

jh_summary_by_country = group_by(jh_joined, country, date) %>%
  summarize(
    obs = n(),
    n_cases = sum(total_cases, na.rm =T),
    n_deaths = sum(total_deaths,na.rm = T)
  ) %>%
  ungroup() %>%
  rename(
    total_deaths = n_deaths,
    total_cases = n_cases
  ) %>%
  mutate(
    total_tests = total_cases,
    tests_with_results = total_cases,
    state = NA,
    location = ifelse(is.na(state), country, state),
    location_type = ifelse(is.na(state), 'country', 'state/province'),
    location = recode(location, `US` = "United States"),
    country = recode(country, `US` = "United States"),
    data_source = 'Johns Hopkins CSSE',
    location_key = paste(country, state, location_type, location, data_source, sep = '|')
  ) %>%
  arrange(location_key, date) %>%
  filter(
    # !country %in% c('US', 'United States')
    ) # use covidtracking data

#### US and state data ####
us_covid_data = read_csv('https://covidtracking.com/api/us/daily.csv') %>%
  mutate(
    date = as.Date(as.character(date), format = '%Y%m%d'),
    location = 'United States',
    country = 'United States',
    state = NA,
    location_type = 'country',
    data_source = 'covidtracking.com',
    location_key = paste(country, state, location_type, location, data_source, sep = '|')
  ) %>%
  arrange(date) %>%
  rename(
    total_cases = positive,
    total_deaths = death,
    total_tests = total
  ) %>%
  mutate(
    percent_positive_cases = total_cases / (total_cases + negative),
    tests_with_results = negative + total_cases,
    case_fatality_rate = total_deaths / total_cases
  )

state_name_mappings_info = tibble(state_name = state.name, state_abbr = state.abb) %>%
  left_join(
    state_geo_center, by = c('state_abbr')
  ) %>%
  rename(
    fips = STATEFP
  ) %>%
  select(
    state_name, state_abbr, fips, latitude = lat, longitude = long
  )

us_states_covid_data = read_csv('http://covidtracking.com/api/states/daily.csv') %>%
  mutate(
    date = as.Date(as.character(date), format = '%Y%m%d'),
    location_type = 'US State',
    country = 'United States',
    data_source = 'covidtracking.com'
  ) %>%
  rename(
    total_cases = positive,
    total_deaths = death,
    total_tests = total,
    location = state
  ) %>%
  mutate(
    percent_positive_cases = total_cases / (total_cases + negative),
    tests_with_results = negative + total_cases,
    case_fatality_rate = total_deaths / total_cases
  ) %>%
  left_join(
    state_name_mappings_info, by = c('location' = 'state_abbr')
  ) %>%
  rename(
    state = state_name
  ) %>%
  mutate(
    location_key = paste(country, state, location_type, location, data_source, sep = '|')
  ) %>%
  arrange(location_key, date)

#### county data ####
nyt_county_data = read_csv('https://raw.githubusercontent.com/nytimes/covid-19-data/master/us-counties.csv') %>%
  arrange(county, state, fips, date) %>%
  rename(
    location = county,
    total_cases = cases,
    total_deaths = deaths
  ) %>%
  mutate(
    total_tests = total_cases,
    tests_with_results = total_cases,
    location_type = 'County',
    country = 'United States',
    data_source = 'NYT',
    location_key = paste(country, state, location_type, location, data_source, sep = '|')
  ) %>%
  arrange(location_key, date)
nyt_county_data[nyt_county_data$location == 'New York City','fips'] = '36061'

all_covid_data_stacked = bind_rows(
  us_states_covid_data,
  nyt_county_data,
  jh_summary_by_country
) %>%
  arrange(location_key, date) %>%
  select(-percent_positive_cases, -case_fatality_rate) %>%
  pivot_longer(cols = c('total_cases', 'total_deaths', 'total_tests',
                        'tests_with_results'),
               names_to = c('measure'), values_to = 'value') %>%
  data.table()

# compute first differences, pct changes, etc. by state
all_covid_data_diffs =
  all_covid_data_stacked[, {
    # the_dat = filter(all_covid_data_stacked, location_key == 'United States|Alaska|County|Kodiak Island Borough|NYT',
    # measure=='total_cases')
    # attach(the_dat)
    # detach(the_dat)
    # cat("\nkey ==",.BY[[1]],"\n\n")
    # cat("\nmeasure ==",.BY[[2]],"\n\n")

    lag_value = lag(value, 1)
    diff_value = value - lag_value
    pct_change_value = diff_value / lag_value

    cum_diff_value = value - lag_value
    cum_diff_value[is.na(cum_diff_value)] = value[1]

    lag_4_value = lag(value, 4)
    lag_5_value = lag(value, 5)
    lag_6_value = lag(value, 6)

    cum_lag_4_diff_value = lag(cum_diff_value, 4)
    cum_lag_5_diff_value = lag(cum_diff_value, 5)
    cum_lag_6_diff_value = lag(cum_diff_value, 6)

    if (length(value) < 2) {
      value_avg_3 = as.numeric(NA)
      diff_value_avg_3 = as.numeric(NA)
    } else {
      value_avg_3 = c(rep(NA, 2), roll_mean(value, 3))
      diff_value_avg_3 = c(rep(NA, 2), roll_mean(diff_value, 3))
    }

    list(
      time = as.integer(date - min(date)),
      date = date,
      value = value,
      lag_value = lag_value,
      diff_value = diff_value,
      pct_change_value = pct_change_value,
      value_avg_3 = value_avg_3,
      diff_value_avg_3 = diff_value_avg_3,
      lag_4_value = lag_4_value,
      lag_5_value = lag_5_value,
      lag_6_value = lag_6_value,
      cum_diff_value = cum_diff_value,
      cum_lag_4_diff_value = cum_lag_4_diff_value,
      cum_lag_5_diff_value = cum_lag_5_diff_value,
      cum_lag_6_diff_value = cum_lag_6_diff_value,
      first_value = date[date == min(date)],
      last_value = date[date == max(date)],
      value_past_100 = min(date[value >= 100])
    )

  }, by = list(location_key, measure)] %>%
  pivot_wider(
    id_cols = c('location_key', 'date'),
    names_from = 'measure',
    values_from = c('value', 'lag_value', 'diff_value',
                    'pct_change_value', 'lag_4_value', 'lag_5_value',
                    'lag_6_value', 'value_avg_3', 'diff_value_avg_3',
                    'cum_lag_4_diff_value', 'cum_lag_5_diff_value',
                    'cum_lag_6_diff_value', 'cum_diff_value')
  )

id_cols = dplyr::select(all_covid_data_stacked, location_key,
                        location, location_type, fips, state, country, data_source, latitude, longitude) %>% unique()

# add on population #
all_covid_data_diffs_clean =
  all_covid_data_diffs %>%
  left_join(
    id_cols
  ) %>%
  left_join(
    select(population_by_state, state_name, state_pop = value), by = c('state' = 'state_name')
  ) %>%
  mutate(
    country = recode(country, `Korea, South` = "South Korea")
  ) %>%
  left_join(
    latest_country_pop %>% select(-year, country_pop = population),
    by = c('country')
  ) %>%
  left_join(
    county_pops_sub
  ) %>%
  mutate(
    population = coalesce(county_pop, state_pop, country_pop),
    pop_100k = population / 1e5
  )

### get timing of when the 20th case occurred ###
case_dates = group_by(all_covid_data_diffs_clean, location_key) %>%
  summarize(
    date_case_20 = min(date[value_total_cases >= 20]),
    date_case_100 = min(date[value_total_cases >= 100])
  )

covid_data_diffs_excl_county = filter(all_covid_data_diffs_clean, location_type != 'County') %>% data.table()

### one more set of by-state computations, to get r0 and other stats ###

effective_r0_dat = covid_data_diffs_excl_county[, {
  # ny = filter(covid_data_diffs_excl_county, location == 'NY')
# attach(ny)

  # the_dat = filter(all_covid_data_diffs_dt, location_key == 'United States|Alaska|County|Nome Census Area|NYT')

  cat("\nkey ==",.BY[[1]],"\n\n")
  # cat("\nmeasure ==",.BY[[2]],"\n\n")

  cum_diff_value_total_cases[value_total_cases == 0] = NA

  # what is the r0 of cases on a rolling 6 day basis? This uses the last six days, computes r0, and then pushes the computations
  # forward six days to show the r0 of the cases themselves
  new_cases_zoo = zoo(cum_diff_value_total_cases, 1:length(cum_diff_value_total_cases))
  r0_rolling = rep(NA, length(new_cases_zoo)) %>% as.numeric()
  if (length(r0_rolling)>= r0_window_size) {
    tryCatch({
      r0_rolling = c(rep(NA, r0_window_size-1), rollapply(new_cases_zoo %>% na.approx(new_cases_zoo, na.rm = F), r0_window_size, est_r0_window)) %>%
        lead(r0_window_size) %>% as.numeric()
    }, error = function(e){
      print( e)

    })

  }

  # Median is 5.1 days, mean is 6.4 days
  # https://annals.org/aim/fullarticle/2762808/incubation-period-coronavirus-disease-2019-covid-19-from-publicly-reported
  # https://www.ncbi.nlm.nih.gov/pmc/articles/PMC7014672/
  effective_r0 = cum_diff_value_total_cases / cum_lag_6_diff_value_total_cases
  #
  # # there are NAs because of the lags, there are infinite values because of missing data
  effective_r0_nas = ifelse(is.infinite(effective_r0) | effective_r0 == 0, NA, effective_r0) %>% as.numeric()
  #
  # # interpolate the cases
  effective_r0_interpolated = zoo(effective_r0_nas, 1:length(effective_r0_nas)) %>% na.approx(na.rm = F) %>% as.numeric()
  #
  # # there are data integrity issues. Limit max r0 to 20 and min to 0
  effective_r0_interpolated = pmin(effective_r0_interpolated, 20)
  effective_r0_interpolated = pmax(effective_r0_interpolated, 0)

  # this needs to be pushed back to where the cases originated
  effective_r0_interpolated_lead = lead(effective_r0_interpolated, 6)

  # get rolling average positive tests for last seven days
  percent_positive_new_tests = cum_diff_value_total_cases / cum_diff_value_tests_with_results

  if (length(cum_diff_value_tests_with_results) < 6) {
    rolling3_tests_with_results = rep(NA, length(cum_diff_value_tests_with_results)) %>% as.numeric()
    rolling7_tests_with_results = rep(NA, length(cum_diff_value_tests_with_results)) %>% as.numeric()
    rolling3_new_cases = rep(NA, length(cum_diff_value_tests_with_results)) %>% as.numeric()

    rolling3_percent_positive_new_tests = rep(NA, length(cum_diff_value_tests_with_results)) %>% as.numeric()
    rolling7_percent_positive_new_tests = rep(NA, length(cum_diff_value_tests_with_results)) %>% as.numeric()
    delta_roll_3_7 = rolling3_percent_positive_new_tests - rolling7_percent_positive_new_tests
    r0_rolling_lead_7 = rep(NA, length(cum_diff_value_tests_with_results)) %>% as.numeric()
    effective_r0_interpolated_lead_7 = rep(NA, length(cum_diff_value_tests_with_results)) %>% as.numeric()
  } else {
    rolling3_tests_with_results = c(rep(NA, 2), roll_mean(cum_diff_value_tests_with_results, 3))
    rolling7_tests_with_results = c(rep(NA, 6), roll_mean(cum_diff_value_tests_with_results, 7))
    rolling3_new_cases = c(rep(NA, 2), roll_mean(cum_diff_value_total_cases, 3))

    rolling3_percent_positive_new_tests = c(rep(NA, 2), roll_mean(percent_positive_new_tests, 3))
    rolling7_percent_positive_new_tests = c(rep(NA, 6), roll_mean(percent_positive_new_tests, 7))
    delta_roll_3_7 = rolling3_percent_positive_new_tests - rolling7_percent_positive_new_tests
    r0_rolling_lead_7 = lead(r0_rolling, 7)
    effective_r0_interpolated_lead_7 = lead(effective_r0_interpolated, 7)
  }

  lag_percent_positive_new_tests = lag(percent_positive_new_tests, 1)
  delta_percent_positive_new_tests = percent_positive_new_tests - lag_percent_positive_new_tests

  # limit R0 to 30 max and 0 min
  r0_rolling_lead_7 = pmin(r0_rolling_lead_7, 30)
  r0_rolling_lead_7 = pmax(r0_rolling_lead_7, 0)

  list(
    date = date,
    effective_r0_interpolated = effective_r0_interpolated_lead,
    effective_r0_interpolated_lead_7 = effective_r0_interpolated_lead_7,
    r0_rolling = r0_rolling,
    r0_rolling_lead_7 = r0_rolling_lead_7,
    percent_positive_new_tests = percent_positive_new_tests,
    lag_percent_positive_new_tests = lag_percent_positive_new_tests,
    delta_percent_positive_new_tests = delta_percent_positive_new_tests,
    rolling3_new_cases = rolling3_new_cases,
    rolling3_tests_with_results = rolling3_tests_with_results,
    rolling7_tests_with_results = rolling7_tests_with_results,
    rolling3_percent_positive_new_tests = rolling3_percent_positive_new_tests,
    rolling7_percent_positive_new_tests = rolling7_percent_positive_new_tests,
    delta_roll_3_7_percent_positive_new_tests = delta_roll_3_7
  )
}, by = list(location_key, location)]

covid_cases_mobility_stringency = fread('data/covid_cases_mobility_stringency.csv') %>%
  mutate(
    date = as.Date(date),
    country = country_name.x,
    country = recode(country, `Korea, South` = "South Korea"),
    state = as.character(NA),
    location = entity_name,
    location_type = ifelse(country == location, 'country', 'County')
  ) %>%
  select(
    date, country, location, location_type, StringencyIndex, mobility, predicted_walking_baseline,
    mean_temp,
    percent_of_predicted, smoothed_percent_of_predicted, fips
  )

fips_by_area = group_by(covid_cases_mobility_stringency, location) %>%
  summarize(
    fips = fips[!is.na(fips)][1] %>% as.character()
  )

covid_cases_mobility_stringency_fin = left_join(covid_cases_mobility_stringency %>% select(-fips), fips_by_area)

# final, clean dataset with all sorts of calculations complete #
all_covid_data_diffs_dates = left_join(all_covid_data_diffs_clean, case_dates) %>%
  left_join(effective_r0_dat) %>%
  mutate(
    location = recode(location, `Korea, South` = "South Korea"),
    # country = recode(country, `Korea, South` = "South Korea"),
    location = ifelse(location_type == 'US State', state, location)
  ) %>%
  full_join(covid_cases_mobility_stringency_fin, by = c('date', 'location', 'location_type', 'country')) %>%
  mutate(location_type = recode(location_type, `country` = 'Country')) %>%
  left_join(lockdown_dates_fin %>% select(location, country, lockdown_start, lockdown_end, location_type),
            by = c('location', 'location_type', 'country')) %>%
  mutate(
    days_since_lockdown_start = as.numeric(date - lockdown_start),
    lockdown_period = ifelse(is.na(lockdown_start), 'No Lockdown', ifelse(days_since_lockdown_start < 0, 'Pre-Lockdown', 'Post-Lockdown')) %>%
      factor() %>% relevel(ref = 'Pre-Lockdown'),
    days_since_case_20 = as.numeric(date - date_case_20),
    days_since_case_100 = as.numeric(date - date_case_100),
    new_tests_per_100k = cum_diff_value_total_tests / pop_100k,
    tests_per_100k = value_total_tests / pop_100k,
    cases_per_100k = value_total_cases / pop_100k,
    new_cases_per_100k = cum_diff_value_total_cases / pop_100k,
    deaths_per_100k = value_total_deaths / pop_100k,
    diff_value_avg_3_total_tests_per_100k = diff_value_avg_3_total_tests / pop_100k,
    week_day = lubridate::wday(date),
    weekend_ind = ifelse(week_day %in% c(7, 1), 'Weekend', "Week Day"),
  ) %>%
  arrange(location, date) %>%
  select(-fips.y) %>%
  rename(
    fips = fips.x
  )

write.csv(all_covid_data_diffs_dates, 'data/countries_states_county_covid_calcs.csv', row.names = F)


#' Stan DDM Example Data
#'
#'A small example data set which has been simulated. First the parameters with with
#'the function \code{\link{makeFakeParams}}, then, the data itself with the function
#'\code{\link{simulDat}}. It contains 10 simulated subjects with 10 'trials' each.
#'Use this data to test a new model or in general, the packages' functionalities.
#'
#' @docType data
#'
#' @usage StanDDM::example_data
#'
#' @format An object of class \code{data frame}.
#'
#' @keywords datasets
#'
#'
"example_data"