library(RColorBrewer)
library(VGAM)
library(smatr)

geneAnnotation = read.table("ensemblGenes_ensembl83_160307_MOD.txt", sep="\t", stringsAsFactors=FALSE, head=TRUE)
rownames(geneAnnotation) = geneAnnotation[,1]
allNames <- geneAnnotation[, "geneName"]
names(allNames) <- geneAnnotation[,1]
allNames[which(allNames == "")] <- names(allNames)[which(allNames == "")]

allNamesInv <- names(allNames)
names(allNamesInv) <- allNames

load("R_jointASEData")
# previously generated in initial ASE comparison:
load("R_localeQTL_170222.RData")
rownames(localeQTL) <- localeQTL$gene

AlbertCounts <- read.table("Albert_2014_hybridCounts.txt", sep="\t", head=TRUE, stringsAsFactors=FALSE)
rownames(AlbertCounts) <- AlbertCounts[,1]
AlbertCounts <- AlbertCounts[,2:3]
summary(rowSums(AlbertCounts))
#   Min. 1st Qu.  Median    Mean 3rd Qu.    Max.
#20.0    75.0   188.0   535.4   447.0 33170.0

# AlbertCounts has two genes that are not in jointASEdata
# force the two to have the same genes:
AlbertCounts <- AlbertCounts[rownames(jointASEData),]

# Noori data
load("R_NooriCountByGeneDownSampled_170316.RData")
NooriCountByGeneDownSampled <- NooriCountByGeneDownSampled[rownames(jointASEData),]

######################################################
# need to incorporate overdispersion into the simulations
# for that, need to find an overdispersion parameter that matches the observed data

# ASEdat has 3 columns: observed count for one allele, total coverage, "true" fold change
omDbetabinom=function(targetRho, ASEdat) {
    -sum(dbetabinom(ASEdat$AlleleCount, ASEdat$Coverage, ASEdat$Prob, targetRho, log=TRUE))
}

ASEdat4OptimAlbert <- data.frame(
    AlbertCounts[, 1],
    rowSums(AlbertCounts),
    (jointASEData[,"NooriFC"] + jointASEData[,"AlbertFC"] / 2)
)
ASEdat4OptimAlbert[,3] <- 2^ASEdat4OptimAlbert[,3] / ( 1 + 2^ASEdat4OptimAlbert[,3])
names(ASEdat4OptimAlbert) <- c("AlleleCount", "Coverage", "Prob")

optimResultAlbert <- optim(0.5, omDbetabinom, ASEdat = ASEdat4OptimAlbert, method='Brent', lower=1/1e8, upper=1)
optimResultAlbert$par
# 0.005365516

ASEdat4OptimNoori <- data.frame(
    NooriCountByGeneDownSampled[, 1],
    rowSums(NooriCountByGeneDownSampled),
    (jointASEData[,"NooriFC"] + jointASEData[,"AlbertFC"] / 2)
)
ASEdat4OptimNoori[,3] <- 2^ASEdat4OptimNoori[,3] / ( 1 + 2^ASEdat4OptimNoori[,3])
names(ASEdat4OptimNoori) <- c("AlleleCount", "Coverage", "Prob")

optimResultNoori <- optim(0.5, omDbetabinom, ASEdat = ASEdat4OptimNoori, method='Brent', lower=1/1e8, upper=1)
optimResultNoori$par
# 0.00414922
# similar, but not the same

# in https://www.ncbi.nlm.nih.gov/pmc/articles/PMC4837449/
# they essentially follow our procedure, but treat ALL genes as hvaing expected prob=0.5
# this was also done in Pritchard's WASP: http://www.nature.com/nmeth/journal/v12/n11/extref/nmeth.3582-S1.pdf & http://www.nature.com/nmeth/journal/v12/n11/full/nmeth.3582.html

# so let's try it too:
ASEdat4OptimAll0.5_Albert <- ASEdat4OptimAlbert
ASEdat4OptimAll0.5_Albert$Prob <- 0.5
optimResultAlbert_all0.5 <- optim(0.5, omDbetabinom, ASEdat = ASEdat4OptimAll0.5_Albert, method='Brent', lower=1/1e8, upper=1)
optimResultAlbert_all0.5$par
# 0.01284717
# big, but less than when using the eQTL FCs

ASEdat4OptimAll0.5_Noori <- ASEdat4OptimNoori
ASEdat4OptimAll0.5_Noori$Prob <- 0.5
optimResultNoori_all0.5 <- optim(0.5, omDbetabinom, ASEdat = ASEdat4OptimAll0.5_Noori, method='Brent', lower=1/1e8, upper=1)
optimResultNoori_all0.5$par
# 0.009470975

################################################
# simulate counts without overdispersion

# function to generate paired count data
simulateCountsBinom <- function(thisFC, coverage){
        thisX <- (thisFC * coverage) / (1 + thisFC)
        thisProb = thisX/coverage
        thisRandomCount = rbinom(1, coverage, thisProb)
        c(thisRandomCount, coverage - thisRandomCount)
}

# 2^(localeQTL$"naturalLMCoeff" * 2)[1]
simCountsBinomial <- t(sapply(1:10000, function(i){simulateCountsBinom(0.5, 100)}))

# how well does this recapitulate the observed spread in the ASE data?
oneRandomASESampleAcrossGenesBinom <- function(theseGenes){
    t(sapply(theseGenes, function(x){
        thisFC <- 2^((jointASEData[x, "NooriFC"] + jointASEData[x, "AlbertFC"]) / 2)
        thisCov <- rowSums(AlbertCounts[x,])
        if (is.na(thisCov) | is.na(thisFC)){return(c(NA, NA))}
        simCounts <- simulateCountsBinom(thisFC, thisCov)
        simCounts
    }))
}
oneRandomASESampleAcrossGenesBinom(rownames(jointASEData)[1:3])

# make 100 sets and get the respective FCs
binomialFCs <- sapply(1:100, function(i){
    print(i)
    thisSet <- oneRandomASESampleAcrossGenesBinom(rownames(jointASEData))
    log2(thisSet[,1] / thisSet[,2])
})

################################################
# simulate counts with overdispersion

# function to generate paired count data
# default is for Albert data
simulateCountsBetaBinom <- function(thisFC, coverage, rho=0.005365516){
    thisX <- (thisFC * coverage) / (1 + thisFC)
    thisProb = thisX/coverage
    thisRandomCount = rbetabinom(1, coverage, thisProb, rho)
    c(thisRandomCount, coverage - thisRandomCount)
}
simCountsBetaBinomialAlbert <- t(sapply(1:10000, function(i){simulateCountsBetaBinom(0.5, 100, 0.01284717)}))
simCountsBetaBinomialNoori <- t(sapply(1:10000, function(i){simulateCountsBetaBinom(0.5, 100, 0.009470975)}))

oneRandomASESampleAcrossGenesBetaBinomAlbert <- function(theseGenes){
    t(sapply(theseGenes, function(x){
        thisFC <- 2^((jointASEData[x, "NooriFC"] + jointASEData[x, "AlbertFC"]) / 2)
        thisCov <- rowSums(AlbertCounts[x,])
        if (is.na(thisCov) | is.na(thisFC)){return(c(NA, NA))}
        simCounts <- simulateCountsBetaBinom(thisFC, thisCov, rho=0.01284717)
        simCounts
    }))
}
oneRandomASESampleAcrossGenesBetaBinomNoori <- function(theseGenes){
    t(sapply(theseGenes, function(x){
        thisFC <- 2^((jointASEData[x, "NooriFC"] + jointASEData[x, "AlbertFC"]) / 2)
        thisCov <- sum(NooriCountByGeneDownSampled[x,])
        if (is.na(thisCov) | is.na(thisFC)){return(c(NA, NA))}
        simCounts <- simulateCountsBetaBinom(thisFC, thisCov, rho=0.009470975)
        simCounts
    }))
}

# make 50 sets and get the respective FCs
betaBinomialFCsAlbert <- sapply(1:50, function(i){
    print(i)
    thisSet <- oneRandomASESampleAcrossGenesBetaBinomAlbert(rownames(jointASEData))
    log2(thisSet[,1] / thisSet[,2])
})
betaBinomialFCsNoori <- sapply(1:50, function(i){
    print(i)
    thisSet <- oneRandomASESampleAcrossGenesBetaBinomNoori(rownames(jointASEData))
    log2(thisSet[,1] / thisSet[,2])
})

# compare the three sets of simulated data
pdf("ASE_binomialVsbetaBinomial.pdf")
boxplot(list(simCountsBinomial[,1] / simCountsBinomial[,2], simCountsBetaBinomialAlbert[,1] / simCountsBetaBinomialAlbert[,2], simCountsBetaBinomialNoori[,1] / simCountsBetaBinomialNoori[,2]), names=c("binomial", "betabinomial Albert", "betabinomial Noori"))
dev.off()

summary(simCountsBinomial[,1] / simCountsBinomial[,2])
#    Min. 1st Qu.  Median    Mean 3rd Qu.    Max.
# 0.1905  0.4286  0.4925  0.5066  0.5625  1.0410
sd(simCountsBinomial[,1] / simCountsBinomial[,2])
# 0.1089637

summary(simCountsBetaBinomialAlbert[,1] / simCountsBetaBinomialAlbert[,2])
#    Min. 1st Qu.  Median    Mean 3rd Qu.    Max.
# 0.08696 0.38890 0.49250 0.51710 0.61290 1.50000
sd(simCountsBetaBinomialAlbert[,1] / simCountsBetaBinomialAlbert[,2])
# 0.1722746

summary(simCountsBetaBinomialNoori[,1] / simCountsBetaBinomialNoori[,2])
#    Min. 1st Qu.  Median    Mean 3rd Qu.    Max.
# 0.1236  0.4085  0.4925  0.5152  0.6129  1.5640
sd(simCountsBetaBinomialNoori[,1] / simCountsBetaBinomialNoori[,2])
# 0.156884

# spread is wider in betabinom, and a tiny little bit wider in Albert vs Noori

# how do the two sets of FCs compare to the observed spread between datasets?
# what is the real correlation between Noori & Albert?
cor.test(jointASEData[,"NooriFC"], jointASEData[,"AlbertFC"])
# r = 0.3909369

# what are correlations between two typical binomial datasets (we'd expect these to be better than Noori/Albert, i.e. too good)
binomialCorrelations <- sapply(1:ncol(binomialFCs), function(i){
    sapply(1:ncol(binomialFCs), function(j){
        if(i >= j){return(NA)}
        cor.test(binomialFCs[,i], binomialFCs[,j])$est
    })
})
summary(as.numeric(binomialCorrelations))
# Min. 1st Qu.  Median    Mean 3rd Qu.    Max.    NA's
#0.475   0.528   0.538   0.538   0.549   0.588    5535

# we'd expect the betaBinomials to be worse
# we can directly run a bunch of simulated Albert vs Noori comparisons
betaBinomialCorrelations <- sapply(1:ncol(betaBinomialFCsAlbert), function(i){
    sapply(1:ncol(betaBinomialFCsNoori), function(j){
        if(i >= j){return(NA)}
        cor.test(betaBinomialFCsAlbert[,i], betaBinomialFCsNoori[,j])$est
    })
})
summary(as.numeric(betaBinomialCorrelations))
#Min. 1st Qu.  Median    Mean 3rd Qu.    Max.    NA's
#0.3713  0.4058  0.4153  0.4147  0.4240  0.4584    1285
# this is pretty close, and seems to mimick the real construction of this distribution well

# what are the observed fold changes in the local eQTL
testFCs <- quantile(2^(abs(localeQTL$"naturalLMCoeff") * 2), probs=c(0, 0.25, 0.5, 0.75, 0.9, 0.95, 0.99))
# natural scale:
#0%      25%      50%      75%      90%      95%      99%
#1.020001 1.059405 1.099968 1.187402 1.415266 1.825191 5.841893
# wow, median is only 1.1 fold

# to get power for a different combinations of FC, simulate 1k at a given depth and test
nSims <- 1000
covRangeAlbert <- c(round(quantile(rowSums(AlbertCounts), probs=c(0.1, 0.5, 0.9))), 10, 20, 50, 100, 200, 500, 1000, 2000, 5000)
covRangeNoori <- c(round(quantile(rowSums(NooriCountByGeneDownSampled), probs=c(0.1, 0.5, 0.9))), 10, 20, 50, 100, 200, 500, 1000, 2000, 5000)
# pick one (Noori had higher depth)
covRange <- covRangeAlbert
#covRange <- covRangeNoori

# beta binomials
# careful with the variable assignments!
simpVals <- lapply(covRange, function(thisCov){
    sapply(testFCs, function(x){
        sapply(1:nSims, function(i){
            simCounts <- simulateCountsBetaBinom(x, thisCov, rho=0.009470975)
            binom.test(simCounts[1], sum(simCounts))$p.value
        })
    })
})
simFCs <- lapply(covRange, function(thisCov){
    sapply(testFCs, function(x){
        sapply(1:nSims, function(i){
            simCounts <- simulateCountsBetaBinom(x, thisCov, rho=0.009470975)
            simCounts[1]/simCounts[2]
        })
    })
})

simPower <- lapply(simpVals, function(y){
    apply(y, 2, function(x){
        c(length(which(x < 0.05)), length(which(x < (0.05/nrow(AlbertCounts)))))/length(x)
    })
})

simDirCorrect <- lapply(simFCs, function(y){
    apply(y, 2, function(x){
        length(which(x > 1))/length(x)
    })
})

#pdf("ASE_powerSim.pdf", width=12, height=4)
#pdf("ASE_powerSim_betaBinomialAlbert.pdf", width=12, height=4)
#pdf("ASE_powerSim_betaBinomialNoori.pdf", width=12, height=4)

par(mfrow=c(1,3))
plotCols = colorRampPalette(brewer.pal(9, "YlOrRd"))(length(covRange))
plotCols[c(1, 3)] <- "grey"
plotCols[2] <- "blue"
lwds=rep(1, length(covRange))
lwds[1:3] <- 3
plotTypes <- rep("l", length(covRange))
plotTypes[1:3] <- "l"
ltys <- rep(2, length(covRange))
ltys[1:3] <- 1

FCHist <- hist((abs(localeQTL$"naturalLMCoeff") * 2), plot=FALSE, breaks=30)

plot(log2(testFCs), simPower[[1]][1,], type="n", ylim=c(0,1), xlim=c(0, log2(max(testFCs))), ylab="power", xlab="log2(fold change)", main="nominal power")
polygon(c(FCHist$mids, rev(FCHist$mids)), c(FCHist$density/max(FCHist$density), rep(0, length(FCHist$mids))), col="lightgreen", border=NA)
for (i in 1:length(simPower)){
    points(log2(testFCs), simPower[[i]][1,], col=plotCols[i], type=plotTypes[i], lwd=lwds[i], lty=ltys[i])
}

plot(log2(testFCs), simPower[[1]][2,], type="n", ylim=c(0,1), xlim=c(0, log2(max(testFCs))), ylab="power", xlab="log2(fold change)", main="Bonferroni power")
polygon(c(FCHist$mids, rev(FCHist$mids)), c(FCHist$density/max(FCHist$density), rep(0, length(FCHist$mids))), col="lightgreen", border=NA)
for (i in 1:length(simPower)){
    points(log2(testFCs), simPower[[i]][2,], col=plotCols[i], type=plotTypes[i], lwd=lwds[i], lty=ltys[i])
}

plot(log2(testFCs), simPower[[1]][2,], type="n", ylim=c(0,1), xlim=c(0, log2(max(testFCs))), ylab="fraction correct", xlab="log2(fold change)", main="directional agreement")
polygon(c(FCHist$mids, rev(FCHist$mids)), c(FCHist$density/max(FCHist$density), rep(0, length(FCHist$mids))), col="lightgreen", border=NA)
for (i in 1:length(simPower)){
    points(log2(testFCs), simDirCorrect[[i]], col=plotCols[i], type=plotTypes[i], lwd=lwds[i], lty=ltys[i])
}

legend("bottomright", box.lty=0, col=plotCols, lwd=lwds, lty=ltys, legend=c("10th percentile observed", "median observed", "90th percentile observed", covRange[4:length(covRange)]))

dev.off()

# for the median FC, power with Bonferroni reaches ≥80% at 1k coverage
# but the direction of effect is already correctly estimated 50% of time at 10X
# ≥90% at 100X

###################################
# calculate power for each local eQTL, with coverage specific for that gene

# first, restrict eQTL to det that are in ASE data
localeQTLForASE <- localeQTL[localeQTL$gene %in% rownames(jointASEData),]

nSimByGene <- 100
powerByGeneAlbert <- t(apply(localeQTLForASE, 1, function(x){
    print(x["gene"])
    thisFC <- 2^(as.numeric(x["naturalLMCoeff"])*2)
    thisCov <- rowSums(AlbertCounts)[x["gene"]]
    if (is.na(thisCov) | is.na(thisFC)){return(c(NA, NA))}
    thesePs <- sapply(1:nSimByGene, function(i){
        simCounts <- simulateCountsBetaBinom(thisFC, thisCov, rho=0.01284717)
        binom.test(simCounts[1], sum(simCounts))$p.value
    })
    c(length(which(thesePs < 0.05)), length(which(thesePs < (0.05/nrow(AlbertCounts)))))/length(thesePs)
}))

powerByGeneNoori <- t(apply(localeQTLForASE, 1, function(x){
    print(x["gene"])
    thisFC <- 2^(as.numeric(x["naturalLMCoeff"])*2)
    thisCov <- rowSums(NooriCountByGeneDownSampled)[x["gene"]]
    if (is.na(thisCov) | is.na(thisFC)){return(c(NA, NA))}
    thesePs <- sapply(1:nSimByGene, function(i){
        simCounts <- simulateCountsBetaBinom(thisFC, thisCov, rho=0.009470975)
        binom.test(simCounts[1], sum(simCounts))$p.value
    })
    c(length(which(thesePs < 0.05)), length(which(thesePs < (0.05/nrow(NooriCountByGeneDownSampled)))))/length(thesePs)
}))

# how many can be detected with Bonferroni?
length(which(!is.na(powerByGeneAlbert[,2])))
# beta (Albert & Noori): 1974
length(which(powerByGeneAlbert[,2] > 0.8 & !is.na(powerByGeneAlbert[,2])) )

# beta-binomial Albert:
# power > 0.5: 138
# power > 0.8: 36

length(which(powerByGeneNoori[,2] > 0.5 & !is.na(powerByGeneNoori[,2])) )
# beta-binomial Noori:
# power > 0.5: 541
# power > 0.8: 132
# higher power in Noori, probably because of higher counts there?

# and how many are powered in both?
length(which(powerByGeneAlbert[,2] > 0.8 & !is.na(powerByGeneAlbert[,2]) & powerByGeneNoori[,2] > 0.8 & !is.na(powerByGeneNoori[,2])) )
# 0.5: 131
# 0.8: 34
# so the well powered Albert genes are mostly contained in the powered Noori genes

# for comparing to real data, make eQTL and ASE lists the same
jointASEDataForeQTL <- jointASEData[localeQTLForASE$gene,]

# how many genes DO we see significant at Bonferroni?
bonfCut <- 0.05/nrow(jointASEData)
length(which(jointASEDataForeQTL[,"NooriB"] < bonfCut))
# 406
length(which(jointASEDataForeQTL[,"AlbertB"] < bonfCut))
# 145
length(which(jointASEDataForeQTL[,"AlbertB"] < bonfCut & jointASEDataForeQTL[,"NooriB"] < bonfCut))
# 100

directionByGeneAlbert <- apply(localeQTLForASE, 1, function(x){
    thisFC <- 2^(as.numeric(x["naturalLMCoeff"])*2)
    thisCov <- rowSums(AlbertCounts)[x["gene"]]
    if (is.na(thisCov) | is.na(thisFC)){return(NA)}
    theseDirs <- sapply(1:nSimByGene, function(i){
        simCounts <- simulateCountsBetaBinom(thisFC, thisCov, rho=0.01284717)
        sign(log2(simCounts[1]/simCounts[2])) == sign(log2(thisFC))
    })
    length(which(theseDirs))/length(theseDirs)
})

directionByGeneNoori <- apply(localeQTLForASE, 1, function(x){
    thisFC <- 2^(as.numeric(x["naturalLMCoeff"])*2)
    thisCov <- rowSums(NooriCountByGeneDownSampled)[x["gene"]]
    if (is.na(thisCov) | is.na(thisFC)){return(NA)}
    theseDirs <- sapply(1:nSimByGene, function(i){
        simCounts <- simulateCountsBetaBinom(thisFC, thisCov, rho=0.009470975)
        sign(log2(simCounts[1]/simCounts[2])) == sign(log2(thisFC))
    })
    length(which(theseDirs))/length(theseDirs)
})

# how many are majority same direction?
length(which(!is.na(directionByGeneAlbert) & directionByGeneAlbert > 0.8))
# beta binomial Albert:
# 0.8: 233

length(which(!is.na(directionByGeneNoori) & directionByGeneNoori > 0.8))
# 0.8: 392

# OK, the above is for numbers of genes.
# what about gene identities: how many of the individual powered genes DO we see as significant?
# attach power to local eQTL

localeQTLForASEWithPower <- cbind(localeQTLForASE, powerByGeneNoori, powerByGeneAlbert, directionByGeneNoori, directionByGeneAlbert, jointASEDataForeQTL[,1:4], NooriCountByGeneDownSampled[localeQTLForASE$gene,], AlbertCounts[localeQTLForASE$gene,])
colnames(localeQTLForASEWithPower)[21:24] <- c("NooriPowerNominal", "NooriPowerBonferroni", "AlbertPowerNominal", "AlbertPowerBonferroni")
colnames(localeQTLForASEWithPower)[31:34] <- c("NooriBYCount", "NooriRMCount", "AlbertBYCount", "AlbertRMCount")

nrow(localeQTLForASEWithPower[localeQTLForASEWithPower$NooriPowerBonferroni >= 0.8 & localeQTLForASEWithPower$AlbertPowerBonferroni >= 0.8,])
# 35 for >= 0.8, 34 for
# how many are NOT detected?
nrow(localeQTLForASEWithPower[localeQTLForASEWithPower$NooriPowerBonferroni >= 0.8 & localeQTLForASEWithPower$AlbertPowerBonferroni >= 0.8 & localeQTLForASEWithPower$sigDeciderBonferroni == 0 ,])
# 5:
#"YJR060W": CBF1
#"YKL210W": UBA1
#"YKR059W": TIF1
#"YLR261C" VPS63
#"YOR273C" TPO4

# how many found in only one dataset?
nrow(localeQTLForASEWithPower[localeQTLForASEWithPower$NooriPowerBonferroni >= 0.8 & localeQTLForASEWithPower$AlbertPowerBonferroni >= 0.8 & localeQTLForASEWithPower$sigDeciderBonferroni == 1 ,])
# 4
# how many found in two dataset?
nrow(localeQTLForASEWithPower[localeQTLForASEWithPower$NooriPowerBonferroni >= 0.8 & localeQTLForASEWithPower$AlbertPowerBonferroni >= 0.8 & localeQTLForASEWithPower$sigDeciderBonferroni == 2 ,])
# 26

# make plots where ASE power is highlighted:

pdf("ASE_vs_eQTLFC_withPower.pdf", width=12, height=12)
plotCol <- rep("#00000022", nrow(localeQTLForASEWithPower))
plotCol[localeQTLForASEWithPower$sigDeciderBonferroni == 1] <- "#FF000022"
plotCol[localeQTLForASEWithPower$sigDeciderBonferroni == 2] <- "red"
names(plotCol) <- localeQTLForASEWithPower$gene

circleCol <- rep("#00000000", nrow(localeQTLForASEWithPower))
circleCol[localeQTLForASEWithPower$NooriPowerBonferroni >= 0.8 | localeQTLForASEWithPower$AlbertPowerBonferroni >= 0.8] <- "lightblue"
circleCol[localeQTLForASEWithPower$NooriPowerBonferroni >= 0.8 & localeQTLForASEWithPower$AlbertPowerBonferroni >= 0.8] <- "blue"
names(circleCol) <- localeQTLForASEWithPower$gene

circleLwd <- rep(1, nrow(localeQTLForASEWithPower))
circleLwd[localeQTLForASEWithPower$NooriPowerBonferroni >= 0.8 & localeQTLForASEWithPower$AlbertPowerBonferroni >= 0.8] <- 2
names(circleLwd) <- localeQTLForASEWithPower$gene

par(mfrow=c(2,2))

plot(localeQTLForASEWithPower$ASE, localeQTLForASEWithPower$"naturalLMCoeff" * 2, pch=19, col=plotCol, ylab="local eQTL fold change", xlab="log2(ASE signal)", main="significant eQTL")
points(localeQTLForASEWithPower$ASE, localeQTLForASEWithPower$"naturalLMCoeff" * 2, col=circleCol, lwd=circleLwd)
abline(h=0, lwd=2, lty=2, col="grey")
abline(v=0, lwd=2, lty=2, col="grey")
abline(0, 1, lwd=2, lty=2, col="grey")

legend("bottomright", box.lty=0, col=c("#00000022", "#FF000022", "red","lightblue", "blue"), pch=c(19, 19, 19, 1, 1), legend=c("no significant ASE", "one significant ASE dataset", "two significant ASE datasets", "ASE power > 0.8 in one dataset", "ASE power > 0.8 in two datasets"))

textDecider <- ((localeQTLForASEWithPower$"sigDeciderBonferroni" == 0) & (localeQTLForASEWithPower$NooriPowerBonferroni >= 0.8 & localeQTLForASEWithPower$AlbertPowerBonferroni >= 0.8)) | (sign(localeQTLForASEWithPower$"naturalLMCoeff") != sign(localeQTLForASEWithPower$"ASE") & localeQTLForASEWithPower$"sigDeciderBonferroni" == 2 & sign(localeQTLForASEWithPower$"NooriFC") == sign(localeQTLForASEWithPower$"AlbertFC"))

text(localeQTLForASEWithPower$ASE[textDecider], localeQTLForASEWithPower$"naturalLMCoeff"[textDecider] * 2, labels = allNames[localeQTLForASEWithPower$gene[textDecider]], pos=4)

plot(localeQTLForASEWithPower$ASE, localeQTLForASEWithPower$"naturalLMCoeff" * 2, pch=19, col=plotCol, ylab="local eQTL fold change", xlab="log2(ASE signal)", main="significant eQTL", xlim=c(-2, 2), ylim=c(-2, 2))
points(localeQTLForASEWithPower$ASE, localeQTLForASEWithPower$"naturalLMCoeff" * 2, col=circleCol, lwd=circleLwd)
abline(h=0, lwd=2, lty=2, col="grey")
abline(v=0, lwd=2, lty=2, col="grey")
abline(0, 1, lwd=2, lty=2, col="grey")

plot(localeQTLForASEWithPower$ASE[localeQTLForASEWithPower$"sigDeciderBonferroni" > 0 | localeQTLForASEWithPower$NooriPowerBonferroni >= 0.8 | localeQTLForASEWithPower$AlbertPowerBonferroni >= 0.8], localeQTLForASEWithPower$"naturalLMCoeff"[localeQTLForASEWithPower$"sigDeciderBonferroni" > 0 | localeQTLForASEWithPower$NooriPowerBonferroni >= 0.8 | localeQTLForASEWithPower$AlbertPowerBonferroni >= 0.8] * 2, pch=19, col=plotCol[localeQTLForASEWithPower$"sigDeciderBonferroni" > 0 | localeQTLForASEWithPower$NooriPowerBonferroni >= 0.8 | localeQTLForASEWithPower$AlbertPowerBonferroni >= 0.8], ylab="local eQTL fold change", xlab="log2(ASE signal)", main="significant eQTL with significant ASE or high ASE power")
for(i in localeQTLForASEWithPower$gene[localeQTLForASEWithPower$"sigDeciderBonferroni" > 0 | localeQTLForASEWithPower$NooriPowerBonferroni >= 0.8 | localeQTLForASEWithPower$AlbertPowerBonferroni >= 0.8]){
        lines(-localeQTLForASEWithPower[i, c("NooriFC", "AlbertFC")], rep(localeQTLForASEWithPower[i,]$"naturalLMCoeff" * 2, 2), col=plotCol[i])
}
points(localeQTLForASEWithPower$ASE[localeQTLForASEWithPower$"sigDeciderBonferroni" > 0 | localeQTLForASEWithPower$NooriPowerBonferroni >= 0.8 | localeQTLForASEWithPower$AlbertPowerBonferroni >= 0.8], localeQTLForASEWithPower$"naturalLMCoeff"[localeQTLForASEWithPower$"sigDeciderBonferroni" > 0 | localeQTLForASEWithPower$NooriPowerBonferroni >= 0.8 | localeQTLForASEWithPower$AlbertPowerBonferroni >= 0.8] * 2, col=circleCol[localeQTLForASEWithPower$"sigDeciderBonferroni" > 0 | localeQTLForASEWithPower$NooriPowerBonferroni >= 0.8 | localeQTLForASEWithPower$AlbertPowerBonferroni >= 0.8], lwd=circleLwd[localeQTLForASEWithPower$"sigDeciderBonferroni" > 0 | localeQTLForASEWithPower$NooriPowerBonferroni >= 0.8 | localeQTLForASEWithPower$AlbertPowerBonferroni >= 0.8])
abline(h=0, lwd=2, lty=2, col="grey")
abline(v=0, lwd=2, lty=2, col="grey")
abline(0, 1, lwd=2, lty=2, col="grey")

plot(localeQTLForASEWithPower$ASE[localeQTLForASEWithPower$"sigDeciderBonferroni" > 0 | localeQTLForASEWithPower$NooriPowerBonferroni >= 0.8 | localeQTLForASEWithPower$AlbertPowerBonferroni >= 0.8], localeQTLForASEWithPower$"naturalLMCoeff"[localeQTLForASEWithPower$"sigDeciderBonferroni" > 0 | localeQTLForASEWithPower$NooriPowerBonferroni >= 0.8 | localeQTLForASEWithPower$AlbertPowerBonferroni >= 0.8] * 2, pch=19, col=plotCol[localeQTLForASEWithPower$"sigDeciderBonferroni" > 0 | localeQTLForASEWithPower$NooriPowerBonferroni >= 0.8 | localeQTLForASEWithPower$AlbertPowerBonferroni >= 0.8], ylab="local eQTL fold change", xlab="log2(ASE signal)", main="significant eQTL with significant ASE or high ASE power", xlim=c(-2, 2), ylim=c(-2, 2))
for(i in localeQTLForASEWithPower$gene[localeQTLForASEWithPower$"sigDeciderBonferroni" > 0 | localeQTLForASEWithPower$NooriPowerBonferroni >= 0.8 | localeQTLForASEWithPower$AlbertPowerBonferroni >= 0.8]){
    lines(-localeQTLForASEWithPower[i, c("NooriFC", "AlbertFC")], rep(localeQTLForASEWithPower[i,]$"naturalLMCoeff" * 2, 2), col=plotCol[i])
}
points(localeQTLForASEWithPower$ASE[localeQTLForASEWithPower$"sigDeciderBonferroni" > 0 | localeQTLForASEWithPower$NooriPowerBonferroni >= 0.8 | localeQTLForASEWithPower$AlbertPowerBonferroni >= 0.8], localeQTLForASEWithPower$"naturalLMCoeff"[localeQTLForASEWithPower$"sigDeciderBonferroni" > 0 | localeQTLForASEWithPower$NooriPowerBonferroni >= 0.8 | localeQTLForASEWithPower$AlbertPowerBonferroni >= 0.8] * 2, col=circleCol[localeQTLForASEWithPower$"sigDeciderBonferroni" > 0 | localeQTLForASEWithPower$NooriPowerBonferroni >= 0.8 | localeQTLForASEWithPower$AlbertPowerBonferroni >= 0.8], lwd=circleLwd[localeQTLForASEWithPower$"sigDeciderBonferroni" > 0 | localeQTLForASEWithPower$NooriPowerBonferroni >= 0.8 | localeQTLForASEWithPower$AlbertPowerBonferroni >= 0.8])
abline(h=0, lwd=2, lty=2, col="grey")
abline(v=0, lwd=2, lty=2, col="grey")
abline(0, 1, lwd=2, lty=2, col="grey")

dev.off()

# discordant directions:
localeQTLForASEWithPower[(sign(localeQTLForASEWithPower$"naturalLMCoeff") != sign(localeQTLForASEWithPower$"ASE") & localeQTLForASEWithPower$"sigDeciderBonferroni" == 2 & sign(localeQTLForASEWithPower$"NooriFC") == sign(localeQTLForASEWithPower$"AlbertFC")),]
# 3 genes:
# YGR192C (TDH3)
# YMR089C (YTA12)
# YOR046C (DBP5)

# write a table for the paper:
datForLocalEQTLTable <- localeQTLForASEWithPower
datForLocalEQTLTable$naturalLMCoeff <- 2*datForLocalEQTLTable$naturalLMCoeff
colnames(datForLocalEQTLTable)[colnames(datForLocalEQTLTable) == "naturalLMCoeff"] <- "log2eQTLFoldChange"
colnames(datForLocalEQTLTable)[colnames(datForLocalEQTLTable) == "ASE"] <- "log2ASEFoldChange"

write.table(datForLocalEQTLTable, file="ASE_localeQTL_table_170323.txt", quote=FALSE, col.names=TRUE, row.names=FALSE, sep="\t")


print("--------------- File soc-ec.r")

# read in soc-ec table
se <- read.csv("../modelInput/SocEc.csv", stringsAsFactors = FALSE)

# select what you want
se <- data.frame(
  fips = se$FIPS,
  state = se$State,
  area_name = se$Area_Name,
  pop = se$POP_ESTIMATE_2018,
  ## vars ##
  # income
  income = se$Median_Household_Income_2018,
  # density
  density = se$Density.per.square.mile.of.land.area...Population,
  # transit
  transit = se$transit_scores...population.weighted.averages.aggregated.from.town.city.level.to.county,
  # nICU beds
  icu_beds = se$ICU.Beds
)

# remove all rows with any na
se <- se[complete.cases(se), ]

## normalize scores

# density
maxDensity <- max(se$density, na.rm = TRUE)
se$ndensity <- sapply(se$density, function(x) x / maxDensity)

# income
maxIncome <- max(se$income, na.rm = TRUE)
se$nincome <- sapply(se$income, function(x) x / maxIncome)

# transit
maxTransit <- max(se$transit, na.rm = TRUE)
se$ntransit <- sapply(se$transit, function(x) x / maxTransit)

# nICU beds
maxICU <- max(se$icu_beds, na.rm = TRUE)
se$nicu_beds <- sapply(se$icu_beds, function(x) x / maxICU)

# normalized scores
ns <- data.frame(
  density = se$ndensity,
  income = se$nincome,
  transit = se$ntransit,
  icu = se$nicu_beds
)

# raw scores
rs <- data.frame(
  density = se$density,
  income = se$income,
  transity = se$transit,
  icu = se$icu_beds
)

##### mortality

# case-mortality table
d <- read.csv("../modelInput/CaseAndMortalityV2.csv", stringsAsFactors = FALSE)
d$date <- as.Date(d$dateRep, format = "%m/%d/%y")
d$countryterritoryCode <- sapply(d$countryterritoryCode, as.character)
d$countryterritoryCode <- sub("840", "", d$countryterritoryCode)

codeToName <- unique(data.frame("countyCode" = d$countryterritoryCode, "countyName" = d$countriesAndTerritories))
countries <- unique(d$countryterritoryCode)

##### mobility

# Read google mobility
source("./read-mobility.r")
mobility <- read_google_mobility(countries = countries, codeToName = codeToName)

# basic impute values for NA in google mobility
# see: https://github.com/ImperialCollegeLondon/covid19model/blob/v6.0/base-usa.r#L87-L88
for (i in 1:ncol(mobility)) {
  if (is.numeric(mobility[, i])) {
    mobility[is.na(mobility[, i]), i] <- mean(mobility[, i], na.rm = TRUE)
  }
}

#### regress mobility on soc-ec
#### mortality per-capita on soc-ec


# Ingest terrain data into a GeoPackage
# Run this after calc-covars.sh

library(raster)

source("pixel-based/utils/load-sampling-data.r")

InDir = "../../userdata/master-classification/dem/aster-covars/"
OutDir = "../data/pixel-based/terrain"

if (!dir.exists(OutDir))
    dir.create(OutDir)

# Points to extract
TrainingPoints = LoadGlobalTrainingData()
ValidationPoints = LoadGlobalValidationData()
PredictionPoints = LoadGlobalRasterPoints()
AllPoints = rbind(TrainingPoints[,c("x", "y")], ValidationPoints[,c("x", "y")], PredictionPoints[,c("x", "y")])

# Put all data sources into a list
MetricNames = c("elevation", "slope", "aspect", "tpi", "roughness")
MetricStack = stack(c(
    file.path(InDir, "elevation.vrt"),
    file.path(InDir, "slope.tif"),
    file.path(InDir, "aspect.tif"),
    file.path(InDir, "tpi.tif"),
    file.path(InDir, "roughness.tif")))
names(MetricStack) = MetricNames

# Write to database in chunks
ChunkSize = 5000
Iterator = seq(1, nrow(AllPoints), ChunkSize)
pb = txtProgressBar(min = 1, max = nrow(AllPoints), style = 3)
for (i in Iterator)
{
    ChunkEnd = min(i+ChunkSize-1, nrow(AllPoints))
    DataChunk = AllPoints[i:ChunkEnd,]

    DSValues = st_as_sf(extract(MetricStack, DataChunk, df=TRUE, sp=TRUE))
    st_write(DSValues, file.path(OutDir, "terrain.gpkg"))
    rm(DSValues)
    rm(DataChunk)
    gc()

    setTxtProgressBar(pb, ChunkEnd)
}

close(pb)


# Assignment: ASSIGNMENT 4
# Name: BAGAM, NAVEEN
# Date: 2022-01-23

## Load the ggplot2 package
library(ggplot2)
theme_set(theme_minimal())

> library(ggplot2)
> theme_set(theme_minimal())

## Set the working directory to the root of your DSC 520 directory
setwd("/home/jdoe/Workspaces/dsc520")

> setwd("C:/Users/nbaga/dsc520/data")

## Load the `data/r4ds/heights.csv` to
heights_df <- read.csv("data/r4ds/heights.csv")

> heights_df <- read.csv("r4ds/heights.csv")

# https://ggplot2.tidyverse.org/reference/geom_boxplot.html
## Create boxplots of sex vs. earn and race vs. earn using `geom_point()` and `geom_boxplot()`
## sex vs. earn

ggplot(heights_df, aes(x=sex, y= earn)) + geom_point()+geom_boxplot()
## race vs. earn
ggplot(heights_df, aes(x=sex, y= earn)) + geom_point()+geom_boxplot()

# https://ggplot2.tidyverse.org/reference/geom_bar.html
## Using `geom_bar()` plot a bar chart of the number of records for each `sex`
ggplot(heights_df, aes(sex)) + geom_bar()

## Using `geom_bar()` plot a bar chart of the number of records for each race
ggplot(heights_df, aes(sex)) + geom_bar()

## Create a horizontal bar chart by adding `coord_flip()` to the previous plot
ggplot(heights_df, aes(sex)) + geom_bar() + coord_flip()
# https://www.rdocumentation.org/packages/ggplot2/versions/3.3.0/topics/geom_path
## Load the file `"data/nytimes/covid-19-data/us-states.csv"` and
## assign it to the `covid_df` dataframe
covid_df <- read.csv("data/nytimes/covid-19-data/us-states.csv")

## Parse the date column using `as.Date()``
covid_df$date <- covid_df$date <- as.Date(covid_df$date)

## Create three dataframes named `california_df`, `ny_df`, and `florida_df`
## containing the data from California, New York, and Florida
california_df <- covid_df[ which( covid_df$state == "California"), ]
ny_df <- covid_df[ which( covid_df$state == "New York"), ]
florida_df <- covid_df[ which( covid_df$state == "Florida"), ]

## Plot the number of cases in Florida using `geom_line()`
ggplot(data=florida_df, aes(x=state, y=cases, group=1)) + geom_line()

## Add lines for New York and California to the plot
  ggplot(data=florida_df, aes(x=state, group=1)) +
  geom_line(aes(y = cases)) +
  geom_line(data=california_df, aes(y = cases)) +
  geom_line(data=ny_df, aes(y = cases))

## Use the colors "darkred", "darkgreen", and "steelblue" for Florida, New York, and California
  ggplot(data= florida_df, aes(x=state, group=1)) +
  geom_line(aes(y = cases), color = "darkred") +
  geom_line(data=ny_df, aes(y = cases), color= "darkgreen") +
  geom_line(data=california_df, aes(y = cases), color= "steelblue")

## Add a legend to the plot using `scale_colour_manual`
## Add a blank (" ") label to the x-axis and the label "Cases" to the y axis
  ggplot(data=florida_df, aes(x=state, group=1)) +
  geom_line(aes(y = cases, colour = "Florida")) +
  geom_line(data=ny_df, aes(y = cases,colour="New York")) +
  geom_line(data=california_df, aes(y = cases, colour="California")) +
  scale_colour_manual("",
                      breaks = c("Florida","New York","California"),
                      values = c("blue","red","green")) +
  xlab(" ") + ylab("Cases")

## Scale the y axis using `scale_y_log10()`
 ggplot(data=florida_df, aes(x=state, group=1)) +
  geom_line(aes(y = cases, colour = "Florida")) +
  geom_line(data=ny_df, aes(y = cases,colour="New York")) +
  geom_line(data=california_df, aes(y = cases, colour="California")) +
  scale_colour_manual("",
                      breaks = c("Florida","New York","California"),
                      values = c("blue","red","green")) +
  xlab(" ") + ylab("Cases") + scale_y_log10()


### Vic Bio Con - R Workshop ###
########### 6 Jan 17 ##########

se <- function(x){
  sqrt(var(x) / length(x))
}


test_that("Hydrology", {
	library(sf)
	library(units)
	kamp_q = readRDS(system.file("testdata/kamp_q_sm.rds", package="watershed"))
	kamp_vect = readRDS(system.file("testdata/kv_sm.rds", package="watershed"))

	## no units set
	expect_warning(hydraulic_geometry(kamp_q$ca, kamp_q$discharge, kamp_vect$ca), regex = "units")

	## no warning if units are set
	ca = set_units(kamp_vect$ca, "m^2")
	expect_error(hyd1 <- hydraulic_geometry(kamp_q$ca, kamp_q$discharge, ca), regex = NA)

	## should work fine if units are changed
	expect_error(hyd2 <- hydraulic_geometry(kamp_q$ca, kamp_q$discharge, set_units(ca, "km^2")), regex = NA)
	expect_equal(hyd1, hyd2, tolerance = 1e-3) ## quite a bit of error due to the bayesian regression

	## should get a different calibration if we screw up the units
	hyd3 <- hydraulic_geometry(kamp_q$ca, kamp_q$discharge, set_units(kamp_vect$ca, "km^2"))
	expect_true(all(hyd3$Q > hyd1$Q))

})


# load packages needed to run this code
library(ggplot2)
library(dplyr)
library(tidyr)
library(cowplot)
library(gganimate)

# code used from this page on stackoverflow:
# https://stackoverflow.com/questions/8082429/plot-a-heart-in-r
# I cleaned it up

# generate coordinates for a heart
df <- data.frame(t = seq(0, 2 * pi, by = 0.01))

heart1 <-
  df %>%
  mutate(
    x = 16 * sin(t)^3,
    y = 13 * cos(t) - 5 * cos(2 * t) - 2 * cos(3 * t) - cos(4 * t),
  )

heart2 <-
  df %>%
  mutate(
    x = 16 * sin(t)^3,
    y = (13 * cos(t) - 5 * cos(2 * t) - 2 * cos(3 * t) - cos(4 * t)) + 25,
  )

heart3 <-
  df %>%
  mutate(
    x = 16 * sin(t)^3,
    y = (13 * cos(t) - 5 * cos(2 * t) - 2 * cos(3 * t) - cos(4 * t)) + 50,
  )

p_heart <-
  ggplot() +
  geom_polygon(data = heart1, aes(x = x, y = y), fill = "#90007f") +
  geom_polygon(data = heart2, aes(x = x, y = y), fill = "#d52484") +
  geom_polygon(data = heart3, aes(x = x, y = y), fill = "#f185b3") +
  annotate("text", label = "I love you", x = 0, y = 60, color = "white", size = 12) +
  theme_void() +
  scale_y_continuous(limits = c(-15, 80)) +
  scale_x_continuous(limits = c(-18, 18)) +
  transition_reveal(y)

# animate
animate(p_heart,
        device = "png",
        width = 400,
        height = 800)

# save as gif
anim_save("heart2.gif")


#!/usr/bin/env Rscript

# export R_LIBS=/gscmnt/gc2802/halllab/idas/jira/BIO-1834/vendor/R/rpkgs

# this can be considered as a one-off script, it'll probably change for each project
# see bash logs for 2016-10-03 for execution details

# L I B R A R I E S ###########################################################
library('optparse')
library('ggplot2')
library('GGally')

# F U N C T I O N S ###########################################################
"%w/o%" <- function(x, y) x[!x %in% y] # see ?match

get.samples <- function(string) {
  prune <- c()
  if (length(string) > 0) {
        prune <- strsplit(string, ",")[[1]]
    }
    return(prune)
}

get.df <- function(input_file, control_samples) {
  header <- read.table(input_file, skip=1, nrows=1, header=FALSE, sep="\t", stringsAsFactors=FALSE)
  data   <- read.table(input_file, skip=2, header=FALSE, sep="\t")
  colnames(data) <- unlist(header)
  data$TYPE <- 'call-set'
  data[data$SAMPLE %in% control_samples, 'TYPE'] <- 'control'
  return(data)
}

ggpairs.pca.plot <- function(df, title="Top 4 Principal Components") {
  p <- ggpairs(df,
               columns=c('PC1', 'PC2', 'PC3', 'PC4'),
               mapping=aes(color=TYPE),
               axisLabels="show",
               title=title)
  return(p)
}

pca.plot <- function(df, hightlight.samples, title="Top 2 Principal Components") {
  p <- ggplot(df, aes(x=PC1, y=PC2, color=TYPE)) +
       geom_point() +
       ggtitle(title,
               subtitle="By LD pruning [window=50; step=5; r^2=0.3; geno=0] & eigenstat/smartpca on SNPs") +
       xlab("PC 1") +
       ylab("PC 2")
  return(p)
}

pca.nstitziel.plot <- function(df, hightlight.samples, title="Top 2 Principal Components") {
  outlier.set1.df <- subset(df, SAMPLE == 'H_OS-7193-7193')
  outlier.set2.df <- subset(df, SAMPLE == 'H_OS-7541-7541')
  outlier.set3.df <- subset(df, SAMPLE == 'H_OS-10300-10300')
  highlight.df <- df[df$SAMPLE %in% highlight.samples, ]
  p <- ggplot(df, aes(x=PC1, y=PC2, color=TYPE)) +
       geom_point() +
       geom_text(data=outlier.set1.df, aes(x=PC1, y=PC2, label=SAMPLE), size=2.5, color="black", nudge_x=0.0, nudge_y=0.045, angle=90) +
       geom_text(data=outlier.set2.df, aes(x=PC1, y=PC2, label=SAMPLE), size=2.5, color="black", nudge_x=-0.012, nudge_y=0.0) +
       geom_text(data=outlier.set3.df, aes(x=PC1, y=PC2, label=SAMPLE), size=2.5, color="black", nudge_x=-0.014, nudge_y=0.0) +
       geom_point(data=highlight.df, aes(x=PC1, y=PC2), color="red") +
       geom_text(data=highlight.df, aes(x=PC1, y=PC2, label=SAMPLE), size=2.5, color="red", nudge_x=0, nudge_y=-0.002) +
       ggtitle(title,
               subtitle="By LD pruning [window=50; step=5; r^2=0.3; geno=0] & eigenstat/smartpca on SNPs") +
       xlab("PC 1") +
       ylab("PC 2")
  return(p)
}

pca.plot.ctl.outliers <- function(df, control.samples, title="Top 2 Principal Components") {
  ctl.df <- df[df$SAMPLE %in% control.samples, ]
  outlier.set1.df <- subset(ctl.df, PC2 > 0.4)
  outlier.set2.df <- subset(ctl.df, PC1 == -0.3200)
  outlier.set3.df <- subset(ctl.df, PC1 == -0.3160)
  outlier.set4.df <- subset(ctl.df, PC1 == -0.1881)
  outlier.set5.df <- subset(ctl.df, PC1 == -0.1733)
  outlier.set6.df <- subset(ctl.df, PC1 == -0.1688)
  outlier.set7.df <- subset(ctl.df, PC1 == -0.1238)
  outlier.set8.df <- subset(ctl.df, PC1 == -0.1134)
  outlier.set9.df <- subset(ctl.df, PC1 == -0.1269)
  outlier.set10.df <- subset(ctl.df, PC1 == -0.1054)
  outlier.set11.df <- subset(ctl.df, PC1 == -0.0883)
  outlier.set12.df <- subset(ctl.df, PC1 == -0.0832)
  outlier.set13.df <- subset(ctl.df, PC1 == -0.0730)
  outlier.set14.df <- subset(df, SAMPLE == 'H_OS-1336-1336')
  p <- ggplot(df, aes(x=PC1, y=PC2, color=TYPE)) +
       geom_point() +
       geom_text(data=outlier.set1.df, aes(x=PC1, y=PC2, label=SAMPLE), size=2.5, color="black", nudge_x=0.06, nudge_y=0.0) +
       geom_text(data=outlier.set2.df, aes(x=PC1, y=PC2, label=SAMPLE), size=2.5, color="black", nudge_x=0.06, nudge_y=-0.007) +
       geom_text(data=outlier.set3.df, aes(x=PC1, y=PC2, label=SAMPLE), size=2.5, color="black", nudge_x=0.06, nudge_y=0.007) +
       geom_text(data=outlier.set4.df, aes(x=PC1, y=PC2, label=SAMPLE), size=2.5, color="black", nudge_x=0.06, nudge_y=0.0) +
       geom_text(data=outlier.set5.df, aes(x=PC1, y=PC2, label=SAMPLE), size=2.5, color="black", nudge_x=0.06, nudge_y=0.000) +
       geom_text(data=outlier.set6.df, aes(x=PC1, y=PC2, label=SAMPLE), size=2.5, color="black", nudge_x=-0.06, nudge_y=0.000) +
       geom_text(data=outlier.set7.df, aes(x=PC1, y=PC2, label=SAMPLE), size=2.5, color="black", nudge_x=-0.055, nudge_y=0.000) +
       geom_text(data=outlier.set8.df, aes(x=PC1, y=PC2, label=SAMPLE), size=2.5, color="black", nudge_x=-0.055, nudge_y=0.000) +
       geom_text(data=outlier.set9.df, aes(x=PC1, y=PC2, label=SAMPLE), size=2.5, color="black", nudge_x=-0.055, nudge_y=0.000) +
       geom_text(data=outlier.set10.df, aes(x=PC1, y=PC2, label=SAMPLE), size=2.5, color="black", nudge_x=-0.055, nudge_y=0.000) +
       geom_text(data=outlier.set11.df, aes(x=PC1, y=PC2, label=SAMPLE), size=2.5, color="black", nudge_x=-0.05, nudge_y=0.000) +
       geom_text(data=outlier.set12.df, aes(x=PC1, y=PC2, label=SAMPLE), size=2.5, color="black", nudge_x=0.055, nudge_y=-0.007) +
       geom_text(data=outlier.set13.df, aes(x=PC1, y=PC2, label=SAMPLE), size=2.5, color="black", nudge_x=0.055, nudge_y=0.000) +
       geom_text(data=outlier.set14.df, aes(x=PC1, y=PC2, label=SAMPLE), size=2.5, color="black", nudge_x=0.04, nudge_y=0.000) +
       ggtitle(title,
               subtitle="By LD pruning [window=50; step=5; r^2=0.3; geno=0] & eigenstat/smartpca on SNPs") +
       xlab("PC 1") +
       ylab("PC 2")
  return(p)
}

pca.plot.exp.outliers <- function(df, hightlight.samples, title="Top 2 Principal Components") {
  outlier.set1.df <- subset(df, PC1 < -0.06)
  outlier.set2.df <- subset(df, PC2 > 0.03)
  outlier.set3.df <- subset(df, PC2 > -0.01 & PC1 < -0.04 & PC1 > -0.06)
  outlier.set4.df <- subset(df, PC2 < -0.04 & PC1 < -0.04 & PC1 > -0.045)
  outlier.set5.df <- subset(df, PC2 > -0.026 & PC1 < -0.049 & PC1 > -0.055)
  outlier.set6.df <- subset(df, PC2 > -0.025 & PC1 < -0.039 & PC1 > -0.041)
  outlier.set7.df <- subset(df, PC2 > -0.018 & PC1 < -0.037 & PC1 > -0.040)
  outlier.set8.df <- subset(df, PC2 < -0.040 & PC1 < -0.059 & PC1 > -0.061)
  outlier.set9.df <- subset(df, PC2 > 0.010 & PC1 < 0.000 & PC1 > -0.009)
  outlier.set10.df <- subset(df, PC2 < -0.025 & PC1 < -0.010 & PC1 > -0.015)
  highlight.df <- df[df$SAMPLE %in% highlight.samples, ]
  p <- ggplot(df, aes(x=PC1, y=PC2)) +
       geom_point() +
       geom_text(data=outlier.set1.df, aes(x=PC1, y=PC2, label=SAMPLE), size=2.5, nudge_x=0.011) +
       geom_text(data=outlier.set2.df, aes(x=PC1, y=PC2, label=SAMPLE), size=2.5, nudge_x=-0.011, nudge_y=0.002) +
       geom_text(data=outlier.set3.df, aes(x=PC1, y=PC2, label=SAMPLE), size=2.5, nudge_x=0, nudge_y=0.002) +
       geom_text(data=outlier.set4.df, aes(x=PC1, y=PC2, label=SAMPLE), size=2.5, nudge_x=0.011) +
       geom_text(data=outlier.set5.df, aes(x=PC1, y=PC2, label=SAMPLE), size=2.5, nudge_x=-0.011) +
       geom_text(data=outlier.set6.df, aes(x=PC1, y=PC2, label=SAMPLE), size=2.5, nudge_x=-0.020) +
       geom_text(data=outlier.set7.df, aes(x=PC1, y=PC2, label=SAMPLE), size=2.5, nudge_x=-0.020) +
       geom_text(data=outlier.set8.df, aes(x=PC1, y=PC2, label=SAMPLE), size=2.5, nudge_x=-0.020) +
       geom_text(data=outlier.set9.df, aes(x=PC1, y=PC2, label=SAMPLE), size=2.5, nudge_x=-0.018) +
       geom_text(data=outlier.set10.df, aes(x=PC1, y=PC2, label=SAMPLE), size=2.5, nudge_x=0.018) +
       geom_point(data=highlight.df, aes(x=PC1, y=PC2), color="green") +
       geom_text(data=highlight.df, aes(x=PC1, y=PC2, label=SAMPLE), size=2.5, color="red", nudge_x=0, nudge_y=-0.002) +
       ggtitle(title,
               subtitle="By LD pruning [window=50; step=5; r^2=0.3; geno=0] & eigenstat/smartpca on SNPs") +
       xlab("PC 1") +
       ylab("PC 2")
  return(p)
}

# M A I N #####################################################################
option.list <- list(
    make_option(
        c("-i", "--input"),
        action  = "store",
        type    = "character",
        default = NULL,
        help    = "an eigenstrat eigenvector/evec converted tsv"
    ),

    make_option(
        c("-o", "--output"),
        action  = "store",
        type    = "character",
        default = "pca.pdf",
        help    = "name of the output plot file"
    ),

	make_option(
        c("-c", "--control"),
        action  = "store",
        type    = "character",
        default = NULL,
        help    = "sample names to label as 'controls' from the call set"
    ),

	make_option(
        c("-p", "--highlight"),
        action  = "store",
        type    = "character",
        default = NULL,
        help    = "sample names to highlight/label from the call set"
    )
);

opts <- parse_args(OptionParser(option_list=option.list))
cat( paste("input:   ", opts$input  , "\n") )
cat( paste("output:  ", opts$output , "\n") )
cat( paste("highlight:   ", opts$highlight , "\n") )
cat( paste("control:   ", opts$control , "\n") )

# controls: H_HF-CHM1htert-US-5A,H_IJ-HG00512-HG00512_1,H_IJ-HG00513-HG00513_1,H_IJ-HG00514-HG00514_1,H_IJ-HG00731-HG00731_2,H_IJ-HG00732-HG00732_1,H_IJ-HG00733-HG00733_2,H_IJ-NA12878-NA12878_K10,H_IJ-NA12891-NA12891_D2,H_IJ-NA12892-NA12892_E1,H_IJ-NA19238-NA19238_D3,H_IJ-NA19239-NA19239_B9,H_IJ-NA19240-NA19240_F1,H_PY-CHM13-CHM13h

options(width=200)

highlight.samples <- get.samples(opts$highlight)
control.samples <- get.samples(opts$control)

df <- get.df(opts$input, control.samples)
minus.control.df <- df[df$SAMPLE %w/o% control.samples, ]

# pdf(file=opts$output)
# #plot <- ggpairs.pca.plot(df)
# cols <- character(nrow(df))
# cols[] <- "black"
# cols[df$TYPE == "call-set"] <- "orange"
# #pairs(df[2:5], main="Top 4 Principal Components", bg=c("black", "orange")[unclass(df$TYPE)], pch=21)
# pairs(df[2:5], main="Top 4 Principal Components", col=cols, pch=21)
# dev.off()

# input: BIO-2020/data/derived/manual/2-convert-data-frame/merged.eigenstrat.pca.evec.tsv
plot <- pca.nstitziel.plot(df, highlight.samples, title="Top 2 Principal Components w/o Control Samples in Eigenstrat")
ggsave(opts$output, plot)

# plot <- pca.plot.ctl.outliers(df, control.samples, title="Top 2 Principal Components with Control Samples")
# ggsave(opts$output, plot)

# plot <- pca.plot.exp.outliers(minus.control.df, hightlight.samples, title="Top 2 Principal Components w/o Control Samples")
# ggsave('experimental-outliers.pdf', plot)

#merged.stats <- merged.stats[merged.stats$Sample %w/o% prune,] # prune out selected samples

quit(save="no", status=0)


#' Binary item tracelines.
#'
#' @param p_item Vector of item parameters.
#' @param theta Vector of theta values.
#' @param pred_data Matrix or dataframe of DIF and/or impact predictors.
#' @param samp_size Sample size in dataset.
#'
#' @return a \code{"matrix"} of probability values for Bernoulli item likelihood
#'
#' @keywords internal
#'
bernoulli_traceline_pts <-
  function(p_item,
           theta,
           pred_data,
           samp_size) {

    traceline <-
      vapply(theta,
             function(x) {
   1 / (1 + exp(
     -((p_item[1] + pred_data %*% p_item[3:(2+ncol(pred_data))]) +
       (p_item[2] + pred_data %*% p_item[(3+ncol(pred_data)):length(p_item)])*x)
     ))
               }, numeric(samp_size))

    return(traceline)

  }

#' Binary item tracelines for proxy scores.
#'
#' @param p_item Vector of item parameters.
#' @param prox_data Vector of observed proxy scores.
#' @param pred_data Matrix or dataframe of DIF and/or impact predictors.
#'
#' @return a \code{"matrix"} of probability values for Bernoulli item likelihood using observed
#' proxy scores
#'
#' @keywords internal
#'
bernoulli_traceline_pts_proxy <-
  function(p_item,
           prox_data,
           pred_data) {

    traceline <-
      1 / (1 + exp(
        -((p_item[1] + pred_data %*% p_item[3:(2+ncol(pred_data))]) +
            (p_item[2] + pred_data %*% p_item[(3+ncol(pred_data)):length(p_item)])*prox_data)))

    return(traceline)

  }

#' Ordinal tracelines.
#'
#' @param p_item Vector of item parameters.
#' @param theta Vector of theta values.
#' @param pred_data Matrix or dataframe of DIF and/or impact predictors.
#' @param samp_size Sample size in dataset.
#' @param num_responses_item Number of responses for item.
#' @param num_quad Number of quadrature points used for approximating the
#' latent variable.
#'
#' @return a \code{"matrix"} of probability values for categorical (cumulative) item likelihood
#'
#' @keywords internal
#'
cumulative_traceline_pts <-
  function(p_item,
           theta,
           pred_data,
           samp_size,
           num_responses_item,
           num_quad) {

  # Space for cumulative traceline (y >= c category).
  traceline <-
    lapply(1:(num_responses_item-1), function(x) {
              matrix(0,nrow=samp_size,ncol=num_quad)})

  c0_parms <- grepl("c0",names(p_item),fixed=T)
  c1_parms <- grepl("c1",names(p_item),fixed=T)
  a0_parms <- grepl("a0",names(p_item),fixed=T)
  a1_parms <- grepl("a1",names(p_item),fixed=T)

  # For item response 1.
  traceline[[1]] <-
    vapply(theta,
          function(x) {
            1 / (1 + exp(-((p_item[c0_parms][1] +
                              pred_data %*% p_item[c1_parms]) +
                             (p_item[a0_parms] +
                                pred_data %*% p_item[a1_parms])*x)
                         )
                 )
            }, numeric(samp_size))

  # For item response 2 to J.
    for(thr in 2:(num_responses_item-1)) {
      traceline[[thr]] <-
        vapply(theta,
              function(x) {
                1 / (1 + exp(-((p_item[c0_parms][1] -
                                  p_item[c0_parms][thr] +
                                  pred_data %*% p_item[c1_parms]) +
                                 (p_item[a0_parms] +
                                    pred_data %*% p_item[a1_parms])*x)
                             )
                     )
                }, numeric(samp_size))
    }

  return(traceline)

}

#' Ordinal tracelines using proxy data.
#'
#' @param p_item Vector of item parameters.
#' @param prox_data Vector of observed proxy scores.
#' @param pred_data Matrix or dataframe of DIF and/or impact predictors.
#' @param samp_size Sample size in dataset.
#' @param num_responses_item Number of responses for item.
#'
#' @return a \code{"matrix"} of probability values for categorical (cumulative) item likelihood
#'
#' @keywords internal
#'
cumulative_traceline_pts_proxy <-
  function(p_item,
           prox_data,
           pred_data,
           samp_size,
           num_responses_item) {

    # Space for cumulative traceline (y >= c category).
    traceline <- lapply(1:(num_responses_item-1), function(x) {
                  matrix(0,nrow=samp_size,ncol=1)})

    c0_parms <- grepl("c0",names(p_item),fixed=T)
    c1_parms <- grepl("c1",names(p_item),fixed=T)
    a0_parms <- grepl("a0",names(p_item),fixed=T)
    a1_parms <- grepl("a1",names(p_item),fixed=T)

    # For item response 1.
    traceline[[1]] <- 1 / (1 + exp(-((p_item[c0_parms][1] +
                                 pred_data %*% p_item[c1_parms]) +
                                (p_item[a0_parms] +
                                   pred_data %*% p_item[a1_parms])*prox_data))
                           )

    # For item response 2 to J.
    for(thr in 2:(num_responses_item-1)) {
      traceline[[thr]] <- 1 / (1 + exp(-((p_item[c0_parms][1] -
                                   p_item[c0_parms][thr] +
                                   pred_data %*% p_item[c1_parms]) +
                                  (p_item[a0_parms] +
                                     pred_data %*% p_item[a1_parms])*prox_data))
                               )
    }

    return(traceline)

  }

#' Continuous tracelines.
#'
#' @param p_item Vector of item parameters.
#' @param theta Vector of theta values.
#' @param responses_item Vector of item responses.
#' @param pred_data Matrix or data frame of DIF and/or impact predictors.
#' @param samp_size Sample size in data set.
#'
#' @return a \code{"matrix"} of probability values for Gaussian item likelihood
#'
#' @keywords internal
#'
gaussian_traceline_pts <-
  function(p_item,
           theta,
           responses_item,
           pred_data,
           samp_size) {

  c0_parms <- grepl("c0",names(p_item),fixed=T)
  c1_parms <- grepl("c1",names(p_item),fixed=T)
  a0_parms <- grepl("a0",names(p_item),fixed=T)
  a1_parms <- grepl("a1",names(p_item),fixed=T)
  s0_parms <- grepl("s0",names(p_item),fixed=T)
  s1_parms <- grepl("s1",names(p_item),fixed=T)

  mu <-
    vapply(theta,
          function(x) {
            (p_item[c0_parms] +
               pred_data %*% p_item[c1_parms]) +
              (p_item[a0_parms] +
                 pred_data %*% p_item[a1_parms])*x
            }, numeric(samp_size))
  sigma <-
    sqrt(p_item[s0_parms][1]*exp(pred_data %*% p_item[s1_parms]))

  traceline <- t(sapply(1:samp_size,
                        function(x) {
                          dnorm(responses_item[x],mu[x,],sigma[x])
                          }
                        ))

  return(traceline)

}

#' Continuous tracelines using proxy data.
#'
#' @param p_item Vector of item parameters.
#' @param prox_data Vector of observed proxy scores.
#' @param responses_item Vector of item responses.
#' @param pred_data Matrix or data frame of DIF and/or impact predictors.
#' @param samp_size Sample size in data set.
#'
#' @return a \code{"matrix"} of probability values for Gaussian item likelihood
#'
#' @keywords internal
#'
gaussian_traceline_pts_proxy <-
  function(p_item,
           prox_data,
           responses_item,
           pred_data,
           samp_size) {

    c0_parms <- grepl("c0",names(p_item),fixed=T)
    c1_parms <- grepl("c1",names(p_item),fixed=T)
    a0_parms <- grepl("a0",names(p_item),fixed=T)
    a1_parms <- grepl("a1",names(p_item),fixed=T)
    s0_parms <- grepl("s0",names(p_item),fixed=T)
    s1_parms <- grepl("s1",names(p_item),fixed=T)

    mu <- (p_item[c0_parms] +
                  pred_data %*% p_item[c1_parms]) +
                 (p_item[a0_parms] +
                    pred_data %*% p_item[a1_parms])*prox_data
    sigma <-
      sqrt(p_item[s0_parms][1]*exp(pred_data %*% p_item[s1_parms]))

    traceline <- t(sapply(1:samp_size,
                          function(x) {
                            dnorm(responses_item[x],mu[x,],sigma[x])
                          }
    ))

    return(traceline)

  }


piusBenchmark_NumClustKnown_AMI_Ver = function(MVec = NULL, NVec = NULL, numSubgroupsVec = NULL,
                                               lambdaVec = NULL, univVec = NULL, iStrength = 1,
                                               sigmaMax = 0.1, thresholdMult = 10 ^ (-3), maxSteps = 10 ^ 4,
                                               tStep = 10 ^ (-2), intTime = 1, interSmplMult = 0.01,
                                               returnParams = FALSE, conGraph = NULL, rollRange = 0.025,
                                               numClust = NULL, numReplicates = 2, numComputeClusters = 64){

  #  ARGS:
  #
  #  RETURNS:

  source("piusBenchmarkDFCreator.r")
  source("piusDFTest_NumClustKnown_AMI_Ver.r")

  treatmentDF = piusBenchmarkDFCreator(MVec = MVec, NVec = NVec, numSubgroupsVec = numSubgroupsVec,
                                       lambdaVec = lambdaVec, univVec = univVec)

  testResultsDF = piusDFTest_NumClustKnown_AMI_Ver(treatmentDF = treatmentDF, iStrength = iStrength,
                                                   sigmaMax = sigmaMax, thresholdMult = thresholdMult,
                                                   maxSteps = maxSteps, tStep = tStep, intTime = intTime,
                                                   interSmplMult = interSmplMult,
                                                   returnParams = returnParams, conGraph = conGraph,
                                                   rollRange = rollRange, numClust = numClust,
                                                   numReplicates = numReplicates,
                                                   numComputeClusters = numComputeClusters)

  return(testResultsDF)

} #  end  piusBenchmark_NumClustKnown_AMI_Ver  function


#' Handle outliers in a methylation matrix
#'
#' @param beta Methylation matrix (rows=CpG sites, columns=samples, values=methylation levels).
#' @param winsorize.pct Apply all regression models to methylation levels
#' winsorized to the given level. Set to NA to avoid winsorizing (Default: 0.05).
#' @param outlier.iqr.factor For each CpG site, prior to fitting regression models,
#' set methylation levels less than
#' \code{Q1 - outlier.iqr.factor * IQR} or more than
#' \code{Q3 + outlier.iqr.factor * IQR} to NA. Here IQR is the inter-quartile
#' range of the methylation levels at the CpG site, i.e. Q3-Q1.
#' Set to NA to skip this step (Default: NA).
#' @return \code{beta} after winsorizing and outliers set to NA.
#'
#' @export
meffil.handle.outliers <- function(beta, winsorize.pct=0.05, outlier.iqr.factor=NA) {
    if (is.numeric(winsorize.pct))
        beta <- meffil:::winsorize(beta, pct=winsorize.pct)

    if (is.numeric(outlier.iqr.factor)) {
        if (is.matrix(beta)) {
            q <- rowQuantiles(beta, probs = c(0.25, 0.75), na.rm = T)
            iqr <- q[,2] - q[,1]
            too.hi <- which(beta > q[,2] + outlier.iqr.factor * iqr, arr.ind=T)
            too.lo <- which(beta < q[,1] - outlier.iqr.factor * iqr, arr.ind=T)
            if (nrow(too.hi) > 0) beta[too.hi] <- NA
            if (nrow(too.lo) > 0) beta[too.lo] <- NA
        }
        else {
            q <- quantile(beta, probs = c(0.25, 0.75), na.rm = T)
            iqr <- q[2] - q[1]
            too.hi <- which(beta > q[2] + outlier.iqr.factor * iqr)
            too.lo <- which(beta < q[1] - outlier.iqr.factor * iqr)
            if (length(too.hi) > 0) beta[too.hi] <- NA
            if (length(too.lo) > 0) beta[too.lo] <- NA
        }
    }

    beta
}


add=function(a,b)
{
  c=a+b
  print(c)
}
add(5,6)


library(methods)
{{rimport}}('__init__.r')
options(stringsAsFactors = F)

infile   = {{i.infile | R}}
gfile    = {{i.groupfile | R}}
cfile    = {{i.casefile | R}}
outfile  = {{o.outfile | R}}
outdir   = {{o.outdir | R}}
pcut     = {{args.pval | R}}
dofdr    = {{args.fdr | R}}
plotchow = {{args.plot | R}}
devpars  = {{args.devpars | R}}
ggs      = {{args.ggs | R}}
inopts   = {{args.inopts | R}}
covfile  = {{args.cov | R}}

if (plotchow) {
	{{rimport}}('plot.r')
}

if (dofdr == T) dofdr = 'BH'

chow.test = function(formula, group, data, covdata = NULL, ...) {
	fmvars  = all.vars(as.formula(formula))
	vars    = colnames(data)
	if (length(fmvars) == 2 && fmvars[2] == '.') {
		fmvars = c(fmvars[1], vars[vars!=fmvars[1] & vars!=group])
	}
	formula = sprintf(
		'%s ~ %s',
		bQuote(fmvars[1]),
		paste(sapply(fmvars[2:length(fmvars)], bQuote), collapse = '+')
	)
	covs = NULL
	if (is.null(covdata)) {
		pooledfm = as.formula(formula)
	} else {
		covdata = covdata[rownames(data),,drop = FALSE]
		covs    = colnames(covdata)
		data    = cbind(data, covdata)
		rm(covdata)
		pooledfm = as.formula(paste(formula, '+', paste(sapply(covs, bQuote), collapse = '+')))
		fmvars   = c(fmvars, covs)
	}

	if (sum(complete.cases(data[,fmvars])) < 2) {
		pooled_lm = NULL
	} else {
		pooled_lm = lm(pooledfm, data = data, ...)
	}
	#coeff     = as.list(pooled_lm$coefficients)
	groups    = levels(as.factor(data[, group]))
	group_lms = sapply(groups, function(g) {
		if (is.null(covdata)) {
			subfm  = as.formula(formula)
		} else {
			subfm = as.formula(paste(
				formula, '+',
				#paste(sapply(covs, function(x) paste0('offset(', coeff[[x]], '*', bQuote(x), ')')), collapse = '+')
				paste(sapply(covs, bQuote), collapse = '+')
			))
		}
		sublmdata = data[data[,group] == g, , drop = FALSE]
		if (sum(complete.cases(sublmdata[,fmvars])) < 2) {
			NULL
		} else {
			list(lm(subfm, data = sublmdata, ...))
		}
	})

	pooled.ssr = ifelse(is.null(pooled_lm), NA, sum(pooled_lm$residuals ^ 2))
	subssr     = ifelse(is.false(group_lms, 'any'), NA, sum(sapply(group_lms, function(x) sum(x$residuals ^ 2))))
	ngroups    = length(groups)
	K          = length(fmvars) + length(covs)
	J          = (ngroups - 1) * K
	DF         = nrow(data) - ngroups * K
	FS         = (pooled.ssr - subssr) * DF / subssr / J
	list(
		pooled.lm  = pooled_lm,
		group.lms  = group_lms,
		Fstat      = FS,
		group      = group,
		pooled.ssr = pooled.ssr,
		group.ssr  = subssr,
		Pval       = pf(FS, J, DF, lower.tail = FALSE)
	)
}

plot.chow = function(chow, plotfile, ggs, devpars) {
	cols     = all.vars(chow$pooled.lm$terms)[1:2]
	plotdata = do.call(rbind, lapply(names(chow$group.lms), function(m) data.frame(chow$group.lms[[m]]$model[, cols, drop = FALSE], group = m)))
	colnames(plotdata)[3] = chow$group
	if (!is.null(ggs$scale_color_discrete)) {
		ggs$scale_color_discrete$name = ifelse(
			is.function(ggs$scale_color_discrete$name),
			ggs$scale_color_discrete$name(chow$group),
			chow$group
		)
		ggs$scale_color_discrete$labels = sapply(names(chow$group.lms), function(x) {
			coeff = as.list(chow$group.lms[[x]]$coefficients)
			bquote(.(x): beta[.(cols[2])]==.(round(coeff[[cols[2]]], 3)) ~ "," ~ epsilon == .(round(coeff[['(Intercept)']], 3)))
		})
	}

	if (!is.null(ggs$scale_shape_discrete)) {
		ggs$scale_shape_discrete$name = ifelse(
			is.function(ggs$scale_shape_discrete$name),
			ggs$scale_shape_discrete$name(chow$group),
			chow$group
		)
		ggs$scale_shape_discrete$labels = sapply(names(chow$group.lms), function(x) {
			coeff = as.list(chow$group.lms[[x]]$coefficients)
			bquote(.(x): beta[.(cols[2])]==.(round(coeff[[cols[2]]], 3)) ~ "," ~ epsilon == .(round(coeff[['(Intercept)']], 3)))
		})
	}

	if (is.null(ggs$scale_color_discrete) && is.null(ggs$scale_shape_discrete)) {
		ggs$scale_color_discrete = list(
			name = chow$group,
			labels = sapply(names(chow$group.lms), function(x) {
				coeff = as.list(chow$group.lms[[x]]$coefficients)
				bquote(.(x): beta[.(cols[2])]==.(round(coeff[[cols[2]]], 3)) ~ "," ~ epsilon == .(round(coeff[['(Intercept)']], 3)))
			})
		)
	}

	if (is.null(ggs$scale_color_discrete)) ggs$scale_color_discrete = ggs$scale_shape_discrete
	if (is.null(ggs$scale_shape_discrete)) ggs$scale_shape_discrete = ggs$scale_color_discrete

	plot.points(
		plotdata,
		plotfile,
		x = 2, y = 1,
		params = list(aes_string(color = chow$group, shape = chow$group)),
		ggs = c(ggs, list(
			geom_smooth = list(aes_string(color = chow$group), method = "lm", se = FALSE)
		))
	)
}

formatlm = function(m) {
	if (class(m) == 'lm') {
		coeff = as.list(m$coefficients)
		vars = all.vars(m$terms)
		terms = unlist(sapply(c(vars[2:length(vars)], '(Intercept)', 'N'), function(x) {
			ce = list.get(coeff, x, list.get(coeff, bQuote(x)))
			if (x == 'N') {
				paste0('N=', nrow(m$model))
			} else if (is.null(ce)) {
				NULL
			} else {
				l = ifelse(x == '(Intercept)', '_', x)
				paste0(l, '=', round(ce, 3))
			}
		}))
		paste(terms[!is.null(terms)], collapse = ', ')
	} else {
		paste(sapply(names(m), function(x) {
			paste0(x, ': ', formatlm(m[[x]]))
		}), collapse = ' // ')
	}
}

results = data.frame(
	Case   = character(),
	Pooled = character(),
	Groups = character(),
	SSR    = double(),
	SumSSR = double(),
	Fstat  = double(),
	Pval   = double()
)

indata = read.table.inopts(infile, inopts, try = TRUE)
if (is.null(indata)) {
	write.table(results, outfile, col.names = T, row.names = F, sep = "\t", quote = F)
	quit(save = "no")
}

#     X1  X2  X3  X4 ... Y
# G1  1   2   1   4  ... 9
# G2  2   3   1   1  ... 3
# ... ...
# Gm  3   9   1   7  ... 8
#K      = ncol(indata)
covdata = NULL
covs    = NULL
if (covfile != "") {
	covdata = read.table(covfile, header = T, row.names = 1, check.names = F)
	#indata  = cbind(covdata[rownames(indata),,drop = F], indata)
	covs = colnames(covs)
}
gdata  = read.table.inopts(gfile, list(cnames = TRUE, rnames = TRUE))
# 	Case1	Case2
# G1	Group1	Group1
# G2	Group1	NA
# G3	Group2	Group1
# ... ...
# Gm	Group2	Group2
cases  = colnames(gdata)
fmulas = data.frame(x = rep(paste(bQuote(colnames(indata)[ncol(indata)]), '~ .'), length(cases)))
rownames(fmulas) = cases
if (!is.null(cfile) && cfile != "") {
	fmulas = read.table.inopts(cfile, list(cnames = FALSE, rnames = TRUE))
	cases  = rownames(fmulas)
}

for (case in cases) {
	logger('Handling case: ', case, '...')
	fmula  = fmulas[case,,drop = TRUE]
	groups = gdata[!is.na(gdata[,case]),case,drop = FALSE]
	data   = cbind(indata[rownames(groups),, drop = FALSE], group = groups)
	colnames(data)[ncol(data)] = case
	ct = chow.test(fmula, case, data, covdata = covdata)
	if (dofdr == FALSE && (is.na(ct$Pval) || ct$Pval >= pcut)) {
		next
	}
	results = rbind(results, list(
		Case   = case,
		Pooled = formatlm(ct$pooled.lm),
		Groups = formatlm(ct$group.lms),
		SSR    = ct$pooled.ssr,
		SumSSR = ct$group.ssr,
		Fstat  = ct$Fstat,
		Pval   = ct$Pval
	))
	# doplot
	if (plotchow && ct$Pval < pcut) {
		plot.chow(ct, file.path(outdir, paste0(case, '.png')), ggs, devpars)
	}
}

if (dofdr != F) {
	results = cbind(results, Qval = p.adjust(results$Pval, method = dofdr))
}
write.table(pretty.numbers(results, list(
	SSR..SumSSR..Fstat = '%.3f',
	Pval..Qval = '%.3E'
)), outfile, col.names = T, row.names = F, sep = "\t", quote = F)


simulate_joint_HMcontinuous <- function(n=100,k=2,sepxiv=1,type=c("norm","bino")){

# Simulation of the from joint model with continuous HM chain described in
# "A shared-parameter continuous-time hidden Markov and survival model for longitudinal data
#  with informative drop-out"
# by F.Bartolucci and A.Farcomeni (2018)
#
# INPUT:
#
# n          = sample size
# k          = number of latent states
# sepxiv     = separation between the latent state support points
# type       = type of response variables ("norm" or "bino")
#
# OUTPUT:
#
# Y      = matrix of responses (each row corresponds to an individual)
# Y0     = matrix of all responses (without dropout)
# W      = matrix of individual covariates for the survival process
# X      = array of individual covariates on the longitudinal process
# tv     = vector of survival times
# censv  = vector of indicators of censoring
# Q      = infinitesimal transition matrix
# piv    = initial probability vector
# bev    = regression coefficients on the longitudinal process
# nu     = parameter of the Weibull distribution
# xiv    = vector of support points
# phi    = relation between longitudal and survival process
# psiv   = vector of regression paraemters on the survival process
# si2    = variane for normal responses
# TT     = time of each longitudinal observaton
# TT0    = time of each longitudinal observaton (without dropout)
# tU     = matrix of latent states (continuous time)
# tT     = matrix of continuous time jumps
# U      = matrix of latent states (discrete time)
# Q      = infinite transition matrix
# dev    = indicator for non-censoring time

# set up
	type = match.arg(type)
	cv = rep(10,n)                  # censoring times (v stands for vector)
	xiv = seq(1:k)*sepxiv           # support points
	xiv = xiv-mean(xiv)
	piv = rep(1/k,k)                # initial probabilty vector
	Q = matrix(1/(k-1),k,k)         # infinitesimal transition matrix
	diag(Q) = -1
	if(type == "norm")	si2 = 0.25 else si2 = NULL   # variance of continuous data
	X = array(0,c(n,10+1,2))      # array of covariates (AR(1))
	for(i in 1:n){
		X[i,1,] = rnorm(2)
		for(t in 2:11) X[i,t,] = 0.9*X[i,t-1,]+rnorm(2)*sqrt(0.19)
	}
	bev = c(-1,1)                      # corresponding regression parameters
	phi = 0.75                          # random-effect coefficient on survival process
	W = cbind(1,matrix(rnorm(2*n),n))  # covariates for survival process
	psiv = c(-6,-1,1)                  # corresponding regression parameters
	nu = 2                             # parameter of the Weibull distribution

# simulate data
	tU = tT = tTau = matrix(NA,n,100)     # for MC process (initial t stands fro tilde)
	tjv = rep(0,n)                        # number of jumps
	R = Q; diag(R) = 0                    # jump matrix
	qtot = rowSums(R)                     # exponential sojourn rate
	R = R/qtot

# draw continuous MC process
	for(i in 1:n){
		tT[i,1] = 0
		tU[i,1] = which(rmultinom(1,1,piv)==1)
		j = 0
		while(tT[i,j+1]<=cv[i]){
			j = j+1
			tTau[i,j] = rexp(1,qtot[tU[i,1]])
			tT[i,j+1] = tT[i,j]+tTau[i,j]
			tU[i,j+1] = which(rmultinom(1,1,R[tU[i,j],])==1)
		}
		tjv[i] = j
	}

# draw survival time
	bv = tv = rep(0,n)            # vector if random draws and surivavial times
	censv = rep(FALSE,n)          # vector with indicators of censoring
	for(i in 1:n){
		Ht = rep(0,tjv[i])          # cumulative hazard function
		ind = 1:(tjv[i]-1)
		if(tjv[i]>1) Ht[2:tjv[i]] = exp(as.vector(W[i,]%*%psiv))*cumsum(exp(xiv[tU[i,ind]]*phi)*
		                            (tT[i,ind+1]^nu-tT[i,ind]^nu))
		bv[i] = -log(runif(1))
		di = sum(Ht<=bv[i])
		tv[i] = (tT[i,di]^nu + (bv[i]-Ht[di])/(exp(xiv[tU[i,di]]*phi+W[i,]%*%psiv)))^(1/nu)
		if(tv[i]>cv[i]){
			censv[i] = TRUE
			tv[i] = cv[i]
		}
	}
	dev = 1-censv                 # indicator for non-censoring time

# draw longitudinal process
	jv = rep(0,n)                           # number of observations
	TT = TT0 = Y = Y0 = matrix(NA,n,11)     # time of each observation and value
	U = matrix(NA,n,100)                    # matrix of latent state at each observation
	for(i in 1:n){
		jv[i] = floor(tv[i])+1
		TT0[i,] = 0:10
		TT[i,1:jv[i]] = 0:(jv[i]-1)
		U[i,1] = tU[i,1]
		tmp = xiv[U[i,1]]+X[i,1,]%*%bev
		if(type=="norm") Y0[i,1] = tmp+rnorm(1)*sqrt(si2)     # continuous case
		if(type=="bino"){                                     # binary case
			tmp = exp(tmp)/(1+exp(tmp))
			Y0[i,1] = 1*(runif(1)<tmp)
		}
		for(j in 2:11){
			tj = sum(tT[i,]<=TT0[i,j],na.rm=TRUE)
			U[i,j] = tU[i,tj]
			tmp = xiv[U[i,j]]+X[i,j,]%*%bev
			if(type=="norm") Y0[i,j] = tmp+rnorm(1)*sqrt(si2)
			if(type=="bino"){
				tmp = exp(tmp)/(1+exp(tmp))
				Y0[i,j] = 1*(runif(1)<tmp)
			}
		}
		Y[i,1:jv[i]] = Y0[i,1:jv[i]]
	}

# final output
return(list(Y=Y,Y0=Y0,W=W,X=X,tv=tv,censv=censv,Q=Q,piv=piv,bev=bev,nu=nu,xiv=xiv,
	          phi=phi,psiv=psiv,si2=si2,TT=TT,TT0=TT0,tU=tU,tT=tT,U=U,Q=Q,dev=dev))

}


require(lme4)

# We've got rules per run from ipython notebook. Here they are:
mat_rules=c(3.25, 5.0, 5.0, 5.25, 3.75, 3.5, 4.0, 3.75, 4.333333333333333, 3.5, 5.0, 5.25, 4.0, 4.75, 4.25, 3.75, 2.25, 4.25, 1.75, 1.25, 5.25, 4.0, 4.75, 3.5, 4.5)
cat_rules=c(3.25, 2.25, 2.75, 2.5, 3.0, 2.5, 2.5, 3.25, 2.75, 2.0, 2.75, 1.75, 3.25, 4.0, 2.25, 1.5, 1.5, 2.3333333333333335, 3.25, 0.75, 3.25, 3.5, 3.0, 1.25, 3.25)

# Now, let's make one step back and convert them to rules per subject.
# Note: Subjects 3,11,16,19, and 20 had less than 4 runs per task.
# The reason for the step back is that Piosson is not possible on non-integers.
mat_rules_subj=c(3.25*4, 5.0*4, 5.0*3, 5.25*4, 3.75*4, 3.5*4, 4.0*4, 3.75*4, round(4.333333333333333*3), 3.5*4, 5.0*4, 5.25*4, 4.0*4, 4.75*4, 4.25*4, 3.75*4, 2.25*4, 4.25*4, 1.75*4, 1.25*4, 5.25*4, 4.0*4, 4.75*4, 3.5*4, 4.5*4)
cat_rules_subj=c(3.25*4, 2.25*4, 2.75*4, 2.5*4, 3.0*4, 2.5*4, 2.5*4, 3.25*4, 2.75*4, 2.0*4, 2.75*4, 1.75*4, 3.25*4, 4.0*3, 2.25*4, 1.5*4, 1.5*2, round(2.3333333333333335*3), 3.25*4, 0.75*4, 3.25*4, 3.5*4, 3.0*4, 1.25*4, 3.25*4)

mean(mat_rules_subj)
sd(mat_rules_subj)

mean(cat_rules_subj)
sd(cat_rules_subj)

subjects=c(1,2,3,4,5,6,8,10,11,12,13,14,15,16,17,18,19,20,21,22,23,24,25,26,27)
df1=data.frame()
for (i in 1:length(subjects)){

  df1 = rbind(df1, c(mat_rules_subj[i],1,subjects[i]))
  df1 = rbind(df1, c(cat_rules_subj[i],0,subjects[i]))

}
names(df1)=c('num','mat','subj')
m1 = glmer(num~mat + (1|subj),data=df1,family=poisson)
summary(m1)

### Time to criterion
library(coxme)

mat_tc1=c(4, 34, 4, 11, 13, 6, 6, 6, 5, 4, 5, 5, 6, 12, 5, 5, 4, 7, 4, 4, 4, 3, 4, 5, 6, 5, 5, 6, 4, 3, 5, 8, 6, 7, 5, 3, 3, 4, 4, 9, 3, 6, 6, 13, 3, 3, 4, 3, 3, 4, 6, 6, 6, 10, 5, 4, 4, 5, 4, 3, 4, 3, 6, 6, 4, 5, 5, 6, 6, 3, 19, 5, 8, 8, 7, 8, 7, 6, 5, 6, 7, 4, 5, 8, 4, 6, 11, 4, 12, 6, 7, 7, 6, 6, 4, 4, 9, 16, 6, 6, 8, 4, 17, 6, 7, 5, 9, 5, 5, 4, 5, 9, 6, 4, 8, 13, 24, 5, 6, 3, 4, 9, 8, 4, 5, 10, 5, 6, 5, 5, 5, 6, 5, 4, 11, 4, 6, 5, 5, 6, 7, 5, 6, 5, 33, 6, 6, 4, 5, 9, 6, 5, 3, 4, 5, 5, 10, 6, 7, 5, 4, 4, 3, 9, 5, 7, 5, 5, 3, 4, 5, 6, 5, 4, 3, 6, 5, 7, 9, 5, 4, 4, 4, 6, 6, 4, 3, 5, 6, 4, 6, 4, 5, 5, 3, 5, 4, 4, 6, 5, 15, 7, 6, 7, 3, 4, 4, 11, 4, 5, 4, 3, 10, 5, 4, 7, 5, 4, 9, 8, 5, 7, 7, 3, 6, 4, 6, 3, 6, 6, 4, 6, 4, 6, 10, 7, 5, 12, 3, 9, 5, 11, 3, 6, 5, 4, 9, 5, 4, 4, 7, 11, 24, 5, 6, 4, 7, 4, 5, 3, 5, 4, 13, 4, 4, 8, 27, 12, 6, 7, 11, 7, 24, 6, 9, 8, 6, 4, 17, 3, 5, 5, 5, 10, 6, 5, 4, 4, 9, 6, 8, 3, 14, 4, 8, 31, 14, 41, 8, 5, 39, 5, 6, 5, 4, 6, 6, 7, 3, 5, 4, 5, 5, 4, 11, 5, 6, 5, 4, 6, 3, 4, 4, 4, 3, 5, 15, 4, 9, 7, 6, 6, 10, 5, 5, 4, 5, 8, 6, 9, 4, 6, 4, 11, 4, 4, 6, 4, 4, 5, 4, 10, 5, 5, 5, 4, 6, 5, 5, 4, 4, 7, 16, 7, 6, 8, 4, 10, 7, 15, 7, 6, 6, 9, 16, 6, 4, 7, 7, 5, 4, 5, 10, 5, 5, 4, 3, 8, 4, 5, 5, 6)
mat_tc2=c(1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1)
mat_tc3=c(1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 4, 4, 4, 4, 4, 4, 4, 4, 4, 4, 4, 4, 4, 4, 4, 4, 4, 4, 4, 4, 4, 5, 5, 5, 5, 5, 5, 5, 5, 5, 5, 5, 5, 5, 5, 5, 6, 6, 6, 6, 6, 6, 6, 6, 6, 6, 6, 6, 6, 6, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 10, 10, 10, 10, 10, 10, 10, 10, 10, 10, 10, 10, 10, 10, 10, 11, 11, 11, 11, 11, 11, 11, 11, 11, 11, 11, 11, 11, 11, 12, 12, 12, 12, 12, 12, 12, 12, 12, 12, 12, 12, 12, 12, 13, 13, 13, 13, 13, 13, 13, 13, 13, 13, 13, 13, 13, 13, 13, 13, 13, 13, 13, 13, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 16, 16, 16, 16, 16, 16, 16, 16, 16, 16, 16, 16, 16, 16, 16, 16, 16, 16, 16, 17, 17, 17, 17, 17, 17, 17, 17, 17, 17, 17, 17, 17, 17, 17, 17, 17, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 19, 19, 19, 19, 19, 19, 19, 19, 19, 20, 20, 20, 20, 20, 20, 20, 20, 20, 20, 20, 20, 20, 20, 20, 20, 20, 21, 21, 21, 21, 21, 21, 21, 22, 22, 22, 22, 22, 23, 23, 23, 23, 23, 23, 23, 23, 23, 23, 23, 23, 23, 23, 23, 23, 23, 23, 23, 23, 23, 24, 24, 24, 24, 24, 24, 24, 24, 24, 24, 24, 24, 24, 24, 24, 24, 25, 25, 25, 25, 25, 25, 25, 25, 25, 25, 25, 25, 25, 25, 25, 25, 25, 25, 25, 26, 26, 26, 26, 26, 26, 26, 26, 26, 26, 26, 26, 26, 26, 27, 27, 27, 27, 27, 27, 27, 27, 27, 27, 27, 27, 27, 27, 27, 27, 27, 27)

cat_tc1=c(20, 6, 15, 5, 5, 12, 8, 8, 9, 14, 6, 10, 6, 9, 5, 5, 21, 5, 35, 17, 19, 7, 11, 12, 17, 12, 10, 12, 15, 7, 5, 10, 11, 6, 24, 6, 12, 11, 20, 12, 9, 9, 10, 19, 10, 5, 9, 10, 12, 19, 10, 11, 8, 11, 10, 6, 20, 17, 16, 6, 13, 15, 7, 15, 7, 13, 13, 18, 35, 8, 6, 8, 6, 15, 18, 8, 11, 13, 13, 5, 10, 8, 7, 8, 5, 7, 9, 12, 5, 18, 21, 5, 10, 6, 11, 11, 9, 20, 40, 6, 18, 9, 9, 7, 13, 27, 11, 6, 12, 7, 12, 10, 13, 5, 7, 28, 14, 14, 19, 7, 24, 18, 4, 13, 11, 20, 11, 7, 10, 7, 6, 6, 8, 6, 13, 4, 7, 14, 6, 8, 13, 7, 15, 5, 5, 5, 8, 15, 5, 9, 16, 8, 9, 24, 17, 25, 43, 8, 20, 18, 10, 16, 13, 32, 6, 12, 20, 14, 10, 9, 17, 7, 21, 10, 5, 12, 19, 6, 8, 10, 5, 5, 8, 5, 45, 29, 15, 16, 21, 7, 5, 7, 11, 6, 5, 6, 17, 10, 5, 5, 4, 8, 7, 11, 11, 11, 6, 7, 16, 5, 18, 5, 7, 10, 12, 18, 9, 5, 9, 11, 11, 5, 7, 6, 8, 10, 53, 5, 9, 11, 45, 23, 5, 6, 8, 8, 5, 9, 16, 8, 8, 6, 14, 7)
cat_tc2=c(0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0)
cat_tc3=c(1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 2, 2, 2, 2, 2, 2, 2, 2, 2, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 4, 4, 4, 4, 4, 4, 4, 4, 4, 4, 5, 5, 5, 5, 5, 5, 5, 5, 5, 5, 5, 6, 6, 6, 6, 6, 6, 6, 6, 6, 6, 8, 8, 8, 8, 8, 8, 8, 8, 8, 10, 10, 10, 10, 10, 10, 10, 10, 10, 10, 10, 10, 10, 11, 11, 11, 11, 11, 11, 11, 11, 11, 11, 11, 12, 12, 12, 12, 12, 12, 12, 12, 13, 13, 13, 13, 13, 13, 13, 13, 13, 13, 13, 14, 14, 14, 14, 14, 14, 14, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 16, 16, 16, 16, 16, 16, 16, 16, 16, 16, 16, 17, 17, 17, 17, 17, 17, 17, 17, 17, 18, 18, 18, 18, 18, 18, 19, 19, 19, 20, 20, 20, 20, 20, 20, 20, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 22, 22, 22, 23, 23, 23, 23, 23, 23, 23, 23, 23, 23, 23, 23, 23, 24, 24, 24, 24, 24, 24, 24, 24, 24, 24, 24, 24, 24, 24, 25, 25, 25, 25, 25, 25, 25, 25, 25, 25, 25, 25, 26, 26, 26, 26, 26, 27, 27, 27, 27, 27, 27, 27, 27, 27, 27, 27, 27, 27)

mean(mat_tc1)
sd(mat_tc1)

mean(cat_tc1)
sd(cat_tc1)

df2=data.frame()
for (j in 1:length(mat_tc1)){
  df2 = rbind(df2, c(mat_tc1[j],mat_tc2[j],mat_tc3[j]))
}
for (k in 1:length(cat_tc1)){
  df2 = rbind(df2, c(cat_tc1[k],cat_tc2[k],cat_tc3[k]))
}
names(df2)=c('num','mat','subj')
df2$mat <- factor(df2$mat, levels=c("0","1"))
df2 <- within(df2, mat <- relevel(mat, ref = "0"))
m2 = coxme(Surv(num,rep(1,(length(mat_tc1)+length(cat_tc1)))) ~ 1 + mat + (1|subj),data=df2)
summary(m2)


setwd("C:/Users/43365/Documents/school/Fall2017/machineLearning/project")

library("glmnet")
library("plotmo")
library("DMwR")
library("e1071")
library("ROCR")
library("caret")
library("nnet")

zscore <- function(column){
    if (is.factor(column)) {
        return(as.factor(column))
    }
    else {
        return((column - mean(column))/sd(column))
    }
} # Create user defined zscores function to ease zscore calculation

#Cleans a numeric column by removing the comma.  By default it will perform imputation using the column median, good for categorical variables.
transform_column_to_numeric <- function(column){
    new <- as.numeric(gsub(",", "", column))
    med <- median(new, na.rm=TRUE)
	new[which(is.na(new))] <- med
	new[which(!is.numeric(new))] <- med
	new[which(is.nan(new))] <- med
	new[which(is.infinite(new))] <- med
    if (is.factor(column)) {
        return(as.factor(new))
    }
    else {
        return (new)
    }
}

zscores <- function(dataframe) {
    new_df <- dataframe
    for (columnName in names(new_df)){
        new_df[, columnName] <- zscore(transform_column_to_numeric(new_df[, columnName]))
    }
    return(new_df)
}

######## Standardize dataset, establish y var and x vars
data <- read.csv("data.csv", header = TRUE)
y <- data$PCT_OBESE_ADULTS13

####### Find attributes closest to 2013.  Take only attributes expressed as a percentage or per capita figure(where applicable).  Remove codependent attributes (percent diabetes).
data$X2010.Census.Population <- NULL
data$Population.Estimate.2011 <- NULL
data$Population.Estimate.2012 <- NULL
data$Population.Estimate.2014 <- NULL
data$Population.Estimate.2015 <- NULL
data$Population.Estimate.2016 <- NULL
data$LACCESS_POP10 <- NULL
data$LACCESS_POP15 <- NULL
data$PCH_LACCESS_POP_10_15 <- NULL
data$PCT_LACCESS_POP10 <- NULL
data$LACCESS_LOWI10 <- NULL
data$LACCESS_LOWI15 <- NULL
data$PCH_LACCESS_LOWI_10_15 <- NULL
data$PCT_LACCESS_LOWI10 <- NULL
data$LACCESS_HHNV10 <- NULL
data$LACCESS_HHNV15 <- NULL
data$PCH_LACCESS_HHNV_10_15 <- NULL
data$PCT_LACCESS_HHNV10 <- NULL
data$LACCESS_SNAP15 <- NULL
data$LACCESS_CHILD10 <- NULL
data$LACCESS_CHILD15 <- NULL
data$LACCESS_CHILD_10_15 <- NULL
data$PCT_LACCESS_CHILD10 <- NULL
data$LACCESS_SENIORS10 <- NULL
data$LACCESS_SENIORS15 <- NULL
data$PCH_LACCESS_SENIORS_10_15 <- NULL
data$PCT_LACCESS_SENIORS10 <- NULL
data$LACCESS_WHITE15 <- NULL
data$LACCESS_BLACK15 <- NULL
data$LACCESS_HISP15 <- NULL
data$LACCESS_NHASIAN15 <- NULL
data$LACCESS_NHNA15 <- NULL
data$LACCESS_NHPI15 <- NULL
data$LACCESS_MULTIR15 <- NULL
data$FFR09 <- NULL
data$FFR14 <- NULL
data$FFRPTH09 <- NULL
data$PCH_FFRPTH_09_14 <- NULL
data$FSR09 <- NULL
data$FSR14 <- NULL
data$PCH_FSR_09_14 <- NULL
data$FSRPTH09 <- NULL
data$PCH_FSRPTH_09_14 <- NULL
data$PC_FFRSALES07 <- NULL
data$PC_FSRSALES07 <- NULL
data$GROC09 <- NULL
data$PCH_GROC_09_14 <- NULL
data$GROCPTH09 <- NULL
data$PCH_GROCPTH_09_14 <- NULL
data$SUPERC09 <- NULL
data$PCH_SUPERC_09_14 <- NULL
data$SUPERCPTH09 <- NULL
data$PCH_SUPERCPTH_09_14 <- NULL
data$CONVS09 <- NULL
data$PCH_CONVS_09_14 <- NULL
data$CONVSPTH09 <- NULL
data$PCH_CONVSPTH_09_14 <- NULL
data$SPECS09 <- NULL
data$PCH_SPECS_09_14 <- NULL
data$SPECSPTH09 <- NULL
data$PCH_SPECSPTH_09_14 <- NULL
data$SNAPS16 <- NULL
data$PCH_SNAPS_12_16 <- NULL
data$SNAPSPTH16 <- NULL
data$PCH_SNAPSPTH_12_16 <- NULL
data$WICS08 <- NULL
data$PCH_WICS_08_12 <- NULL
data$WICSPTH08 <- NULL
data$PCH_WICSPTH_08_12 <- NULL
data$REDEMP_SNAPS16 <- NULL
data$PCH_REDEMP_SNAPS_12_16 <- NULL
data$PCT_SNAP16 <- NULL
data$PCH_SNAP_12_16 <- NULL
data$PC_SNAPBEN10 <- NULL
data$PCH_PC_SNAPBEN_10_15 <- NULL
data$SNAP_PART_RATE08 <- NULL
data$SNAP_OAPP09 <- NULL
data$SNAP_CAP09 <- NULL
data$SNAP_BBCE09 <- NULL
data$SNAP_REPORTSIMPLE09 <- NULL
data$PCT_NSLP09 <- NULL
data$PCH_NSLP_09_15 <- NULL
data$PCT_FREE_LUNCH09 <- NULL
data$PCT_REDUCED_LUNCH09 <- NULL
data$PCT_SBP09 <- NULL
data$PCH_SBP_09_15 <- NULL
data$PCT_SFSP09 <- NULL
data$PCH_SFSP_09_15 <- NULL
data$PC_WIC_REDEMP08 <- NULL
data$PCH_PC_WIC_REDEMP_08_12 <- NULL
data$REDEMP_WICS08 <- NULL
data$PCH_REDEMP_WICS_08_12 <- NULL
data$PCT_WIC09 <- NULL
data$PCH_WIC_09_15 <- NULL
data$PCT_CACFP09 <- NULL
data$PCH_CACFP_09_15 <- NULL
data$FOODINSEC_10_12 <- NULL
data$FOODINSEC_13_15 <- NULL
data$CH_FOODINSEC_12_15 <- NULL
data$VLFOODSEC_10_12 <- NULL
data$VLFOODSEC_13_15 <- NULL
data$CH_VLFOODSEC_12_15 <- NULL
data$FOODINSEC_CHILD_01_07 <- NULL
data$FOODINSEC_CHILD_03_11 <- NULL
data$MILK_PRICE10 <- NULL
data$SODA_PRICE10 <- NULL
data$MILK_SODA_PRICE10 <- NULL
data$DIRSALES_FARMS07 <- NULL
data$DIRSALES_FARMS12 <- NULL
data$PCH_DIRSALES_FARMS_07_12 <- NULL
data$PCT_LOCLFARM07 <- NULL
data$PCT_LOCLSALE07 <- NULL
data$DIRSALES07 <- NULL
data$DIRSALES12 <- NULL
data$PCH_DIRSALES_07_12 <- NULL
data$PC_DIRSALES07 <- NULL
data$PCH_PC_DIRSALES_07_12 <- NULL
data$FMRKT09 <- NULL
data$PCH_FMRKT_09_16 <- NULL
data$FMRKTPTH09 <- NULL
data$PCH_FMRKTPTH_09_16 <- NULL
data$FMRKT_SNAP16 <- NULL
data$FMRKT_WIC16 <- NULL
data$FMRKT_WICCASH16 <- NULL
data$FMRKT_SFMNP16 <- NULL
data$FMRKT_CREDIT16 <- NULL
data$FMRKT_FRVEG16 <- NULL
data$FMRKT_ANMLPROD16 <- NULL
data$FMRKT_BAKED16 <- NULL
data$FMRKT_OTHERFOOD16 <- NULL
data$VEG_FARMS07 <- NULL
data$PCH_VEG_FARMS_07_12 <- NULL
data$VEG_ACRES07 <- NULL
data$PCH_VEG_ACRES_07_12 <- NULL
data$VEG_ACRESPTH07 <- NULL
data$PCH_VEG_ACRESPTH_07_12 <- NULL
data$FRESHVEG_FARMS07 <- NULL
data$PCH_FRESHVEG_FARMS_07_12 <- NULL
data$FRESHVEG_ACRES07 <- NULL
data$PCH_FRESHVEG_ACRES_07_12 <- NULL
data$FRESHVEG_ACRESPTH07 <- NULL
data$PCH_FRESHVEG_ACRESPTH_07_12 <- NULL
data$ORCHARD_FARMS07 <- NULL
data$PCH_ORCHARD_FARMS_07_12 <- NULL
data$ORCHARD_ACRES07 <- NULL
data$PCH_ORCHARD_ACRES_07_12 <- NULL
data$ORCHARD_ACRESPTH07 <- NULL
data$PCH_ORCHARD_ACRESPTH_07_12 <- NULL
data$BERRY_FARMS07 <- NULL
data$PCH_BERRY_FARMS_07_12 <- NULL
data$BERRY_ACRES07 <- NULL
data$PCH_BERRY_ACRES_07_12 <- NULL
data$BERRY_ACRESPTH07 <- NULL
data$PCH_BERRY_ACRESPTH_07_12 <- NULL
data$SLHOUSE07 <- NULL
data$PCH_SLHOUSE_07_12 <- NULL
data$GHVEG_FARMS07 <- NULL
data$PCH_GHVEG_FARMS_07_12 <- NULL
data$GHVEG_SQFT07 <- NULL
data$PCH_GHVEG_SQFT_07_12 <- NULL
data$GHVEG_SQFTPTH07 <- NULL
data$PCH_GHVEG_SQFTPTH_07_12 <- NULL
data$CSA07 <- NULL
data$PCH_CSA_07_12 <- NULL
data$AGRITRSM_OPS07 <- NULL
data$PCH_AGRITRSM_OPS_07_12 <- NULL
data$AGRITRSM_RCT07 <- NULL
data$PCH_AGRITRSM_RCT_07_12 <- NULL
data$FARM_TO_SCHOOL09 <- NULL
data$PCT_DIABETES_ADULTS08 <- NULL
data$PCT_DIABETES_ADULTS13 <- NULL
data$RECFAC09 <- NULL
data$PCH_RECFAC_09_14 <- NULL
data$RECFACPTH09 <- NULL
data$PCH_RECFACPTH_09_14 <- NULL
data$PCT_NHWHITE10 <- NULL
data$PCT_NHBLACK10 <- NULL
data$PCT_HISP10 <- NULL
data$PCT_NHASIAN10 <- NULL
data$PCT_NHNA10 <- NULL
data$PCT_NHPI10 <- NULL
data$PCT_65OLDER10 <- NULL
data$PCT_18YOUNGER10 <- NULL
data$PERPOV10 <- NULL
data$PERCHLDPOV10 <- NULL
data$POPLOSS10 <- NULL
data$SNAP_REPORTSIMPLE16 <- NULL
data$PCH_FFR_09_14 <- NULL
data$GROC14 <- NULL
data$SUPERC14 <- NULL
data$CONVS14 <- NULL
data$SPECS14 <- NULL
data$SNAPS12 <- NULL
data$WICS12 <- NULL
data$FMRKT16 <- NULL
data$VEG_FARMS12 <- NULL
data$VEG_ACRES12 <- NULL
data$FRESHVEG_ACRES12 <- NULL
data$ORCHARD_FARMS12 <- NULL
data$ORCHARD_ACRES12 <- NULL
data$BERRY_FARMS12 <- NULL
data$BERRY_ACRES12 <- NULL
data$GHVEG_SQFT12 <- NULL
data$RECFAC14 <- NULL

data$PCT_OBESE_ADULTS13 <- NULL
data$PCT_OBESE_ADULTS08 <- NULL

labels <- data.frame(data$FIPS, data$State, data$County)
data$FIPS <- NULL
data$State <- NULL
data$County <- NULL

# Factors
data$SNAP_CAP16 <- as.factor(data$SNAP_CAP16)
data$SNAP_BBCE16 <- as.factor(data$SNAP_BBCE16)
data$FARM_TO_SCHOOL13 <- as.factor(transform_column_to_numeric(data$FARM_TO_SCHOOL13))
data$Population.Estimate.2013 <- as.numeric(gsub(",", "", data$Population.Estimate.2013))

x <- data

# Perform imputation using column median
#x_z <- zscores(x)

# Perform imputation using nearest neighbors method (based on euclidian distance, uses square root of the number of observations for k)
x_knn = knnImputation(x, k=round(sqrt(nrow(x))))
x_z = zscores(x_knn)
x_z$SNAP_CAP16 <- as.numeric(x_z$SNAP_CAP16)
x_z$SNAP_BBCE16 <- as.numeric(x_z$SNAP_BBCE16)
x_z$FARM_TO_SCHOOL13 <- as.numeric(x_z$FARM_TO_SCHOOL13)

write.csv(x, file = "predictorData.csv")

write.csv(x_z, file = "predictorsNormalized.csv")

####### Linear model to check for outliers and identify significant predictors (using coefficients/p-values for significance and cook's distance for outliers)
x_z <- x_z
x_z$SNAP_CAP16 <- as.numeric(x_z$SNAP_CAP16)
x_z$SNAP_BBCE16 <- as.numeric(x_z$SNAP_BBCE16)
x_z$FARM_TO_SCHOOL13 <- as.numeric(x_z$FARM_TO_SCHOOL13)

linear_model <- lm(y ~ as.matrix(x_z))
summary(linear_model)
layout(matrix(c(1,2,3,4), 2, 2))
plot(linear_model)
cooks_distance <- cooks.distance(linear_model)
layout(matrix(c(1), 1, 1))
plot(cooks_distance, pch="*", cex=2, main="Cook's Distance")
abline(h = 4*mean(cooks_distance, na.rm=T), col="red")  # add cutoff line
text(x=1:length(cooks_distance)+1, y=cooks_distance, labels=ifelse(cooks_distance>4*mean(cooks_distance, na.rm=T),names(cooks_distance),""), col="red", pos=4) #labels

####### Remove outliers based on Cook's Distance
x_z <- x_z[-c(298,1013,1226),]
y <- y[-c(298,1013,1226)]

####### Lasso to determine significant predictors
layout(matrix(c(1), 1, 1))
lasso <- glmnet(as.matrix(x_z), y, alpha=1) # Create a lasso plot for the data
plot_glmnet(lasso)
cvmodel <- cv.glmnet(as.matrix(x_z), y, alpha=1, nfold=10) # Run CV model using 10-fold cross validation
coef(lasso, s=cvmodel$lambda.1se)
plot(cvmodel)
#Lambda chosen: 0.07562909
#Percent variability explained: 56%

####### Remove insignificant predictors
x_z$PCT_LACCESS_POP15 <- NULL
x_z$PCT_LACCESS_LOWI15 <- NULL
x_z$PCT_LACCESS_SNAP15 <- NULL
x_z$PCT_LACCESS_CHILD15 <- NULL
x_z$PCT_LACCESS_WHITE15 <- NULL
x_z$PCT_LACCESS_NHNA15 <- NULL
x_z$PCT_LACCESS_MULTIR15 <- NULL
x_z$SPECSPTH14 <- NULL
x_z$WICSPTH12 <- NULL
x_z$REDEMP_SNAPS12 <- NULL
x_z$PCT_REDUCED_LUNCH14 <- NULL
x_z$PCT_SBP15 <- NULL
x_z$REDEMP_WICS12 <- NULL
x_z$FDPIR12 <- NULL
x_z$SODATAX_VENDM14 <- NULL
x_z$CHIPSTAX_STORES14 <- NULL
x_z$FOOD_TAX14 <- NULL
x_z$PCT_LOCLSALE12 <- NULL
x_z$FMRKTPTH16 <- NULL
x_z$PCT_FMRKT_WIC16 <- NULL
x_z$PCT_FMRKT_WICCASH16 <- NULL
x_z$PCT_FMRKT_FRVEG16 <- NULL
x_z$PCT_FMRKT_BAKED16 <- NULL
x_z$PCT_FMRKT_OTHERFOOD16 <- NULL
x_z$VEG_ACRESPTH12 <- NULL
x_z$FRESHVEG_FARMS12 <- NULL
x_z$FRESHVEG_ACRESPTH12 <- NULL
x_z$BERRY_ACRESPTH12 <- NULL
x_z$SLHOUSE12 <- NULL
x_z$GHVEG_FARMS12 <- NULL
x_z$GHVEG_SQFTPTH12 <- NULL
x_z$FARM_TO_SCHOOL13 <- NULL
x_z$PCT_HSPA15 <- NULL
x_z$POVRATE15 <- NULL
x_z$CHILDPOVRATE15 <- NULL
x_z$METRO13 <- NULL

####### Set y-pred to predict whether a county is in the third quartile of obesity:
y_pred <- ifelse(y >= quantile(y,.75), 1, 0)
set.seed(320489239)
size <- floor(0.667 * nrow(x_z))
train_ind <- sample(seq_len(nrow(x_z)), size = size)
x_train <- x_z[train_ind,]
x_test <- x_z[-train_ind,]
y_train <- y_pred[train_ind]
y_test <- y_pred[-train_ind]
labels_train <- labels[train_ind,]
labels_test <- labels[-train_ind,]

write.csv(x_train, file = "x_train.csv")
write.csv(x_test, file = "x_test.csv")
write.csv(y_train, file = "y_train.csv")
write.csv(y_test, file = "y_test.csv")
write.csv(labels_train, file = "labels_train.csv")
write.csv(labels_test, file = "labels_test.csv")

####### SVM model - tune
cv <- tune(svm, x_train, as.factor(y_train), cross=10, probability=TRUE, kernel="radial") #Perform 10-fold cross validation on the data set
svm_model <- cv$best.model #Get the model selected by tune
summary (svm_model) #Summary information for the SVM model
summary(cv) #Summary information for the cross validation
svm_val <- predict(svm_model, x_test) #Using the model, predict cell dna on validation data for fold eight
svm_predicted <- as.numeric(levels(svm_val))[svm_val] #Convert predicted values to a numeric vector
svm_confusionMatrix <- confusionMatrix(svm_predicted, y_test, mode="prec_recall", positive="1") #Check precision, accuracy, and recall for the eighth fold
svm_confusionMatrix
svm_pred <- prediction(svm_predicted, y_test) #Build a prediction object using predicted classification values and actual class
svm_perf <- performance(svm_pred, measure="tpr", x.measure="fpr") #Build a performance object measuring true positive rate and false positive rate
plot(svm_perf) #Plot the ROC curve

####### Neural net
nnet_data <- x_train
nnet_data$y <- y_train
nn <- nnet(as.factor(y) ~ ., data=nnet_data, size=3)
summary (nn) #Summary information for the SVM model
predicted <- predict(nn, x_test, type="class")
confusionMatrix(as.factor(predicted), y_test, mode="prec_recall", positive="1") #Check precision, accuracy, and recall for the eighth fold
pred <- prediction(as.numeric(predicted), y_test) #Build a prediction object using predicted classification values and actual class
perf <- performance(pred, measure="tpr", x.measure="fpr") #Build a performance object measuring true positive rate and false positive rate
plot(perf) #Plot the ROC curve


discretize_data = function( x, brks, digits=NULL ) {
  # discretize data x along the break points .. and midpointss as labels
  o = as.numeric( as.character( cut( x, breaks=brks, labels=diff(brks)/2 + brks[-length(brks)], include.lowest=TRUE ) ))
  if (!is.null(digits)) o = signif(o, digits=digits )
  return( o )
}