## analyze effectiveness of Multiple Alignment method
# init
library(readr)
library(ggplot2)
library(reshape2)
library(hexbin)

# load data
#ev <- read_tsv('dat/ev.adjusted.txt')
ev <- read_tsv('dat/ev.adj.elite.txt')
ev.f <- ev[, c('Sequence', 'Proteins', 'Raw file',
               'Retention time','PEP', 'rt.minus', 'rt.plus',
               'muijs', 'sigmas', 'PEP.new')]

# set original PEP > 1 to PEP = 1
ev.f$PEP[ev.f$PEP > 1] = 1

# plot distributions of PEP and PEP.new
par(mfcol=c(2, 1))
with(ev.f, hist(PEP[PEP < 0.05], breaks=seq(0, 0.05, by=1e-3),
  main=paste('Original PEP\n',
             'PEP > 0.05:', sum(ev$PEP > 0.05), '(',
             formatC(sum(ev$PEP > 0.05) / length(ev$PEP) * 100, digits=4),'%)',
             '\nPEP < 0.05:', sum(ev$PEP < 0.05), '(',
             formatC(sum(ev$PEP < 0.05) / length(ev$PEP) * 100, digits=4),'%)'),
  xlab='Original PEP'))

with(ev.f, hist(PEP.new[PEP.new < 0.05], breaks=seq(0, 0.05, by=1e-3),
  main=paste('Adjusted PEP\n',
             'PEP > 0.05:', sum(ev.f$PEP.new > 0.05), '(',
             formatC(sum(ev.f$PEP.new > 0.05) / length(ev.f$PEP.new) * 100, digits=4),'%)',
             '\nPEP < 0.05:', sum(ev.f$PEP.new < 0.05), '(',
             formatC(sum(ev.f$PEP.new < 0.05) / length(ev.f$PEP.new) * 100, digits=4),'%)'),
  xlab='Adjusted PEP'))

## dPEP (PEP - PEP.new)
ev.f <- cbind(ev.f, ev.f$PEP.new - ev.f$PEP)
names(ev.f)[11] <- 'dPEP'

# change in PEP by experiment
dpep.exp <- aggregate(dPEP ~ `Raw file`, data=ev.f, FUN=mean)$dPEP
hist(dpep.exp, breaks=30)

# dPEP overall
hist(ev.f$dPEP, breaks=50, xlab='PEP.new - PEP',
     main=paste('Change in PEP (PEP.new - PEP)\n',
                '-1 = completely incorrect -> completely correct\n',
                '1 = completely correct -> completely incorrect') )

# for these complete reversals (abs(dPEP) == 1), what is the difference in retention time?
ev.f <- cbind(ev.f, ev.f$`Retention time` - ev.f$muijs)
names(ev.f)[12] <- 'dRT'
hist(ev.f$dRT, main='Difference in RT (dRT) for all PSMs') # for all

# can we correlate dRT and dPEP?
ndPEP <- (ev.f$dPEP + 1)/2 # normalize on a scale of 0 -> 1

# sample 10,000 at a time for sanity
c <- sample.int(nrow(ev.f), size=10000)
# run linear regression
mod.1 <- lm(ndPEP[c] ~ ev.f$dRT[c])

plot(resid(mod.1) ~ fitted(mod.1),
  xlab = "Fitted Values",
  ylab = "Residuals",
  main = "Residual Diagnostic Plot"
)
plot(ndPEP[c], ev.f$dRT[c])
ggplot() +
  geom_point(aes(x=ndPEP[c], y=ev.f$rt.plus[c]), alpha=0.1) +
  scale_x_log10()

# no way this is even close to correlating...

## look at dPEP for CON_ and REV_ proteins
inds.CON = grep('CON_', ev.f$Proteins)
inds.REV = grep('REV_', ev$`Leading razor protein`)

hist(ev.f$dPEP[inds.CON], breaks=100,
     main='Change in PEP for CON_ Contaminants',
     xlab='Change in PEP (PEP.new - PEP)')

hist(ev.f$dPEP[inds.REV], breaks=100,
     main='Change in PEP for REV_ Reverse Matches',
     xlab='Change in PEP (PEP.new - PEP)')

## look at dPEP for certain ranges of original PEP
# originally confident PEPs
dPEP <- ev.f$PEP.new - ev.f$PEP

# PEP < 0.05
inds.l005 <- ev.f$PEP < 0.05
hist(ev.f$dPEP[inds.l005], breaks=100,
     main='Change in PEP for PEP < 0.05',
     xlab='Change in PEP (PEP.new - PEP)')

# PEP < 5e-3
hist(ev.f$dPEP[ev.f$PEP < 5e-3], breaks=100,
     main='Change in PEP for PEP < 5e-3',
     xlab='Change in PEP (PEP.new - PEP)')

# PEP < 1e-4
hist(ev.f$dPEP[ev.f$PEP < 1e-4], breaks=100,
     main='Change in PEP for PEP < 1e-4',
     xlab='Change in PEP (PEP.new - PEP)')

## scatterplot original vs. adjusted PEPs
# we have 1.5M data points, so we either need density, hex bins, or contours

# try some random samples
c <- sample.int(nrow(ev.f), size=50000)
ggplot(ev.f[c,], aes(x=PEP, y=PEP.new)) +
  geom_point(alpha=0.1) +
  geom_abline(color='red') +
  scale_y_log10(limits=c(1e-10, 1), breaks=c(1e-10,1e-9,1e-8,1e-7,1e-6,1e-5,1e-4,1e-3,1e-2,1e-1,1)) +
  scale_x_log10(limits=c(1e-10, 1), breaks=c(1e-10,1e-9,1e-8,1e-7,1e-6,1e-5,1e-4,1e-3,1e-2,1e-1,1)) +
  labs(title=paste0('PEP.new vs. PEP - 10,000 PSMs\n',
                    'Elite Experiments Only'))

inds.trash = (ev.f$PEP >= 1 & ev.f$PEP.new >= 1) |
  seq(1,nrow(ev.f)) %in% inds.CON |
  seq(1,nrow(ev.f)) %in% inds.REV
ggplot(ev.f[(seq(1,nrow(ev.f)) %in% c) & !inds.trash,], aes(x=PEP, y=PEP.new)) +
  stat_density2d(geom='raster', aes(fill=..density..), contour=FALSE) +
  geom_abline(color='white') +
  scale_y_log10(limits=c(1e-10, 1)) +
  scale_x_log10(limits=c(1e-10, 1)) +
  labs(title='PEP vs. PEP.new - 10,000 PSMs')

ggplot(ev.f[(seq(1,nrow(ev.f)) %in% c),], aes(x=PEP, y=PEP.new)) +
  geom_point(alpha=0.1) +
  geom_abline(color='red') +
  scale_y_log10(limits=c(1e-3, 1)) +
  scale_x_log10(limits=c(1e-1, 1)) +
  labs(title='PEP.new vs. PEP - 10,000 PSMs')

# plot fractional increase of confident IDs as a function of p (alpha)
# and plot fractional increase of FDRs as a function of %

lseq <- function(from=1, to=100000, length.out=6) {
  # logarithmic spaced sequence
  # blatantly stolen from library("emdbook"), because need only this
  exp(seq(log(from), log(to), length.out = length.out))
}

# plot ratios of PEP.new / PEP over a log scale of p values (t)
t <- lseq(1e-3, 1e-1, length.out=100)
id.frac <- c(length=100)
id.frac.drt <- c(length=100)
counter <- 0
for (i in t) {
  counter <- counter + 1
  id.frac[counter] <- (sum(ev.f$PEP.new < i) / sum(ev.f$PEP < i))
  id.frac.drt[counter] <- (sum(ev.drt$PEP.new < i) / sum(ev.drt$PEP < i))
}

# calculate FDR and FDR.new
# where FDR for peptide i is sum(PEPi) / sum(i) - sum of PEPs over # of PSMs
ev.peps <- unique(ev.f$Sequence)
ev.FDR <- aggregate(PEP ~ Sequence, data=ev.f, FUN=function(x) {
  sum(x) / length(x)
})$PEP
ev.FDR.new <- aggregate(PEP.new ~ Sequence, data=ev.f, FUN=function(x) {
  sum(x) / length(x)
})$PEP.new

ev.FDR.drt <- aggregate(PEP ~ Sequence, data=ev.drt, FUN=function(x) {
  sum(x) / length(x)
})$PEP
ev.FDR.drt.new <- aggregate(PEP.new ~ Sequence, data=ev.drt, FUN=function(x) {
  sum(x) / length(x)
})$PEP.new

# plot ratios of FDR.new / FDR over a log scale of % values (tq)
tq <- lseq(1e-3, 1e-1, length.out=100)
fdr.frac <- c(length=100)
fdr.frac.drt <- c(length=100)
counter <- 0
for (i in tq) {
  counter <- counter + 1
  fdr.frac[counter] <- (sum(ev.FDR.new < i) / sum(ev.FDR < i))
  fdr.frac.drt[counter] <- (sum(ev.FDR.drt.new < i) / sum(ev.FDR.drt < i))
}

df <- data.frame(PEP=as.numeric(rbind(id.frac, id.frac.drt)),
                 FDR=as.numeric(rbind(fdr.frac, fdr.frac.drt)),
                 Method=as.factor(c('MA-STAN', 'dRT - Ali')), stringsAsFactors=FALSE)
df <- melt(df)

ggplot(df, aes(x=c(t, t, t*100, t*100), y=value)) +
  facet_wrap(Method~variable, nrow=2, scales='free') +
  geom_smooth(aes(color=variable)) +
  scale_x_log10() +
  labs(x='PEP Threshold | FDR Threshold (%)',
       y='Fractional Increase',
       title='Fractional Increase in PEP and FDR \nwith STAN Alignment')

##########################

#ev2 <- read_tsv('dat/ev.adjusted.2.txt')
ev2 <- read_tsv('dat/ev.adjusted.txt')
ev2.f <- ev2[, c('Sequence', 'Proteins', 'Raw file',
               'Retention time','PEP', 'rt.minus', 'rt.plus',
               'muijs', 'sigmas', 'PEP.new')]
ev2.f$PEP[ev2.f$PEP > 1] = 1

ev.dPEP <- ev.f$PEP.new - ev.f$PEP
ev2.dPEP <- ev2.f$PEP.new - ev2.f$PEP
# account for NAs
ev2.dPEP[is.na(ev2.f$PEP.new)] <- 0
ev2.PEP.new <- ev2.f$PEP.new
ev2.PEP.new[is.na(ev2.f$PEP.new)] <- ev2.f$PEP[is.na(ev2.f$PEP.new)]

ev3 <- read_tsv('dat/evidence+dRT.txt')
ev3.dPEP <- ev3$PEP.new - ev3$PEP

d <- data.frame(
  dPEP=as.numeric(rbind(ev.dPEP, ev2.dPEP)),
  PEP.new=as.numeric(rbind(ev.f$PEP.new, ev2.f$PEP.new)),
  Method=as.factor(c('Filter at 0.05','No Filter'))
)

ggplot(d) +
  geom_density(aes(x=dPEP, y=..density.., fill=Method), alpha=0.3) +
  xlim(c(-1, 1))

ggplot(d, aes(x=PEP.new, y=..density.., fill=Method)) +
  geom_density(alpha=0.3)

ggplot(d, aes(x=PEP.new, fill=Method)) +
  geom_histogram(binwidth=3e-2, position='dodge')

## plot fold changes between old method (parameters based on PEP < 0.05)
# and new method (parameters with all PSMs)

t <- lseq(1e-3, 1e-1, length.out=100)
id.frac <- c(length=300)
counter <- 0
for (i in t) {
  counter <- counter + 1
  id.frac[counter] <- (sum(ev.a$PEP.new < i) / sum(ev.a$PEP < i))
  id.frac[100+counter] <- (sum(ev2.f$PEP.new < i) / sum(ev2.f$PEP < i))
  id.frac[200+counter] <- (sum(ev3$PEP.new < i) / sum(ev3$PEP < i))
}

df <- data.frame(
  PEP=as.numeric(id.frac),
  Method=as.character(rep(c('Filter at 0.05','No Filter','Ali RT'),each=100))
)

ggplot(df, aes(x=rep(t, 3), y=PEP, color=Method, fill=Method)) +
  geom_smooth(method='loess') +
  scale_x_log10() +
  labs(x='PEP Threshold', y='Fold Change Increase in IDs',
       title=paste0('Fold Change Increase of PSM IDs\n',
                    '= #Adjusted PEPs / #Original PEPs above Threshold'))

## how many increased PEP (dPEP < 0) come from PSMs that come from sequences only
# identified once? (in the method w/ all PSMs forming the library)

# number of PSMs per sequence
ev.psms <- aggregate(dPEP ~ Sequence, data=ev.f, FUN=length)
names(ev.psms)[2] <- 'Count'

# smallest PEP for that sequence
ev.min.peps <- aggregate(dPEP ~ Sequence, data=ev.f, FUN=min)
#names(ev.min.peps)[2] <- 'dPEP'

# get all sequences with 1 PSM
i <- ev.psms$Count == 1
ev.sole.psms <- cbind(ev.psms[i,],ev.min.peps[i,]$dPEP)
names(ev.sole.psms)[3] <- 'dPEP'

## look at original PEPs below 1e-5 that get their PEP boosted by our method
# first create a subset of data for which we have updated params on
ev.a <- subset(ev.f, !is.na(ev.f$PEP.new))

# normalized dPEP
ev.a$PEP[ev.a$PEP == 0] <- 1e-100
ev.a$dPEP[ev.a$dPEP == 0] <- 1e-100
dPEP.norm <- ev.a$dPEP / ev.a$PEP
# look at 2-fold increases
inds <- ev.a$PEP < 1e-5 & dPEP.norm > 2
ev.twofold <- ev.a[inds,]
# look at general increases
inds <- ev.a$PEP < 1e-5 & dPEP.norm > 0
ev.increase <- ev.a[inds,]

# combine into one data set
a <- as.data.frame(rbind(
  cbind(ev.twofold$dRT, ev.twofold$rt.plus, '2-fold Increase'),
  cbind(ev.increase$dRT, ev.increase$rt.plus, 'Any Increase'),
  cbind(ev.a$dRT[ev.a$PEP < 1e-5], ev.a$rt.plus[ev.a$PEP < 1e-5], 'All')
), stringsAsFactors = FALSE)

names(a) <- c('dRT', 'rt.plus', 'Class')
a$Class <- factor(a$Class, levels=c('All', 'Any Increase', '2-fold Increase'))
a$dRT <- as.numeric(a$dRT)
a$rt.plus <- as.numeric(a$rt.plus)

ggplot(a, aes(x=abs(dRT), color=Class)) +
  geom_density(size=1) +
  scale_x_continuous(limits=c(0,70), breaks=seq(0,70,by=10)) +
  labs(title=paste0('abs(dRT) for PSMs with PEP < 1e-5'),
       color='Increase of PEP.new')

## calculate FDR

ev.PEP <- ev.f$PEP
ev.PEP <- sort(ev.PEP)


# use random forest as it understands negative values and categorical data

library(ggplot2)
library(phyloseq2ML)

names(splitted_keras_binary)
n_copies <- 5
original <- splitted_keras_binary
oversampled_test <- oversample(splitted_keras_binary, n_copies, 0.00)

# check the effect of oversampling
example_set <- oversampled_test[[2]][["train_set"]]
target <- names(example_set[ncol(example_set)])
# samples as rows
orig_cols <- names(example_set[-ncol(example_set)])
full_meta_data <- phyloseq::sample_data(testps)
oversampled_meta_data <- full_meta_data[rep(seq_len(nrow(full_meta_data)),
  each = 1 + n_copies), ]

# do I need this part? only if I want to subset before random Forest
# remove duplicate meta data columns
duplicates <- intersect(names(example_set),names(oversampled_meta_data))

oversampled_meta_data <- oversampled_meta_data[, !names(oversampled_meta_data) %in% duplicates]
merged_before <- merge(example_set, oversampled_meta_data, by = "row.names")
row.names(merged_before) <- merged_before$Row.names
merged_before$Row.names <- NULL

#exam_V4 <- subset(merged_before, Primerset == "V4")
#exam_V4_clean <- exam_V4[, colSums(exam_V4 != 0, na.rm = TRUE) > 0]

# only V4 data available in package training set, duh
exam_V4_clean <- merged_before
exam_V4_clean$replicate <- sapply(strsplit(row.names(exam_V4_clean), "\\."), "[", 2)

mtry_factor <- 5
all_vars <- ncol(example_set)
for_mtry <- ifelse((sqrt(all_vars) * mtry_factor) < all_vars,
  sqrt(all_vars) * mtry_factor, all_vars)
forest <- randomForest::randomForest(exam_V4_clean[, orig_cols], proximity = TRUE, ntree = 1000,
  mtry = for_mtry)

distance_matrix <- dist(1 - forest$proximity)
PCA_object <- cmdscale(distance_matrix, eig = TRUE, x.ret = TRUE)
# calculate percentage of variation for x and y axis
PCA_variation <- round(PCA_object$eig/sum(PCA_object$eig) * 100, 1)
# format data
PCA_values <- PCA_object$points
PCA_data <- data.frame(Sample = rownames(PCA_values),
                           X = PCA_values[, 1],
                           Y = PCA_values[, 2])

merged_after <- merge(PCA_data, exam_V4_clean, by = "row.names")

ggplot(merged_after, aes(X, Y, colour = replicate)) +
  geom_point(pch = 21, size = 3, stroke = 1.5, alpha = 0.8) +
  geom_polygon(aes(fill = !!target, group = Extraction_ID), alpha = 0.7) +
  #geom_text(aes(label = Row.names), size = 1.5, colour = "black") +
  labs(x = paste("PC1 - ", PCA_variation[1], "%", sep = ""),
    y = paste("PC2 - ", PCA_variation[2], "%", sep = ""))


library('ggplot2')
library('reshape')

data=read.table("counts_withID_full3", header=T,sep="\t")
data <- reshape(data,
                varying = c("AFR", "CEU", "CDX","YRI", "Khoisan"),
                v.names = "Source_propotion",
                timevar = "Source",
                times = c("1_AFR", "2_CEU", "3_CDX","4_YRI","5_Khoisan"),
                direction = "long")
data <- subset(data, select = -c(id))
Source=data$Source

p <- ggplot(data, aes(x=Source, y=Source_propotion)) +
             geom_point(alpha=0.3, aes(fill=Source, color=Source), position = "jitter", size = 0.7) +
             geom_boxplot(alpha=0, size=0.2) +
             ggtitle("Genome proportion assigned to source") +
             labs(y="Genome proportion") +
             theme(axis.title.x=element_blank(), legend.position="bottom",axis.text.x=element_blank(), axis.ticks.x=element_blank())
p2 <- p + facet_wrap( ~ Pop)
p3<- p2 + scale_color_manual(values=c("1_Khoisan"="#FF8C1E", "2_West_African"="#9A283D", "3_East_African"="#9FC22E" , "4_Eurasian"="#115E81" ))
ggsave(plot=p3, dpi=600, filename="STW5_RFMix_sourceproportion.pdf", width=8.3, height=11.7, units="in",  useDingbats=FALSE)


x <- y %*% z ;


EvoMorphoSpace<-function(tree,X,Y,sequence,colors){
            #Plot the EvoSpace
                  for(i in sequence){
                  jpeg(sprintf("./EvoSpace_%05.2f.jpg",i),res=300,height=8,width=8,units="in")
                  layout(matrix(c(1), 1, 1, byrow = TRUE))
                        Epoch<-i
                              EvoSpace_X<-MorphoSpaceEpoch(X,Epoch)
                              EvoSpace_Y<-MorphoSpaceEpoch(Y,Epoch)
                              par(bg="black")
                                    #UnEqual limits
                                          lim_min_x<-min(c(X$value_desc,X$value_anc))
                                          lim_min_y<-min(c(Y$value_desc,Y$value_anc))
                                          lim_max_x<-max(c(X$value_desc,X$value_anc))
                                          lim_max_y<-max(c(Y$value_desc,Y$value_anc))
                                          plot(EvoSpace_X$value_desc,EvoSpace_Y$value_desc,pch=19,col="red",bg="red",xlim=c(lim_min_x,lim_max_x),ylim=c(lim_min_y,lim_max_y),ylab="",xlab="",col.axis="white",fg="white")
                                          title(main=paste0((i),"Mya"),col.main="white")
                  dev.off()
                                     }
                                     }


rhyper_100 <- function(N, m, n) {
  N = as.numeric(N)
  m = as.numeric(m)
  n = as.numeric(n)

  if (n >= 100) {
    freq.table <- table(rhyper(N, m, n, 100))
  } else {
    freq.table <- table(rhyper(N, m, n, 10))
  }

  df.table <- as.data.frame(freq.table)

  return (list(as.numeric(df.table$Var1), df.table$Freq))
}

do.call(rhyper_100, input)


# -*- coding: utf-8 -*-

#' Created on Fri Apr 13 15:38:28 2018
#' R version 3.4.3 (2017-11-30)
#'
#' @group   Group 2, DM2 2018 Semester 2
#' @author: Martins T.
#' @author: Mendes R.
#' @author: Santos R.
#'

# Libs --------------------------------------------------------------------
options(warn=-1)
source("src/packages.r")
include_packs(c("dygraphs","d3heatmap","rockchalk","forcats","rJava",
                "xlsxjars","xlsx","tidyverse","stringi","stringr","ggcorrplot",
                "sm","lubridate","magrittr","ggplot2","openxlsx","RColorBrewer",
                "psych","treemap","data.table","pROC","class",'gmodels','klaR',
                "C50","caret",'gmodels',"DMwR","recipes","epiR","pubh"))

# Load data ---------------------------------------------------------------
#Load normalized data xlsx
source("src/wrangling.r")
numericDataset <- xlsx::read.xlsx('datasets/numericDataset.xlsx',1, header= TRUE)
temp<-numericDataset
numericDataset<-temp

numericDataset$isChurn <- ifelse(numericDataset$isChurn==1,"Yes","No")

#Save test_labels
numericDataset$isChurn <- as.factor(numericDataset$isChurn)

set.seed(375)

# ## now using SMOTE to create a more "balanced problem"
newData <- DMwR::SMOTE(isChurn ~ ., numericDataset, perc.over = 300,perc.under=0)
# count(newData$isChurn)
#
numericDataset<-rbind(numericDataset,newData)
# count(numericDataset$isChurn)

#glmStepAIC

#Setting up CV
ControlParamteres <- trainControl(method="repeatedcv",
                                  number=10,
                                  repeats=10,
                                  #sampling = "up",
                                  #verboseIter = FALSE,
                                  # metric = "ROC",
                                  savePredictions = TRUE,
                                  classProbs = TRUE)

#regLogistic
log_CV <- train(isChurn~.,
                data=numericDataset,
                method = "glm",
                preProc=c("center", "scale"),
                trControl = ControlParamteres)

log_CV

pred <- predict(log_CV)

#predict prob, no response w/ factors

numericDataset$prob <-predict(log_CV, type = "prob")[2]

g <- roc(isChurn ~ prob$Yes, data =numericDataset )
dev.off(); plot(g, col = 4, lty = 1,
                main = "ROC", asp = NA,
                xlab = "Specificity (%)",
                ylab = "Sensitivity (%)",
                print.auc=TRUE, type  = 'l', ps=1000)
legend(.35,.75,
       legend=c("48 Variables"),
       col=c("4"),
       lwd=2, ncol = 1,bty = "n", cex=1.3)

#confusionMatrix(pred, obs, positive = NULL,...), not the inverse
cm <- caret::confusionMatrix(pred,numericDataset$isChurn, positive = 'Yes',
                             dnn=c("Pred","Actual"))

draw_confusion_matrix_cv(cm)

lmFuncs$fit<-function (x, y, first, last, ...){
  tmp <- as.data.frame(x)
  tmp$y <- y
  glm(y ~ ., data = tmp,family=binomial)
}
#note that this lmFuncs is logistic regr by my overwrite function
rfe_controller <- rfeControl(functions=lmFuncs, method="repeatedcv",
                             rerank = FALSE,repeats = 10, verbose = FALSE)

subsets <- c(5:15)

predictorss<-normalizedDataset[,1:48]
predictorss<- predictorss[,sample(ncol(predictorss))]

log_Profiler <- rfe(predictorss,normalizedDataset[,49],
                    size=subsets, rfeControl = rfe_controller)
log_Profiler
plot(log_Profiler, type = c("g", "o"), col="blue")

ga_ctrl <- gafsControl(functions = rfGA,
                       method = "cv")
# , repeats = 1)

## Use the same random number seed as the RFE process
## so that the same CV folds are used for the external
## resampling.
set.seed(10)
rf_ga <- gafs(x = normalizedDataset[,1:48], y = normalizedDataset[,49],
              iters = 15,
              method = "glm",
              gafsControl = ga_ctrl)
rf_ga
plot(rf_ga, type = c("g", "o"), col="blue")

pubh::contingency(isChurn~Age, data = normalizedDataset, method = "cohort.count")


#' Calculate PROGENy pathway scores from gene expression
#'
#' This function uses the linear model of pathway-responsive genes underlying
#' the PROGENy method. It transforms a gene expression matrix with HGNC/MGI gene
#' symbols in rows and sample names in columns into a pathway score matrix with
#' samples in rows and pathways in columns.
#'
#' The publication of the method is available at:
#' https://www.nature.com/articles/s41467-017-02391-6
#'
#' The supplied expression object has to contain HGNC/MGI symbols in rows. This
#' will, in most cases (and how we originally used it), be either normalized
#' gene expression of a microarray experiment or log-transformed (and
#' possible variance-stabilized) counts from an RNA-seq experiment.
#'
#' The human and mouse model matrices consists of 14 pathways and large set of
#' genes with an associated p-value (p-value per gene and pathway) that accounts
#' for the importance of each gene on each pathway upon perturbation.
#' Its coefficients are non-zero if the gene-pathway pair corresponds
#' to the top N genes (100 by default) that were up-regulated upon stimulation
#' of the pathway in a wide range of experiments. The value corresponds to the
#' fitted z-score across experiments in our model fit.
#' Only rows with at least one non-zero coefficient were included, as the rest
#' is not used to infer pathway activity.
#'
#' @param expr   A gene expression object with HGNC/MGI symbols in rows and
#'               samples in columns. In order to run PROGENy in single-cell
#'               RNAseq data, it also accepts Seurat and SingleCellExperiment
#'               object, taking the normalized counts for the computation.
#' @param scale  A logical value indicating whether to scale the scores of each
#'               pathway to have a mean of zero and a standard deviation of one.
#'               It does not apply if we use permutations.
#' @param organism The model organism - "Human" or "Mouse"

#' @param top    The top n genes for generating the model matrix according to
#'               significance (p-value)
#' @param perm   An interger detailing the number of permutations. No
#'               permutations by default (1). When Permutations larger than 1,
#'               we compute progeny pathway scores and assesses their
#'               significance using a gene sampling-based permutation strategy,
#'               for a series of experimental samples/contrasts.
#' @param verbose    A logical value indicating whether to display a message
#'                   about the number of genes used per pathway to compute
#'                   progeny scores (i.e. number of genes present in the
#'                   progeny model and in the expression dataset)
#' @param z_scores Only applies if the number of permutations is greater than 1.
#'                 A logical value. TRUE: the z-scores will be returned for
#'                 the pathway activity estimations. FALSE: the function returns
#'                 a normalized z-score value between -1 and 1.
#' @param get_nulldist Only applies if the number of permutations is greater
#'                 than 1. A logical value. TRUE: the null distributions
#'                 generated to assess the signifance of the pathways scores
#'                 is also returned.
#' @param assay_name Only applies if the input is a Seurat object. It selects the
#'               name of the assay on which Progeny will be run. Default to:
#'               RNA, i.e. normalized expression values.
#' @param return_assay Only applies if the input is a Seurat object. A logical
#'               value indicating whether to return progeny results as a new
#'               assay called Progeny in the Seurat object used as input.
#'               Default to FALSE.
#' @param ...    Additional arguments to be passed to the functions.
#'
#' @return       A matrix with samples in rows and pathways in columns. In case
#'               we run the method with permutations and the option get_nulldist
#'               to TRUE, we will get a list with two elements. The first
#'               element is the matrix with the pathway activity as before.
#'               The second elements is the null distributions that we generate
#'               to assess the signifance of the pathways scores.
#' @export
#' @seealso \code{\link{progenyPerm}}
#' @examples
#' # use example gene expression matrix here, this is just for illustration
#' gene_expression <- as.matrix(read.csv(system.file("extdata",
#' "human_input.csv", package = "progeny"), row.names = 1))
#'
#' # calculate pathway activities
#' pathways <- progeny(gene_expression, scale=TRUE,
#'     organism="Human", top = 100, perm = 1)
progeny = function(expr, scale=TRUE, organism="Human", top = 100, perm = 1,
    verbose = FALSE, z_scores = FALSE, get_nulldist = FALSE, assay_name = "RNA",
    return_assay = FALSE, ...) {
    UseMethod("progeny")
}

#' @export
progeny.ExpressionSet = function(expr, scale=TRUE, organism="Human", top = 100,
    perm = 1, verbose = FALSE, z_scores = FALSE, get_nulldist = FALSE, ...) {

    progeny(Biobase::exprs(expr), scale=scale, organism=organism, top=top,
        perm = perm, verbose = verbose,  z_scores = z_scores,
        get_nulldist = get_nulldist)
}

#' @export
progeny.Seurat = function(expr, scale=TRUE, organism="Human", top = 100,
    perm = 1, verbose = FALSE, z_scores = FALSE, get_nulldist = FALSE,
    assay_name = "RNA", return_assay = FALSE,...) {

    requireNamespace("Seurat")

    if (!is.logical(return_assay)){
        stop("return_assay should be a logical value")
    }

    if (scale & return_assay){
        warning("Scale and return_assay should not be both true.
        Please use the function Seurat::ScaleData(object, assay = \"progeny\")
        to scale PROGENy scores. Scale is set to FALSE")
        scale = FALSE
    }

    results <- progeny(as.matrix(Seurat::GetAssayData(expr, slot = "data",
        assay = assay_name)), scale=scale, organism=organism, top=top,
        perm = perm, verbose = verbose, z_scores = z_scores,
        get_nulldist = get_nulldist, assay_name = assay_name,
        return_assay = return_assay)

    if (return_assay){
        expr[['progeny']] = Seurat::CreateAssayObject(data = t(results))
        Seurat::Key(object = expr[['progeny']]) <- 'progeny_'
        return(expr)
    } else {
        return(results)
    }

}

#' @export
progeny.SingleCellExperiment =  function(expr, scale=FALSE, organism="Human",
    top = 100, perm = 1, verbose = FALSE, z_scores = FALSE,
    get_nulldist = FALSE, ...) {

    requireNamespace("SingleCellExperiment")

    progeny(as.matrix(SingleCellExperiment::normcounts(expr)), scale=scale,
        organism=organism, top=top, perm = perm, verbose = verbose,
        z_scores = z_scores, get_nulldist = get_nulldist)
}

#' @export
progeny.matrix = function(expr, scale=TRUE, organism="Human", top = 100,
    perm = 1, verbose = FALSE,  z_scores = FALSE, get_nulldist = FALSE,...) {

    if (!is.logical(scale)){
        stop("scale should be a logical value")
    }

    if (!(is.numeric(perm)) || perm < 1){
        stop("perm should be an integer value")
    }

    if (!is.logical(verbose)){
        stop("verbose should be a logical value")
    }

    if (!is.logical(z_scores)){
        stop("z_scores should be a logical value")
    }

    if (!is.logical(get_nulldist)){
        stop("get_nulldist should be a logical value")
    }

    if (perm == 1 && (z_scores || get_nulldist)){
        if (verbose){
            message("z_scores and get_nulldist are only applicable when the
                number of permutations is larger than 1.")
        }
    }

    model <- getModel(organism, top=top)
    common_genes <- intersect(rownames(expr), rownames(model))

    if (verbose){
        number_genes <- apply(model, 2, function (x) {
            sum(rownames(model)[which (x != 0)] %in% unique(rownames(expr)))
        })
        message("Number of genes used per pathway to compute progeny scores:")
        message(paste(names(number_genes),": ", number_genes, " (",
            (number_genes/top)*100,"%)",sep = "","\n"))
    }

    if (perm==1) {
        result <- t(expr[common_genes,,drop=FALSE]) %*%
            as.matrix(model[common_genes,,drop=FALSE])

        if (scale && nrow(result) > 1) {
            rn <- rownames(result)
            result <- apply(result, 2, scale)
            rownames(result) <- rn
        }

    } else if (perm > 1) {
      expr <- data.frame(names = row.names(expr), row.names = NULL, expr)
      model <- data.frame(names = row.names(model), row.names = NULL, model)
      result <- progenyPerm(expr, model, k = perm, z_scores = z_scores,
          get_nulldist = get_nulldist)
    }

    return(result)
}

#' @export
progeny.default = function(expr, scale=TRUE, organism="Human", top = 100,
    perm = 1, verbose = FALSE, z_scores = FALSE, get_nulldist = FALSE, ...) {
    stop("Do not know how to access the data matrix from class ", class(expr))
}


# resp_rate_df.R
# Separate by bins the data by cde, 1 = right, 2 = left lever
# needs tidyverse and funtion bind_all_Ss.R

resp_rate_df <- function(dfs, res, n_trials){

  # dfs <- read_sep_by_lever(k,1)
  # print(k)

  if(is.null(res)) res <- 1
  if(!is.null(dfs)) {

    dfs     <- na.omit(dfs)

    # get max bin
    # get the bins of all response times,
    # then return bins
    # Note: if other resolution desired, change parameter 'res'

    dfs <- dfs %>% filter(cum_trial <= n_trials)

    #Establece
    dfs$bins <- dfs$cum_dt %>%
      get_bins(.,1,180,res)

    # filter if bins is greater than T*3
    dfs    <- dfs %>%
      as.data.frame() %>%
      filter(bins <= 180)
    # separates right component
    dfs_der     <- dfs %>% filter(cde == 1)
    # code resp on right component
    dfs_der$rsp <- ifelse(dfs_der$evento==1,1,0)
    # code head entry
    dfs_der$ec  <- ifelse(dfs_der$evento==12,1,0)
    # computes response rate by bin
    dfs_der_sum <- dfs_der %>%
      group_by(bins,cde,sujeto) %>%
      dplyr::summarise(
        resp = sum(rsp)/180,
        ec_resp = sum(ec)/180,
        n_resp = sum(rsp),
        n_ec   = sum(ec)
      ) %>% as.data.frame()
    # the same as in the other
    dfs_izq     <- dfs %>% filter(cde == 2)

    dfs_izq$rsp <- ifelse(dfs_izq$evento==11,1,0)
    dfs_izq$ec  <- ifelse(dfs_izq$evento==12,1,0)

    dfs_izq_sum <- dfs_izq %>%
      group_by(bins,cde,sujeto) %>%
      dplyr::summarise(
        resp = sum(rsp)/180,
        n_resp = sum(rsp),
        n_ec   = sum(ec),
        ec_resp=sum(ec)/180
      ) %>% as.data.frame()

    dfs_res_ec <- bind_rows(dfs_izq_sum,dfs_der_sum )

    dfs_res_ec
  }
}


library('mxnet')
model <- mx.model.load('CUDA_model2/pokerhands5M_3cpu.model',600)

#Generate deck for creating hands
deck <- paste0(rep(c(2:9, "T", "J", "Q", "K", "A"), 4),  #card values
               rep(c("s", "h", "d", "c"), each = 13)) #suits

#set up repeatedly used values for scoring the hands
cardarray <- rep(0,52)
cardID <- 2:14
names(cardID) <- c("2", "3", "4","5","6","7","8","9","T","J","Q","K","A")
suiteID <- 1:4
names(suiteID) <- c("s","d","c","h")
handarray <- rep(0,256)

handValue <- function(hand){
    #cardarray[int(suit_int)*13 + rank_int] = 1
    for (i in 1:length(hand)){
        card <- hand[i]
        cardarray[ cardID[[substr(card,0,1)]]-1 + suiteID[[substr(card,nchar(card),nchar(card))]]*13-13] <- 1
    }

    handConverted<-data.matrix(cardarray)
    #Paste the data in the right places to make this work as a 16 by 16 array and then reshape for scoring
    handarray[99:111] <- handConverted[1:13]
    handarray[115:127]<- handConverted[14:26]
    handarray[131:143]<- handConverted[27:39]
    handarray[147:159]<- handConverted[40:52]

    h2<-data.matrix(handarray)
    h_array <- h2
    dim(h_array)<-c(16,16,1,1)

    predicted <- predict(model, h_array)
    predicted_label <- max.col(t(predicted)) - 1
    return(predicted_label)
}


ProjDirPath = "C:\\xampp\\htdocs\\Testing\\"

#Loading Necessary Packages for Prediction
library(caret)
library(kknn)

#Loading Stock data CSV File saved as table.csv for stock ticker entered by user
DataPath = paste0(ProjDirPath,"table.csv")
stockData=read.csv(DataPath)

#Adding a new column "Distance" to stockData
stockData["Distance"] <- NA
no_of_row <- nrow(stockData)
for(n in 1:no_of_row){
stockData$Distance[n] <- stockData$Open[n] - stockData$Close[n+1]
}

#Adding a new column "Polarity" to stockData
stockData["Polarity"] <- NA
stockData$Polarity <- ifelse(stockData$Distance>0, "Up", "Down")

#Data Partition
PartitionData <- createDataPartition(y= stockData$Volume,p=0.40,list=FALSE)
TrainData <- stockData[-PartitionData,]
TestData <- stockData[PartitionData,]
dim(TrainData)
dim(TestData)

#Applyin knn algorithm
model <- kknn(Polarity~.,TrainData,TestData,k=13)
prediction <- summary(model)

#Obtaining Next Day Polarity as Result
result <- as.matrix(prediction)
result[1]

#Analyzing Algorithm Precision
fit <- fitted(m1)
table(TestData$Polarity, fit)

confusionMatrix(fit,TestData$Polarity)


context("Pretty milliseconds")

test_that("pretty_ms works", {

  expect_equal(pretty_ms(0), '0ms')
  expect_equal(pretty_ms(0.1), '1ms')
  expect_equal(pretty_ms(1), '1ms')
  expect_equal(pretty_ms(1000 + 400), '1.4s')
  expect_equal(pretty_ms(1000 * 2 + 400), '2.4s')
  expect_equal(pretty_ms(1000 * 55), '55s')
  expect_equal(pretty_ms(1000 * 67), '1m 7s')
  expect_equal(pretty_ms(1000 * 60 * 5), '5m')
  expect_equal(pretty_ms(1000 * 60 * 67), '1h 7m')
  expect_equal(pretty_ms(1000 * 60 * 60 * 12), '12h')
  expect_equal(pretty_ms(1000 * 60 * 60 * 40), '1d 16h')
  expect_equal(pretty_ms(1000 * 60 * 60 * 999), '41d 15h')

})

test_that("compact pretty_ms works", {

  expect_equal(pretty_ms(1000 + 4, compact = TRUE), '~1s')
  expect_equal(pretty_ms(1000 * 60 * 60 * 999, compact =  TRUE), '~41d')

})

test_that("pretty_ms handles vectors", {

  v <- c(0, 0.1, 1, 1400, 2400, 1000 * 55, 1000 * 67,
         1000 * 60 * 5, 1000 * 60 * 67, 1000 * 60 * 60 * 12,
         1000 * 60 * 60 * 40, 1000 * 60 * 60 * 999)
  v2 <- c("0ms", "1ms", "1ms", "1.4s", "2.4s", "55s", "1m 7s",
          "5m", "1h 7m", "12h", "1d 16h", "41d 15h")

  expect_equal(pretty_ms(v), v2)
})

context("Pretty seconds")

test_that("pretty_sec works", {

  expect_equal(pretty_sec(0 / 1000), '0ms')
  expect_equal(pretty_sec(0.1 / 1000), '1ms')
  expect_equal(pretty_sec(1 / 1000), '1ms')
  expect_equal(pretty_sec((1000 + 400) / 1000), '1.4s')
  expect_equal(pretty_sec((1000 * 2 + 400) / 1000), '2.4s')
  expect_equal(pretty_sec(1000 * 55 / 1000), '55s')
  expect_equal(pretty_sec(1000 * 67 / 1000), '1m 7s')
  expect_equal(pretty_sec(1000 * 60 * 5 / 1000), '5m')
  expect_equal(pretty_sec(1000 * 60 * 67 / 1000), '1h 7m')
  expect_equal(pretty_sec(1000 * 60 * 60 * 12 / 1000), '12h')
  expect_equal(pretty_sec(1000 * 60 * 60 * 40 / 1000), '1d 16h')
  expect_equal(pretty_sec(1000 * 60 * 60 * 999 / 1000), '41d 15h')

})

test_that("compact pretty_sec works", {

  expect_equal(pretty_sec((1000 + 4) / 1000, compact = TRUE), '~1s')
  expect_equal(pretty_sec(1000 * 60 * 60 * 999 / 1000, compact =  TRUE), '~41d')

})

test_that("pretty_sec handles vectors", {

  v <- c(0, 0.1, 1, 1400, 2400, 1000 * 55, 1000 * 67,
         1000 * 60 * 5, 1000 * 60 * 67, 1000 * 60 * 60 * 12,
         1000 * 60 * 60 * 40, 1000 * 60 * 60 * 999) / 1000
  v2 <- c("0ms", "1ms", "1ms", "1.4s", "2.4s", "55s", "1m 7s",
          "5m", "1h 7m", "12h", "1d 16h", "41d 15h")

  expect_equal(pretty_sec(v), v2)
})

context("Pretty dt")

test_that("pretty_dt works", {

  expect_equal(pretty_dt(as.difftime(units = "secs", 0 / 1000)), '0ms')
  expect_equal(pretty_dt(as.difftime(units = "secs", 0.1 / 1000)), '1ms')
  expect_equal(pretty_dt(as.difftime(units = "secs", 1 / 1000)), '1ms')
  expect_equal(pretty_dt(as.difftime(units = "secs", (1000 + 400) / 1000)), '1.4s')
  expect_equal(pretty_dt(as.difftime(units = "secs", (1000 * 2 + 400) / 1000)), '2.4s')
  expect_equal(pretty_dt(as.difftime(units = "secs", 1000 * 55 / 1000)), '55s')
  expect_equal(pretty_dt(as.difftime(units = "secs", 1000 * 67 / 1000)), '1m 7s')
  expect_equal(pretty_dt(as.difftime(units = "secs", 1000 * 60 * 5 / 1000)), '5m')
  expect_equal(pretty_dt(as.difftime(units = "secs", 1000 * 60 * 67 / 1000)), '1h 7m')
  expect_equal(pretty_dt(as.difftime(units = "secs", 1000 * 60 * 60 * 12 / 1000)), '12h')
  expect_equal(pretty_dt(as.difftime(units = "secs", 1000 * 60 * 60 * 40 / 1000)), '1d 16h')
  expect_equal(pretty_dt(as.difftime(units = "secs", 1000 * 60 * 60 * 999 / 1000)), '41d 15h')

})

test_that("compact pretty_dt works", {

  expect_equal(pretty_dt(as.difftime(units = "secs", (1000 + 4) / 1000), compact = TRUE), '~1s')
  expect_equal(pretty_dt(as.difftime(units = "secs", 1000 * 60 * 60 * 999 / 1000), compact =  TRUE), '~41d')

})

test_that("pretty_dt handles vectors", {

  v <- c(0, 0.1, 1, 1400, 2400, 1000 * 55, 1000 * 67,
         1000 * 60 * 5, 1000 * 60 * 67, 1000 * 60 * 60 * 12,
         1000 * 60 * 60 * 40, 1000 * 60 * 60 * 999) / 1000
  v2 <- c("0ms", "1ms", "1ms", "1.4s", "2.4s", "55s", "1m 7s",
          "5m", "1h 7m", "12h", "1d 16h", "41d 15h")

  expect_equal(pretty_dt(as.difftime(units = "secs", v)), v2)
})


# movies is pre-loaded in your workspace

# Customize the plot further
plot(movies$votes, movies$runtime,
     main = "Votes versus Runtime",
     xlab = "Number of votes [-]",
     ylab = "Runtime [s]",
     sub = "No clear correlation",
     pch = 9,
     col = "#dd2d2d",
     col.main = 604)


## This is a work in progress

plotres <- function(fit, df, x) {
    ## function to plot residuals
    fitsum <- summary(fit)
    residuals <- fitsum$residuals
    dffit <- cbind(df, dffit, residuals)
    #plotfit(dffit, logy, fit)
    #abline(a=0,b=1,col="red")   # y = a + b x
#
#    plotfit(dffit, fit, residuals)
#
#    plot(dffit$fit, dffit$residuals)
#    x <- dffit$fit
#    y <- dffit$residuals
#    smooth <- predict( lm(y ~ x + I(x^2) + I(x^3)) )
#    smooth <- data.frame(x,y,smooth)
#    smooth <- smooth[order(smooth$x),]
#    lines(smooth$x,smooth$smooth)
}


#: --- assign value for "catg_part_dt" (categorical cols)--------
# assign "missing_value".
#: memory efficient version, replace in place, serial.
for (var in catg_var_withNAs_names) {

  message("+ ", appendLF = FALSE)
  #temp <- temp %>% unlist
  temp <- joined_dt[[var]]
  #head(temp) %>% print
  levels(temp) <- c(levels(temp), "missing_value")
  temp[is.na(temp)] <- "missing_value"
  set(joined_dt, i = NULL, j = var, value = temp )

}

# or

# #: parallel, faster with spread on 29 cores, but need more memory.
# catg_part_dt <- foreach (temp = joined_dt[, catg_var_withNAs_names, with = FALSE], .inorder = TRUE, .combine = cbind) %dopar% {

#     #message("+ ", appendLF = FALSE)
#     #temp <- temp %>% unlist
#     #temp <- joined_dt[ , var, with = FALSE] %>% unlist
#     #head(temp) %>% print
#     levels(temp) <- c(levels(temp), "missing_value")
#     temp[is.na(temp)] <- "missing_value"
#     #set(joined_dt, i = NULL, j = var, value = temp )
#     #head(temp) %>% print
#     return(temp %>% as.data.table)

# }

# #: then assign collected data.table back to `joined_dt`s corresponding colnames.
# joined_dt[, (catg_var_withNAs_names) := catg_part_dt]

#: --- assign value for "contin_part_dt" (continuous, i.e., numeric and integer, cols)--------
# assign median (or mean), here use median.
for (var in contin_var_withNAs_names) {

  set(joined_dt, i = which(is.na(joined_dt[[var]])), j = var, value =  joined_dt[[var]] %>% median(., na.rm = TRUE))
  message("+ ", appendLF = FALSE)
}


pdf_file<-"pdf/timeseries_seasonalsubseries_inc.pdf"
cairo_pdf(bg="grey98", pdf_file,width=8,height=8)
par(omi=c(1,0,1,0.5),mai=c(2,0.80,0,0.5),family="Lato Light",las=1)

# Import data and prepare chart

source("scripts/inc_datadesign_dbconnect.r")
sql<-"select left(week, 4) year, substr(week, 6, 2) month, avg(chicken_soup) chicken_soup from google_trends group by left(week, 4), substr(week, 6, 2) order by year, month"
myData<-dbGetQuery(con,sql)
attach(myData)
y<-ts(chicken_soup,frequency =12,start=c(2004,1))

# Create chart

monthplot(y,axes=F,box=F,type="h",lwd=3,col="darkred",ylab="Normalized Search Activity")
axis(2,col=par("bg"),col.ticks="grey81",lwd.ticks=0.5,tck=-0.025)

# Titling

mtext("Google trend for 'chicken soup'",3,line=2,adj=0,cex=2.0,family="Lato Black",outer=T)
mtext("Jan 2004 to Feb 2012",3,line=0,adj=0,cex=1.5,font=3,outer=T)
mtext("Source: www.google.com/trends",1,line=3,adj=1.0,cex=0.95,font=3,outer=T)
dev.off()


dyn.load('/Library/Java/JavaVirtualMachines/jdk1.8.0_131.jdk/Contents/Home/jre/lib/server/libjvm.dylib')
library(rJava)

setwd("/Users/mengmengjiang/all datas/print")

library(xlsx)

# reading ux and sd

k1<-read.xlsx("dotx.xlsx",sheetName="600",header=TRUE)
k2<-read.xlsx("dotx.xlsx",sheetName="1khz",header=TRUE)
k3<-read.xlsx("dotx.xlsx",sheetName="2khz",header=TRUE)
k4<-read.xlsx("dotx.xlsx",sheetName="2.5khz",header=TRUE)

# errorbar
error.bar <- function(x, y, upper, coll,lower=upper, length=0.05,...){
if(length(x) != length(y) | length(y) !=length(lower) | length(lower) != length(upper))
stop("vectors must be same length")
arrows(x,y+upper, x, y-lower,col=coll, angle=90, code=3, length=length, ...)
}

# color setting

yan<-c("red","blue","black","green3")
pcc<-c(0,1,2,5)

# plot

plot(k1$ux,k1$sdeva, col=0,xlab = expression(italic(U["x"]) (mm/s)),
          ylab = expression(italic(S["d"]) (um)), mgp=c(1.1, 0, 0),tck=0.02,
               main = "", xlim = c(0,300),ylim=c(0,400))

mtext("Droplet space",3,line=0.2,font=2,cex=1.2)

points(k1$ux,k1$sdeva,col=yan[1],pch=pcc[1])
points(k2$ux,k2$sdeva,col=yan[2],pch=pcc[2])
points(k3$ux,k3$sdeva,col=yan[3],pch=pcc[3])
points(k4$ux,k4$sdeva,col=yan[4],pch=pcc[4])

z1<-lm(k1$sdeva~k1$ux)
z2<-lm(k2$sdeva~k2$ux)
z3<-lm(k3$sdeva~k3$ux)
z4<-lm(k4$sdeva~k4$ux)

abline(z1,col=yan[1],lwd=1.5,lty=2)
abline(z2,col=yan[2],lwd=1.5,lty=2)
abline(z3,col=yan[3],lwd=1.5,lty=2)
abline(z4,col=yan[4],lwd=1.5,lty=2)

error.bar(k1$ux,k1$sdeva,k1$sdstd/2,col=yan[1])
error.bar(k2$ux,k2$sdeva,k2$sdstd/2,col=yan[2])
error.bar(k3$ux,k3$sdeva,k3$sdstd/2,col=yan[3])
error.bar(k4$ux,k4$sdeva,k4$sdstd/2,col=yan[4])

leg<-c("600Hz","1KHz","2KHz","2.5KHz")

legend("topright",legend=leg,col=yan,pch=pcc,lwd=1.5,lty=2,inset=.02,
bty="n")


#Write a function named 'pollutantmean' that calculates the mean of a pollutant (sulfate or nitrate) across a specified list of monitors.
#The function 'pollutantmean' takes three arguments: 'directory', 'pollutant', and 'id'.
#Given a vector monitor ID numbers, 'pollutantmean' reads that monitors' particulate matter data from the directory specified in the 'directory' argument
#and returns the mean of the pollutant across all of the monitors, ignoring any missing values coded as NA.

pollutantmean <- function(directory, pollutant, id = 1:332) {
        data <- list.files(directory, full.names = TRUE)
        pollutant_data <- data.frame()
        for (i in id) {
        csv_file <- read.csv(data[i])
        pollutant_data <- rbind(pollutant_data, csv_file)
        }

        mean(pollutant_data[, pollutant], na.rm = TRUE)
}

Data Science /R Programming/ProgrammingAssignment1/pollutantmean.r


#Equivalence of FD's
equivalence <- function(fd1,fd2){
  #All Attributes on RHS of FD1
  temp <- strsplit(paste(fd1[,'V2'],collapse = ''),'')[[1]]
  temp <- temp[!duplicated(temp)]
  rhs_fd1 <- paste(sort(temp),collapse = '')

  #All Attributes on RHS of FD2
  temp <- strsplit(paste(fd2[,'V2'],collapse = ''),'')[[1]]
  temp <- temp[!duplicated(temp)]
  rhs_fd2 <- paste(sort(temp),collapse = '')

  equi = FALSE
  if(rhs_fd1 == rhs_fd2){
    c1 = check_subset(fd1,fd2) #In function.r
    c2 = check_subset(fd2,fd1) #In function.r
    if(c1 == c2)
      equi = TRUE
  }
  return(equi)
}


#   Differential expression analysis with limma
library(Biobase)
library(GEOquery)
library(limma)

# load series and platform data from GEO

gset <- getGEO("GSE53012", GSEMatrix =TRUE, destdir= ".")
if (length(gset) > 1) idx <- grep("GPL570", attr(gset, "names")) else idx <- 1
gset <- gset[[idx]]

# make proper column names to match toptable
fvarLabels(gset) <- make.names(fvarLabels(gset))

# group names for all samples
sml <- c("X","X","X","X","X","X","X","X","X","X","X","X","X","X","X","X","X","X","X","X","X","G1","G1","G1","G0","G0","G0");

# eliminate samples marked as "X"
sel <- which(sml != "X")
sml <- sml[sel]
gset <- gset[ ,sel]

# log2 transform
ex <- exprs(gset)
qx <- as.numeric(quantile(ex, c(0., 0.25, 0.5, 0.75, 0.99, 1.0), na.rm=T))
LogC <- (qx[5] > 100) ||
        (qx[6]-qx[1] > 50 && qx[2] > 0) ||
        (qx[2] > 0 && qx[2] < 1 && qx[4] > 1 && qx[4] < 2)
if (LogC) { ex[which(ex <= 0)] <- NaN
            exprs(gset) <- log2(ex) }

# set up the data and proceed with analysis
fl <- as.factor(sml)
gset$description <- fl
design <- model.matrix(~ description + 0, gset)
colnames(design) <- levels(fl)
fit <- lmFit(gset, design)
cont.matrix <- makeContrasts(G1-G0, levels=design)
fit2 <- contrasts.fit(fit, cont.matrix)
fit2 <- eBayes(fit2, 0.01)
tT <- topTable(fit2, adjust="fdr", sort.by="P", number=10000)

# load NCBI platform annotation
gpl <- annotation(gset)
platf <- getGEO(gpl, AnnotGPL=TRUE)
ncbifd <- data.frame(attr(dataTable(platf), "table"))

# replace original platform annotation
tT <- tT[setdiff(colnames(tT), setdiff(fvarLabels(gset), "ID"))]
tT <- merge(tT, ncbifd, by="ID")
tT <- tT[order(tT$P.Value), ]  # restore correct order

tT <- subset(tT, select=c("ID","adj.P.Val","P.Value","t","B","logFC","Gene.symbol","Gene.title"))
tT


#### load libraries

#source('functions.R')
#source('unittests.r')
library(reshape2)
library(openxlsx)
library(lme4)
library(heatmap.plus)
library(ggrepel)
# library(ggforce)

#### load data

clean<-function(x,skip=1){
	x = x[,-skip]
	x$Dataset = paste0('d',x$Dataset)
	x$Secretor = ! x$Pateint.ID %in% c('L2','L3')
	x$scretor_col = ifelse(x$Secretor,'black','grey')
	x$DPP_col = heat.colors(length(unique(x$DPP)))[factor(x$DPP)]
	x= droplevels(na.omit(x[ x$Dataset=='d1' ,] ))
	x$subject_col = rainbow(length(levels(x$Pateint.ID)))[x$Pateint.ID]
	x
}

ma = clean( read.csv('/Users/apple/PycharmProjects/GlyCompare/hmo/refinaldatawillbeused/motif_abundance.csv') )
mand = clean( read.csv('/Users/apple/PycharmProjects/GlyCompare/hmo/refinaldatawillbeused/motif_abundance_nodes_dropped.csv') )
mandm = clean( read.csv('/Users/apple/PycharmProjects/GlyCompare/hmo/refinaldatawillbeused/motif_abundance_nodes_dropped_more.csv') )
smandm = clean( read.csv('/Users/apple/PycharmProjects/GlyCompare/hmo/refinaldatawillbeused/smallest_motif_abundance_nodes_dropped_more.csv') )
gly = clean ( tmp<-read.csv('/Users/apple/PycharmProjects/GlyCompare/hmo/Data12.csv'), 21)

vars = c( grep('X',colnames(ma),value=T), colnames(gly)[4:19])

gly_p = gly
gly_p[,colnames(gly)[4:19]] = gly[,colnames(gly)[4:19]]/as.numeric(as.character(gly$SUM))

data=list(motif_abundance=ma,motif_abundance_dropped=mand,motif_abundance_dropped_more=mandm,smallest_motif_abundance_dropped_more=smandm,glycan_concentration=gly,glycan_percent=gly_p)

#### heatmaps

pdf('./secretor.pdf')
lapply(names(data),function(xn){
	print(xn)
	x=data[[xn]]
	data_i = data.matrix(x[,colnames(x)%in%vars])
	cols = as.matrix(x[,rev(c('scretor_col','subject_col','DPP_col'))])
	heatmap.plus( data_i,RowSideColors=cols,main=xn) #,
#		hclustfun=function(x) hclust(x,method="complete"),distfun=function(x) as.dist((1 - cor(  t(x) ,method='spearman' ))/2))
	heatmap.plus( scale(data_i),RowSideColors=cols,main=paste('z-normalized',xn)) #,
#		hclustfun=function(x) hclust(x,method="complete"),distfun=function(x) as.dist((1 - cor(  t(x) ,method='spearman' ))/2))
	})
dev.off()

pdf('./secretor.pearson_dist.pdf')
lapply(names(data),function(xn){
	print(xn)
	x=data[[xn]]
	data_i = data.matrix(x[,colnames(x)%in%vars])
	cols = as.matrix(x[,rev(c('scretor_col','subject_col','DPP_col'))])
	heatmap.plus( data_i,RowSideColors=cols,main=xn,
		hclustfun=function(x) hclust(x,method="complete"),distfun=function(x) as.dist((1 - cor(  t(x) ,method='pearson' ))/2))
	heatmap.plus( scale(data_i),RowSideColors=cols,main=paste('z-normalized',xn),
		hclustfun=function(x) hclust(x,method="complete"),distfun=function(x) as.dist((1 - cor(  t(x) ,method='pearson' ))/2))
	})
dev.off()

# changes in correlation
lapply(names(data)[-(1:2)],function(xn){
	print(xn)
	x=data[[xn]]
	cr_sec = cor(data.matrix(x[x$Secretor,colnames(x)%in%vars]),method='spearman')
	cr_nsec = cor(data.matrix(x[!x$Secretor,colnames(x)%in%vars]),method='spearman')

	m1=melt(cr_sec)
	m2=melt(cr_nsec)
	m=cbind(m1,m2[,3])
	m[,1:2] = t(apply( m[,1:2],1,sort))

	colnames(m)[3:4] = c('value_sec','value_nsec')
	m$prod = (m[,3]^2+m[,4]^2)^.5
	m$lab = ifelse(m$prod>.5 & sign(m[,3])!=sign(m[,4]),paste(gsub('X','',m$X1),gsub('X','',m$X2),sep='~'),NA)

	g=ggplot( unique(m) , aes(x=value_sec,y=value_nsec , label=lab)) + geom_label_repel(size=7) + geom_point()+
		geom_hline(yintercept=0)+geom_vline(xintercept=0)+geom_abline() +
		theme_classic(base_size=35)
	ggsave(g,filename=paste0('motifAnyl/cor_diff.',xn,'.pdf'))
		#+geom_circle() # +stat_ellipse(level=.5)
})

#### regression
library(lme4)
library(gee)

i=0
out_i=lapply( data, function(x){
	i=i+1
	x$Secretor = as.numeric(x$Secretor)
#	x$Secretor = relevel(factor(ifelse(x$Secretor,'secretor','nonsecretor')),ref='nonsecretor')
	mods_i = lapply( colnames(x)[colnames(x)%in%vars] , function(motif){
		mod=NA
		#try(mod<-gee(as.formula(paste('Secretor ~log(DPP)+scale(',motif,')')),id=Pateint.ID,family='binomial',data=droplevels(x)))
		try(mod<-gee(as.formula(paste('Secretor ~log(DPP)+scale(',motif,')')),id=Pateint.ID,family='binomial',data=droplevels(x),corstr='exchangeable'))
#		if(i>=4){
#			try(mod<-gee(as.formula(paste('Secretor ~log(DPP)+log(',motif,')')),id=Pateint.ID,family='binomial',data=droplevels(x),corstr='exchangeable'))
#		}else{
#			try(mod<-gee(as.formula(paste('Secretor ~log(DPP)+',motif)),id=Pateint.ID,family='binomial',data=droplevels(x),corstr='exchangeable'))
#		}9632
		#try(mod<-glmer(as.formula(paste('Secretor ~log(DPP)+',motif,'+(1|Pateint.ID)')),family='binomial',data=droplevels(x)))
		#print(coef(summary(mod)))
		if(is.na(mod)){return(NULL)}else{coef(summary(mod))}
	})
	mods=as.data.frame( do.call(rbind,mods_i[!sapply(mods_i,is.null)]) )
	colnames(mods) = c('Coef','naiveSE','naiveZ','robustSE','robustZ')
	mods$vars = gsub('scale|log|\\(|\\)','',rownames(mods))
	mods$response = 'secretor'
	mods$robustPr = 2*pnorm(-abs(mods$robustZ))
	mods1=mods[mods$vars%in%vars,]

	mods_i = lapply( colnames(x)[colnames(x)%in%vars] , function(motif){
		mod=NA
		try(mod<-gee(as.formula(paste('log(DPP) ~Secretor+scale(',motif,')')),id=Pateint.ID,data=droplevels(x),corstr='exchangeable'))
#		if(i>=4){
#			try(mod<-gee(as.formula(paste('log(DPP)~Secretor+log(',motif,')')),id=Pateint.ID,data=droplevels(x),corstr='exchangeable'))
#		}else{
#			try(mod<-gee(as.formula(paste('log(DPP)~Secretor+',motif)),id=Pateint.ID,data=droplevels(x),corstr='exchangeable'))
#		}		#try(mod<-glmer(as.formula(paste('Secretor ~log(DPP)+',motif,'+(1|Pateint.ID)')),family='binomial',data=droplevels(x)))
		#print(coef(summary(mod)))
		if(is.na(mod)){return(NULL)}else{coef(summary(mod))}
	})
	mods=as.data.frame( do.call(rbind,mods_i[!sapply(mods_i,is.null)]) )
	colnames(mods) = c('Coef','naiveSE','naiveZ','robustSE','robustZ')
	mods$vars = gsub('scale|\\(|\\)','',rownames(mods))
	mods$response = 'DPP'
	mods$robustPr = 2*pnorm(-abs(mods$robustZ))
	mods2=mods[mods$vars%in%vars,]

	rbind(mods1,mods2)
})
out=do.call(rbind,out_i) #[-(4:5)])
out$data = unlist(lapply(strsplit(rownames(out),'\\.'),function(x) x[1]))

#ggplot( out[abs(out$Coef)<15,] , aes(x=Coef,y=-log(robustPr,10),label=vars)) + geom_text(check_overlap=T) + facet_grid(response~data,scale='free')
g= ggplot( out[abs(out$Coef)<15,] , aes(x=Coef,y=-log(robustPr,10),label=vars,color=vars)) + geom_label_repel() + facet_grid(data~response,scale='free')+geom_hline(yintercept=1.3)+geom_vline(xintercept=0)+theme_classic()
ggsave(plot=g,filename='motifAnyl/motif_assc.pdf',height=15,width=15)
write.csv(out,file='motifAnyl/motif_assc.csv')

library(gridExtra)

g=grid.arrange(grobs=list(
	ggplot(data[[3]],aes(x=log(DPP),y=X80,color=factor(Secretor),shape=Pateint.ID))+geom_point()+stat_smooth(method='lm'),
	ggplot(data[[5]],aes(x=log(DPP),y=DSLNT,color=factor(Secretor),shape=Pateint.ID))+geom_point()+stat_smooth(method='lm'),
	ggplot(data[[5]],aes(x=log(DPP),y=DSLNH,color=factor(Secretor),shape=Pateint.ID))+geom_point()+stat_smooth(method='lm'),
	ggplot(data[[5]],aes(x=log(DPP),y=LSTb,color=factor(Secretor),shape=Pateint.ID))+geom_point()+stat_smooth(method='lm')
	))
ggsave(plot=g,filename='motifAnyl/individual_trajectories.pdf',height=15,width=15)


pdf_file<-"pdf/timeseries_columns_progress.pdf"
cairo_pdf(bg="grey98", pdf_file,width=6,height=9)

par(las=1,cex=0.9,omi=c(0.75,0.25,1.25,0.25),mai=c(0.5,0.25,0.5,0.75),family="Lato Light",las=1)

#  Read data and prepare chart

myData<-c(25296,28365,32187,36835,39788,44282,51122,60420,58437,62484)/1000
myLabels<-c(2002:2011)
myColours<-c(rep("olivedrab",length(myData)-1),"darkred")

# Create chart and other elements

barplot(myData,border=NA,col=myColours,names.arg=substr(myLabels,3,4),axes=F,cex.names=0.8)
abline(h=c(10,20,30,40,50,60,70,80),col=par("bg"),lwd=1.5)
axis(4,at=c(0,20,40,60))
text(11.5,myData[10]+0.025*myData[10],format(round(myData[10]),nsmall=1),adj=0.5,xpd=T,col="darkgrey")

# Titling

mtext("Sales Development Microsoft",3,line=4,adj=0,family="Lato Black",outer=T,cex=2)
mtext("2002–2011, figures in Bill. US-Dollars",3,line=1,adj=0,cex=1.35,font=3,outer=T)
mtext("Source: money.cnn.com",1,line=2,adj=1.0,cex=1.1,font=3,outer=T)
dev.off()


bigres=matrix(0,length(dir(pattern="*.rda")),7)

k=1
Id=dir(pattern="*.rda")
for(I in Id) {
load(I)
for(i in 1:6) {
sa=sapply(1:1000,function(j) {
jnk=res[[j]][[i]]
ifelse(!inherits(jnk,"try-error"),
       sum(abs(jnk$k-res[[1]]$ktrue)),NA)})
bigres[k,i]=mean(sa==0,na.rm=TRUE)
}
lambdas=c(0.01,0.05,0.1,0.2,0.35,0.5)

for(j in 1:1000) {
    liks=sapply(res[[j]][1:6],function(x) x$lik)
    crit=diff(liks)/(mean(liks)*diff(lambdas))
        w=which.min(crit)+1
        bigres[k,7]=bigres[k,7]+ifelse(sum(abs(res[[j]][[w]]$k-res[[1]]$ktrue))==0,1/1000,0)}
        k=k+1}

rm(res)
save.image(file="L.RData")


test_that("define_factor_line",{
  df = data.frame(factor1=c("var1", "var2", "var3"))
  result = define_factor_line(df)("factor1")
  expect_equal(result, "factor1 =~ 1*var1 + var2 + var3")
})

test_that("define_factor_line weak",{
  df = data.frame(factor1=c("var1", "var2", "var3"))
  result = define_factor_line(df, TRUE)("factor1")
  expect_equal(result, "factor1 =~ 1*var1 + lambda2*var2 + lambda3*var3")
})

test_that("define_factors", {
  dat_new <- data.frame(
    factor1=c("var1","var2"),
    factor2=c("2var1","2var2")
  )
  result <- define_factors(dat_new)
  expect_equal(result, 'factor1 =~ 1*var1 + var2\nfactor2 =~ 1*2var1 + 2var2')
})

test_that("define_intercepts",{
  dat_new <- data.frame(
    factor1=c("var1","var2"),
    factor2=c("2var1","2var2")
  )
  result <- define_intercepts(dat_new)
  expect_equal(result, 'var1 ~ 1\nvar2 ~ 1\n\n2var1 ~ 1\n2var2 ~ 1')
})

test_that("define_intercepts strong",{
  dat_new <- data.frame(
    factor1=c("var1","var2"),
    factor2=c("2var1","2var2")
  )
  result <- define_intercepts(dat_new, TRUE)
  expect_equal(result, 'var1 ~ i1*1\nvar2 ~ i2*1\n\n2var1 ~ i1*1\n2var2 ~ i2*1')
})

test_that("define_intercepts partial strong - when constraining less than 50% of parcels",{
  dat_new <- data.frame(
    factor1=c("var1","var2", "var3"),
    factor2=c("2var1","2var2", "2var3")
  )
  expect_error(define_intercepts(dat_new, TRUE, unconstrained=c(2, 3)))
})

test_that("define_intercepts partial strong - when constraining at least 50% of parcels",{
  dat_new <- data.frame(
    factor1=c("var1","var2", "var3", "var4"),
    factor2=c("2var1","2var2", "2var3", "2var4")
  )
  result = define_intercepts(dat_new, TRUE, unconstrained=c(2, 3))
  expect_equal(result, 'var1 ~ i1*1\nvar2 ~ 1\nvar3 ~ 1\nvar4 ~ i4*1\n\n2var1 ~ i1*1\n2var2 ~ 1\n2var3 ~ 1\n2var4 ~ i4*1')
})

test_that("define_variances",{
  dat_new <- data.frame(
    factor1=c("var1","var2"),
    factor2=c("2var1","2var2")
  )
  result <- define_variances(dat_new)
  expect_equal(result, 'var1 ~~ var1\nvar2 ~~ var2\n\n2var1 ~~ 2var1\n2var2 ~~ 2var2')
})

test_that("define_variances unique",{
  dat_new <- data.frame(
    factor1=c("var1","var2"),
    factor2=c("2var1","2var2")
  )
  result <- define_variances(dat_new, TRUE)
  expect_equal(result, 'var1 ~~ u1*var1\nvar2 ~~ u2*var2\n\n2var1 ~~ u1*2var1\n2var2 ~~ u2*2var2')
})

test_that("define_covariances",{
  dat_new <- data.frame(
    factor1=c("1var1","1var2"),
    factor3=c("3var1","3var2"),
    factor5=c("5var1","5var2")
  )
  result <- define_covariances(dat_new)
  expect_equal(result, '1var1 ~~ 3var1\n1var2 ~~ 3var2\n\n1var1 ~~ 5var1\n1var2 ~~ 5var2\n\n3var1 ~~ 5var1\n3var2 ~~ 5var2')
})

test_that("latent variable means when constrain_all_means_to_zero is true",{
  dat_new <- data.frame(
    factor1=c("1var1","1var2"),
    factor3=c("3var1","3var2"),
    factor5=c("5var1","5var2")
  )
  result <- define_latent_variable_means(dat_new, TRUE)
  expect_equal(result, 'factor1 ~ 0*1\nfactor3 ~ 0*1\nfactor5 ~ 0*1')
})

test_that("latent variable means when constrain_all_means_to_zero is false",{
  dat_new <- data.frame(
    factor1=c("1var1","1var2"),
    factor3=c("3var1","3var2"),
    factor5=c("5var1","5var2")
  )
  result <- define_latent_variable_means(dat_new, FALSE)
  expect_equal(result, 'factor1 ~ 0*1\nfactor3 ~ 1\nfactor5 ~ 1')
})

test_that("latent variable variances",{
  dat_new <- data.frame(
    factor1=c("1var1","1var2"),
    factor3=c("3var1","3var2"),
    factor5=c("5var1","5var2")
  )
  result <- define_latent_variable_variances(dat_new)
  expect_equal(result, 'factor1 ~~ factor1\nfactor3 ~~ factor3\nfactor5 ~~ factor5')
})

test_that("latent variable covariances",{
  dat_new <- data.frame(
    factor1=c("1var1","1var2"),
    factor3=c("3var1","3var2"),
    factor5=c("5var1","5var2")
  )
  result <- define_latent_variable_covariances(dat_new)
  expect_equal(result, 'factor1 ~~ factor3\nfactor1 ~~ factor5\nfactor3 ~~ factor5')
})

test_that("latent variable covariances - when constraining to zero",{
  dat_new <- data.frame(
    factor1=c("1var1","1var2"),
    factor3=c("3var1","3var2"),
    factor5=c("5var1","5var2")
  )
  constrain_to_zero = TRUE
  result <- define_latent_variable_covariances(dat_new, constrain_to_zero)
  expect_equal(result, 'factor1 ~~ 0*factor3\nfactor1 ~~ 0*factor5\nfactor3 ~~ 0*factor5')
})


#' covariate_selection_JAGS
#' algorithm to perform backwards covariate selection based on JAGS model deviance scores.
#' Given a model and a set of predictors the algorithm proceeds this way:
#' Step 1. calculate model deviance with all predictors.
#' Step 2. Rerun the model without a particular predictor, calculate deviance. Do this for all predictors.
#' Step 3. Drop the predictor that results in the largest improvement in deviance (apparently this is the greedy part of a greedy algorithm.)
#' Step 4. Using our new best model, repeat Steps 2 and 3 until:
#'         (a.) deviance no longer improves,
#'         (b.) deviance does not improve beyond a threshold change (say 2 units),
#'         (c.) there are no more predictors to remove.
#'
#' @param y           #matrix of species relative abundances.
#' @param x_mu        #matrix of covaraites.
#' @param n.adapt     #number of adaptive iterations.
#' @param n.burnin    #number of burnin iterations.
#' @param n.sample    #number of sampling iterations.
#'
#' @return            #returns a list of covariates retained, deviance scores of the last comparison, and the JAGS model that is the best.
#'                    #JAGS model in list is also a list with the full model, model summary, species X parameter tables and predicted/observed/residual matrices.
#' @export
#'
#' @examples
#' #### generate pseudo data to test ####
#'n.obs <- 25
#'x1 <- runif(n.obs,20,40);x2 <- runif(n.obs, 2, 4);x3 <- runif(n.obs,100,110);intercept <- rep(1,n.obs);y <- x1*0.5 + x2*3 + rnorm(n.obs)
#'y1 <- y;y2 <- rep(10, length(y1));y <- data.frame(cbind(y1,y2));y <- y / rowSums(y)
#'x_mu <- data.frame(intercept,x1,x2,x3)
#'test <- covariate_selection_JAGS(y=y, x_mu = x_mu)
#'n.adapt = 100; n.burnin=100;n.sample=200; parallel=F;silent.jags = F;burnin=100;sample=200;adapt=100;n.chains=3; silent.jags = F
#'

#Function depends on these things.
library(runjags)
library(doParallel)
source('NEFI_functions/ddirch_site.level_JAGS_no.missing.data.r')
source('NEFI_functions/crib_fun.r')
source('NEFI_functions/tic_toc.r')
source('NEFI_functions/return_pD.r')

covariate_selection_JAGS <- function(y, x_mu, n.adapt = 100, n.burnin = 100, n.sample = 200, parallel = F, silent.jags = T){
  #### Fit first JAGS model to all covariates. ####
  #register parallel cores
  registerDoParallel(cores = detectCores())

  #start a loop counter and a done indicator for the while loop.
  donezo <- 0
  loop.count <- 1
  runmode <- ifelse(parallel == F, F, T)

  #fit first model, calculate deviance.
  cat('Fitting initial model...\n')
  tic()
  fit <- site.level_dirlichet_jags(y = y, x_mu = x_mu, adapt = n.adapt, burnin = n.burnin, sample = n.sample, parallel = runmode)
  dev <- fit$deviance #grab deviance
  #calculate pD
  pD <- return_pD(y=y, x=x_mu, x.mm = fit$x.mm, alpha = fit$alpha, silent.jags = T)
  dic <- 2*dev[4] - pD
  cat('Initial model fit complete.')
  toc()
  while(donezo < 1){
    #sequentially leave out one predictor, except intercept.
    tic()
    fit.list <- list()
    fit.list <-
      foreach(i = 2:ncol(x_mu)) %dopar% {
        x_new <- x_mu[,-i]
        mod.fit <- site.level_dirlichet_jags(y=y, x_mu = x_new, adapt = n.adapt, burnin = n.burnin, sample = n.sample, parallel = runmode, silent.jags = silent.jags)
        fit.list[[i-1]] <- mod.fit
      }
    #grab deviance statistics as data.frame.
    dic.list <- list()
    for(i in 1:length(fit.list)){
      x.new <- x_mu[,-(i+1)]
      dev.fit <- fit.list[[i]]$deviance[4]
       pD.fit <- return_pD(y = y, x_mu = x.new, x.mm = fit.list[[i]]$x.mm, alpha = fit.list[[i]]$alpha,silent.jags = silent.jags)
      dic.list[[i]] <- 2*dev.fit - pD
    }
    dic.list <-data.frame(do.call(rbind,dic.list))
    rownames(dic.list) <- colnames(x_mu)[2:ncol(x_mu)]

    #calculate difference in deviance scores.
    dic.list$diff <- dic - dic.list$Mean

    #removing predictor that results in the largest improvement in deviance score.
    max.diff <- max(dic.list$diff)
    to.drop <- rownames(dic.list[which.max(dic.list$diff),])

    #report how long current selection loop took to complete.
    cat('Model selection loop',loop.count,'complete. ')
    toc()

    #if the difference is less than 1 or negative you are done.
    if(max.diff < 1){
      cat('*Best* model found! results are in output.list. \n')
      to_keep <- colnames(x_mu)
      dic.list[nrow(dic.list) + 1,] <- c(dic,NA)
      rownames(dic.list)[nrow(dic.list)] <- 'reference'
      output.list <- list(dic.list, to_keep, fit)
      names(output.list) <- c('deviance_table','variables','jags_model')
      donezo <- 1
      next
    }

    #If removing the next predictor brings you to a single predictor remaining, you are done.
    if(ncol(x_mu) == 3){
      #Drop the predictor.
      x_mu <- x_mu[,-which(colnames(x_mu) %in% to.drop)]
      #Grab the model thats the best.
      pos <- which(rownames(dic.list) == to.drop)
      fit <- fit.list[[pos]]
      dic.list[nrow(dic.list) + 1,] <- c(dic,NA)
      rownames(dic.list)[nrow(dic.list)] <- 'reference'
      #wrap the restof the output.
      to_keep <- colnames(x_mu)
      output.list <- list(dic.list, to_keep, fit)
      names(output.list) <- c('deviance_table','variables','jags_model')
      #tell R you are done and report.
      donezo <- 1
      cat('Only one predictor left (plus intercept). No more predictors to remove. Returning *best* model. Results in output.list.\n')
      next
    }

    #If dropping the variables improves deviance by more than 1, awesome. Drop it and repeat the procedure!
    x_mu <- x_mu[,-which(colnames(x_mu) %in% to.drop)]
    #get new reference model to compare things to.
    pos <- which(rownames(dic.list) == to.drop)
    fit <- fit.list[[pos]]
    dic <- dic.list$Mean[pos]
    loop.count <- loop.count + 1
    #tell yourself whats going on.
    cat(to.drop,'removed from model. Refitting...\n')
  } #end while loop

  return(output.list)
} #end function


library(FLCore)

##############################
SMS.dat<-read.FLSMS.control(file=file.path(data.path,'SMS.dat'))

SMS.stocks<-SMS2FLStocks(sumfile=file.path(data.path,'summary.out'),
            bio.interact=F, read.input=TRUE, read.output=TRUE,control=SMS.dat)
summary(SMS.stocks)
summary(SMS.stocks[[1]])

slotNames(SMS.stocks[[1]])

SMS.stocks[[1]]@catch.n

# does not work? plot(SMS.stocks[[1]])

SMS.stocks<-lapply(SMS.stocks,function(x){ window(x, start = 1963, end = 2010)} )

if (F) {
  a<-window(SMS.stocks[[1]], start = 2007, end = 2010)

  a@catch
  a@landings
  a@discards

  a[,,,1,]@catch.n
  a[,,,1,]@landings.n
  a[,,,1,]@discards.n
  a[,,,1,]@catch.n/a[,,,1,]@landings.n

  a[,,,1,]@catch.wt
  a[,,,1,]@landings.wt
  a[,,,1,]@discards.wt
}

###########################################################################
# make objects with "annual data"

sp<-1 # select species

if (sp==3) SMS.stocks[[sp]]<- setPlusGroup(SMS.stocks[[sp]],7)

stockDims <- FLQuant(dimnames=list(age = SMS.stocks[[sp]]@range["min"]:SMS.stocks[[sp]]@range["max"],
                                   year = SMS.stocks[[sp]]@range["minyear"]:SMS.stocks[[sp]]@range["maxyear"], unit = 'thousands',
                                   season = 'all', area = 'unique'))

a<- FLStock(name =SMS.stocks[[sp]]@name, desc = "test",catch.n = stockDims)

a@range['minfbar']<-SMS.dat@avg.F.ages[sp,1]
a@range['maxfbar']<-SMS.dat@avg.F.ages[sp,2]

if (sp==3) a@range['plusgroup']<-NA

a@catch<-seasonSums(SMS.stocks[[sp]]@catch)
a@catch.n<-seasonSums(SMS.stocks[[sp]]@catch.n)
units(a@catch.n)<-"thousands"
a@catch.wt<-apply(SMS.stocks[[sp]]@catch.n[,,,,,]*SMS.stocks[[sp]]@catch.wt[,,,,,],c(1,2),sum,na.rm=T)/seasonSums(SMS.stocks[[sp]]@catch.n)
units(a@catch.wt)<-"kg"
#a@catch.wt[1,,,,,]<-0

a@discards<-seasonSums(SMS.stocks[[sp]]@discards)
a@discards.n<-seasonSums(SMS.stocks[[sp]]@discards.n)
units(a@discards.n)<-"thousands"
a@discards.wt<-apply(SMS.stocks[[sp]]@discards.n[,,,,,]*SMS.stocks[[sp]]@discards.wt[,,,,,],c(1,2),sum,na.rm=T)/seasonSums(SMS.stocks[[sp]]@discards.n)
units(a@discards.wt)<-"kg"
#a@discards.wt[1,,,,,]<-0

a@landings<-seasonSums(SMS.stocks[[sp]]@landings)
a@landings.n<-seasonSums(SMS.stocks[[sp]]@landings.n)
units(a@landings.n)<-"thousands"
a@landings.wt<-apply(SMS.stocks[[sp]]@landings.n[,,,,,]*SMS.stocks[[sp]]@landings.wt[,,,,,],c(1,2),sum,na.rm=T)/seasonSums(SMS.stocks[[sp]]@landings.n)
units(a@landings.wt)<-"kg"
#a@landings.wt[1,,,,,]<-0

a@stock<-SMS.stocks[[sp]]@stock[,,,1,,] # first quarter data
units(a@stock)<-'tonnes'
a@stock.n<-SMS.stocks[[sp]]@stock.n[,,,1,,] # first quarter N
a@stock.n[1,,,,,]<-SMS.stocks[[sp]]@stock.n[1,,,3,,] # recruit age 0 (index 1) in quarter 3

a@stock.wt<-SMS.stocks[[sp]]@stock.wt[,,,1,,] # first quarter N
a@stock.wt[1,,,,,]<-SMS.stocks[[sp]]@stock.wt[1,,,3,,] # recruit age 0 (index 1) in quarter 3

units(a@stock.n)<-'thousands'

a@m<-seasonSums(SMS.stocks[[sp]]@m)
a@mat<-SMS.stocks[[sp]]@mat[,,,1,,]

a@harvest<-seasonSums(SMS.stocks[[sp]]@harvest)
units(a@harvest)<-"f"

# one stock only a<-SMS.stocks
a@harvest.spwn[,,,,,]<-0
a@m.spwn[,,,,,]<-0

summary(a)

if (F) {
  summary(a)
  b<-window(a, start = 2007, end = 2010)
  b@catch
  b@landings
  b@discards
  b@catch.n
  b@landings.n
  b@discards.n
  b@catch.wt
  b@landings.wt
  b@discards.wt

}

# stock recruitment
sr<-as.FLSR(a)

summary(sr)

frange<-seq(0, 1, 0.01)
# select regression model
if (sp==1) {
  sr<-window(sr, start = 1963, end = 2009)
  #  sr<-window(sr, start = 1974, end = 2009)

  model(sr)<-segreg()
   model(sr)<-ricker()
}
if (sp==2) {
  sr<-window(sr, start = 1974, end = 2009)
  model(sr)<-ricker()
}
if (sp==3) {
#  sr<-window(sr, start = 1990, end = 2009)
    sr<-window(sr, start = 1974, end = 2009)
    sr<-transform(sr,ssb=ssb/1000,rec=rec/1000)
  model(sr)<-segreg()
   #model(sr)<-ricker()
}

cleanup()
#
model(sr)
sr<-fmle(sr)
plot(sr)
summary(sr)
 ## Check fit
#profile(sr)

#  reference points
library(FLBRP)

## ## estimate reference points. Create the corresponding FLBRP object
bfy<-2000  # period for calculating mean weight and exploitation pattern
bly<-2010

X11()
# without S/R function
Brp  <-FLBRP(window(a,start=bfy, end=bly),fbar =frange )
#summary(Brp)
# And fit it
Brp <-brp(Brp)
plot(Brp)
refpts(Brp)

X11()
# with S/R function
Brp.sr  <-FLBRP(window(a,start=bfy, end=bly),sr=sr,fbar =frange)
#model(Brp.sr)
#params(Brp.sr)
# And fit it
Brp.sr<-brp(Brp.sr)
plot(Brp.sr)
refpts(Brp.sr)


##img=raster
##trainData=vector
##responseCol=field trainData
##nsamples=number 1000
##output=output raster
library(sp)
library(raster)
library(caret)

names(img) <- paste0("B", c(1:5, 7))

dfAll = data.frame(matrix(vector(), 0, length(names(img)) + 1))

for (i in 1:length(unique(trainData[[responseCol]]))){
  category <- unique(trainData[[responseCol]])[i]
  categorymap <- trainData[trainData[[responseCol]] == category,]
  dataSet <- extract(img, categorymap)
  dataSet <- dataSet[!unlist(lapply(dataSet, is.null))]
  dataSet <- lapply(dataSet, function(x){cbind(x, class = as.numeric(rep(category, nrow(x))))})
  df <- do.call("rbind", dataSet)
  dfAll <- rbind(dfAll, df)
}

sdfAll <- dfAll[sample(1:nrow(dfAll), nsamples), ]

modFit_rf <- train(as.factor(class) ~ B3 + B4 + B5, method = "rf", data = sdfAll)

beginCluster()
preds_rf <- clusterR(img, raster::predict, args = list(model = modFit_rf))
endCluster()

output = preds_rf


load("/home/ben/bio.data/bio.snowcrab/data/set.complete.rdata")
set$P = 1
require(PBSmapping)

a = aggregate(P~cfa+yr,subset(set,totmass.male.com>0),FUN=sum)
b = aggregate(P~cfa+yr,subset(set),FUN=sum)
g=merge(a,b,by=c('cfa','yr'))
g$prop = g$P.x/g$P.y
nN = list()
m=0
for(i in 2004:2018){
      m = m+1
       nor=set[which(set$cfa=='cfanorth'&set$yr==i),]
      #AREA OF NORTH BASED ON CONVEX HULL OF SURVEY
           nor$x = nor$lon
            nor$y = nor$lat
            norcord = nor[chull(nor$x,nor$y),c('x','y')]
            plot(norcord)
            norcord$X = norcord$x;
            norcord$Y = norcord$y
            norcord$PID = 1
            norcord$POS = 1:nrow(norcord)
            plotPolys(norcord)
            attr(norcord,'projection') <- "LL"
            nN[[m]] = c(i, calcArea(norcord))
}
  nN = as.data.frame(do.call(rbind,nN))
  mean(unlist(nN$area) )
      #AREA OF NORTH 8349
gN = subset(g,cfa=='cfanorth')
gN$Area = gN$prop *8349 #PROXY FOR HABITAT

require(PBSmapping)

###SOUTH
sE = list()
sW = list()
m=0
for(i in 2004:2018) {
  m=m+1
        nor=set[which(set$cfa=='cfasouth' & set$lon>-62 & set$yr==i),]
        #AREA OF NORTH BASED ON CONVEX HULL OF SURVEY
        nor$x = nor$lon
        nor$y = nor$lat
        norcord = nor[chull(nor$x,nor$y),c('x','y')]
        plot(norcord)
        norcord$X = norcord$x;
        norcord$Y = norcord$y
        norcord$PID = 1
        norcord$POS = 1:nrow(norcord)
        plotPolys(norcord)
        attr(norcord,'projection') <- "LL"
        sE[[m]] = c(i,calcArea(norcord))

        nor=set[which(set$cfa=='cfasouth' & set$lon< -62& set$yr==i),]
        nor$x = nor$lon
        nor$y = nor$lat
        norcord = nor[chull(nor$x,nor$y),c('x','y')]
        plot(norcord)
        norcord$X = norcord$x;
        norcord$Y = norcord$y
        norcord$PID = 1
        norcord$POS = 1:nrow(norcord)
        plotPolys(norcord)
        attr(norcord,'projection') <- "LL"
        sW[[m]] = c(i,calcArea(norcord))
}
  sE = as.data.frame(do.call(rbind,sE))
  sW = as.data.frame(do.call(rbind,sW))
  sS = merge(sE,sW,by=c('V1','PID'))
  sS$area = unlist(sS$area.x)+unlist(sS$area.y)
  mean(sS$area)
#AREA OF South 71190
gS = subset(g,cfa=='cfasouth')
gS$Area = gS$prop *71190 #PROXY FOR HABITAT

#4X
sX = list()
    m=0
for(i in c(2004:2013,2015:2018)) {
  m=m+1
        nor=set[which(set$cfa=='cfa4x' & set$yr==i),]
        #AREA OF NORTH BASED ON CONVEX HULL OF SURVEY
        require(PBSmapping)
        nor$x = nor$lon
        nor$y = nor$lat
        norcord = nor[chull(nor$x,nor$y),c('x','y')]
        plot(norcord)
        norcord$X = norcord$x;
        norcord$Y = norcord$y
        norcord$PID = 1
        norcord$POS = 1:nrow(norcord)
        plotPolys(norcord)
        attr(norcord,'projection') <- "LL"
        sX[[m]] = c(i,calcArea(norcord))
        }
        sX = as.data.frame(do.call(rbind,sX))
        mean(unlist(sX$area))
        #AREA OF 4X 5854
        gX = subset(g,cfa=='cfa4x')
        gX$Area = gX$prop *5854 #PROXY FOR HABITAT
        td = reshape(td,idvar='yr',timevar='region',direction='wide')

        Area = rbind(rbind(gX[,c('cfa','yr','Area')],gS[,c('cfa','yr','Area')]),gN[,c('cfa','yr','Area')])
        Area = reshape(Area,idvar='yr',timevar='cfa',direction='wide')
        Area = Area[order(Area$yr),]
        Area = subset(Area,yr>1998)
        Area$Area.cfa4x[which(Area$yr<2004)] <- 0


#!/usr/bin/Rscript

## Author: David Eccles (gringer), 2007 <programming@gringer.org>

## infocred.r -- carries out a difference-of-means test for difference between two populations

source("/itsshared/phd/common.r");

usage <- function(){
  cat("usage: ./infocred.r",
      "<file> <split point> [options]\n");
  cat("\nOther Options:\n");
  cat("-help               : Only display this help message\n");
  cat("notitle, hist, credible, showgreen, yrange, pointsize,svg, showdata, qrange,stdev");
  cat("\n");
}

if(commandArgs(TRUE)[1] == "-help"){
  usage();
  quit(save = "no", status=0);
}

cred.df <- read.table(commandArgs(TRUE)[1], header = TRUE)
splitPoint <- as.numeric(commandArgs(TRUE)[2]);

argLoc <- 3;
doGreen <- FALSE;
minYRange <- 0;
maxYRange <- 1;
pointSize <- 1;
doHist <- FALSE;
doSVG <- FALSE;
doTitle <- FALSE;
showData <- FALSE;
doSD <- TRUE;
doCredible <- FALSE;

while(!is.na(commandArgs(TRUE)[argLoc])){
  if(commandArgs(TRUE)[argLoc] == "-help"){
    usage();
    quit(save = "no", status=0);
  }
  if(commandArgs(TRUE)[argLoc] == "-notitle"){
    doTitle <- FALSE;
  }
  if(commandArgs(TRUE)[argLoc] == "-hist"){
    doHist <- TRUE;
  }
  if(commandArgs(TRUE)[argLoc] == "-credible"){
    doCredible <- TRUE;
  }
  if(commandArgs(TRUE)[argLoc] == "-showgreen"){
    doGreen <- TRUE;
  }
  if(commandArgs(TRUE)[argLoc] == "-yrange"){
    minYRange <- as.numeric(commandArgs(TRUE)[argLoc+1]);
    cat("Setting minYRange to",minYRange,"\n");
    maxYRange <- as.numeric(commandArgs(TRUE)[argLoc+2]);
    cat("Setting maxYRange to",maxYRange,"\n");
    argLoc <- argLoc + 2;
  }
  if(commandArgs(TRUE)[argLoc] == "-pointsize"){
    pointSize <- as.numeric(commandArgs(TRUE)[argLoc+1]);
    argLoc <- argLoc + 1;
  }
  if(commandArgs(TRUE)[argLoc] == "-svg"){
    library(cairoDevice);
    doSVG <- TRUE;
  }
  if(commandArgs(TRUE)[argLoc] == "-showdata"){
    showData <- TRUE;
  }
  if(commandArgs(TRUE)[argLoc] == "-qrange"){
    doSD <- FALSE;
  }
  if(commandArgs(TRUE)[argLoc] == "-stdev"){
    doSD <- TRUE;
  }
  argLoc <- argLoc + 1;
}

cred.df$Qrange <- abs(cred.df$Qlow - cred.df$Qhigh);
Q.matrix <- xtabs(Q ~ SNPs + ID,data = cred.df);
dataSize <- dim(Q.matrix)[2];
numSNPs <- dim(Q.matrix)[1];

p1Cluster <- (apply(Q.matrix[,1:splitPoint],1,mean) > 0.5) * 1;
p2Cluster <- (apply(Q.matrix[,(splitPoint+1):dataSize],1,mean) > 0.5) * 1;
Q.matrix.pops <-
t(rbind(apply(matrix(p1Cluster,1,length(p1Cluster)),2,rep, splitPoint),
        apply(matrix(p2Cluster,1,length(p2Cluster)),2,rep, dataSize - splitPoint)));
Q.matrix.diff <- abs(Q.matrix - Q.matrix.pops);

gs.diff <- abs(apply(Q.matrix.diff,1,function(x){x - Q.matrix.diff[numSNPs,]}));

Qrange.matrix <- xtabs(Qrange ~ SNPs + ID,data = cred.df);

Q.means <- rbind(apply(Q.matrix[,1:splitPoint],1,mean),
                 apply(Q.matrix[,(splitPoint+1):dataSize],1,mean));
Q.sd <- rbind(apply(Q.matrix[,1:splitPoint],1,sd),
              apply(Q.matrix[,(splitPoint+1):dataSize],1,sd));
Q.n <- rbind(apply(Q.matrix[,1:splitPoint],1,length),
             apply(Q.matrix[,(splitPoint+1):dataSize],1,length));
Qdiff.means <- abs(Q.means[1,] - Q.means[2,]);
Qdiff.sd <- sqrt(((Q.sd[1,]^2)/Q.n[1,]) + ((Q.sd[2,]^2)/Q.n[2]));

Qrange.means <- apply(Qrange.matrix,1,mean)

if(showData){
  cat("Difference of means:\n");
  print(Qdiff.means);
  print(Qdiff.means[Qdiff.means == max(Qdiff.means)]);
  cat("SD of difference:\n");
  print(Qdiff.sd);
  print(Qdiff.sd[Qdiff.sd == min(Qdiff.sd)]);
  print(round((1 - Qdiff.sd[2:length(Qdiff.sd)] /
         Qdiff.sd[1:(length(Qdiff.sd)-1)])*100),4);
  print(round(100 * Qdiff.sd[length(Qdiff.sd)] / Qdiff.sd),4);
  cat("Mean credible range:\n");
  print(Qrange.means);
  print(Qrange.means[Qrange.means == min(Qrange.means)]);
  print(round((1 - Qrange.means[2:length(Qrange.means)] / Qrange.means[1:(length(Qrange.means)-1)])*100),4);
  print(round(100 * Qrange.means[length(Qrange.means)] / Qrange.means),4);
  cat("mean, SD for",length(Qdiff.means),"SNPs:\n");
  print(Q.means[,length(Qdiff.means)]);
  print(Q.sd[,length(Qdiff.means)]);
}

if(doHist){
  if(doSVG){
    Cairo_svg("output_infohist.svg", width = 11, height = 8);
  } else {
    pdf("output_infohist.pdf", width = 11, height = 8, paper = "a4r");
  }
  par(mar=c(5,5,3,1));
  histcurve(Qdiff.means,
            main = paste("Histogram of Group Membership Difference Across",
              length(Q.means),"Samplings"), col = "red");
  histcurve(Qdiff.sd,
            main = paste("Histogram of Standard Deviation of Difference Across",
              length(Qdiff.sd),"Samplings"), col = "red");
  histcurve(Qrange.means,
            main = paste("Histogram of Mean Credible Region Size Across",
              length(Qrange.means),"Samplings"), col = "red");
  dummy <- dev.off();
}
if(doCredible){
  if(doSVG){
    Cairo_svg("output_credible.svg", width = 11, height = 8);
  } else {
    pdf("output_credible.pdf", width = 11, height = 8, paper = "a4r");
  }
  if(!doTitle){
    par(mar=c(5,5,1,1));
  } else {
    par(mar=c(5,5,3,1));
  }
  tmpcred <- subset(cred.df, No <= splitPoint);
  credmean.pop1 <- 1 - tapply(tmpcred$Qrange, tmpcred$SNPs, mean);
  tmpcred <- subset(cred.df, No > splitPoint);
  credmean.pop2 <- 1 - tapply(tmpcred$Qrange, tmpcred$SNPs, mean);
  tmpcred <- cred.df;
  credmean.all <- 1 - tapply(tmpcred$Qrange, tmpcred$SNPs, mean);
  plot(x = as.numeric(names(credmean.all)), y = credmean.all, ylim =
       c(minYRange,maxYRange), xlab = "Number of SNPs", main =
       "Q Value Accuracy (by credible range) for top n SNPs",
       ylab = "Mean Q Value Accuracy (%)", pch = NA, cex =
       0.5 * pointSize, col = "blue", cex.lab = 2, cex.axis = 1.5,
       frame.plot = FALSE);
  points(x = as.numeric(names(credmean.pop1)), y = credmean.pop1, pch =
         16, cex = 0.5 * pointSize, col = "green");
  points(x = as.numeric(names(credmean.pop2)), y = credmean.pop2, pch =
         16, cex = 0.5 * pointSize, col = "blue");
  points(x = as.numeric(names(credmean.all)), y = credmean.all, pch =
         16, cex = 0.5 * pointSize, col = "black");
  credmean.pop1 <- abs(1 - apply(Q.matrix.diff[,1:splitPoint], 1, mean));
  credmean.pop2 <- abs(1 - apply(Q.matrix.diff[,(splitPoint+1):dataSize], 1, mean));
  credmean.all <- 1 - apply(Q.matrix.diff, 1, mean);
  plot(x = as.numeric(names(credmean.all)), y = credmean.all, ylim =
       c(minYRange,maxYRange), xlab = "Number of SNPs", main =
       "Q Value Accuracy (by difference from 0/1) for top n SNPs",
       ylab = "Mean Q Value Accuracy (%)", pch = NA, cex =
       0.5 * pointSize, col = "blue", cex.lab = 2, cex.axis = 1.5,
       frame.plot = FALSE);
  points(x = as.numeric(names(credmean.pop1)), y = credmean.pop1, pch =
         16, cex = 0.5 * pointSize, col = "green");
  points(x = as.numeric(names(credmean.pop2)), y = credmean.pop2, pch =
         16, cex = 0.5 * pointSize, col = "blue");
  points(x = as.numeric(names(credmean.all)), y = credmean.all, pch =
         16, cex = 0.5 * pointSize, col = "black");
  credmean.all <- 1 - apply(Q.matrix.diff, 1, mean);
  credsd.all <- tapply(cred.df$Qrange, cred.df$SNPs, sd);
  credse.all <- sqrt(credsd.all / dataSize);
  plot(x = as.numeric(names(credmean.all)), y = credmean.all, ylim =
       c(minYRange,maxYRange), xlab = "Number of SNPs", main =
       "Q Value Accuracy (0/1 difference, with error as SE for credible range) for top n SNPs",
       ylab = "Mean Q Value Accuracy (%)", pch = NA, cex =
       0.5 * pointSize, col = "blue", cex.lab = 2, cex.axis = 1.5,
       frame.plot = FALSE);
  arrows(x0=as.numeric(names(credmean.all)),
         x1=as.numeric(names(credmean.all)),
         y0=apply(cbind(0,credmean.all - (credse.all / 2)),1,max),
         y1=apply(cbind(1,credmean.all + (credse.all / 2)),1,min),
         angle = 90, code = 3, length = 0.03*sqrt(pointSize), lwd = 1
         * pointSize);
  points(x = as.numeric(names(credmean.all)), y = credmean.all, pch =
         16, cex = 0.5 * pointSize, col = "black");
  mainLabel = paste("Q Value Accuracy (difference from ",numSNPs,"SNP result) for top n SNPs in pop1");
  if(!doTitle){mainLabel = ""};
  boxplot((1 - gs.diff[1:splitPoint,])*100, col = "green", main = mainLabel,
          xlab = "Number of SNPs", ylab = "Q Value Accuracy (%)", cex.lab = 2, cex.axis = 1.5);
  boxplot(1 - gs.diff[(splitPoint+1):dataSize,], col = "blue", main =
          paste("Q Value Accuracy (difference from ",numSNPs,"SNP result) for top n SNPs in pop2"),
          xlab = "Number of SNPs", ylab = "Q Value Accuracy (%)", cex.lab = 2, cex.axis = 1.5);
  boxplot(1 - gs.diff, col = "white", main =
          paste("Q Value Accuracy (difference from ",numSNPs,"SNP result) for top n SNPs"),
          xlab = "Number of SNPs", ylab = "Q Value Accuracy (%)", cex.lab = 2, cex.axis = 1.5);
  dummy <- dev.off();
} else {
  if(doSVG){
    Cairo_svg("output_diffpower.svg", width = 11, height = 8);
  } else {
    pdf("output_diffpower.pdf", width = 11, height = 8, paper = "a4r");
  }
  if(!doTitle){
    par(mar=c(5,5,1,1));
  } else {
    par(mar=c(5,5,3,1));
  }
  if(doSD){
    mainLabel <- paste("Group membership Difference for top n SNPs",
                       "(showing standard deviation)",
                       sep="\n");
  } else {
    mainLabel <- paste("Group membership Difference for top n SNPs",
                       "(with mean credible range across all individuals)",
                       sep="\n");
  }
  if(!doTitle){
    mainLabel <- "";
  }
  plot(x = as.numeric(names(Qdiff.means)), y = Qdiff.means, ylim =
       c(minYRange,maxYRange), xlab = "Number of SNPs", main =
       mainLabel, ylab = "Difference of mean Q", pch = NA, cex =
       0.5 * pointSize, col = "blue", cex.lab = 2, cex.axis = 1.5,
       frame.plot = FALSE);
  if(doSD){
    arrows(x0=as.numeric(names(Qdiff.means)),
           x1=as.numeric(names(Qdiff.means)),
           y0=apply(cbind(0,Qdiff.means - (Qdiff.sd / 2)),1,max),
           y1=apply(cbind(1,Qdiff.means + (Qdiff.sd / 2)),1,min),
           angle = 90, code = 3, length = 0.03*sqrt(pointSize), lwd = 1
           * pointSize);
  } else {
    arrows(x0=as.numeric(names(Qdiff.means)),
           x1=as.numeric(names(Qdiff.means)),
           y0=apply(cbind(0,Qdiff.means - (Qrange.means / 2)),1,max),
           y1=apply(cbind(1,Qdiff.means + (Qrange.means / 2)),1,min),
           angle = 90, code = 3, length = 0.03*sqrt(pointSize), lwd = 1
           * pointSize);
  }
  points(x = as.numeric(names(Qdiff.means)), y = Qdiff.means, pch =
       16, cex = 0.5 * pointSize, col = "blue");
  if(doGreen){
    if(doSD){
      points(x = as.numeric(names(Qrange.means)),
             y = Qrange.means, col = "green", pch = 25);
    } else {
      points(x = as.numeric(names(Qrange.means)),
             y = Qrange.means, col = "green", pch = 25);
    }
  }
  dummy <- dev.off();
}


portfolio.plot <- function(twri=NA, twrc=NA, perf=NA, twri.ef=NA,
                           plottype=c('twri', 'twrc', 'rra', 'ab'), pch.hold=21,
                           main=NULL, label='symbol') {

    ## input: twri = incremental TWR (Time Weighted Return)
    ##               xts object with holdings, portfolio, and benchmarks listed in that order
    ##               'portfolio' is used to identify the breakpoint
    ##               portfolio.calc() creates output in this format
    ##               easy to create otherwise with cbind()
    ##        twrc = cumulative TWR xts object (same format as twri)
    ##        twri.ef = xts object with twri for SPY, IWM, EFA, AGG, SHV
    ##                  for use in adding efficient frontier line to risk/reward plot
    ##                  can get by running ef(addline=FALSE)
    ##                  make sure dates correspond to those for twri
    ##        perf = dataframe with rows in same order as twri columns for entire period
    ##               perf and columns only required if request rr or ab plots
    ##               columns define: holding
    ##                               twrc = ending twrc (should match twrc)
    ##                               std  = standard deviation
    ##                               twrc.ann = annualized TWRC if duration > 1 year
    ##                               std.ann  = annualized standard deviation (std*sqrt(12))
    ##                               alpha
    ##                               beta
    ##        label     = 'symbol' uses holding symbols on risk/return and beta/alpha plots
    ##                  = 'simple' collapses all holdings to "holding"

    ## identify number of holdings and benchmarks
    port.col <- grep('portfolio', names(twri))  # get column number for portfolio
    nhold  <- port.col - 1
    nbench <- ncol(twri) - port.col

    ## initialize output parameters
    efdata.Schwab = NA
    efdata.simple = NA

    for (requested in plottype) {

        ##-----------------------------------------------------------------------------
        ## plot incremental TWR
        if (requested == 'twri') {
            ## plot( plotxts(twri, main=main) )
            xts <- twri
            pp <- xts::plot.xts(xts[, 1:nhold], ylab='Incremental TWR', main="",
                                col=c(1:nhold),
                                ylim=range(xts, na.rm = TRUE))
            pp <- xts::addSeries(xts$portfolio,
                                 on=1, col='red'    , lwd=2, lty=2)
            pp <- xts::addSeries(xts[, (port.col+1):ncol(twri)],
                                 on=1, col=c('black', 'cyan')  , lwd=2, lty=2)
            legend.names <- names(xts)
            pp <- xts::addLegend("topleft",
                                 legend.names = legend.names,
                                 lty=c(rep(1, nhold), 2, 2, 3),
                                 col=c(    1: nhold, 'red', 'black', 'cyan'))
            plot(pp)
        }

        ##-----------------------------------------------------------------------------
        ## plot cumulative TWR
        if (requested == 'twrc') {
            ## plot( plotxts(twrc, main=main) )
            xts <- twrc
            pp <- xts::plot.xts(xts[, 1:nhold], ylab='Cumulative TWR', main="",
                                col=c(1:nhold),
                                ylim=range(xts, na.rm=TRUE))
            pp <- xts::addSeries(xts$portfolio,
                                 on=1, col='red'    , lwd=2, lty=2)
            pp <- xts::addSeries(xts[, (port.col+1):ncol(twri)],
                                 on=1, col=c('black', 'cyan')  , lwd=2, lty=2)
            legend.names <- names(xts)
            pp <- xts::addLegend("topleft",
                                 legend.names = legend.names,
                                 lty=c(rep(1, nhold), 2, 2, 3),
                                 col=c(    1: nhold, 'red', 'black', 'cyan'))
            plot(pp)
        }

        ##-----------------------------------------------------------------------------
        ## add label for plot legend to perf
        if (label == 'symbol') {
            ## use holding symbols on risk/return and beta/alpha plots
            perf$label <- perf$holding
        } else {
            ## use labels of 'holding', 'portfolio', or 'benchmark' on plot
            perf$label <- 'holding'
            perf[perf$holding == 'portfolio',]$label <- 'portfolio'
            perf[(port.col+1):nrow(perf),]$label <- 'benchmark'
        }

        ##-----------------------------------------------------------------------------
        ## separate performance table into 3 dataframes for risk/reward and alpha/beta plots
        perfhold  <- perf[1:nhold,]
        perfport  <- perf[perf$holding == 'portfolio',]
        perfbench <- perf[(port.col+1),]
        perfbench1 <- perfbench[1,]        # first benchmark only

        ##-----------------------------------------------------------------------------
        ## plot risk/reward

        if (requested == 'rr') {
            ## risk   = standard deviation
            ## reward = twrc

            if (nrow(twri) > 2) {
                ## need at least 3 rows for sd() (1st row is not used)

                ## determine range making room for legend
                efdata.schwab <- ef(model='Schwab', efdata=twri.ef, annualize=FALSE, addline=FALSE)
                efdata.simple <- ef(model='simple', efdata=twri.ef, annualize=FALSE, addline=FALSE)
                xrange <- range(perf$std, efdata.schwab$ef$efstd, efdata.simple$ef$efstd)
                xlim   <- c(min(xrange, na.rm = TRUE),
                            max(xrange, na.rm = TRUE) +
                            0.25*(max(xrange, na.rm = TRUE) - min(xrange, na.rm = TRUE)))
                ylim   <- range(perf$twrc, efdata.schwab$ef$eftwrc, efdata.simple$ef$eftwrc,
                                na.rm = TRUE)

                ## plot holdings
                with(perfhold, plotfit(std, twrc, label, interval='noline',
                                       xlimspec=xlim, ylimspec=ylim, pch=pch.hold,
                                       xlabel = 'Standard Deviation',
                                       ylabel = 'Cumulative TWR',
                                       main   = main))
                ## add portfolio
                points(perfport$std, perfport$twrc, col='red', pch=1)
                ## add benchmark (only the 1st)
                points(perfbench1$std, perfbench1$twrc, col='blue', pch=2)
                ## add efficient frontier line
                efdata.Schwab <- ef(model='Schwab', efdata=twri.ef, annualize=FALSE,
                                    addline=TRUE, col='black', lty=1, pch=3)
                efdata.simple <- ef(model='simple', efdata=twri.ef, annualize=FALSE,
                                    addline=TRUE, col='black', lty=2, pch=4)
                mtext('(portfolio = open red circle; benchmark = open blue triangle)',
                      side=3, line=0.8, cex=1)
                mtext('(Schwab EF = solid line; S&P 500 / AGG EF = dotted line)',
                      side=3, line=0, cex=1)
            } else {
                cat('WARNING: Insufficient number of rows in twri for requested rr plot.\n')
            }

        }

        if (requested == 'rra') {
            ## risk   = standard deviation * sqrt(12)
            ## reward = annualized twrc

            if (nrow(twri) > 2) {
                ## need at least 3 rows for sd() (1st row is not used)

                ## determine range making room for legend
                ## first run ef() to get range of effective frontier plots
                efdata.schwab <- ef(model='Schwab', efdata=twri.ef, annualize=TRUE, addline=FALSE)
                efdata.simple <- ef(model='simple', efdata=twri.ef, annualize=TRUE, addline=FALSE)
                xrange <- range(perf$std.ann, efdata.schwab$ef$efstd, efdata.simple$ef$efstd)
                xlim   <- c(min(xrange, na.rm = TRUE),
                            max(xrange, na.rm = TRUE) +
                            0.25*(max(xrange, na.rm = TRUE) - min(xrange, na.rm = TRUE)))
                ylim   <- range(perf$twrc.ann, efdata.schwab$ef$eftwrc, efdata.simple$ef$eftwrc,
                                na.rm = TRUE)

                ## plot holdings
                with(perfhold, plotfit(std.ann, twrc.ann, label, interval='noline',
                                       xlimspec=xlim, ylimspec=ylim, pch=pch.hold,
                                       xlabel = 'Standard Deviation * sqrt(12)',
                                       ylabel = 'Annualized Cumulative TWR',
                                       main   = main))
                ## add portfolio
                points(perfport$std.ann, perfport$twrc.ann, col='red', pch=1)
                ## add benchmark
                points(perfbench1$std.ann, perfbench1$twrc.ann, col='blue', pch=2)
                ## add efficient frontier line
                efdata.Schwab <- ef(model='Schwab', efdata=twri.ef,
                                    annualize=TRUE, addline=TRUE, col='black', lty=1, pch=3)
                efdata.simple <- ef(model='simple', efdata=twri.ef,
                                    annualize=TRUE, addline=TRUE, col='black', lty=2, pch=4)
                mtext('(portfolio = open red circle; benchmark = open blue triangle)',
                      side=3, line=0.8, cex=1)
                mtext('(Schwab EF = solid line; S&P 500 / AGG EF = dotted line)',
                      side=3, line=0, cex=1)
            } else {
                cat('WARNING: Insufficient number of rows in twri for requested rra plot.\n')
            }

        }

        ##-----------------------------------------------------------------------------
        ## alpha/beta plot
        if (requested == 'ab') {
            ## create plot
            xrange <- range(perf[1:(nhold+2),]$beta)
            xlim   <- c(min(xrange, na.rm = TRUE),
                        max(xrange, na.rm = TRUE) +
                            0.25*(max(xrange, na.rm = TRUE) - min(xrange, na.rm = TRUE)))
            ylim   <- range(perf[1:(nhold+2),]$alpha, na.rm = TRUE)
            with(perfhold, plotfit(beta, alpha, label, interval='noline',
                                   xlimspec=xlim, ylimspec=ylim, pch=pch.hold,
                                   xlabel = 'beta',
                                   ylabel = 'alpha',
                                   main   = main))
            ## add portfolio
            points(perfport$beta, perfport$alpha, col='red', pch=1)
            ## add benchmark
            points(perfbench1$beta, perfbench1$alpha, col='blue', pch=2)
            ## add subtitle text
            mtext('(portfolio = open red circle; benchmark = open blue triangle)',
                  side=3, line=0.75, cex=1)
            abline(v=1)
            abline(h=0)
        }

        ## any correlation?
        if (requested == 'pairs') {
            ## identify performance info to output and use in correlation plot
            ## pairplot <- select(perf, twrc, std, alpha, beta, 'P/E Ratio', 'Price/Book', weight)
            ## pairsdf(pairplot)
            pairsdf(as.data.frame(twri))
        }
    }

    return(list(perf  = perf,
                efdata.Schwab = efdata.Schwab,
                efdata.simple = efdata.simple))

}