#!/usr/bin/env Rscript

# force usage of conda R environment
.libPaths(R.home("library"))
## Command line script for generating individual expression context figures
##
##
## Manual
## ------
##
## In command line type:
## Rscript --vanilla parse_rna_tcga_pat_data.r <TCGA_normalized> <sample_normalized> <out>
##
##  <TCGA_normalized>   - the TCGA reference cohort normalized count data
##  <sample_normalized> - the RSEM normalized sample counts
##  <out> 		- name of the out file
###############################################################################

## Retrieve command line arguments (all character)
args <- commandArgs(trailingOnly = TRUE)

## Read command line input.
TCGA <- read.table(args[1], stringsAsFactor=F, header=T, row.names=1)
sample <- read.table(args[2],stringsAsFactor=F, header=T)
out <- args[3]

## Initialize the result table.
data <-c("gene", "lower_whisker","lower_quartile", "median","upper_quartile","higher_whisker","patient_sample","normalized_expression","normalized_expression_text", "percentile")
## Start looping through the patients data.
print(length(sample[,1]))
for (i in 1:length(sample[,1])){

	## Read in the current gene, the patients value and the cohort values.
    gene<-sample[i,1]
	name<-(strsplit(gene, split="\\|")[[1]][1])
	pat<- c(sample[i,2])
	cohort <- t(TCGA[name,])
	## Calculate the percentile corresponding to the patient values.
	quant <- quantile(cohort,probs = seq(0, 1, by= 0.01), na.rm=TRUE)
	percentile<- max(1, which(pat >=quant))-1
	if (is.null(pat) & all(is.null(quant))){percentile <- "NA"}
	if (is.null(pat) & quant[1]>0){percentile <- "1"}
	if (!is.null(pat) & all(is.null(quant))){percentile <- "100"}
	## Calculate in which part of a boxplot the patient value would be located.
	## 	0=Below lower whisker, 1=Within lower whisker, 2=Within lower part of box.
	## 	3=Within upper part of box, 4=Within upper whisker, 5=Above upper whisker.
	stats <- boxplot(cohort, horizontal = T, plot =F)$stats
	pat.location <- max(0, which(pat >stats))
	if (pat.location == 0){
	text <- "under_expression"}
	else if (pat.location == 1){
	text <- "low_expression"}
	else if (pat.location == 4){
        text <- "high_expression"}
	else if (pat.location == 5){
        text <- "over_expression"}
	else if (pat.location == 2 | pat.location == 3){
	text <- "normal"}
	else {
	print("Patient value does not fall in any expected range")}
	## Append results to rest of data.
	data<-rbind(data, c(as.vector(name),as.vector(stats),pat, as.vector(pat.location),as.vector(text),as.vector(percentile)))
	}

## Define the first row as new header & then delete the first row.
colnames(data) = data[1, ]
data = data[-1, ]

## Write the results.
write.table(data, file=out,sep="\t",quote=FALSE,row.names=FALSE)


library(deconstructSigs)
mut=read.delim('MUTCOUNTIN',sep=',',header=FALSE,check.names=FALSE) #C:\\Users\\tuf78332\\Desktop\\mutational-signature\\PhyloSig\\Example\\E.csv
colnames(mut) <- c('Type','Count')
Pro=mut$Count/sum(mut$Count)
mut0=cbind(mut,Pro)
row.names(mut0)=mut0$Type
signaturesCOSMIC=read.delim('SIGIN',sep=',')  #C:\\Users\\tuf78332\\Desktop\\mutational-signature\\PhyloSig\\PhyloSig1\\cosmicSig.csv
row.names(signaturesCOSMIC)=signaturesCOSMIC$X
drops <- c("X")
signaturesCOSMIC=signaturesCOSMIC[ , !(names(signaturesCOSMIC) %in% drops)]
order = match(row.names(mut0), row.names(signaturesCOSMIC))
signaturesCOSMIC=signaturesCOSMIC[,c('SIGLS')]
cancer_signatures = signaturesCOSMIC[order,]
cancer_signatures=data.matrix(cancer_signatures, rownames.force = NA)
mut1=data.frame(mut0$Pro)
MutProT=t(mut0$Pro)
colnames(MutProT) <-mut0$Type
rownames(MutProT) <- c('A')
B=data.frame(MutProT,check.names=FALSE)
cancer_signaturesT=t(cancer_signatures)
cancer_signaturesT=t(cancer_signatures)
SigForm=as.matrix(cancer_signaturesT)
SigForm1=data.frame(SigForm,check.names=FALSE)
test = whichSignatures(tumor.ref = B,sample.id = "A",signatures.ref = SigForm1, signature.cutoff = 0.001,contexts.needed = FALSE)
dSig=t(test$weights)
write.table(dSig,'Expo.out')


library(devtools)
library(doMC)
library(iotools)
library(xts)
library(devtools)
library(doMC)
#registerDoMC(cores=16)
#registerDoMC(cores=10)

document("..")
col_types=c(rep("character",3), rep("numeric", 3), rep("character", 2))

x = dstrsplit(readAsRaw(
 "/Users/mike/projects/jackson_lecture/may_trades/taq_20100506_trades_all.csv"),
 sep=",", skip=1, col_types=col_types)

names(x) = c("symbol", "date", "time", "price", "size", "corr", "cond", "ex")

# Remove bunk trades.
x = na.omit(x[!(x$cond %in% c("L", "N", "O", "Z", "P")),1:5])
x = x[x$size > 0,]

sym_split = split(1:nrow(x), x$symbol)
x$time_stamp = paste(x$date, x$time)
x$date_time=strptime(x$time_stamp, format="%Y%m%d %H:%M:%S", tz=Sys.timezone())

data(sp)
x = x[x$symbol %in% sp$symbol,]

on="minutes"
k=30

sym_split = split(1:nrow(x), x$symbol)
# Create the consolidated trade data.
cat("Consolidating trade data\n")
taq = foreach (sym = sp$symbol, .combine=rbind, .inorder=FALSE) %dopar% {
  registerDoSEQ()
  d = x[sym_split[[sym]],]
  ret = NULL
  if (nrow(d) > 0) {
    ret = as.data.frame(consolidate_prices(d$date, d$time, d$price, d$size,
                             time_format="%H:%M:%S", date_format="%Y%m%d",
                             on=on, k=k))
    ret$symbol = sym
  }
  ret
}

taq$date_time = strptime(rownames(taq), "%Y-%m-%d %H:%M:%S")
# Create the xts matrix of stock values.
sym_split = split(1:nrow(x), x$symbol)
prices = foreach(sym_inds=sym_split, .combine=cbind) %dopar% {
  xs = x[sym_inds,]
  xst = xts(xs$price, order.by=xs$date_time)
  xts(xs$price, order.by=xs$date_time)
}

colnames(prices) = names(sym_split)
# Carry prices forward for each column.
cat("Carrying prices forward.\n")
prices = carry_prices_forward(prices)
prices = na.omit(prices)

# Make sure that we are dealing with the right resolution after combining.
prices = period.apply(prices, endpoints(prices, on=on, k=k),
  function(ps) {
    xts(matrix(apply(as.matrix(ps), 2, mean, na.rm=TRUE), nrow=1),
        order.by=time(ps[1]))
  })

# x is a data frame with a price, size, and symbol column.
clean_and_normalize_transactions = function(x, on="minutes", k=1) {
  sp_split = split(1:nrow(x), x$symbol)
  x = foreach(inds=sp_split, .combine=cbind) %dopar% {
    xts(cbind(x$price[inds], x$size[inds]), order.by=x$date_time[inds])
  }
  psp = matrix(1:ncol(x), ncol=2, byrow=TRUE)
  # The following is a hog and it needs to be better. Should vwap return an
  # xts object or would it be better as a data frame?
  x = foreach(i = 1:nrow(psp), .combine=cbind) %dopar% {
    vwap(as.vector(x[,psp[i, 1]]), as.vector(x[,psp[i,2]]),
         time(x), on=on, k=k)
  }
  x = foreach(j=1:ncol(x), .combine=cbind) %dopar% {
    carry_price_forward(x[,j])
  }
  colnames(x) = names(sp_split)
  x
}

sp_trades = clean_and_normalize_transactions(x, on="seconds", k=1)
document("..")
foreach(it = volume_window_gen(time(x)), .combine=rbind) %dopar% {
  ci = cointegration_info(x[it,])
  c(ci$p_value, ci$p_stat)
}


#devtools::test("asremlPlus")
context("prediction_presentation")

cat("#### Test for Intercept prediction on Oats with asreml4\n")
test_that("predict_Intercept4", {
  skip_if_not_installed("asreml")
  skip_on_cran()
  library(asreml)
  library(asremlPlus)
  library(dae)
  data(Oats.dat)

  m1.asr <- asreml(Yield ~ Nitrogen*Variety,
                   random=~Blocks/Wplots,
                   data=Oats.dat)
  testthat::expect_equal(length(m1.asr$vparameters),3)
  current.asrt <- as.asrtests(m1.asr)

  #Test for Intercept predict
  Int.pred <- predict(m1.asr, classify="(Intercept)")$pvals
  testthat::expect_equal(nrow(Int.pred), 1)
  testthat::expect_true(abs( Int.pred$predicted.value - 103.9722) < 1e-04)
  Int.diffs <- predictPlus(m1.asr, classify="(Intercept)")
  testthat::expect_equal(length(Int.diffs),7)
  testthat::expect_equal(nrow(Int.diffs$predictions), 1)
  testthat::expect_true(abs( Int.diffs$predictions$predicted.value - 103.9722) < 1e-04)

  xtitl <- "Overall mean"
  names(xtitl) <- "Intercept"
  testthat::expect_silent(plotPredictions(classify="(Intercept)", y = "predicted.value",
                  data = Int.diffs$predictions,
                  y.title = "Yield", titles = xtitl,
                  error.intervals = "Conf"))
})

cat("#### Test for predictPlus.asreml4\n")
test_that("predictPlus.asreml4", {
  skip_if_not_installed("asreml")
  skip_on_cran()
  library(asreml)
  library(asremlPlus)
  library(dae)
  data(WaterRunoff.dat)
  asreml.options(keep.order = TRUE) #required for asreml4 only
  testthat::expect_warning(current.asr <- asreml(fixed = pH ~ Benches + (Sources * (Type + Species)),
                                                 random = ~ Benches:MainPlots,
                                                 data= WaterRunoff.dat))
  testthat::expect_silent(current.asrt <- as.asrtests(current.asr, NULL, NULL))
  testthat::expect_silent(diffs <- predictPlus(classify = "Sources:Type",
                                               asreml.obj = current.asr, tables = "none",
                                               wald.tab = current.asrt$wald.tab,
                                               present = c("Type","Species","Sources")))
  testthat::expect_is(diffs, "alldiffs")

  #### Get the observed combinations of the factors and variables in classify
  class.facs <- c("Species","Date","xDay")
  levs <- as.data.frame(table(WaterRunoff.dat[class.facs]))
  levs <- levs[do.call(order, levs), ]
  levs <- as.list(levs[levs$Freq != 0, class.facs])
  levs$xDay <- as.numfac(levs$xDay)

  current.asr <- asreml(fixed = log.Turbidity ~ Benches + Sources + Type + Species +
                          Sources:Type + Sources:Species +
                          Sources:xDay + Species:xDay + Species:Date,
                        data = WaterRunoff.dat)
  current.asrt <- as.asrtests(current.asr, NULL, NULL)

  diffs.p <- predictPlus(asreml.obj = current.asr,
                         classify="Species:Date:xDay",
                         term = "Species:Date",
                         parallel = TRUE, levels=levs,
                         present=c("Type","Species","Sources"),
                         x.num = "xDay", x.fac = "Date",
                         x.plot.values=c(0,28,56,84), tables = "none",
                         wald.tab = current.asrt$wald.tab)

  testthat::expect_is(diffs.p, "alldiffs")

})

cat("#### Test for plotPredictions.asreml4\n")
test_that("plotPredictions.asreml4", {
  skip_if_not_installed("asreml")
  skip_on_cran()
  library(asreml)
  library(asremlPlus)
  library(ggplot2)
  library(dae)
  data(WaterRunoff.dat)
  #### Get the observed combinations of the factors and variables in classify
  class.facs <- c("Species","Date","xDay")
  levs <- as.data.frame(table(WaterRunoff.dat[class.facs]))
  levs <- levs[do.call(order, levs), ]
  levs <- as.list(levs[levs$Freq != 0, class.facs])
  levs$xDay <- as.numfac(levs$xDay)

  asreml.options(keep.order = TRUE) #required for asreml4 only
  current.asr <- asreml(fixed = log.Turbidity ~ Benches + Sources + Type + Species +
                          Sources:Type + Sources:Species +
                          Sources:xDay + Species:xDay + Species:Date,
                        data = WaterRunoff.dat)
  current.asrt <- as.asrtests(current.asr, NULL, NULL)
  predictions <- predict(current.asr, class="Species:Date:xDay",
                         parallel = TRUE, levels = levs,
                         present = c("Type","Species","Sources"))$pvals
  predictions <- predictions[predictions$status == "Estimable",]

  x.title <- "Days since first observation"
  names(x.title) <- "xDay"
  #Get predictions without specifying levels
  plotPredictions(classify="Species:Date:xDay", y = "predicted.value",
                  data = predictions, wald.tab = current.asrt$wald.tab,
                  x.num = "xDay", x.fac = "Date",
                  titles = x.title,
                  y.title = "Predicted log(Turbidity)",
                  present = c("Type","Species","Sources"),
                  error.intervals = "none",
                  ggplotFuncs = list(ggtitle("Transformed turbidity over time")))

  #Specify the levs and parallel = TRUE
  diffs <- predictPlus(asreml.obj = current.asr,
                       classify="Species:Date:xDay",
                       term = "Species:Date",
                       present=c("Type","Species","Sources"),
                       x.num = "xDay", x.fac = "Date",
                       parallel = TRUE, levels = levs,
                       x.plot.values=c(0,28,56,84),
                       wald.tab = current.asrt$wald.tab)
  plotPredictions(classify="Species:Date:xDay", y = "predicted.value",
                  data = diffs$predictions, wald.tab = current.asrt$wald.tab,
                  x.num = "xDay", x.fac = "Date",
                  titles = x.title,
                  y.title = "Predicted log(Turbidity)")
  testthat::expect_silent("dummy")
})

cat("#### Test for predictPresent.asreml4\n")
test_that("predictPresent.asreml4", {
  skip_if_not_installed("asreml")
  skip_on_cran()
  library(dae)
  library(asreml)
  library(asremlPlus)
  data(WaterRunoff.dat)
  #### Get the observed combinations of the factors and variables in classify
  class.facs <- c("Species","Date","xDay")
  levs <- as.data.frame(table(WaterRunoff.dat[class.facs]))
  levs <- levs[do.call(order, levs), ]
  levs <- as.list(levs[levs$Freq != 0, class.facs])
  levs$xDay <- as.numfac(levs$xDay)

  titles <- list("Days since first observation", "Days since first observation", "pH", "Turbidity (NTU)")
  names(titles) <- names(WaterRunoff.dat)[c(5,7,11:12)]
  asreml.options(keep.order = TRUE) #required for asreml4 only
  current.asr <- asreml(fixed = log.Turbidity ~ Benches + Sources + Type + Species +
                          Sources:Type + Sources:Species + Sources:Species:xDay +
                          Sources:Species:Date,
                        data = WaterRunoff.dat)
  current.asrt <- as.asrtests(current.asr, NULL, NULL)
  #Example that fails because Date has levels that are not numeric in nature
  testthat::expect_error(diff.list <- predictPresent(terms = "Date:Sources:Species",
                                                     asreml.obj = current.asrt$asreml.obj,
                                                     wald.tab = current.asrt$wald.tab,
                                                     x.fac = "Date",
                                                     plots = "predictions",
                                                     error.intervals = "StandardError",
                                                     titles = titles,
                                                     transform.power = 0,
                                                     present = c("Type","Species","Sources"),
                                                     tables = "differences",
                                                     level.length = 6))
  #Example that does not produce predictions because has Date but not xDay
  testthat::expect_error(diff.list <- predictPresent(terms = "Date:Sources:Species",
                                                     asreml.obj = current.asrt$asreml.obj,
                                                     wald.tab = current.asrt$wald.tab,
                                                     plots = "predictions",
                                                     error.intervals = "StandardError",
                                                     titles = titles,
                                                     transform.power = 0,
                                                     present = c("Type","Species","Sources","Date"),
                                                     tables = "differences",
                                                     level.length = 6))

  #### Get the observed combinations of the factors and variables in classify
  class.facs <- c("Sources","Species","Date","xDay")
  levs <- as.data.frame(table(WaterRunoff.dat[class.facs]))
  levs <- levs[do.call(order, levs), ]
  levs <- as.list(levs[levs$Freq != 0, class.facs])
  levs$xDay <- as.numfac(levs$xDay)

  # parallel and levels are arguments from predict.asreml
  diff.list <- predictPresent.asreml(asreml.obj = current.asrt$asreml.obj,
                                     terms = "Date:Sources:Species:xDay",
                                     x.num = "xDay", x.fac = "Date",
                                     parallel = TRUE, levels = levs,
                                     wald.tab = current.asrt$wald.tab,
                                     plots = "predictions",
                                     error.intervals = "StandardError",
                                     titles = titles,
                                     transform.power = 0,
                                     present = c("Type","Species","Sources"),
                                     tables = "none",
                                     level.length = 6)
  testthat::expect_equal(length(diff.list), 1)
  testthat::expect_match(names(diff.list), "Date.Sources.Species.xDay")

  # test that backtransforms have halfLSD intervals
  diff.list <- predictPresent.asreml(asreml.obj = current.asrt$asreml.obj,
                                     terms = "Date:Sources:Species:xDay",
                                     x.num = "xDay", x.fac = "Date",
                                     parallel = TRUE, levels = levs,
                                     wald.tab = current.asrt$wald.tab,
                                     plots = "backtransforms",
                                     error.intervals = "halfLeast",
                                     avsed.tolerance = 1,
                                     titles = titles,
                                     transform.power = 0,
                                     present = c("Type","Species","Sources"),
                                     tables = "none",
                                     level.length = 6)
  testthat::expect_equal(length(diff.list), 1)
  testthat::expect_match(names(diff.list), "Date.Sources.Species.xDay")
  testthat::expect_true(all(c("upper.halfLeastSignificant.limit",
                              "lower.halfLeastSignificant.limit") %in%
                              names(diff.list$Date.Sources.Species.xDay$backtransforms)))

  })

#### This test is not relevant to asreml3 because its saving of sed and vcov are different
cat("#### Test for error when no predictions.asreml4\n")
test_that("noPredictions.asreml4", {
  skip_if_not_installed("asreml")
  skip_on_cran()
  library(asreml)
  library(asremlPlus)
  data(gw.dat)
  current.asr <- do.call(asreml,
                         args=list(fixed = y ~ Species*Substrate*Irrigation,
                                   random = ~ Row + Column,
                                   keep.order=TRUE, data = gw.dat,
                                   maxiter=50, workspace = 1e08, stepsize = 0.0001))
  current.asrt <- as.asrtests(current.asr, NULL, NULL)
  current.asrt <- rmboundary(current.asrt)
  testthat::expect_error(diffs <- predictPresent(current.asrt$asreml.obj,
                                                 terms = "Irrigation",
                                                 error.intervals = "Conf",
                                                 wald.tab = current.asrt$wald.tab,
                                                 tables = "none")[[1]],
                         regexp = "predict.asreml has not returned the sed component for the predictions as requested",
                         fixed = TRUE)

  testthat::expect_error(diffs <- predictPresent(current.asrt$asreml.obj,
                                                 terms = "Irrigation",
                                                 linear.transformation = ~ Irrigation,
                                                 error.intervals = "Conf",
                                                 wald.tab = current.asrt$wald.tab,
                                                 tables = "none")[[1]],
                         regexp = "predict.asreml has not returned the variance matrix of the predictions as requested",
                         fixed = TRUE)
})

cat("#### Test for plotPvalues.asreml4\n")
test_that("plotPvalues.asreml4", {
  skip_if_not_installed("asreml")
  skip_on_cran()
  library(asreml)
  library(asremlPlus)
  library(dae)
  library(reshape)
  data(WaterRunoff.dat)
  asreml.options(keep.order = TRUE) #required for asreml4 only
  testthat::expect_output(current.asr <- asreml(fixed = pH ~ Benches + (Sources * (Type + Species)),
                                                random = ~ Benches:MainPlots,
                                                data= WaterRunoff.dat))
  current.asrt <- as.asrtests(current.asr, NULL, NULL)
  diffs <- predictPlus.asreml(classify = "Sources:Type",
                              asreml.obj = current.asr, tables = "none",
                              wald.tab = current.asrt$wald.tab,
                              present = c("Type","Species","Sources"))
  testthat::expect_is(diffs, "alldiffs")

  p <- diffs$p.differences
  rownames(p) <- colnames(p) <- NULL
  p <- within(reshape::melt(p),
              {
                X1 <- factor(X1, labels=dimnames(diffs$p.differences)[[1]])
                X2 <- factor(X2, labels=levels(X1))
              })
  names(p)[match("value", names(p))] <- "p"
  testthat::expect_silent(plotPvalues(p, x = "X1", y = "X2",
                                      gridspacing = rep(c(3,4), c(4,2)),
                                      show.sig = TRUE))

  #Test different size, face and colour
  testthat::expect_silent(plotPvalues(p, x = "X1", y = "X2",
                                      gridspacing = rep(c(3,4), c(4,2)),
                                      show.sig = TRUE, sig.size = 5, sig.colour = "blue"))
  testthat::expect_silent(plotPvalues(p, x = "X1", y = "X2",
                                      gridspacing = rep(c(3,4), c(4,2)),
                                      show.sig = TRUE, sig.size = 5, sig.face = "bold",
                                      sig.family = "serif"))

  #Plot with sections
  pdata <- plotPvalues(diffs, sections = "Sources", show.sig = TRUE)
  testthat::expect_equal(nrow(pdata), 400)
  testthat::expect_equal(ncol(pdata), 5)
  testthat::expect_true(all(c("X1","X2","p","sections1","sections2") %in% names(pdata)))

  #Plot without sections, but automatic gridspacing
  pupdata <- plotPvalues(diffs, show.sig = TRUE, factors.per.grid = 1)
  testthat::expect_equal(nrow(pupdata), 400)
  testthat::expect_equal(ncol(pupdata), 3)
  testthat::expect_true(all(c("X1","X2","p") %in% names(pupdata)))
  testthat::expect_equal(sum(!is.na(pupdata$p)), 380)

  #Plot without sections, but automatic gridspacing and upper triangle
  pupdata <- plotPvalues(diffs, show.sig = TRUE, factors.per.grid = 1,
                         triangles = "upper")
  testthat::expect_equal(nrow(pupdata), 400)
  testthat::expect_equal(ncol(pupdata), 3)
  testthat::expect_true(all(c("X1","X2","p") %in% names(pupdata)))
  testthat::expect_equal(sum(!is.na(pupdata$p)), 190)

  #Plot without sections, but manual gridspacing and upper triangle
  pupdata <- plotPvalues(diffs, show.sig = TRUE, gridspacing = rep(c(3,4), c(4,2)),
                         triangles = "upper")
  testthat::expect_equal(nrow(pupdata), 400)
  testthat::expect_equal(ncol(pupdata), 3)
  testthat::expect_true(all(c("X1","X2","p") %in% names(pupdata)))
  testthat::expect_equal(sum(!is.na(pupdata$p)), 190)

  #Plot without sections, but manual gridspacing and lower triangle
  pupdata <- plotPvalues(diffs, sections = "Sources", show.sig = TRUE, triangles = "upper")
  pupdata <- na.omit(pupdata)
  testthat::expect_equal(nrow(pupdata), 190)
  testthat::expect_equal(ncol(pupdata), 5)
  testthat::expect_true(all(c("X1","X2","p","sections1","sections2") %in% names(pupdata)))
})

cat("#### Test for plotPvalues.asreml4\n")
test_that("plotPvalues.asreml4", {
  skip_if_not_installed("asreml")
  skip_on_cran()
  library(asreml)
  library(asremlPlus)
  library(dae)
  LeafSucculence.diff <- readRDS("./data/LeafSucculence.diff")
  LeafSucculence.diff <- LeafSucculence.diff[[1]]

  pdata <- plotPvalues(LeafSucculence.diff, gridspacing = 3, show.sig = TRUE,
                       axis.labels = TRUE)
  testthat::expect_equal(nrow(pdata), 144)
  testthat::expect_equal(ncol(pdata), 3)
  testthat::expect_true(all(c("X1","X2","p") %in% names(pdata)))

  pdata <- plotPvalues(LeafSucculence.diff, factors.per.grid = 2, show.sig = TRUE,
                       axis.labels = TRUE)
  testthat::expect_equal(nrow(pdata), 144)
  testthat::expect_equal(ncol(pdata), 3)
  testthat::expect_true(all(c("X1","X2","p") %in% names(pdata)))

  pdata <- plotPvalues(LeafSucculence.diff, sections = c("Depths","Slope"),
                       show.sig = TRUE, axis.labels = TRUE)
  testthat::expect_equal(nrow(pdata), 144)
  testthat::expect_equal(ncol(pdata), 5)
  testthat::expect_true(all(c("X1","X2","p","sections1","sections2") %in% names(pdata)))

})

cat("#### Test for factor combinations asreml4\n")
test_that("factor.combinations.asreml4", {
  skip_if_not_installed("asreml")
  skip_on_cran()
  library(asreml)
  library(asremlPlus)
  library(dae)
  LeafSucculence.diff <- readRDS("./data/LeafSucculence.diff")
  LeafSucculence.diff <- LeafSucculence.diff[[1]]

  LeafSucculence.diff <- recalcLSD(LeafSucculence.diff, LSDtype = "factor.combinations",
                                   LSDby = "Species")
  testthat::expect_warning(LeafSucculence.diff <- redoErrorIntervals(LeafSucculence.diff,
                                                                    error.intervals = "half"))
  testthat::expect_equal(nrow(LeafSucculence.diff$LSD), 3)
  testthat::expect_equal(ncol(LeafSucculence.diff$LSD), 8)
  testthat::expect_true(all(c("P1","P2","P3") %in% rownames(LeafSucculence.diff$LSD)))
  testthat::expect_false("lower.halfLeastSignificant.limit" %in% names(LeafSucculence.diff$predictions))
  testthat::expect_true(names(LeafSucculence.diff$predictions)[length(names(
    LeafSucculence.diff$predictions))] == "est.status")

})

cat("#### Test for recalcLSD.alldiffs4\n")
test_that("recalcLSD.alldiffs4", {
  skip_if_not_installed("asreml")
  skip_on_cran()
  library(asreml)
  library(asremlPlus)
  library(dae)
  data(WaterRunoff.dat)
  asreml.options(keep.order = TRUE) #required for asreml4 only
  testthat::expect_output(current.asr <- asreml(fixed = pH ~ Benches + (Sources * (Type + Species)),
                                                random = ~ Benches:MainPlots,
                                                data= WaterRunoff.dat))
  current.asrt <- as.asrtests(current.asr, NULL, NULL)
  diffs <- predictPlus.asreml(classify = "Sources:Type",
                              asreml.obj = current.asr, tables = "none",
                              wald.tab = current.asrt$wald.tab,
                              present = c("Type","Species","Sources"))
  testthat::expect_is(diffs, "alldiffs")

  diffs <- recalcLSD.alldiffs(diffs, LSDtype = "factor.combinations", LSDby = "Sources")
  testthat::expect_equal(nrow(diffs$LSD), 6)
  testthat::expect_equal(ncol(diffs$LSD), 8)
  testthat::expect_warning(diffs <- redoErrorIntervals(diffs,
                                                       error.intervals = "halfLeastSignificant"))
  testthat::expect_false("upper.halfLeastSignificant.limit" %in% names(diffs$predictions))

})

cat("#### Test for LSDby4\n")
test_that("LSDby4", {
  skip_if_not_installed("asreml")
  skip_on_cran()
  library(asreml)
  library(asremlPlus)
  library(dae)
  #example 9-1 from Montgomery 5 edn

  #Set up data.frame
  Pressure.lev <- c(10,15,20)
  Speed.lev <- c(100,120,140)
  Nozzle.lev <- c("A", "B", "C")
  Fac3Syrup.dat <- fac.gen(generate=list(Nozzle = Nozzle.lev,
                                         Pressure = Pressure.lev, Speed = Speed.lev),
                           each=2)
  Fac3Syrup.dat <- within(Fac3Syrup.dat,
                          {
                            SpeedPress <- fac.combine(list(Speed,Pressure),
                                                       combine.levels = TRUE)
                            WSpeedPress <- fac.nested(SpeedPress)
                          })
  Fac3Syrup.dat <- data.frame(Test = factor(1:54), Fac3Syrup.dat)
  Fac3Syrup.dat$Loss <- c(-35,-25,-45,-60,-40,15, 110,75,-10,30,80,54,
                          4,5,-40,-30,31,36, 17,24,-65,-58,20,4,
                          55,120,-55,-44,110,44, -23,-5,-64,-62,-20,-31,
                          -39,-35,-55,-67,15,-30, 90,113,-28,-26,110,135,
                          -30,-55,-61,-52,54,4)+70
  Fac3Syrup.dat <- with(Fac3Syrup.dat, Fac3Syrup.dat[order(SpeedPress, WSpeedPress),])
  #Analysis
  interaction.ABC.plot(Loss, Pressure, Speed, Nozzle, data=Fac3Syrup.dat)
  Fac3Syrup.aov <- aov(Loss ~ Nozzle * Pressure * Speed + Error(Test), Fac3Syrup.dat)
  summary(Fac3Syrup.aov)

  m1 <- do.call("asreml",
                args = list(Loss ~ Nozzle * Pressure * Speed,
                            residual = ~idh(SpeedPress):WSpeedPress,
                            data = Fac3Syrup.dat))
  testthat::expect_true(abs(summary(m1)$varcomp$component[2] - 27.5) < 1e-05)
  wald.tab <- wald.asreml(m1, denDF = "numeric")$Wald
  testthat::expect_equal(nrow(wald.tab), 8)
  diffs <- predictPlus(m1, classify = "Nozzle:Pressure:Speed",
                       #linear.transformation = ~(Nozzle + Pressure):Speed,
                       wald.tab = wald.tab,
                       tables = "none")
  testthat::expect_true("upper.Confidence.limit" %in% names(diffs$predictions))
  testthat::expect_true(all(c( "LSDtype", "LSDstatistic") %in% names(attributes(diffs))))
  testthat::expect_true(is.null(attr(diffs, which = "LSDby")))
  testthat::expect_true((attr(diffs, which = "LSDtype") == "overall"))

  #Calculate LSD, but leave as CIs
  diffs.LSD <- recalcLSD(diffs, LSDtype = "factor",
                         LSDby = c("Speed","Pressure"))
  testthat::expect_equal(nrow(diffs.LSD$LSD), 9)
  testthat::expect_true(abs(diffs.LSD$LSD$minLSD[1]- 11.92550) < 1e-05)
  testthat::expect_true(all(abs(diffs.LSD$LSD$minLSD- diffs.LSD$LSD$maxLSD) < 1e-05))
  testthat::expect_true(all(c( "LSDtype", "LSDby", "LSDstatistic") %in% names(attributes(diffs.LSD))))
  testthat::expect_true((attr(diffs.LSD, which = "LSDtype") == "factor.combinations"))
  testthat::expect_true("upper.Confidence.limit" %in% names(diffs$predictions))

  #Convert from CI to LSI
  diffs.LSI <- redoErrorIntervals(diffs.LSD, error.intervals = "half")
  testthat::expect_true("upper.halfLeastSignificant.limit" %in% names(diffs.LSI$predictions))
  testthat::expect_equal(nrow(diffs.LSI$LSD), 9)
  diffs <- redoErrorIntervals(diffs, error.intervals = "half", LSDtype = "factor",
                       LSDby = c("Speed","Pressure"), wald.tab = wald.tab,
                       tables = "none")
  testthat::expect_true("upper.halfLeastSignificant.limit" %in% names(diffs$predictions))
  testthat::expect_equal(nrow(diffs$LSD), 9)
  testthat::expect_true(abs(diffs$LSD$minLSD[1]- 11.92550) < 1e-05)
  testthat::expect_true(all(abs(diffs$LSD$minLSD- diffs$LSD$maxLSD) < 1e-05))

  #Test changing the LSDby
  testthat::expect_warning(diff.Press <-
                             redoErrorIntervals(diffs, error.intervals = "half",
                                                LSDtype = "factor",
                                                LSDby = "Pressure", wald.tab = wald.tab,
                                                tables = "none"))
  diff.Press$LSD
  testthat::expect_equal(nrow(diff.Press$LSD), 3)
  testthat::expect_true(abs(diff.Press$LSD$minLSD[1]- 11.92550) < 1e-05)
  testthat::expect_true(abs(diff.Press$LSD$meanLSD[1]- 41.13342) < 1e-05)
  testthat::expect_true(abs(diff.Press$LSD$maxLSD[1]- 67.62672) < 1e-05)

  #No LSDtype
  testthat::expect_warning(diff.Press <-
                             redoErrorIntervals(diffs, error.intervals = "half",
                                                LSDby = "Pressure", wald.tab = wald.tab,
                                                tables = "none"))
  testthat::expect_equal(nrow(diff.Press$LSD), 3)
  testthat::expect_true(abs(diff.Press$LSD$minLSD[1]- 11.92550) < 1e-05)
  testthat::expect_true(abs(diff.Press$LSD$meanLSD[1]- 41.13342) < 1e-05)
  testthat::expect_true(abs(diff.Press$LSD$maxLSD[1]- 67.62672) < 1e-05)

  testthat::expect_warning(diff.all <-
                             redoErrorIntervals(diffs, error.intervals = "half",
                                                LSDtype = "overall",
                                                LSDby = NULL, wald.tab = wald.tab,
                                                tables = "none"))
  testthat::expect_equal(nrow(diff.all$LSD), 1)
  testthat::expect_true(rownames(diff.all$LSD) == "overall")
  testthat::expect_true(abs(diff.all$LSD$minLSD[1]- 11.92550) < 1e-05)

  #LSDtype = overall only
  testthat::expect_warning(diff.all <-
                             redoErrorIntervals(diffs, error.intervals = "half",
                                                LSDtype = "overall",
                                                wald.tab = wald.tab,
                                                tables = "none"))
  testthat::expect_equal(nrow(diff.all$LSD), 1)
  testthat::expect_true(abs(diff.all$LSD$minLSD[1]- 11.92550) < 1e-05)

  #Test predictPlus with LSD options
  #With linear transformation and LSDtype = "factor combinations"
  diffs.LSD <- predictPlus(m1, classify = "Nozzle:Pressure:Speed",
                       linear.transformation = ~(Nozzle + Pressure):Speed,
                       error.intervals = "half", LSDtype = "factor", LSDby = c("Speed", "Pressure"),
                       wald.tab = wald.tab,
                       tables = "none")
  testthat::expect_true("upper.halfLeastSignificant.limit" %in% names(diffs.LSD$predictions))
  testthat::expect_true(all(c( "LSDtype", "LSDby", "LSDstatistic") %in% names(attributes(diffs.LSD))))
  testthat::expect_true((attr(diffs.LSD, which = "LSDtype") == "factor.combinations"))
  testthat::expect_true(all(c( "LSDtype", "LSDby", "LSDstatistic", "LSDvalues") %in%
                              names(attributes(diffs.LSD$predictions))))
  testthat::expect_true(attr(diffs.LSD$predictions, which = "LSDtype") == "factor.combinations")
  testthat::expect_true(attr(diffs.LSD$predictions, which = "LSDstatistic") == "mean")

})


# Author: Justin Abraham
# R Version: R-3.6.2
# RStudio Version: 1.2.5033

###############################
## Install required packages ##
###############################

set.seed(47269801)

install.packages("pacman", repos='https://cloud.r-project.org/')
library("pacman")

p_load("here", "tidyr", "dplyr", "lmtest", "multiwayvcov", "multcomp", "reshape2", "knitr", "flextable", "officer", "forestplot", "cowplot", "ggplot2", "matrixStats", "ggthemes", "ggsignif", "rstudioapi", "iptools")

source(here("r", "Funs.r"), echo = TRUE)

################
## Clean data ##
################

## Read data ##

varnames <- as.vector(read.delim(file = here("data", "K1_Field_Survey.csv"), sep = ",", header = FALSE, stringsAsFactors = FALSE, na.strings = "", nrows = 1))
k1_df <- read.delim(file = here("data", "K1_Field_Survey.csv"), sep = ",", header = FALSE, stringsAsFactors = FALSE, na.strings = "", skip = 2, nrows = 600, col.names = varnames)

## Survey meta data ##

k1_df$start.time.mst <- as.POSIXct(as.character(k1_df$V3), format = "%m/%d/%y %H:%M")
k1_df$start.time.eat <- k1_df$start.time.mst + (3600 * 9)

k1_df$end.time.mst <- as.POSIXct(as.character(k1_df$V4), format = "%m/%d/%y %H:%M")
k1_df$end.time.eat <- k1_df$end.time.mst + (3600 * 9)

## Participant ID ##

k1_df$survey.id <- k1_df$V1
k1_df <- k1_df[complete.cases(k1_df$survey.id), ]

nonentry <- c("R_5ZkChbiXDIj6KsK", "R_7N8rNtLsxF5a9on", "R_97Tx2cAjy30fqMR", "R_lYnRvOAJhuax6LS", "R_8dky4iSC7rfEuNc", "R_nczo7KPxLkkKkgo", "R_5j1OiNu3wMp265N", "R_0GYX0scNN16ICfQ", "R_6PoFtAhwvSBNYzi", "R_696kAyWai9bDkFI", "R_hPaLwAaYCnY0l69", "R_oGNBAVexMWYhMml", "R_3rwTGdEULwOGH2y", "R_bhNv0SnArTa32Xe", "R_5txHVIbQY6twLIZ", "R_kaSM6nunZ9Ynatj", "R_0ppcidBVCPaEkXK", "R_oWceQFJG5NnSokN", "R_h5Cw4tvVUeDY8NI", "R_9ib4ASBi450NZPt", "R_mAlfPdxj5GQsJF5", "R_kbW6NDTS1FWXyn3", "R_b1GC7jpoQrJKrFN", "R_5YpNpbPWOxnSNWc", "R_mwLFSjScVyrgs9J", "R_1jbOtmMIrvgTgaE", "R_if5tz3h1N9MzTp2", "R_aFmo1jRrWIwsLjI", "R_2itxVUcUstO3Syp", "R_9LP4exOnWpJ1TrE", "R_cQLu9PDCtFwbn7K", "R_oFl39knSVL3SKpz", "R_11Y1KTzawxBJmvy")
k1_df <- k1_df[!k1_df$survey.id %in% nonentry, ]

## Treatment assignment ##

k1_df$treat[k1_df$condition == "poor"] <- 0
k1_df$treat[k1_df$condition == "individual"] <- 1
k1_df$treat[k1_df$condition == "community"] <- 2
k1_df$treat <- factor(k1_df$treat, labels = c("Pov", "Ind", "Com"))

k1_df$condition.order <- factor(k1_df$treat, labels = c("Poverty Alleviation", "Individual Empowerment", "Community Empowerment"))

k1_df$pov <- ifelse(k1_df$condition == "poor", 1, 0)
k1_df$ind <- ifelse(k1_df$condition == "individual", 1, 0)
k1_df$com <- ifelse(k1_df$condition == "community", 1, 0)

k1_df$msg1 <- recode(as.numeric(as.factor(k1_df$ORG_MESSAGE)), `2` = 0, `3` = 2)
k1_df$msg2 <- recode(as.numeric(as.factor(k1_df$ORG_MESSAGE_2)), `2` = 0)
k1_df$msg3 <- recode(as.numeric(as.factor(k1_df$ORG_MESSAGE_3)), `3` = 2)

## Video selection ##

k1_df$vid.imp1 <- k1_df$vid.dec1 %in% c(3, 5)
k1_df$vid.imp2 <- k1_df$vid.dec2 %in% c(3, 5)
k1_df$vid.num <- k1_df$vid.imp1 + k1_df$vid.imp2

## Intertemporal choice ##

k1_df$sav.save <- k1_df$sav.dec > 1
k1_df$sav.save[k1_df$sav.dec < 0] <- NA

k1_df$sav.amt[k1_df$sav.dec == 1] = 0
k1_df$sav.amt[k1_df$sav.dec == 2] = 100
k1_df$sav.amt[k1_df$sav.dec == 3] = 200
k1_df$sav.amt[k1_df$sav.dec < 0] <- NA

## Query theory (savings) ##

que_df <- k1_df[names(k1_df) %in% c("survey.id", "que.rat1", "que.rat2", "que.rat3", "que.rat4", "que.rat5")]

k1_df$que.nonm <- apply(que_df[, 1:5], 1, function(x) length(x[is.na(x) == FALSE]))

que_df <- melt(que_df, id = c("survey.id"))
que_df$variable <- as.numeric(que_df$variable)
que_df <- dcast(que_df[is.na(que_df$value) == FALSE & que_df$value > 0, ], survey.id ~ value, median, value.var = "variable")
names(que_df) <- c("survey.id", "que.mri", "que.mrp")
k1_df <- merge(k1_df, que_df, all.x = TRUE)

k1_df$que.smrd <- (2 * (k1_df$que.mrp - k1_df$que.mri)) / k1_df$que.nonm
k1_df$que.smrd[is.na(k1_df$que.mrp)] <- 1
k1_df$que.smrd[is.na(k1_df$que.mri)] <- -1

# missing values are imputed with upper and lower bounds

## Message of support (5-point scale) ##

k1_df$msg.dec[k1_df$msg.dec < 0] = NA
k1_df$msg.dec <- k1_df$msg.dec - 1

k1_df$msg.emp[k1_df$msg.emp < 0] = NA

k1_df$msg.lik[k1_df$msg.lik < 0] = NA
k1_df$msg.lik.r <- (7 - k1_df$msg.lik) * (5/6)

k1_df$msg.avg <- (k1_df$msg.emp + k1_df$msg.lik.r) / 2

## Frame evaluation ##

k1_df$eva.poor[k1_df$msg1 == 0] <- k1_df$eva.msg1[k1_df$msg1 == 0]
k1_df$eva.poor[k1_df$msg2 == 0] <- k1_df$eva.msg2[k1_df$msg2 == 0]
k1_df$eva.poor[k1_df$msg3 == 0] <- k1_df$eva.msg3[k1_df$msg3 == 0]

k1_df$eva.ind[k1_df$msg1 == 1] <- k1_df$eva.msg1[k1_df$msg1 == 1]
k1_df$eva.ind[k1_df$msg2 == 1] <- k1_df$eva.msg2[k1_df$msg2 == 1]
k1_df$eva.ind[k1_df$msg3 == 1] <- k1_df$eva.msg3[k1_df$msg3 == 1]

k1_df$eva.com[k1_df$msg1 == 2] <- k1_df$eva.msg1[k1_df$msg1 == 2]
k1_df$eva.com[k1_df$msg2 == 2] <- k1_df$eva.msg2[k1_df$msg2 == 2]
k1_df$eva.com[k1_df$msg3 == 2] <- k1_df$eva.msg3[k1_df$msg3 == 2]

k1_df$eva.vid.poor <- k1_df$eva.rank.vid_8
k1_df$eva.vid.ind <- k1_df$eva.rank.vid_9
k1_df$eva.vid.com <- k1_df$eva.rank.vid_10

k1_df$eva.conf[k1_df$eva.conf < 0] <- NA

k1_df$eva.emp.poor <- k1_df$eva.rank.emp_5
k1_df$eva.emp.ind <- k1_df$eva.rank.emp_6
k1_df$eva.emp.com <- k1_df$eva.rank.emp_7

## Ladder scales ##

k1_df$ses.lad.now[k1_df$ses.lad.now < 0] <- NA
k1_df$ses.lad.now.z <- scale(k1_df$ses.lad.now)

k1_df$ses.lad.y2[k1_df$ses.lad.y2 < 0] <- NA
k1_df$ses.lad.y2.z <- scale(k1_df$ses.lad.y2)

k1_df$ses.lad.diff <- k1_df$ses.lad.y2 - k1_df$ses.lad.now
k1_df$ses.lad.avg <- (k1_df$ses.lad.y2 + k1_df$ses.lad.now) / 2

## Sociodemographics ##

k1_df$soc.age[k1_df$soc.age < 0] <- NA

k1_df$soc.pri <- as.numeric(k1_df$soc.edu > 3)

k1_df$soc.fem <- k1_df$soc.gen - 1
k1_df$soc.fem[k1_df$soc.fem < 0] <- NA

k1_df$soc.chr <- k1_df$soc.rel %in% c(1, 2)

k1_df$ses.unemp <- k1_df$ses.emp %in% c(1, 2)

k1_df$soc.inc[k1_df$soc.inc < 0] <- NA
k1_df$soc.inc.wins[k1_df$soc.inc <= quantile(k1_df$soc.inc, .99)] <- k1_df$soc.inc[k1_df$soc.inc <= quantile(k1_df$soc.inc, .99)]
k1_df$soc.inc.wins.ln <- log(k1_df$soc.inc.wins + sqrt(k1_df$soc.inc.wins^2 + 1))

k1_df$soc.con[k1_df$soc.con < 0] <- NA
k1_df$soc.con.wins[k1_df$soc.con <= quantile(k1_df$soc.con, .99)] <- k1_df$soc.con[k1_df$soc.con <= quantile(k1_df$soc.con, .99)]
k1_df$soc.con.wins.ln <- log(k1_df$soc.con.wins + sqrt(k1_df$soc.con.wins^2 + 1))

k1_df$soc.sav <- k1_df$soc.sav - 1

k1_df$soc.eme.z <- scale(k1_df$soc.eme)

## Survey validity ##

k1_df$end.hear <- k1_df$end.hear - 1
k1_df$end.hear[k1_df$end.hear < 0] <- NA

## Center covariates ##

k1_df$soc.fem.c <- scale(k1_df$soc.fem, scale = FALSE)
k1_df$soc.pri.c <- scale(k1_df$soc.pri, scale = FALSE)
k1_df$soc.age.c <- scale(k1_df$soc.age, scale = FALSE)
k1_df$ses.unemp.c <- scale(k1_df$ses.unemp, scale = FALSE)
k1_df$soc.sav.c <- scale(k1_df$soc.sav, scale = FALSE)

## Remove extraneous variables ##

k1_df <- k1_df[grep("RA_coder", names(k1_df), value = TRUE, invert = TRUE)]

save(k1_df, file = here("data", "KenyaData.RData"))
write.csv(k1_df, file = here("data", "KenyaData.csv"))


pdf_file<-"pdf/radial_columncharts_inc.pdf"
cairo_pdf(bg=par("bg"), pdf_file,width=9,height=9)

par(bg=rgb(0.8627,0.8627,0.8627))
par(omi=c(0,0,0,0),mai=c(0,2,0,0.5),family="Droid Sans Mono", col.lab=par("bg"))
library(plotrix)

# Import data and prepare chart

library(gdata)
source("scripts/inc_data_radial_columncharts.r")
myNames<-c("Rooms",
		 "Dwelling",
		 "Income",
		 "Wealth",
		 "Employment",
		 "Unemployment",
		 "Network",
		 "Educational",
		 "Reading",
		 "Air",
		 "Consultation",
		 "Voter",
		 "Life",
		 "Health",
		 "Satisfaction  ",
		 "  Homicide",
		 "Assault",
		 "Long",
		 "Children",
		 "Time")

g1<-rgb(150,150,150,maxColorValue=255)
g2<-rgb(80,80,80,maxColorValue=255)
m<-rgb(180,180,180,maxColorValue=255)

n<-length(myNames)
myRadialColours<-rep(rgb(255,128,0,maxColorValue=255),n)
myMarginColours<-c(rep(g1,6),rep(g2,n-6))
myCenterColours<-rep(m,n)

radial_mar<-c(7,7,7,7)

myCountry<-myData["DEU",3:length(myData)]+1
myCountry[is.na(myCountry)]<-1

myCountryData<-NULL

for (j in 1:length(myCountry)) myCountryData<-c(myCountryData,list(0:as.numeric(myCountry[j])))

# Create chart

radial.pie(myDataMargin,label.prop=1.35,show.grid.labels=F,radlab=T,boxed.radial=F,show.radial.grid=F,grid.bg=par("bg"),grid.col="white",labels=myNames,sector.colors=myMarginColours,mar=radial_mar,radial.lim=c(0,11),xpd=T)

radial.pie(myCountryData,label.prop=1.35,show.grid.labels=F,radlab=T,boxed.radial=F,show.radial.grid=T,grid.bg=par("bg"),grid.col="white",labels=myNames,sector.colors=myRadialColours,mar=radial_mar,radial.lim=c(0,11),xpd=T,add=T)

radial.pie(myDataCenter,label.prop=1.35,show.grid.labels=F,radlab=T,boxed.radial=F,show.radial.grid=F,grid.bg=par("bg"),grid.col="white",labels=myNames,sector.colors=myCenterColours,mar=radial_mar,radial.lim=c(0,11),xpd=T,add=T)

par(family="Droid Sans Mono")
arctext("Economic Indicators",col="white",radius=12,start=1.3)
arctext("Social and Other Indicators",col="white",radius=12,start=4.3)
dev.off()


pdf(file="distribution.pdf", 6, 9)
# read length file
rls<-read.table("srna.len")
rlt<-read.table("trna.len")
len<-length(rls$V1)
rld=rep(0, len*3)
dim(rld)<-c(len,3)
rld<-rlt[,1:2]
rld[1:len,3]<-rls$V2 - rlt$V2
# plot
layout(c(1:3))
par(mar=(c(4.5,5,2,1)))
barplot(t(rls[,3:6]), col=c("green","red","blue","black"), legend = c("A","T","C","G"), main="Length distribution of sRNA reads", xlab="length (nt)", ylab="Frequency", names.arg=rls$V1)
par(mar=(c(4.5,5,2,1)))
barplot(t(rlt[,3:6]), col=c("green","red","blue","black"), legend = c("A","T","C","G"), main="Length distribution of tRNA reads", xlab="length (nt)", ylab="Frequency", names.arg=rlt$V1)
par(mar=(c(4.5,5,2,1)))
barplot(t(rld[,1:3]), col=c("red","green"), legend = c("sRNA","tRNA"), main="Length distribution of tRNA and non-tRNA reads", xlab="length (nt)", ylab="Frequency", names.arg=rlt$V1)
dev.off()


library(ggplot2)
library(reshape2)

dat<-read.table(covfile, sep="\t", header=F, stringsAsFactors = F)

sampleIndex<-4
for (sampleIndex in c(4:ncol(dat))){
  sampleData<-dat[,c(1,2,sampleIndex)]
  sampleName<-sample_names[sampleIndex-3]
  colnames(sampleData)<-c("Chromosome", "Position", "Reads")
  sampleData<-sampleData[sampleData$Chromosome != "Y",]
  sampleData$Chromosome[sampleData$Chromosome == "X"]<-"23"
  sampleData$Chromosome<-as.numeric(sampleData$Chromosome)

  finalData<-sampleData[FALSE,]

  chr<-sampleData$Chromosome[1]
  for(chr in unique(sampleData$Chromosome)){
    chrData<-sampleData[sampleData$Chromosome==chr,]
    csumz<-which(chrData$Reads>0)
    if(length(csumz) == 0){
      next
    }

    mincsumz<-min(csumz)
    maxcsumz<-max(csumz)

    chrData<-chrData[c(mincsumz:maxcsumz),]
    finalData<-rbind(finalData, chrData)
  }
  finalData$Log2Reads<-log2(finalData$Reads+1)

  pdf(file=paste0(covfile, "_", sampleName, ".log2.pdf"), width=5, height=20)
  g<-ggplot(finalData, aes(x=Position, y=Log2Reads)) +
    geom_point(size=0.5) +
    facet_grid(Chromosome~.) +
    ylab("log2(Reads)") +
    theme_classic()
  print(g)
  dev.off()
}


x <- read.csv("../data/wine.csv", header=FALSE)
write.table(cov(x[,1:13]), file="../data/wineCovariance.csv", row.names=FALSE, quote=FALSE, na="", col.names=FALSE, sep=",")
x <- read.csv("../data/wineDiscrete.csv", header=FALSE)
write.table(cov(x[,1:13]), file="../data/wineDiscreteCovariance.csv", row.names=FALSE, quote=FALSE, na="", col.names=FALSE, sep=",")

x <- read.csv("../data/iris.csv", header=FALSE)
write.table(cov(x[,1:4]), file="../data/irisCovariance.csv", row.names=FALSE, quote=FALSE, na="", col.names=FALSE, sep=",")
x <- read.csv("../data/irisDiscrete.csv", header=FALSE)
write.table(cov(x[,1:4]), file="../data/irisDiscreteCovariance.csv", row.names=FALSE, quote=FALSE, na="", col.names=FALSE, sep=",")

x <- read.csv("../data/heartDisease.csv", header=FALSE)
write.table(cov(x[,1:13]), file="../data/heartDiseaseCovariance.csv", row.names=FALSE, quote=FALSE, na="", col.names=FALSE, sep=",")
x <- read.csv("../data/heartDiseaseDiscrete.csv", header=FALSE)
write.table(cov(x[,1:13]), file="../data/heartDiseaseDiscreteCovariance.csv", row.names=FALSE, quote=FALSE, na="", col.names=FALSE, sep=",")


#' build a metacell cover from a co-clust object using a simple hclust approach
#'
#' @param mc_id Id of new metacell object
#' @param coc_id cocluster object to use
#' @param mat_id mat object to use when building the mc object
#' @param K number of clusters to generate from the coclust hclust. Look at the coclust plot to detemrine this. But make sure you keep the clusters at reasonable size (e.g. <100) for use as metacells.
#' @param force set this to true to overide size limits on hclust
#'
#' @export
mcell_mc_from_coclust_hc = function(mc_id, coc_id, mat_id, K, force=F)
{
	tgs_coclust_hc_type = get_param("scm_coclust_hc_type")

	coc = scdb_coclust(coc_id)
	if(is.null(coc)) {
		stop("MC-ERR: coclust ", coc_id , " is missing when running mc from coclust")
	}
	mat = scdb_mat(mat_id)
	if(is.null(mat)) {
		stop("MC-ERR: mat id ", mat_id, " is missing when running add_mc_from_graph")
	}
	if(ncol(mat@mat) > 20000 & !force) {
		stop("no support for hclust on coclust with more than 20K nodes, use force=T")
	}
	message("running cocluster hclust now")

	m_coc = as.matrix(sparseMatrix(coc@coclust$node1, coc@coclust$node2, x=coc@coclust$cnt))
	m_samp = (coc@n_samp/mean(coc@n_samp)) %*% t(coc@n_samp)
	m_coc = m_coc/m_samp
	rownames(m_coc) = colnames(mat@mat)
	colnames(m_coc) = colnames(mat@mat)
	outliers = colnames(mat@mat)[rowSums(m_coc)==0]
	m_coc = m_coc[rowSums(m_coc) > 0,rowSums(m_coc)>0]
	hc = hclust(as.dist(1-tgs_cor(m_coc)), tgs_coclust_hc_type)
	clust = cutree(hc, K)
	scdb_add_mc(mc_id, tgMCCov(clust, outliers, mat))
	message("reordering metacells by hclust and most variable two markers")
	mcell_mc_reorder_hc(mc_id)
}

#' build a metacell cover from a big co-clust using louvain clustering and metacell coverage within clusters
#'
#' @param mc_id Id of new metacell object
#' @param coc_id cocluster object to use
#' @param mat_id mat object to use when building the mc object
#' @param max_mc_size maximum mc size (bigger clusters will be dissected)
#' @param max_clust_size maximum clust size. Bigger chunks will be clustered
#'
#' @export
#'

mcell_mc_from_coclust_louv_sub = function(mc_id, coc_id, mat_id,
		max_clust_size, max_mc_size, min_mc_size, T_weight = 1)
{

#	tgs_coclust_hc_type= get_param("scm_coclust_hc_type")

	coc = scdb_coclust(coc_id)
	if(is.null(coc)) {
		stop("MC-ERR: coclust ", coc_id , " is missing when running mc from coclust")
	}
	mat = scdb_mat(mat_id)
	if(is.null(mat)) {
		stop("MC-ERR: mat id ", mat_id, " is missing when running add_mc_from_graph")
	}

#hierarchically break coclust
	filt_coc = coc@coclust[coc@coclust$cnt > T_weight,]
	tot_deg = tabulate(c(filt_coc$node1, filt_coc$node2), nbins = ncol(mat@mat))
	outliers = colnames(mat@mat)[tot_deg <= 1]
	h_mc = list(root=which(tot_deg>1))
	h_coc = list(root=filt_coc)
	recent_zoom=TRUE
	while(recent_zoom) {
		new_h_mc = list()
		new_h_coc = list()
		recent_zoom = FALSE
		message("next h iteration, current sup_clst N = ", length(h_mc))
		for(cl_i in 1:length(h_mc)) {
			next_id = length(new_h_mc) + 1
			sz = length(h_mc[[cl_i]])
			if(sz > max_clust_size) {
				sub_clust = coc_dissect_louvain(h_coc[[cl_i]], h_mc[[cl_i]])
				message("open up large cluster on ", sz, " nodes, got ", length(sub_clust), " sub clusts, sizes ", paste(lapply(sub_clust, length),collapse=","))
				f = lapply(sub_clust, length) < min_mc_size
				if(sum(f) > 0) {
					outliers = c(outliers, colnames(mat@mat)[unlist(sub_clust[f])])
					message("removing ", sum(f), " small clusters into the outlier set, new total outliers ", length(outliers))
					sub_clust = sub_clust[!f]
				}
				if(length(sub_clust) > 0) {
					names(sub_clust) = next_id : (next_id + length(sub_clust) - 1)
					new_h_mc = append(new_h_mc, sub_clust)
					sub_coc = gen_sub_coclust(h_coc[[cl_i]],sub_clust)
					new_h_coc = append(new_h_coc, sub_coc)
				}

				#break using louvain
				if(length(sub_clust) > 1) {
					recent_zoom = TRUE
				} else {
					message("louvain returned just one cluster on N =", length(h_mc[[cl_i]]), "\n")
				}
			} else if(sz > max_mc_size) {
				sub_mc = coc_dissect_mc(h_coc[[cl_i]], h_mc[[cl_i]], min_mc_size)
				message("cover intermediate cluster on ", sz, " nodes, got ", length(sub_mc), " new mcs, size ", paste(lapply(sub_mc, length),collapse=","))
				if(length(sub_mc) == 1 & length(sub_mc[["0"]])>0) {
					message("renaming ", length(sub_mc[["0"]]), " outliers, tot edges was ", nrow(h_coc[[cl_i]]))
					names(sub_mc) = c(1)
				}
				if(length(sub_mc[["0"]])>0) {
					message("adding ", length(sub_mc[["0"]]), " outliers, tot edges was ", nrow(h_coc[[cl_i]]))
					outliers = c(outliers, colnames(mat@mat)[sub_mc[["0"]]])
					sub_mc[["0"]] = NULL
				}
				if(length(sub_mc) != 0) { #only if all of it is outliers
					names(sub_mc) = next_id : (next_id + length(sub_mc) - 1)
					new_h_mc = append(new_h_mc, sub_mc)
					sub_coc = gen_sub_coclust(h_coc[[cl_i]],sub_mc)
					new_h_coc = append(new_h_coc, sub_coc)
				} else {
					browser()
				}
			} else {
				message("retain mc ", cl_i, " as ", next_id, " N = ", length(h_mc[[cl_i]]))
				new_h_mc[[next_id]] = h_mc[[cl_i]]
				new_h_coc[[next_id]] = h_coc[[cl_i]]
				names(new_h_mc)[[next_id]] = next_id
				names(new_h_coc)[[next_id]] = next_id
			}
		}
	   h_mc = new_h_mc
		h_coc = new_h_coc
	}

	clust = rep(as.numeric(names(h_mc)), times=lapply(h_mc, length))
	names(clust) = colnames(mat@mat)[unlist(h_mc)]
	scdb_add_mc(mc_id, tgMCCov(clust, outliers, mat))
	message("reordering metacells by hclust and most variable two markers")
	mcell_mc_reorder_hc(mc_id)
}

coc_dissect_louvain = function(coclust, nodes)
{
	colnames(coclust) = c("node1", "node2", "weight")

	message("will build graph")
	g_cc = graph_from_data_frame(d=coclust, directed=F)
	message("will cluster w louvain")
	a = cluster_louvain(g_cc)

	clusts = split(nodes, a$membership)
	return(clusts)
}

coc_dissect_mc = function(coclust, nodes, min_mc_size)
{
    old_seed = .set_seed(get_param("mc_rseed"))

	tgs_clust_cool = get_param("scm_tgs_clust_cool")
	tgs_clust_burn = get_param("scm_tgs_clust_burn_in")

	edges = coclust
	colnames(edges) = c("col1", "col2", "weight")
	edges$weight = edges$weight/max(edges$weight)

	edges = edges[edges$col1 != edges$col2,]
	redges = edges[,c("col1", "col2", "weight")]
	redges$col1= edges$col2
	redges$col2= edges$col1
	edges = rbind(edges,redges)

	node_clust = tgs_graph_cover(edges, min_mc_size,
					cooling = tgs_clust_cool, burn_in = tgs_clust_burn)
	rownames(node_clust) = node_clust$node
	clusts = split(nodes, node_clust$cluster[nodes])

	.restore_seed(old_seed)

	return(clusts)
}

gen_sub_coclust = function(coc, subc)
{
	message("dissect ", nrow(coc), " edges ")
	clust = rep(as.numeric(names(subc)), times=lapply(subc, length))
	clust_map = rep(NA, max(unlist(subc)))
	clust_map[unlist(subc)] = clust
	c1 = clust_map[coc$node1]
	c2 = clust_map[coc$node2]
	message("done building map")
	f = !is.na(c1) & !is.na(c2) & c1 == c2
	message("done getting factor")
	coc = coc[f,]
	intra_c = c1[f]
	message("done first subseting")
	names(intra_c) = NULL
	sub_coc = split(coc, intra_c)
	names(sub_coc) = names(subc)
	return(sub_coc)
}

#' build a metacell cover from co-clust data through filtering un-balanced edges
#' and running graph cover
#'
#' @param mc_id Id of new metacell object
#' @param coc_id cocluster object to use
#' @param mat_id mat object to use when building the mc object
#' @param K - this will
#' @param min_mc_size minimum mc size for graph cov
#' @param alpha the threshold for filtering edges by their coclust weight is alpha * (Kth highest coclust on either node1 or node2)
#'
#' @export
mcell_mc_from_coclust_balanced = function(mc_id, coc_id,
												mat_id, K, min_mc_size, alpha=2)
{
    old_seed = .set_seed(get_param("mc_rseed"))

	tgs_clust_cool = get_param("scm_tgs_clust_cool")
	tgs_clust_burn = get_param("scm_tgs_clust_burn_in")

	coc = scdb_coclust(coc_id)
	if(is.null(coc)) {
		stop("MC-ERR: coclust ", coc_id , " is missing when running mc from coclust")
	}
	mat = scdb_mat(mat_id)
	if(is.null(mat)) {
		stop("MC-ERR: mat id ", mat_id, " is missing when running add_mc_from_graph")
	}

	edges = coc@coclust
	filt_edges = mcell_coclust_filt_by_k_deg(coc_id, K, alpha)

	message("filtered ", nrow(edges) - sum(filt_edges), " left with ", sum(filt_edges), " based on co-cluster imbalance")
	edges = edges[filt_edges,]

	colnames(edges) = c("col1", "col2", "weight")
	edges$weight = edges$weight/max(edges$weight)

	edges = edges[edges$col1 != edges$col2,]
	redges = edges[,c("col1", "col2", "weight")]
	redges$col1= edges$col2
	redges$col2= edges$col1
	edges = rbind(edges,redges)

	node_clust = tgs_graph_cover(edges, min_mc_size,
					cooling = tgs_clust_cool, burn_in = tgs_clust_burn)

	f_outlier = (node_clust$cluster == 0)

	outliers = colnames(mat@mat)[node_clust$node[f_outlier]]
	mc = as.integer(as.factor(node_clust$cluster[!f_outlier]))
	names(mc) = colnames(mat@mat)[!f_outlier]
	message("building metacell object, #mc ", max(mc))
	cell_names = colnames(mat@mat)
	scdb_add_mc(mc_id, tgMCCov(mc, outliers, mat))
	message("reordering metacells by hclust and most variable two markers")

	.restore_seed(old_seed)

	mcell_mc_reorder_hc(mc_id)
}


# make percentile out of bigwig files
#Arguments
# bigwig_path
# cut_off <-percentile cutoff between 0 to 1
bw_perc<-function(bigwig_path,cut_off=FALSE,bigwig_export=FALSE){
  library(rtracklayer)
  library(GenomeInfoDb)
  bw<-import(bigwig_path)
  perc.rank <- function(x) trunc(rank(x))/length(x)
  temp<-bw
  temp$score<-perc.rank(bw$score)
  cutoff_file_ext<-""
  if (cut_off){
    temp<-temp[temp$score>cut_off]
    cutoff_file_ext<-trunc(cut_off*100)
  }
  if (bigwig_export){
      export(object = temp,con = paste(tools::file_path_sans_ext(bigwig_path),"_",
                                       cutoff_file_ext,"pct.bw",sep='')
      )
    }else return(temp)

  }


# library imports
library(tidyverse)
library(scales)
library(limma)
library(edgeR)
library(psych)

# get the default plot width and height
width <- options()$repr.plot.width
height <- options()$repr.plot.height

# load the IRS-normalized data and check the table
data_import <- read_tsv("ave_labeled_grouped_protein_summary_TMT_9_IRS_normalized.txt", guess_max = 596)

# the "Filter" column flags contams and decoys
# the "Missing" column flags proteins without reporter ion intensities (full sets missing)
# the prepped table from pandas is sorted so these are the upper rows
data_all <- filter(data_import, is.na(Filter), is.na(Missing))

# save gene names for edgeR so we can double check that results line up
accessions <- data_all$Accession

# see how many rows in the table
nrow(data_all)

# we want to get the SL normed columns, and subsetted by condition
sl_all <- data_all %>%
  select(starts_with("SLNorm"))
sl_N <- sl_all %>% select(contains("_N"))
sl_SLE <- sl_all %>% select(contains("_SLE"))

# and the IRS normed columns by condition
irs_all <- data_all %>%
  select(starts_with("IRSNorm"))
irs_N <- irs_all %>% select(contains("_N"))
irs_SLE <- irs_all %>% select(contains("_SLE"))

# and collect the pooled channels before and after IRS
sl_pool <- sl_all %>% select(contains("pool"))
irs_pool <- irs_all %>% select(contains("pool"))

head(sl_N)

# multi-panel scatter plot grids from the psych package
pairs.panels(log2(sl_pool), lm = TRUE, main = "Pooled Std before IRS")
pairs.panels(log2(irs_pool), lm = TRUE, main = "Pooled Std after IRS")

# multi-panel scatter plot grids
N_sample <- sample(1:9, 4)
pairs.panels(log2(sl_N[N_sample]), lm = TRUE, main = "Normal before IRS (random 4)")
pairs.panels(log2(irs_N[N_sample]), lm = TRUE, main = "Normal after IRS (same 4)")

# multi-panel scatter plot grids
SLE_sample  <- sample(1:10, 4)
pairs.panels(log2(sl_SLE[SLE_sample]), lm = TRUE, main = "SLE before IRS (random 4)")
pairs.panels(log2(irs_SLE[SLE_sample]), lm = TRUE, main = "SLE after IRS (same 4)")

# get the biological sample data into a DGEList object
group = c(rep('N', 9), rep('SLE', 10))
y_sl <- DGEList(counts = cbind(sl_N, sl_SLE), group = group, genes = accessions)
y_irs <- DGEList(counts = cbind(irs_N, irs_SLE), group = group, genes = accessions)

# run TMM normalization (also includes a library size factor)
y_sl <- calcNormFactors(y_sl)
y_irs <- calcNormFactors(y_irs)

# set some colors by condition
colors = c(rep('red', 9), rep('blue', 10))

# check the clustering
plotMDS(y_sl, col = colors, main = "Before IRS: all samples")
plotMDS(y_irs, col = colors, main = "After IRS: all samples")

# we do not want the technical replicates in the mix for dispersion estimates
irs <- cbind(irs_N, irs_SLE)

# load a new DGEList object (need to update the groups)
y <- DGEList(counts = irs, group = group, genes = accessions) # group was set above
y <- calcNormFactors(y)

# see what the normalization factors look like
y$samples

# ================== TMM normalization from DGEList object =====================

apply_tmm_factors <- function(y, color = NULL, plot = TRUE) {
    # computes the tmm normalized data from the DGEList object
        # y - DGEList object
        # returns a dataframe with normalized intensities

    # compute grand total (library size) scalings
    lib_facs <- mean(y$samples$lib.size) / y$samples$lib.size

    # the TMM factors are library adjustment factors (so divide by them)
    norm_facs <- lib_facs / y$samples$norm.factors
    cat("Overall Factors (lib.size+TMM):\n", sprintf("%-5s -> %f\n",
                                                     colnames(y$counts), norm_facs))

    # compute the normalized data as a new data frame
    tmt_tmm <- as.data.frame(sweep(y$counts, 2, norm_facs, FUN = "*"))
    colnames(tmt_tmm) <- str_c(colnames(y$counts), "_tmm")

    # visualize results and return data frame
    if(plot == TRUE) {
        boxplot(log10(tmt_tmm), col = color, notch = TRUE, main = "TMM Normalized data")
    }
    tmt_tmm
}

# compute the normalized data as a new data frame
irs_tmm <- apply_tmm_factors(y, colors)

long_results <- gather(irs_tmm, key = "sample", value = "intensity") %>%
  mutate(log_int = log10(intensity)) %>%
  extract(sample, into = 'group', ".*?_(.*?)\\d", remove = FALSE)
head(long_results)

ggplot(long_results, aes(x = sample, y = log_int, fill = group)) +
  geom_boxplot(notch = TRUE) +
  coord_flip() +
  ggtitle("edgeR normalized data")

ggplot(long_results, aes(x = log_int, color = sample)) +
  geom_density() +
  guides(color = FALSE) +
  ggtitle("edgeR normalized data (with legend is too busy)")

# we can compare CVs before and after IRS
sl <- cbind(sl_N, sl_SLE)

# save column indexes for different conditions (indexes to data_raw frame)
# these make things easier (and reduce the chance for errors)
N <- 1:9
SLE <- 10:19

# create a CV computing function
CV <- function(df) {
    ave <- rowMeans(df)
    sd <- apply(df, 1, sd)
    cv <- 100 * sd / ave
}

# put CVs in data frames to simplify plots and summaries
cv_frame <- data.frame(N_sl = CV(sl[N]), N_final = CV(irs_tmm[N]),
                       SLE_sl = CV(sl[SLE]), SLE_final = CV(irs_tmm[SLE]))

# see what the median CV values are
medians <- apply(cv_frame, 2, FUN = median)
print("Median CVs by condition, before/after IRS (%)")
round(medians, 1)

# see what the CV distibutions look like
# need long form for ggplot
long_cv <- gather(cv_frame, key = "condition", value = "cv") %>%
  extract(condition, into = 'group', "(.*?)_+", remove = FALSE)

# traditional boxplots
cv_plot <- ggplot(long_cv, aes(x = condition, y = cv, fill = group)) +
  geom_boxplot(notch = TRUE) +
  ggtitle("CV distributions")

# vertical orientation
cv_plot

# horizontal orientation
#cv_plot + coord_flip()

# density plots
ggplot(long_cv, aes(x = cv, color = condition)) +
  geom_density() +
  coord_cartesian(xlim = c(0, 150)) +
  ggtitle("CV distributions")

# compute dispersions and plot BCV
y <- estimateDisp(y)
plotBCV(y, main = "BCV plot of IRS normed, TMM normed, all 19")

# the exact test object has columns like fold-change, CPM, and p-values
et <- exactTest(y, pair = c("N", "SLE"))

# this counts up, down, and unchanged genes (proteins) at 10% FDR
summary(decideTestsDGE(et, p.value = 0.10))

# the topTags function adds the BH FDR values to an exactTest data frame
# make sure we do not change the row order (the sort.by parameter)!
topTags(et, n = 31)
tt <- topTags(et, n = Inf, sort.by = "none")
tt <- tt$table    # tt is a list. We just need the "table" data frame

# make an MD plot (like MA plot)
plotMD(et, p.value = 0.10)
abline(h = c(-1, 1), col = "black")

# check the p-value distribution
ggplot(tt, aes(PValue)) +
  geom_histogram(bins = 100, fill = "white", color = "black") +
  geom_hline(yintercept = mean(hist(et$table$PValue, breaks = 100,
                                    plot = FALSE)$counts[26:100])) +
  ggtitle("N vs SLE PValue distribution")

# get the averages within each condition
# results already has the normalized data in its left columns
tt$ave_N <- rowMeans(irs_tmm[N])
tt$ave_SLE <- rowMeans(irs_tmm[SLE])

# add the cadidate status column
tt <- tt %>%
  mutate(candidate = cut(FDR, breaks = c(-Inf, 0.01, 0.05, 0.10, 1.0),
  labels = c("high", "med", "low", "no")))

tt %>% count(candidate)  # count candidates

ggplot(tt, aes(x = logFC, fill = candidate)) +
  geom_histogram(binwidth=0.1, color = "black") +
  facet_wrap(~candidate) +
  coord_cartesian(xlim = c(-2, 2)) +
  ggtitle("N vs SLE logFC distributions by candidate")

# ================= reformat edgeR test results ================================

collect_results <- function(df, tt, x, xlab, y, ylab) {
    # Computes new columns and extracts some columns to make results frame
        # df - data in data.frame
        # tt - top tags table from edgeR test
        # x - columns for first condition
        # xlab - label for x
        # y - columns for second condition
        # ylab - label for y
        # returns a new dataframe

    # condition average vectors
    ave_x <- rowMeans(df[x])
    ave_y <- rowMeans(df[y])

    # FC, direction, candidates
    fc <- ifelse(ave_y > ave_x, (ave_y / ave_x), (-1 * ave_x / ave_y))
    direction <- ifelse(ave_y > ave_x, "up", "down")
    candidate <- cut(tt$FDR, breaks = c(-Inf, 0.01, 0.05, 0.10, 1.0),
                     labels = c("high", "med", "low", "no"))

    # make data frame
    temp <- cbind(df[c(x, y)], data.frame(logFC = tt$logFC, FC = fc,
                                          PValue = tt$PValue, FDR = tt$FDR,
                                          ave_x = ave_x, ave_y = ave_y,
                                          direction = direction, candidate = candidate,
                                          Acc = tt$genes))

    # fix column headers for averages
    names(temp)[names(temp) %in% c("ave_x", "ave_y")]  <- str_c("ave_", c(xlab, ylab))

    temp # return the data frame
}

# get the results
results <- collect_results(irs_tmm, tt, N, "N", SLE, "SLE")

transform <- function(results, x, y) {
    # Make data frame with some transformed columns
        # results - results data frame
        # x - columns for x condition
        # y - columns for y condition
        # return new data frame
    df <- data.frame(log10((results[x] + results[y])/2),
                     log2(results[y] / results[x]),
                     results$candidate,
                     -log10(results$FDR))
    colnames(df) <- c("A", "M", "candidate", "P")

    df # return the data frame
}

MA_plots <- function(results, x, y, title) {
    # makes MA-plot DE candidate ggplots
        # results - data frame with edgeR results and some condition average columns
        # x - string for x-axis column
        # y - string for y-axis column
        # title - title string to use in plots
        # returns a list of plots

    # uses transformed data
    temp <- transform(results, x, y)

    # 2-fold change lines
    ma_lines <- list(geom_hline(yintercept = 0.0, color = "black"),
                     geom_hline(yintercept = 1.0, color = "black", linetype = "dotted"),
                     geom_hline(yintercept = -1.0, color = "black", linetype = "dotted"))

    # make main MA plot
    ma <- ggplot(temp, aes(x = A, y = M)) +
        geom_point(aes(color = candidate, shape = candidate)) +
        scale_y_continuous(paste0("logFC (", y, "/", x, ")")) +
        scale_x_continuous("Ave_intensity") +
        ggtitle(title) +
        ma_lines

    # make separate MA plots
    ma_facet <- ggplot(temp, aes(x = A, y = M)) +
        geom_point(aes(color = candidate, shape = candidate)) +
        scale_y_continuous(paste0("log2 FC (", y, "/", x, ")")) +
        scale_x_continuous("log10 Ave_intensity") +
        ma_lines +
        facet_wrap(~ candidate) +
        ggtitle(str_c(title, " (separated)"))

    # make the plots visible
    print(ma)
    print(ma_facet)
}

scatter_plots <- function(results, x, y, title) {
    # makes scatter-plot DE candidate ggplots
        # results - data frame with edgeR results and some condition average columns
        # x - string for x-axis column
        # y - string for y-axis column
        # title - title string to use in plots
        # returns a list of plots

    # 2-fold change lines
    scatter_lines <- list(geom_abline(intercept = 0.0, slope = 1.0, color = "black"),
                          geom_abline(intercept = 0.301, slope = 1.0, color = "black", linetype = "dotted"),
                          geom_abline(intercept = -0.301, slope = 1.0, color = "black", linetype = "dotted"),
                          scale_y_log10(),
                          scale_x_log10())

    # make main scatter plot
    scatter <- ggplot(results, aes_string(x, y)) +
        geom_point(aes(color = candidate, shape = candidate)) +
        ggtitle(title) +
        scatter_lines

    # make separate scatter plots
    scatter_facet <- ggplot(results, aes_string(x, y)) +
        geom_point(aes(color = candidate, shape = candidate)) +
        scatter_lines +
        facet_wrap(~ candidate) +
        ggtitle(str_c(title, " (separated)"))

    # make the plots visible
    print(scatter)
    print(scatter_facet)
}

volcano_plot <- function(results, x, y, title) {
    # makes a volcano plot
        # results - a data frame with edgeR results
        # x - string for the x-axis column
        # y - string for y-axis column
        # title - plot title string

    # uses transformed data
    temp <- transform(results, x, y)

    # build the plot
    ggplot(temp, aes(x = M, y = P)) +
        geom_point(aes(color = candidate, shape = candidate)) +
        xlab("log2 FC") +
        ylab("-log10 FDR") +
        ggtitle(str_c(title, " Volcano Plot"))
}

# make the DE plots
MA_plots(results, "ave_N", "ave_SLE", "Normal vs SLE")
scatter_plots(results, "ave_N", "ave_SLE", "Normal vs SLE")
volcano_plot(results, "ave_N", "ave_SLE", "Normal vs SLE")

# ============== individual protein expression plots ===========================

# function to extract the identifier part of the accesssion
get_identifier <- function(accession) {
    identifier <- str_split(accession, "\\|", simplify = TRUE)
    identifier[,3]
}

set_plot_dimensions <- function(width_choice, height_choice) {
    options(repr.plot.width=width_choice, repr.plot.height=height_choice)
}

plot_top_tags <- function(results, nleft, nright, top_tags) {
    # results should have data first, then test results (two condition summary table)
    # nleft, nright are number of data points in each condition
    # top_tags is number of up and number of down top DE candidates to plot
    # get top ipregulated
    up <- results %>%
        filter(logFC >= 0) %>%
        arrange(FDR)
    up <- up[1:top_tags, ]

    # get top down regulated
    down <- results %>%
        filter(logFC < 0) %>%
        arrange(FDR)
    down <- down[1:top_tags, ]

    # pack them into one data frame
    proteins <- rbind(up, down)

    color = c(rep("red", nleft), rep("blue", nright))
    for (row_num in 1:nrow(proteins)) {
        row <- proteins[row_num, ]
        vec <- as.vector(unlist(row[1:(nleft + nright)]))
        names(vec) <- colnames(row[1:(nleft + nright)])
        title <- str_c(get_identifier(row$Acc), ", int: ", scientific(mean(vec), 2),
                       ", p-val: ", scientific(row$FDR, digits = 3),
                       ", FC: ", round(row$FC, digits = 1))
        barplot(vec, col = color, main = title)
    }
}

# set plot size, make plots, reset plot size
set_plot_dimensions(7, 4)
plot_top_tags(results, length(N), length(SLE), 10)
set_plot_dimensions(width, height)

write.table(results, "IRS_R_ave_results.txt", sep = "\t",
           row.names = FALSE, na =  " ")

sessionInfo()


# each file is one scaffold of downy woodpecker genome
# need to remove the first 1 bp of all files (estimates recombination from the previous snp, which there isn't any)
# modify the window size here for the 50kbp or 100kbp windows

# determine number of files
scalaris_maps_files <- list.files("output", pattern="scalaris.*mapping", full.names=T)

# summarize per sliding windows
sliding_window <- 50000
# turn off scientific notation for output with large numbers in sliding windows
options(scipen=999)

# write initial output file
output_header <- c("scaffold", "window_start", "window_end", "mean_rho", "nuttallii_rho", "pubescens_rho", "scalaris_rho")
write(output_header, file="dryobates_window_rho.txt", sep="\t", ncolumns=7)
for(a in 1:length(scalaris_maps_files)) {
	scalaris_maps <- read.table(paste("output/scalaris_", a, ".mapping", sep=""), header=F, stringsAsFactors=F, sep=" ")
	scalaris_res <- read.table(paste("output/scalaris.", a, "res.txt", sep=""), header=T, stringsAsFactors=F, sep="\t")
	nuttallii_maps <- read.table(paste("output/nuttallii_", a, ".mapping", sep=""), header=F, stringsAsFactors=F, sep=" ")
	nuttallii_res <- read.table(paste("output/nuttallii.", a, "res.txt", sep=""), header=T, stringsAsFactors=F, sep="\t")
	pubescens_maps <- read.table(paste("output/pubescens_", a, ".mapping", sep=""), header=F, stringsAsFactors=F, sep=" ")
	pubescens_res <- read.table(paste("output/pubescens.", a, "res.txt", sep=""), header=T, stringsAsFactors=F, sep="\t")

	# combine locations, recombination
	scalaris <- cbind(scalaris_maps, scalaris_res$Mean_rho)
	scalaris <- scalaris[2:nrow(scalaris), ]
	nuttallii <- cbind(nuttallii_maps, nuttallii_res$Mean_rho)
	nuttallii <- nuttallii[2:nrow(nuttallii), ]
	pubescens <- cbind(pubescens_maps, pubescens_res$Mean_rho)
	pubescens <- pubescens[2:nrow(pubescens), ]

	# divide by the size of the whole window (because ldhat assumes the units are kbp, but they are not)
	scalaris[,3] <- scalaris[,3] / ((scalaris[nrow(scalaris),2] - scalaris[1,2] + 1) / 1000)
	nuttallii[,3] <- nuttallii[,3] / ((nuttallii[nrow(nuttallii),2] - nuttallii[1,2] + 1) / 1000)
	pubescens[,3] <- pubescens[,3] / ((pubescens[nrow(pubescens),2] - pubescens[1,2] + 1) / 1000)

	#summarize per 100 kbp
	num_windows <- floor(max(c(scalaris[,2], nuttallii[,2], pubescens[,2])) / sliding_window)
	start <- 1
	end <- sliding_window
	for(b in 1:num_windows) {
		scalaris_rep <- mean(scalaris[scalaris[,2] >= start & scalaris[,2] <= end, 3])
		nuttallii_rep <- mean(nuttallii[nuttallii[,2] >= start & nuttallii[,2] <= end, 3])
		pubescens_rep <- mean(pubescens[pubescens[,2] >= start & pubescens[,2] <= end, 3])
		weighted_mean_rep <- mean(na.omit(c(rep(scalaris_rep, 10), rep(nuttallii_rep, 10), rep(pubescens_rep, 8))))
		output_rep <- c(scalaris[1,1], start, end, weighted_mean_rep, nuttallii_rep, pubescens_rep, scalaris_rep)
		write(output_rep, file="dryobates_window_rho.txt", sep="\t", ncolumns=7, append=T)

		start <- start + sliding_window
		end <- end + sliding_window
	}
}

require(Hmisc)

# look at output
x <- read.table("dryobates_window_rho.txt", sep="\t", header=T, stringsAsFactors=F)
rcorr(as.matrix(x[,5:7]))
plot(x[,5:7], pch=19, cex=0.2)


library(corrplot)
library(Hmisc)
library(magrittr)
library(tidyr)
library(ggplot2)
library(purrr)

data = read.csv("datasets/CardiacDataAdj.csv")
data.categorical = keep(data, function(x) {all(x %in% (c(0,1,1.5)))})

data.categorical %>%
  gather() %>%                             # Convert to key-value pairs
  ggplot(aes(value)) +                     # Plot the values
  facet_wrap(~ key, scales = "free_x") +   # In separate panels
  geom_bar() +                             # Bar Plot
  scale_x_discrete()                       # Discrete x values


Args<-commandArgs()
n1=as.numeric(unlist(strsplit(Args[6], ",")))
n2=as.numeric(unlist(strsplit(Args[7], ",")))
r=t.test(n1,n2)
print(r$statistic)
print(r$parameter)
print(r$p.value)


# via Houstonwp
library(data.table)

q <- c(0.001,
       0.002,
       0.003,
       0.003,
       0.004,
       0.004,
       0.005,
       0.007,
       0.009,
       0.011)

w <- c(0.05,
       0.07,
       0.08,
       0.10,
       0.14,
       0.20,
       0.20,
       0.20,
       0.10,
       0.04)

P <- 100
S <- 25000
r <- 0.02

dt <- as.data.table(cbind(q,w))

npv <- function(cf, r, S, P) {
  cf[, inforce := shift(cumprod(1 - q - w), fill = 1)
  ][, lapses := inforce * w
  ][, deaths := inforce * q
  ][, claims := deaths * S
  ][, premiums := inforce * P
  ][, ncf := premiums - claims
  ][, d := (1/(1+r))^(.I)
  ][, sum(ncf*d)]
}

npv(dt,r,S,P)
#> [1] 50.32483

microbenchmark::microbenchmark(npv(dt,r,S,P))


#Governance
rm(list=ls())
#Function Library
tryCatch(expr=setwd("~/GitHub/Truthcoin/lib"), error=function(e) setwd(choose.dir(caption="Failed to set working directory automatically. Choose 'lib' folder:")) )
source(file="market/Markets.r")
source(file="consensus/ConsensusMechanism.r")
Sha256 <- function(x) digest(unlist(x),algo='sha256',serialize=FALSE)

GenesisBlock <- list(
  "Bn"=1,               #Block Number

  "h.B.1"=Sha256(""),   #Hash of previous block

  "Time"=Sys.time(),    #System Date and Time

  "ListFee"=.001,       #Listing Fee - Fee to create a new Market and add a column to the V matrix. (selected to be nonzero but arbitrarily low - about 1 USD)

  "ListFee2"=log(8)/(8^2),                              #Second listing fee...even smaller, designed to lightly discourage low-k, high-n Markets with more than N=256 states. st f1(x) = a(x^2) = f2(x) = b (log(x)) @ x=8

  "Cnew"=NULL,                                          #New Markets (appends to C) ?

  "Cmatrix"=data.frame(                                 #Matrix of Active Markets (stores only the essential information).
    "Market"='a',
    "Matures"=1)[-1,],

  "Vmatrix"=matrix(0,nrow=6,ncol=0,dimnames=(           #Matrix of 'Votes' ...extensive attention is given to this matrix with the 'Factory' function.
    list(paste("Voter",1:6,sep="."))                    #(fake names, will be Truthcoin Addresses)
    )),

  "Reputation"=c(.3,.2,.15,.15,.1,.1),   #Reputation

  "Jmatrix"=data.frame("Market"='a',"State"=1)[-1,],  #The Markets that, in this block, were ruled to have been decisivly judged (appends to H) ?

  "h.H.1"=Sha256(""),             #Hash of the H matrix (the H matrix refers to the 'history' of Markets and their outcomes)

  "Nonce"=1
  )

#+nonce, merkle, Bitcoin fields, etc.
BlockChain <- list(NA,GenesisBlock)
#Setup Complete

## Functions Involving BlockChain Information ##

QueryAddMarket <- function(NewMarket,CurChain=BlockChain) {

  Now <- length(CurChain)
  CurDecFee <- CurChain[[Now]]$ListFee    #get parameters for this block
  CurStateFee <- CurChain[[Now]]$ListFee2 #get parameters for this block

  D.calc <- sum(GetDim(NewMarket,0))  #Total number of decisions that must be made.
  S.calc <- prod(GetDim(NewMarket))   #Size of the trading space.

  Seed.Capital <- NewMarket$B*log(S.calc)

  Out <- list("MarketMake"=Seed.Capital,
              "CurrentDecisionFee"=CurDecFee,
              "D"=D.calc,
              "D.cost"= D.calc*CurDecFee,
              "CurrentStateFee"=CurStateFee,
              "S"=S.calc,
              "S.cost"=  (S.calc^2) * CurStateFee,
              "TotalCost"= Seed.Capital + (D.calc * CurDecFee) + ((S.calc^2) * CurStateFee)  #Cost to list this Market.
              )
  return(Out)
}

QueryAddMarket(C1)
QueryAddMarket(C2)

AddMarket <- function(NewMarket,CurChain=BlockChain,PaymentTransaction=0) {

  #Verify Payment
  Cost <- QueryAddMarket(NewMarket,CurChain)$TotalCost
  #Payment <- LookUpPayment(PaymentTransaction)
  #if(Payment<Cost) return("Payment Error")

  #Declare Working Variables
  Now <- length(CurChain)
  CurBlock.Old <- CurChain[[Now]]
  CurBlock.New <- CurBlock.Old

  #Format the Market's Decision-States as rows
  C.Filled <- FillMarketInfo(NewMarket)
  if( !all.equal(C.Filled, FillMarketInfo(C.Filled)) ) { # Sanity Check
    print("Market Error")
    return(all.equal(C.Filled, FillMarketInfo(C.Filled)))
  }

  UJRows <- GetUJRows(C.Filled) #The 'Unjudged' that need to be added as rows.
  UJRows.Cformat <- data.frame("Market"=paste("C",UJRows[,2],UJRows[,3],UJRows[,1], sep="."), #in the format for adding to Cmatrix
                               "Maturity"=UJRows[,4])
  #Add the Market to Cmatrix
  CurBlock.New$Cmatrix <- rbind(CurBlock.Old$Cmatrix,UJRows.Cformat)

  #Assign Output - Replace
  NewChain <- CurChain
  NewChain[[Now]] <- CurBlock.New
  return(NewChain)
}

AdvanceChain <- function(VDuration=10) {

  #Add a new link to the chain.
  Now <- length(BlockChain)
  Old <- BlockChain[[Now]] #The most recent block
  New <- Old               #A copy of the most recent block.

  #Add hash of previous block
  New$h.B.1  <- Sha256(Old)
  #Add the current time
  New$Time <- Sys.time()

  ## Construct a Vote every X=10 rounds (if there are Markets waiting) ##
  if(Now%%VDuration==0&length(Old$Vmatrix)>0) {

    #Use our big function
    Results <- Factory(Old$Vmatrix,Rep=Old$Reputation)

    #Set Reputations
    New$Reputation <- Results$Agents[,"RowBonus"]

    #Adjust Entry/Authorship Fee - based on voter turnout
    Participation.Target <- .90
    Participation.Actual <- Results$Participation
    New$ListFee <- Old$ListFee* (Participation.Target/Participation.Actual)

    #Set Market State using DecisionOutcome.Final
    MarketOutcomes <- Results$Decisions["DecisionOutcome.Final",]
    PreReformat <- unlist(strsplit(names(MarketOutcomes),split=".",fixed=TRUE))
    MaxX <- length(names(MarketOutcomes))*4    # (4 fields)

    Reformat <- data.frame( "IDc"=             PreReformat[1:MaxX%%4==0],
                            "IDd"= as.numeric( PreReformat[1:MaxX%%4==2] ), #lost the numeric formating in strsplit
                            "IDs"= as.numeric( PreReformat[1:MaxX%%4==3] ),
                             "J"= MarketOutcomes)

    #Market undecided - kick out to -1  ("Market is permanently unresolveable")
    if(sum(Results$J==.5)>0) return(-1)  #It is possible to improve this through some kind of marginal space.

    for(k in unique(Reformat$IDc)) {
      Temp <- Reformat[Reformat$IDc==k,]  #Subset

      # "GetDim" lite - Take list of decisions and return vector of dimensions, Question x State
      C.Dim <- vector("numeric",length=max(Temp$IDd))
      for(j in 1:max(Temp$IDd)) C.Dim[j] <- max(Temp[Temp$IDd==j,"IDs"]) + 1

      # 'GetSpace' lite - Take Dimensions and return the 'State Array' of all possible states.
      MaxN <- prod(C.Dim) #multiply dimensions to get total # of partitions
      Names <- vector('list',length=length(C.Dim))
      for(i in 1:length(C.Dim)) Names[[i]] <- paste("d",i,".",c("No",rep("Yes",C.Dim[i]-1)) ,sep="" )
      JSpace <- array(data=1:MaxN,dim=C.Dim,dimnames=Names)

      # 'Format' lite - Take Judgements from Consensus and use them to navigate to the correct state.
      Temp$T <- Temp$IDs*Temp$J + 1  # +1 for index.. R does not count from zero
      PreState <- 1:length(C.Dim)                #For each dimension of the Market
      for(i in 1:length(PreState)) PreState[i] <- max(Temp$T[Temp$IDd==i])  #Find the maximum value within dimension (assumes Markets have been ordered)
      JState <- JSpace[PreState[1],PreState[2],PreState[3]]

      print(paste("Market",k,"ended in State",JState,"."))

      #Publish Result
      New$Jmatrix <- rbind(New$Jmatrix,data.frame("Market"=k, "State"=JState))
    }

  }

  #if any Markets have matured in Cmatrix, add them to Vmatrix
  OpenMarkets <- New$Cmatrix[New$Cmatrix$Maturity==Now,1]  #gets the ID of any Markets maturing today #! change to ID after validation
  Vm1 <- length(OpenMarkets)
  if(Vm1>0) {
    Vn <- dim(New$Vmatrix)[1]
    Vm2 <- dim(New$Vmatrix)[2]

    New$Vmatrix  <- matrix(data=    c(New$Vmatrix, rep(NA,Vn*Vm1)),
                           nrow=    Vn,
                           ncol=    (Vm2+Vm1),
                           dimnames=list(row.names(Old$Vmatrix), c(colnames(Old$Vmatrix),OpenMarkets)) )
    print(paste("Added",Vm1,"rows to the Vmatrix."))
    print(New$Vmatrix)
  }

  #if any Markets have expired from Vmatrix, remove them from Vmatrix
  ExpiredMarkets <- New$Cmatrix[New$Cmatrix$Maturity==(Now-VDuration),1]  #gets the ID of any Markets maturing today #! change to ID after validation
  if(length(ExpiredMarkets)>0) {
    New$Vmatrix <- New$Vmatrix[,(colnames(New$Vmatrix)!=ExpiredMarkets)]
    print(paste("Removed",length(ExpiredMarkets),"rows from the Vmatrix."))
    print(New$Vmatrix)
  }

  BlockChain[[(Now+1)]] <<- New
}

FastForward <- function(Times=2) {
  for(i in 1:Times) AdvanceChain()
}

BlockChain

QueryAddMarket(C2)
BlockChain <- AddMarket(C2)

BlockChain

AdvanceChain()

BlockChain

FastForward(5)

BlockChain[[length(BlockChain)]]

SetVote <- function(Row,Column,Vote) {
  #Eventually this will require Message Signing, of course.
  try( BlockChain[[length(BlockChain)]]$Vmatrix[Row,Column] <<- Vote )
}

SetVote("Voter.1","C.1.1.5fa52bc3609598e28214d0e8ba47eca4",1)
SetVote("Voter.2","C.1.1.5fa52bc3609598e28214d0e8ba47eca4",1)
SetVote("Voter.3","C.1.1.5fa52bc3609598e28214d0e8ba47eca4",1)
SetVote("Voter.4","C.1.1.5fa52bc3609598e28214d0e8ba47eca4",1)
SetVote("Voter.5","C.1.1.5fa52bc3609598e28214d0e8ba47eca4",1)
SetVote("Voter.6","C.1.1.5fa52bc3609598e28214d0e8ba47eca4",1)

SetVote("Voter.1","C.2.1.5fa52bc3609598e28214d0e8ba47eca4",1)
SetVote("Voter.2","C.2.1.5fa52bc3609598e28214d0e8ba47eca4",1)
SetVote("Voter.3","C.2.1.5fa52bc3609598e28214d0e8ba47eca4",1)
SetVote("Voter.4","C.2.1.5fa52bc3609598e28214d0e8ba47eca4",1)
SetVote("Voter.5","C.2.1.5fa52bc3609598e28214d0e8ba47eca4",1)
SetVote("Voter.6","C.2.1.5fa52bc3609598e28214d0e8ba47eca4",1)

SetVote("Voter.1","C.2.2.5fa52bc3609598e28214d0e8ba47eca4",1)
SetVote("Voter.2","C.2.2.5fa52bc3609598e28214d0e8ba47eca4",1)
SetVote("Voter.3","C.2.2.5fa52bc3609598e28214d0e8ba47eca4",1)
SetVote("Voter.4","C.2.2.5fa52bc3609598e28214d0e8ba47eca4",1)
SetVote("Voter.5","C.2.2.5fa52bc3609598e28214d0e8ba47eca4",1)
SetVote("Voter.6","C.2.2.5fa52bc3609598e28214d0e8ba47eca4",1)

SetVote("Voter.1","C.2.3.5fa52bc3609598e28214d0e8ba47eca4",0)
SetVote("Voter.2","C.2.3.5fa52bc3609598e28214d0e8ba47eca4",0)
SetVote("Voter.3","C.2.3.5fa52bc3609598e28214d0e8ba47eca4",0)
SetVote("Voter.4","C.2.3.5fa52bc3609598e28214d0e8ba47eca4",0)
SetVote("Voter.5","C.2.3.5fa52bc3609598e28214d0e8ba47eca4",0)
SetVote("Voter.6","C.2.3.5fa52bc3609598e28214d0e8ba47eca4",0)

SetVote("Voter.1","C.3.1.5fa52bc3609598e28214d0e8ba47eca4",0)
SetVote("Voter.2","C.3.1.5fa52bc3609598e28214d0e8ba47eca4",0)
SetVote("Voter.3","C.3.1.5fa52bc3609598e28214d0e8ba47eca4",0)

SetVote("Voter.4","C.3.2.5fa52bc3609598e28214d0e8ba47eca4",0)
SetVote("Voter.5","C.3.2.5fa52bc3609598e28214d0e8ba47eca4",0)
SetVote("Voter.6","C.3.2.5fa52bc3609598e28214d0e8ba47eca4",0)

AdvanceChain()


# Formatting the data from panzea phenotype database
# Jinliang Yang
# Jan 17th, 2012
# server .7

setwd("/Users/yangjl/Documents/VariationDB/pheno/panzea_pheno")
library(ggplot2)
############### BLUE function #################################
library(nlme)
BLUE <- function(data=krn, model=KRN~Genotype, random=~1|Datasource/Farm/Year, trait="KRN", intercept="B73"){
  lmeout1 <- lme(model, data=data, random=random);
  ped.hat1 <- lmeout1$coef$fixed;
  ped.hat1[-1] <- ped.hat1[-1]+ped.hat1[1];
  names(ped.hat1)[1]=intercept;
  names(ped.hat1) <- gsub("Genotype", "", names(ped.hat1));
  tped <- data.frame(Genotype=names(ped.hat1), trait=ped.hat1)
  names(tped)[2] <- trait;
  return(tped)
}
######################################################################################
namid <- read.table("~/Documents/Heterosis_GWAS/pheno2011/nam_parents", header=TRUE)
namid <- toupper(namid$parent)

diallel <- read.csv("~/Documents/Heterosis_GWAS/pheno2011/pheno_diallel_master_raw_040612.csv")
idx <- grep("@", diallel$Genotype)
pames <- diallel[idx,]

###### FUNCTION  ##############################################
getblue <- function(amesdata=pameskrn, panzeadata=pkrn, trait="KRN",
                    model=KRN~Genotype, nathan=FALSE){
  ####################### AMES data ----------------------------------
  amesdata <- amesdata[, c("p1", trait, "Farm")];
  names(amesdata)[1] <- "Genotype";
  amesdata[, trait] <- as.numeric(as.character(amesdata[, trait]));
  amesdata <- amesdata[!is.na(amesdata[, trait]),]

  blue1 <- BLUE(data=amesdata, model=model, random=~1|Farm, trait=trait);

  amesdata$Datasource <- "Ames";
  amesdata$Year <- "2011_Summer"

  ####################### Panzea data --------------------------------

  if(nathan){
    intercept="B97"
    cols <- c("Env", "INBRED", paste(trait, "Inbred", sep="_"));
    panzeadata <- panzeadata[, cols]
    panzeadata$Datasource <- "Panzea";
    panzeadata$Year <- "2011_Summer";
    panzeadata <- panzeadata[, c("INBRED",paste(trait, "Inbred", sep="_"),"Env","Datasource", "Year")];
    panzeadata <- panzeadata[panzeadata[,paste(trait, "Inbred", sep="_") ]!=".",]
  } else {
    intercept="B73"
    cols <- c("Evaluation.Locality", "Rep", "Accession", "Phenotype.Value");
    panzeadata <- panzeadata[, cols]
    panzeadata$Datasource <- "Panzea";
    panzeadata <- panzeadata[, c("Accession","Phenotype.Value", "Evaluation.Locality", "Datasource", "Rep")];
    panzeadata$Phenotype.Value <- as.character(panzeadata$Phenotype.Value)
    for(i in 1:nrow(panzeadata)){
      tem0 <- unlist(strsplit(panzeadata[i,"Phenotype.Value"], split=";"))
      panzeadata[i,"Phenotype.Value"] <- as.numeric(gsub("mean=", "", tem0[1]))
    }
  }

  names(panzeadata) <- names(amesdata)
  panzeadata$Genotype <- toupper(panzeadata$Genotype)
  panzeadata <- subset(panzeadata, Genotype %in% namid)
  panzeadata[, trait] <- as.numeric(as.character(panzeadata[, trait]))

  blue2 <- BLUE(data=panzeadata, model=model, random=~1|Datasource/Farm/Year, trait=trait, intercept=intercept)

  alldata <- rbind(amesdata, panzeadata)
  blue3 <- BLUE(data=alldata, model=model, random=~1|Datasource/Farm/Year, trait=trait)

  myblue <- merge(blue1, blue2, by="Genotype", all=TRUE)
  myblue<- merge(myblue, blue3, by="Genotype", all=TRUE)
  names(myblue) <- c("Genotype", "Amesdata", "Panzeadata", trait)
  return(myblue)
}

#####################################################################################################
# KRN: ames data, remvoe the annotated ones (normally not well developed);
# KRN: panzea data, (Farm, Year and different datasource)
pames$Note_KRN <- as.character(pames$Note_KRN)
pameskrn <- pames[pames$Note_KRN=="", ]
pkrn <- read.csv("panzea_KRN.csv")
#nathan <- read.csv("~/Documents/Heterosis_GWAS/pheno2011/Nathan_p1_subset.csv")

krnblue <- getblue(amesdata=pameskrn, panzeadata=pkrn, trait="KRN",model=KRN~Genotype, nathan=FALSE)

###### 2. EAR-KC Nathan ##############################################
# KC: ames data, remove the annotated ones and the one have less than 40 observations
# KC: panzea data from Nathan, which only have four locations
pames$Note_ear <- as.character(pames$Note_ear)
ear <- pames[pames$Note_ear=="" & pames$KC >40, ]
nathan <- read.csv("~/Documents/Heterosis_GWAS/pheno2011/Nathan_p1_subset.csv")

kcblue <- getblue(amesdata=ear, panzeadata=nathan, trait="KC", model=KC~Genotype, nathan=TRUE)

###### 3. EAR-TKW Nathan ##############################################
# TKW: ames data, remove the annotated ones and the one have less than 40 observations
# TKW: panzea data from Nathan, which only have four locations
pames$Note_ear <- as.character(pames$Note_ear)
ear <- pames[pames$Note_ear=="" & pames$KC >40, ]
nathan <- read.csv("~/Documents/Heterosis_GWAS/pheno2011/Nathan_p1_subset.csv")

tkwblue <- getblue(amesdata=ear, panzeadata=nathan, trait="TKW", model=TKW~Genotype, nathan=TRUE)

###### 4. EAR-AKW Nathan ##############################################
# TKW: ames data, remove the annotated ones and the one have less than 40 observations
# TKW: panzea data from Nathan, which only have four locations
pames$Note_ear <- as.character(pames$Note_ear)
ear <- pames[pames$Note_ear=="" & pames$KC >40, ]
nathan <- read.csv("~/Documents/Heterosis_GWAS/pheno2011/Nathan_p1_subset.csv")
nathan <- nathan[nathan$X10KW_Inbred !=".",]
nathan$X10KW_Inbred <- as.numeric(as.character(nathan$X10KW_Inbred))/10
names(nathan)[7] <- "AKW_Inbred"

akwblue <- getblue(amesdata=ear, panzeadata=nathan, trait="AKW", model=AKW~Genotype, nathan=TRUE)

###### 5. COB-CD Nathan ##############################################
# CD: ames data, remove the annotated ones
# CD: panzea data from Nathan, which only have four locations
pames$Note_cob <- as.character(pames$Note_cob)
cob <- pames[pames$Note_cob=="", ]
#nathan <- read.csv("~/Documents/Heterosis_GWAS/pheno2011/Nathan_p1_subset.csv")
pcd <- read.csv("panzea_CD.csv")

cdblue <- getblue(amesdata=cob, panzeadata=pcd, trait="CD", model=CD~Genotype, nathan=FALSE)

###### 6. COB-CW Nathan ##############################################
# CW: ames data, remove the annotated ones
# CW: panzea data from Nathan, which only have four locations
pames$Note_cob <- as.character(pames$Note_cob)
cob <- pames[pames$Note_cob=="", ]
#nathan <- read.csv("~/Documents/Heterosis_GWAS/pheno2011/Nathan_p1_subset.csv")
pcw <- read.csv("panzea_CW.csv")
cwblue <- getblue(amesdata=cob, panzeadata=pcw, trait="CW", model=CW~Genotype, nathan=FALSE)

###### 7. COB-CL Nathan ##############################################
# CL: ames data, remove the annotated ones
# CL: panzea data from Nathan, which only have four locations
pames$Note_cob <- as.character(pames$Note_cob)
cob <- pames[pames$Note_cob=="", ]
nathan <- read.csv("~/Documents/Heterosis_GWAS/pheno2011/Nathan_p1_subset.csv")
#pcl <- read.csv("panzea_KRN.csv")
clblue <- getblue(amesdata=cob, panzeadata=nathan, trait="CL", model=CL~Genotype, nathan=TRUE)
#######################################################################################################################

ptrait <- merge(krnblue[, c(1,4)], kcblue[, c(1,4)], by="Genotype")
ptrait <- merge(ptrait, tkwblue[, c(1,4)], by="Genotype")
ptrait <- merge(ptrait, akwblue[, c(1,4)], by="Genotype")
ptrait <- merge(ptrait, cdblue[, c(1,4)], by="Genotype")
ptrait <- merge(ptrait, cwblue[, c(1,4)], by="Genotype")
ptrait <- merge(ptrait, clblue[, c(1,4)], by="Genotype")

write.table(ptrait, "/Users/yangjl/Documents/Heterosis_GWAS/pheno2011/cache/pheno_namparents_BLUE.csv", sep=",", row.names=FALSE, quote=FALSE)


source("_common.r")
x = readLines("../runs/summit/dgemm/openblas_cuda.txt")
df = process(x, gpu=TRUE)

plotter(df, color=ngpu) +
  facet_wrap(.~tile) +
  labs(color="Number of GPUs") +
  ggtitle("Square Matrix Product", subtitle="NVBLAS from R")

ggsave(last_plot(), file="nvblas.pdf")


library(Seurat)
library(ggplot2)
library(cowplot)
library(data.table)
library(DoubletFinder)
library(pheatmap)
library(future)
library(magrittr) # needs to be run every time you start R and want to use %>%
library(dplyr)
library('org.Hs.eg.db')
library(limma)

seurat_recipet = function(expr){
expr_obj = CreateSeuratObject(expr)
expr_obj = NormalizeData(expr_obj, normalization.method = "LogNormalize", scale.factor = 10000)
expr_obj = ScaleData(expr_obj)
expr_obj = FindVariableFeatures(expr_obj, selection.method = "vst", nfeatures = 2000)
expr_obj = RunPCA(expr_obj, features = VariableFeatures(object = expr_obj), npcs = 100)
expr_obj
}

write_csv = function(vec, fn){write.table(vec, file = fn, append = FALSE, quote = FALSE, sep = ",",
                eol = "\n", na = "NA", dec = ".", row.names = TRUE,
                col.names = TRUE, qmethod = c("escape", "double"),
                fileEncoding = "")}

folder_to_read = paste0('../processed_data/clean_data/')
exprs=read.csv(paste0(folder_to_read, 'gene_expression.csv'), row.names=1, header=T , check.names = F)
exprs=t(exprs)

meta=read.csv(paste0(folder_to_read, 'metadata.csv'), row.names=1, header=T, check.names = F)
abrain = seurat_recipet(exprs)

Idents(abrain) = meta$celltype

abrain.markers=FindAllMarkers(object = abrain, min.pct= 0.3)

saveRDS(abrain.markers, file = paste0(folder_to_read, "seurat.marker.list.rds"))
topgene=abrain.markers %>% group_by(cluster) %>% top_n(n = 10, wt = avg_logFC)
write_csv(topgene, paste0(folder_to_read,'seurat_topgene.csv'))
write_csv(as.data.frame(abrain.markers), paste0(folder_to_read, 'seurat_markers.csv') )

bk_genes = mapIds(org.Hs.eg.db, rownames(abrain@assays$RNA), 'ENTREZID', 'SYMBOL')

for (ct in unique(meta$celltype))
{
    fn_go = paste0(folder_to_read, ct, '_go.csv')
    markers = as.data.frame(abrain.markers[abrain.markers[ ,6] == ct, ])

    ind = (markers$p_val_adj < 0.05) & (markers$avg_logFC > 0.2)
    #ind = (markers$p_val_adj < 0.05)
    sgenes = markers[ind, ]
    ind = rev(order(sgenes$avg_logFC))[1:50]
    sgenes = sgenes[ind, ]$gene

    sgene_id = mapIds(org.Hs.eg.db, sgenes, 'ENTREZID', 'SYMBOL')

    go = goana(sgene_id, universe = bk_genes)

    write.table(go, file = fn_go, append = FALSE, sep = ",",
                eol = "\n", na = "NA", dec = ".", row.names = TRUE,
                col.names = TRUE, qmethod = c("escape", "double"),
                fileEncoding = "")

    }


calc_fstat <- function(infile,outdir,scores){
    ifelse(dir.exists(outdir),print("Ouput Directory Exisits"),dir.create(outdir))

    in_data <- read.table(infile,header = T,sep = "\t")
    colnames(in_data) <- c("gene","go_id","score")
    hist(in_data$score)

    #pred_file,test_file,gene_perf_out
    test_file <- "test_datasets/maizegdb/annot/maizegdb_annot.txt"
    tool_name <- gsub(".*/","",dirname(infile))[[1]]
    pred_file <- paste("tmp/",tool_name,".txt",sep = "")

    tmp_fstat <- lapply(scores,function(x){
        if(T){
            filt_data <- in_data[in_data$score>=x,]
            if(dim(filt_data)[1]>0){
                write.table(filt_data,pred_file,quote = F,sep = "\t",row.names = F,col.names = T)
                out_file <- paste(outdir,"/",x,sep = "")

                all_perf <- go_pred_perform(pred_file,test_file,out_file)
                if(!is.null(all_perf)){
                    all_perf <- data.frame(all_perf)
                    colnames(all_perf)[7] <- "GO"
                    all_perf[,2:6] = as.data.frame(lapply(all_perf[,2:6],function(x){as.numeric(as.character(x))}))
                    all_perf_dt <- data.table(all_perf)

                    pr_rc <- all_perf_dt[,list(pr=calc_pr(num_tp,num_fp),rc=calc_rc(num_tp,num_fn)),by=GO]
                    fstat <- (2*pr_rc$pr*pr_rc$rc)/(pr_rc$pr+pr_rc$rc)
                    pr_rc <- cbind(pr_rc,fstat,th=x)
                    pr_rc
                }else{
                    NULL
                }
            }else{
                NULL
            }
        }
    })

    tmp_fstat
    fstats <- do.call(rbind,tmp_fstat)
    barplot(fstats[fstats$GO=="MF"]$fstat,ylim = c(0,1),names.arg = fstats[fstats$GO=="MF"]$th)
    barplot(fstats[fstats$GO=="BP"]$fstat,ylim = c(0,1),names.arg = fstats[fstats$GO=="BP"]$th)
    barplot(fstats[fstats$GO=="CC"]$fstat,ylim = c(0,1),names.arg = fstats[fstats$GO=="CC"]$th)

    dim(in_data[in_data$score>=0.5,])
    onts <- Ontology(as.character(in_data$go_id))
    in_data_ont <- cbind(in_data,onts)
    in_data_ont <- in_data_ont[!is.na(onts),]

    head(in_data_ont)

    plot(fstats[fstats$GO=="MF"]$rc,fstats[fstats$GO=="MF"]$pr,type="l",xlim=c(0,1),ylim=c(0,1),xlab="Precision",ylab="Recall")

}

calc_pr <- function(num_tp,num_fp){
    pr <- mean(num_tp/(num_tp+num_fp))
    return(pr)
}

calc_rc <- function(num_tp,num_fn){
    rc <- mean(num_tp/(num_tp+num_fn))
    return(rc)
}