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

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

set.seed(47269801)

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

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

source(here("r", "Funs.r"))

load(here("data", "KenyaData.RData"))

attach(k1_df)

################################
## Create forecasting dataset ##
################################

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

forecast <-subset(k1_df, select = c(vid.imp1, eva.msg1, eva.msg2, eva.msg3,treat,pov,ind,com,eva.conf, survey.id))

#Recoding into proportion selecting a business video for first video

forecast$eva.m1_rec <- eva.msg1/(10)
forecast$eva.m2_rec <- eva.msg2/(10)
forecast$eva.m3_rec <- eva.msg3/(10)

#Reshaping

forecast.long <- forecast %>% gather(WhichTreat, pred, eva.m1_rec, eva.m1_rec,eva.m2_rec,eva.m3_rec)

#Dummies for own condition

forecast.long$Own <- 0
forecast.long$Own[forecast.long$WhichTreat == "eva.m1_rec" & forecast.long$pov == 1] <- 1
forecast.long$Own[forecast.long$WhichTreat == "eva.m2_rec" & forecast.long$ind == 1] <- 1
forecast.long$Own[forecast.long$WhichTreat == "eva.m3_rec" & forecast.long$com == 1] <- 1

############################
## Forecasting regression ##
############################

refmeans <- c(mean(forecast.long[which(forecast.long$WhichTreat == "eva.m1_rec"), "pred"]), mean(forecast.long[which(forecast.long$WhichTreat == "eva.m1_rec"), "pred"]), mean(forecast.long[which(forecast.long$WhichTreat == "eva.m3_rec"), "pred"]))

## Without controls ##

FR <- RegTest("pred ~ WhichTreat", clustvars = forecast.long$survey.id, hypotheses = c("WhichTreateva.m2_rec = 0", "WhichTreateva.m3_rec = 0", "WhichTreateva.m2_rec - WhichTreateva.m3_rec = 0"), data = forecast.long)
FR <- cbind(FR[, -ncol(FR)], refmeans, FR[, ncol(FR)])
FR <- cbind(format(round(FR[, -ncol(FR)], 3), nsmall = 3), round(FR[, ncol(FR)], 0))
FR <- cbind(c("Individual = Poverty", "Community = Poverty", "Individual = Community"), FR[, -2])

## With controls ##

FRC <- RegTest("pred ~ WhichTreat + Own", clustvars = forecast.long$survey.id, hypotheses = c("WhichTreateva.m2_rec = 0", "WhichTreateva.m3_rec = 0", "WhichTreateva.m2_rec - WhichTreateva.m3_rec = 0"), data = forecast.long)
FRC <- cbind(FRC[, -ncol(FRC)], refmeans, FRC[, ncol(FRC)])
FRC <- cbind(format(round(FRC[, -ncol(FRC)], 3), nsmall = 3), round(FRC[, ncol(FRC)], 0))
FRC <- cbind(c("Individual = Poverty", "Community = Poverty", "Individual = Community"), FRC[, -2])

## Combine panels ##

FR.tab <- rbind(c(" ", " ", " ", " ", " ", " "), FR, c("Controlling for own treatment assignment", " ", " ", " ", " ", " "), FRC)

colnames(FR.tab) <- c("Hypothesis", "Coefficient", "Std. error", "p-value", "Reference mean", "Obs.")

## Print table ##

appendix <- read_docx()

WriteHeading(appendix , "Forecasting data analysis for Kenya recipient experiment (study 2)")
LineBreak(appendix)
WriteTitle(appendix, "Forecasting results")

appendix <- body_add_flextable(appendix, value = FTable(FR.tab, panels = 2, note = "Note: The dependent variable is the proportion selecting a business video for first video. Each of the 565 participants made three forecasts for a total of 565 x 3 = 1,695 observations. The first and second panels respectively exclude and include a dummy for own treatment assignment. The first column reports the mean difference between groups. The second column reports robust standard errors. The reference mean column lists the mean of the poverty alleviation condition for the first two hypotheses and the mean of the community empowerment condition for the third hypothesis."))

print(appendix, target = here("doc", "S2_appendix.docx"))

################################
## Forecasting bar graph (2A) ##
################################

attach(forecast.long)

WhichTreat <- factor(WhichTreat, labels = c("Poverty\nAlleviation", "Individual\nEmpowerment", "Community\nEmpowerment"))

for.stats <- forecast.long[complete.cases(pred), ] %>% group_by(WhichTreat) %>% summarise(mean = mean(pred), sd = sd(pred), obs = length(pred))
for.stats <- cbind(as.data.frame(c("Forecast results", "Forecast results", "Forecast results")), as.data.frame(table(WhichTreat))[, 1], as.data.frame(for.stats[, 2]), as.data.frame(for.stats[, 3] / sqrt(for.stats[, 4])))
colnames(for.stats) <- c("type", "treat", "mean", "SE")

attach(k1_df)

k1_df$treat.long <- factor(treat, labels = c("Poverty\nAlleviation", "Individual\nEmpowerment", "Community\nEmpowerment"))

exp.stats <- k1_df[complete.cases(vid.imp1), ] %>% group_by(k1_df$treat.long) %>% summarise(mean = mean(vid.imp1), sd = sd(vid.imp1), obs = length(vid.imp1))
exp.stats <- cbind(as.data.frame(c("Experimental results", "Experimental results", "Experimental results")), as.data.frame(table(k1_df$treat.long))[, 1], as.data.frame(exp.stats[, 2]), as.data.frame(exp.stats[, 3] / sqrt(exp.stats[, 4])))
colnames(exp.stats) <- c("type", "treat", "mean", "SE")

Fig2aData <- rbind(exp.stats, for.stats)

## Plot means ##

Figure2A <- ggplot(Fig2aData, aes(fill=treat, y=mean, x=type)) +
  geom_bar(position = position_dodge(width=0.9), stat = "identity", width = .7) +
  ggtitle("A Comparison of forecasts to experimental results") +
  geom_errorbar(aes(x = type, ymin = mean - 1.96 * SE, ymax = mean + 1.96 * SE), position = position_dodge(width=0.9), width=.3, size=0.7) +
  scale_fill_manual(values=c('#c6c6c7', '#7ca6c0', '#c05746')) +
  labs(y = "Prop. selecting a business skills video first", x ="") +
  coord_cartesian(ylim=c(0.4, 0.85)) +
  theme(panel.grid.major = element_blank(),
        panel.grid.minor = element_blank(),
        panel.background = element_blank(),
        panel.grid.major.y = element_line(size = .2, color = "black", linetype = "dashed"),,
        axis.line = element_line(colour = "black"),
        axis.text.x = element_text(size = 8),
        axis.text.y = element_text(size = 8),
        legend.position = "bottom",
        legend.title = element_blank(),
        plot.title = element_text(size=10, face="bold"),
        text = element_text(size=8)) +
        geom_signif(y_position=c(0.82, 0.67, 0.72), xmin=c(0.7, 1.7, 1.7), xmax=c(1.3, 2, 2.3), annotation=c("*", "*", "*"), vjust = 0.2) + theme(legend.justification=c(0,-.22), legend.position=c(0,-.22), legend.direction = "horizontal", plot.margin = margin(0, 0, .75, 0, "cm")) +
       theme(plot.title = element_text(hjust=-.05, size=8.5))

###############################
## Histogram of video choice ##
###############################

pdf(here("graphics", "FigureS1.pdf"), width = 8, height = 5, encoding = "MacRoman")
ggplot(k1_df, aes(x= vid.num,  group=condition.order)) + geom_bar(aes(y = ..prop..)) + facet_grid(~condition.order) + geom_text(aes( label = scales::percent(..prop..), y= ..prop.. ), stat= "count", vjust = -.5) + labs(y = "Percent") + guides(fill = FALSE) + xlab("No. of business videos chosen") + scale_y_continuous(labels = scales::percent) + aes(fill = condition.order) + scale_fill_manual(values = c('#c6c6c7', '#7ca6c0', '#c05746')) + theme_bw()
dev.off()

##################################
## Figures for synthetic pilots ##
##################################

#Recode forecasts:
forecast$eva.msg1<-forecast$eva.msg1/10
forecast$eva.msg2<-forecast$eva.msg2/10
forecast$eva.msg3<-forecast$eva.msg3/10

#Range of sample sizes
minsize=30
maxsize=150

numsims <- 10000

#Experimental
B1_EXP <- matrix(nrow=(maxsize-minsize), ncol=1)
B2_EXP <- matrix(nrow=(maxsize-minsize), ncol=1)
B1p_EXP <- matrix(nrow=(maxsize-minsize), ncol=1)
B2p_EXP <- matrix(nrow=(maxsize-minsize), ncol=1)

for(i in minsize:maxsize){
    TEMP <- Simulator(k1_df, iterations = numsims, n = i, by = k1_df$survey.id, "vid.imp1", "treat")
    B1_EXP[i-(minsize-1)]<-as.vector(TEMP[1])
    B2_EXP[i-(minsize-1)]<-TEMP[2]
    B1p_EXP[i-(minsize-1)]<-TEMP[3]
    B2p_EXP[i-(minsize-1)]<-TEMP[4]
}

B1_EXP_DF= as.data.frame(t(as.data.frame(B1_EXP)))
B2_EXP_DF= as.data.frame(t(as.data.frame(B2_EXP)))
B1p_EXP_DF= as.data.frame(t(as.data.frame(B1p_EXP)))
B2p_EXP_DF= as.data.frame(t(as.data.frame(B2p_EXP)))

#Forecasting
B1_FOR <- matrix(nrow=(maxsize-minsize), ncol=1)
B2_FOR <- matrix(nrow=(maxsize-minsize), ncol=1)
B1p_FOR <- matrix(nrow=(maxsize-minsize), ncol=1)
B2p_FOR <- matrix(nrow=(maxsize-minsize), ncol=1)
for(i in minsize:maxsize){
TEMP <- Simulator(forecast.long, iterations = numsims, n = i, by = forecast.long$survey.id, "pred", "WhichTreat")
B1_FOR[i-(minsize-1)]<-TEMP[1]
B2_FOR[i-(minsize-1)]<-TEMP[2]
B1p_FOR[i-(minsize-1)]<-TEMP[3]
B2p_FOR[i-(minsize-1)]<-TEMP[4]
}

B1_FOR_DF= as.data.frame(t(as.data.frame(B1_FOR)))
B2_FOR_DF= as.data.frame(t(as.data.frame(B2_FOR)))
B1p_FOR_DF= as.data.frame(t(as.data.frame(B1p_FOR)))
B2p_FOR_DF= as.data.frame(t(as.data.frame(B2p_FOR)))

B1_EXP_DF_ERROR<- -abs(B1_EXP_DF-0.0697)
B1_Exp_MeanError<-as.data.frame(rowMeans(B1_EXP_DF_ERROR))

B2_EXP_DF_ERROR<- -abs(B2_EXP_DF-0.1292)
B2_Exp_MeanError<-as.data.frame(rowMeans(B2_EXP_DF_ERROR))

B1_FOR_DF_ERROR<- -abs(B1_FOR_DF-0.0697)
B1_FOR_MeanError<-as.data.frame(rowMeans(B1_FOR_DF_ERROR))

B2_FOR_DF_ERROR<- -abs(B2_FOR_DF-0.1292)
B2_FOR_MeanError<-as.data.frame(rowMeans(B2_FOR_DF_ERROR))

NUM<-c(minsize:maxsize)%>%as.data.frame()

MeanERR<-bind_cols(B1_Exp_MeanError,B2_Exp_MeanError,B1_FOR_MeanError,B2_FOR_MeanError,  c(minsize:maxsize)%>%as.data.frame())
names(MeanERR)<-c("B1_Exp_MeanError","B2_Exp_MeanError","B1_FOR_MeanError","B2_FOR_MeanError","N")

df2c <- melt(MeanERR, id = "N")

#Figure2B: Negative absolute error

Figure2B <- ggplot(df2c, aes(x = N, y = value, color = variable)) +
    geom_smooth(size = 0.8, se = FALSE, aes(linetype = variable)) +
    scale_linetype_manual(values = c("solid","solid", "dashed", "dashed"), name="Coefficients (Ref: Poverty Alleviation)",
                          labels=c("Sim. pilot: Ind. Empowerment",
                                   "Sim. pilot: Com. Empowerment",
                                   "Forecasting: Ind. Empowerment",
                                   "Forecasting: Com. Empowerment")) +
    scale_color_manual(values=c('#7ca6c0', '#c05746','#7ca6c0', '#c05746'),
                       name="Coefficients (Ref: Poverty Alleviation)",
                       labels=c("Sim. pilot: Ind. Empowerment",
                                "Sim. pilot: Com. Empowerment",
                                "Forecasting: Ind. Empowerment",
                                "Forecasting: Com. Empowerment")) +
    ggtitle("B Accuracy of forecasts versus simulated experimental pilots") +
    xlab("Bootstrap sample size across all groups") +
    ylab("Prediction accuracy (negative absolute error)") +
    scale_x_continuous(breaks=seq(25, 150, 25)) +
    coord_cartesian(xlim=c(25, 150), ylim=c(-0.2,0)) +
    theme(panel.grid.major = element_blank(),
          panel.grid.minor = element_blank(),
          panel.background = element_blank(),
          panel.grid.major.y = element_line(size = .5, color = "gray", linetype = "dashed"),
          axis.line = element_line(colour = "black"),
          axis.text.x = element_text(size = 10),
          legend.position = c(0.8, 0.15),
          plot.title = element_text(size=10, face="bold"),
          text = element_text(size=8)) +
    guides(fill = guide_legend(keywidth = 1, keyheight = 1),
           linetype=guide_legend(keywidth = 1.5, keyheight = 0.7),
           colour=guide_legend(keywidth = 1.5, keyheight = 0.7))+
       theme(plot.title = element_text(hjust=-.05, size=8.5))

pdf(here("graphics", "Figure2.pdf"), width = 8, height = 4, encoding = "MacRoman")
plot_grid(Figure2A, Figure2B, nrow = 1, ncol = 2, rel_widths = c(1, 1.5))
dev.off()

#Figure S2

#B1 Experimental
B1_EXP_DF_T<-bind_cols(as.data.frame(B1_EXP),rep(c("B1_EXP"), times = numsims)%>%as.data.frame)

names(B1_EXP_DF_T)<-c(sprintf("N%d", 30:150),"VAR")

B1_EXP_DF_T <- reshape(data=B1_EXP_DF_T, idvar="SIZE",
                          varying = c(sprintf("N%d", 30:150)),
                          v.names = c("COEF"),
                          times = c(sprintf("N%d", 30:150)),
                                               direction = "long")
#B2 Experimental
B2_EXP_DF_T<-bind_cols(as.data.frame(B2_EXP),rep(c("B2_EXP"), times = numsims)%>%as.data.frame)

names(B2_EXP_DF_T)<-c(sprintf("N%d", 30:150),"VAR")

B2_EXP_DF_T <- reshape(data=B2_EXP_DF_T, idvar="SIZE",
                       varying = c(sprintf("N%d", 30:150)),
                       v.names = c("COEF"),
                       times = c(sprintf("N%d", 30:150)),
                       direction = "long")

#B1 Forecasting
B1_FOR_DF_T<-bind_cols(as.data.frame(B1_FOR),rep(c("B1_FOR"), times = numsims)%>%as.data.frame)

names(B1_FOR_DF_T)<-c(sprintf("N%d", 30:150),"VAR")

B1_FOR_DF_T <- reshape(data=B1_FOR_DF_T, idvar="SIZE",
                       varying = c(sprintf("N%d", 30:150)),
                       v.names = c("COEF"),
                       times = c(sprintf("N%d", 30:150)),
                       direction = "long")

#B2 Forecasting
B2_FOR_DF_T<-bind_cols(as.data.frame(B2_FOR),rep(c("B2_FOR"), times = numsims)%>%as.data.frame)

names(B2_FOR_DF_T)<-c(sprintf("N%d", 30:150),"VAR")

B2_FOR_DF_T <- reshape(data=B2_FOR_DF_T, idvar="SIZE",
                       varying = c(sprintf("N%d", 30:150)),
                       v.names = c("COEF"),
                       times = c(sprintf("N%d", 30:150)),
                       direction = "long")

#Create data set
DenDat<-bind_rows(B1_EXP_DF_T,B2_EXP_DF_T,B1_FOR_DF_T,B2_FOR_DF_T%>%as.data.frame)

#Create data set
  DenDatN50B1<-DenDat[ which(DenDat$time=='N50'
                             & (DenDat$VAR=='B1_EXP' | DenDat$VAR=='B1_FOR')  ), ]
  DenDatN50B2 <-DenDat[ which(DenDat$time=='N50'
                              & (DenDat$VAR=='B2_EXP' | DenDat$VAR=='B2_FOR')  ), ]
  DenDatN100B1<-DenDat[ which(DenDat$time=='N100'
                             & (DenDat$VAR=='B1_EXP' | DenDat$VAR=='B1_FOR')  ), ]
  DenDatN100B2 <-DenDat[ which(DenDat$time=='N100'
                              & (DenDat$VAR=='B2_EXP' | DenDat$VAR=='B2_FOR')  ), ]
  DenDatN150B1<-DenDat[ which(DenDat$time=='N150'
                              & (DenDat$VAR=='B1_EXP' | DenDat$VAR=='B1_FOR')  ), ]
  DenDatN150B2 <-DenDat[ which(DenDat$time=='N150'
                               & (DenDat$VAR=='B2_EXP' | DenDat$VAR=='B2_FOR')  ), ]

#Generate figure S2
FigTheme <- function ()
{
 theme(panel.grid.major = element_blank(),
       panel.grid.minor = element_blank(),
       panel.background = element_blank(),
       axis.line = element_line(colour = "black"),
       axis.text.x = element_text(size = 11),
       plot.title = element_text(size=11, face="bold"),
       text = element_text(size=11),
       legend.position = "none")
}

#B1

PanelA <- ggplot(DenDatN50B1, aes(COEF, fill = as.factor(VAR))) +
 geom_vline(xintercept = 0.06970,  linetype="dashed", color = "black", size=1)+
 labs(subtitle="N=50") +
 ylab("")+xlab("") +xlim(-.6,.6)+
 coord_cartesian(ylim = c(1, 20))+
 geom_density(alpha = .5,color=NA) + FigTheme()

PanelC <- ggplot(DenDatN100B1,aes(COEF, fill = as.factor(VAR))) +
 geom_vline(xintercept = 0.06970,  linetype="dashed", color = "black", size=1)+
 labs(subtitle="N=100") +
 ylab("")+xlab("") +xlim(-.6,.6)+ coord_cartesian(ylim = c(1, 20))+
 geom_density(alpha = .5,color=NA) + FigTheme()

PanelE <- ggplot(DenDatN150B1,aes(COEF, fill = as.factor(VAR))) +
 geom_vline(xintercept = 0.06970,  linetype="dashed", color = "black", size=1)+
 labs(subtitle="N=150") +
 ylab("")+xlab("Individual Empowerment coefs.")+xlim(-.6,.6)+
 coord_cartesian(ylim = c(1, 20))+
 geom_density(alpha = .5,color=NA) + FigTheme()

#B2

PanelB <- ggplot(DenDatN50B2,aes(COEF, fill = as.factor(VAR))) +
 geom_vline(xintercept = 0.12916,  linetype="dashed", color = "black", size=1)+
 ylab("")+xlab("") +xlim(-.6,.6)+
 coord_cartesian(ylim = c(1, 20))+
 labs(subtitle="") +
 geom_density(alpha = .5,color=NA) + FigTheme()

PanelD <- ggplot(DenDatN100B2, aes(COEF, fill = as.factor(VAR))) +
 geom_vline(xintercept = 0.12916,  linetype="dashed", color = "black", size=1)+
 ylab("")+xlab("") +xlim(-.6,.6)+
 coord_cartesian(ylim = c(1, 20))+
 labs(subtitle="") +
 geom_density(alpha = .5,color=NA) + FigTheme()

PanelF <- ggplot(DenDatN150B2, aes(COEF, fill = as.factor(VAR))) +
 geom_vline(xintercept = 0.12916,  linetype="dashed", color = "black", size=1)+
 ylab("")+xlab("Community Empowerment coefs.") +xlim(-.6,.6)+
 coord_cartesian(ylim = c(1, 20))+
 labs(subtitle="") +
   geom_density(alpha = .5,color=NA) + FigTheme()

pdf(here("graphics", "FigureS2.pdf"), width = 6, height = 9, encoding = "MacRoman")
plot_grid(ggarrange(PanelA,
                   PanelC,
                   PanelE,ncol=1),
         ggarrange(PanelB,
                   PanelD,
                   PanelF,ncol=1))
dev.off()


## Blink Amplitudes
# We only compare the correction methods in the ANOVA because we are not interested whether rASR or ASR correct significantly
# in comparison to uncorrected data but only amongst themselves.
raw <- read.table(file = "data/blink_uncorrected.csv",header = FALSE, dec = ".", col.names = "amplitude", sep=",")
raw$condition <- c(c(rep("inside",27)), c(rep("outside",27)))
raw$subj      <- c(c(1:27), c(1:27))
raw$method    <- c(rep("uncorrected", 27*2))

asr <- read.table(file = "data/blink_asr.csv",header = FALSE, dec = ".", col.names = "amplitude", sep=",")
asr$condition <- c(c(rep("inside",27)), c(rep("outside",27)))
asr$subj      <- c(c(1:27), c(1:27))
asr$method    <- c(rep("asr", 27*2))

rasr <- read.table(file = "data/blink_rasr.csv",header = FALSE, dec = ".", col.names = "amplitude", sep=",")
rasr$condition <- c(c(rep("inside",27)), c(rep("outside",27)))
rasr$subj      <- c(c(1:27), c(1:27))
rasr$method    <- c(rep("rasr", 27*2))

library(ez)
library(effsize)

# combine correction methods for ANOVA, leave uncorected data out
all <- rbind(asr, rasr)
aov_group <- ezANOVA(data=all, dv = amplitude, within = .(condition, method), wid=subj)
print(aov_group)

source("pairwise.t.test.with.t.and.df.R")
result <- pairwise.t.test.with.t.and.df(all$amplitude, all$condition, adjust.method="bonf", paired=TRUE)
# print t-test result
print(result)
# Print t-values
print(c("t-value: ", result[[5]]))

# Print dfs
print(c("Df: ", result[[6]]))

# Cohen's D for t-test
cohen.d(all$amplitude, all$condition, paired = TRUE)
a <- mean(all$amplitude[all$condition== "inside" & all$method == "rasr"])
b <- mean(all$amplitude[all$condition== "inside" & all$method == "asr"])
c <- mean(all$amplitude[all$condition== "outside" & all$method == "rasr"])
d <- mean(all$amplitude[all$condition== "outside" & all$method == "asr"])
plot(c(a,b,c,d), xlab = "methods", ylab = "mean blink amplitude", xaxt = "n")
# Changing x axis
axis(1, at=1:4, labels=c("in rASR","in ASR", "out rASR","out ASR"))
legend("topright", legend=c(a,b,c,d))

print(c(mean(c(a,b)), "inside"))
print(c(mean(c(c,d)), "outside"))

un_in <- mean(raw$amplitude[raw$condition== "inside" & raw$method == "uncorrected"])
print(c(un_in, "uncorrected inside"))
un_out <- mean(raw$amplitude[raw$condition== "outside" & raw$method == "uncorrected"])
print(c(un_out, "uncorrected outside"))


# File: qpe.r
# Description:
#    Functions to perfrom QPE from radar data
#
#=========================================================================================
cmToMetrics <- function(cm, positive=1){
  # Decode the matrix
  if(positive==0){
    TP <- cm[1,1]/sum(cm)
    TN <- cm[2,2]/sum(cm)
    FP <- cm[1,2]/sum(cm)
    FN <- cm[2,1]/sum(cm)
  } else {
    TP <- cm[2,2]/sum(cm)
    TN <- cm[1,1]/sum(cm)
    FP <- cm[2,1]/sum(cm)
    FN <- cm[1,2]/sum(cm)
  }
  # Derive Metrics
  sensitivity <- TP/(TP+FN)
  specificity <- TN/(FP+TN)
  prevalence <- TP+FN/(FN+TP+FP+TN)
  ppv <- TP/(TP+FP)
  npv <- TN/(TN+FN)
  fpr <- FP/(FP+TN)
  fnr <- FN/(FN+TP)
  fdr <- FP/(FP+TP)
  FOR <- FN/(TN+FN)
  accuracy <- (TP+TN)/(FN+TP+FP+TN)
  F1 <- 2*TP/(2*TP+FP+FN)
  MCC <- (TP*TN-FP*FN)/sqrt((TP+FP)*(TP+FN)*(TN+FP)*(TN+FN))
  informedness <- sensitivity + specificity - 1
  markedness <- ppv + npv -1
  # Output
  output <- c("Accuracy"=accuracy,
              "True.Positive"=TP,
              "False.Negative"=FN,
              "False.Positive"=FP,
              "True.Negative"=TN,
              "Sensitivity"=sensitivity,
              "Specificity"=specificity,
              "Prevalence"=prevalence,
              "Positive.Predictive.Value"=ppv,
              "Negative.Predictive.Value"=npv,
              "False.Positive.Rate"=fpr,
              "False.Discovery.Rate"=fdr,
              "False.Negative.Rate"=fnr,
              "False.Omission.Rate"=FOR,
              "F1.Score"=F1,
              "Matthews.correlation.coefficient"=MCC,
              "Informedness"=informedness,
              "Markedness"=markedness)
  return(output)
}
#=========================================================================================
# Load input/output data
load("input.1316.ae.RData")
load("../workspace/output.1316.RData")
rseed = 1234543
# Load library
require(caret)
require(kernlab)
require(parallel)
# Set up multi-core
#library(doParallel)
#cluster <- makeCluster(12, outfile='aesvm.par.log') # convention to leave 8 core for OS
#registerDoParallel(cluster)
# Collect results
cmsByModels <- NULL
mod.glm <- NULL
mod.svm <- NULL
# Run through each station
nstation <- length(y.1316)
for(i in 1:nstation){
  #
  print(paste("Creating IO data for",names(y.1316)[i]))
  # Combine IO
  tmp <- data.frame('date'=y.1316[[i]]$date,'y'=(y.1316[[i]]$t1hr>=40.)*1) # 1:>=40mm/hr
  iodata <- merge(tmp, input.1316, by.x="date", by.y=0)
  iodata$y <- factor(iodata$y)
  # Clean up NA and move date to row.names
  print("Cleaning up data...")
  row.names(iodata) <- iodata$date
  iodata <- iodata[,-1]
  iodata <- iodata[complete.cases(iodata),]
  #iodata <- iodata[1:1000,]
  print(paste("    Number of valid records:", nrow(iodata)))
  # Setup train-control
  print("Creating folds for cross validation...")
  set.seed(rseed)
  cvOut <- createFolds(iodata$y, k=10)
  cvIn <- cvOut
  for(i in 1:10){
    cvIn[[i]] <- (1:length(iodata$y))[-cvOut[[i]]]
  }
  trctrl <- trainControl("cv", index=cvIn, indexOut=cvOut, allowParallel=T, savePred=T)
  # Fit model
  print("Training and cross validating...")
  # GLM
  fit.glm <- train(y~., data=iodata, method="glm", family="binomial", preProcess="scale", trControl=trctrl)
  # SVM
  fit.svm <- train(y~., data=iodata, method="svmRadial", preProcess="scale", trControl=trctrl)
  # Collection predictions
  cms <- list("glm"=confusionMatrix.train(fit.glm)$table,
              "svm"=confusionMatrix.train(fit.svm)$table)
  # Save model
  mod.glm <- c(mod.glm, list(fit.glm$finalModel))
  mod.svm <- c(mod.svm, list(fit.svm$finalModel))
  cmsByModels <- c(cmsByModels, list(cms))
}
names(cmsByModels) <- names(y.1316)
names(mod.glm) <- names(y.1316)
names(mod.svm) <- names(y.1316)
# Clean up
rm(i, iodata, cvOut, cvIn, trctrl, fit.glm, fit.svm)
# Stop parallel
#stopCluster(cluster)
#registerDoSEQ()
# Save
save(cmsByModels, file="qpe1316_ae_svm.results.RData")
save(mod.svm, file="qpe1316_ae_svm.mod.RData")


estimate.mean <- function(x,trim) {
#Purpose:
#  Estimates trimmed means on data x, using a vector of trimming levels
#Inputs:
# x - data
# trim - vector of trimming levels
#Outputs:
# vector of trimmed means

#create vector for results
  n.trimmed.means <- length(trim)
  trimmed.means <- numeric(n.trimmed.means)

#loop through, calculating trimmed means
  for(i in 1:n.trimmed.means)
    trimmed.means[i] <- mean(x,trim[i])

  return(trimmed.means)
}


#' Create all (non-trivial) clades on \code{n} taxa.
#'
#' Creates all clades on \code{n} taxa in the form of a vector of  strings.
#' Clades are of the form \code{"{t1,t4}"}, \code{"{t1,t2,t4}"}.
#' @param n number of taxa.
#'
#' @return a vector of strings containing all clades on \code{n} taxa.
#' @importFrom utils combn
#' @export make_all_clades
#' @details  Excludes 'trivial' clades such as \code{"{t1}"} or \code{"{t1,t2,t3,t4,t5}"} (for 5 taxa).
#' @examples
#' make_all_clades(4)
make_all_clades <- function(n){
  tips <- paste("t", 1:n,  sep = "")
  inner <- 2:(n-1)
  Pos <- lapply(inner, function(k) combn(n, k))
  AllClades <- lapply(Pos,
                      function(cn) {
                        apply(cn, 2, function(x) paste("{", paste("t", x, collapse = ",", sep = "") , "}",sep = ""))
                      } )
  ans <- unlist(AllClades)
  if(length(ans) != 2^n-n-2) stop("Did not generate the correct number of clades")
  return(ans)
}

#' Construct a grid of 'all vs all' correlations for a list of K clades on \code{n} taxa.
#'
#' @param Clades a character vector with all clades to be included.
#' @param n number of taxa.
#' @param diagonal logical. If \code{TRUE} includes the diagonal entries,
#'  which should all be 1 (default is \code{FALSE}).
#' @param ncores number of cores to be used.
#'
#' @return a grid of correlations between all clades.
#' @importFrom parallel mclapply
#' @importFrom data.table rbindlist
#' @export make_clade_corr_grid
#'
#' @examples
#' clades.n4 <- make_all_clades(4)
#' make_clade_corr_grid(clades.n4, n = 4)
make_clade_corr_grid <- function(Clades, n, diagonal = FALSE, ncores = 2){
  Clades <- gsub(" ", "", Clades) # avoid complications by removing spaces
  Var1 <- Var2 <- NULL
  K <- length(Clades)
  if(diagonal){
    posGrid <- subset(expand.grid(Var1 = 1:K, Var2 = 1:K), Var1 <= Var2)
  }else{
    posGrid <- subset(expand.grid(Var1 = 1:K, Var2 = 1:K), Var1 < Var2)
  }
  Rho <- parallel::mclapply(1:nrow(posGrid),
                            function(i) rho_clades(c1 = Clades[[posGrid[i, 1]]],
                                                   c2 = Clades[[posGrid[i, 2]]], n = n),
                            mc.cores = ncores)
  names(posGrid) <- c("i", "j")
  return(cbind(posGrid, data.table::rbindlist(Rho)))
}

#' Build the matrix of joint probabilities for a list of K clades on \code{n} taxa.
#' @param Clades a character vector with all K clades to be included.
#' @param n number of taxa.
#'
#' @return a  K x  K matrix of joint probabilities.
#' @export make_clade_joint_mat
#'
#' @examples
#' clades.n4 <- make_all_clades(4)
#' make_clade_joint_mat(Clades = clades.n4, n = 4)
make_clade_joint_mat <- function(Clades, n){
  Grid <- make_clade_corr_grid(Clades = Clades, n = n)
  K <- length(Clades)
  M <- matrix(0, ncol = K, nrow = K)
  for(k in 1:nrow(Grid)) M [Grid[k, ]$i, Grid[k, ]$j] <- Grid[k, ]$pij
  M <- M + t(M)
  return(M)
}

#' Build the variance-covariance matrix for a list of K clades on \code{n} taxa.
#'
#' @param Clades a character vector with all K clades to be included.
#' @param n number of taxa
#'
#' @return a K x K matrix of covariances.
#' @export make_clade_cov_mat
#'
#' @examples
#' clades.n4 <- make_all_clades(4)
#' make_clade_cov_mat(Clades = clades.n4, n = 4)
make_clade_cov_mat <- function(Clades, n){
  Grid <- make_clade_corr_grid(Clades = Clades, n = n, diagonal = TRUE)
  K <- length(Clades)
  M <- matrix(0, ncol = K, nrow = K)
  for(k in 1:nrow(Grid)) M [Grid[k, ]$i, Grid[k, ]$j] <- Grid[k, ]$cov
  Diag <- diag(M)
  M <- M + t(M)
  diag(M) <- Diag
  return(M)
}

#' Build the correlation matrix for a list of K clades on \code{n} taxa.
#'
#' @param Clades a character vector with all clades to be included.
#' @param n number of taxa.
#'
#' @return a  K x  K correlation matrix.
#' @export  make_clade_corr_mat
#'
#' @examples
#' clades.n4 <- make_all_clades(4)
#' make_clade_corr_mat(Clades = clades.n4, n = 4)
make_clade_corr_mat <- function(Clades, n){
  Grid <- make_clade_corr_grid(Clades = Clades, n = n)
  K <- length(Clades)
  M <- matrix(0, ncol = K, nrow = K)
  for(k in 1:nrow(Grid)) M [Grid[k, ]$i, Grid[k, ]$j] <- Grid[k, ]$rho
  M <- M + t(M)
  diag(M) <- 1
  return(M)
}


Edge Path 0:
a -> b (5)
b -> c (6)
c -> a (7)
a -> d (1)
d -> c (2)
c -> e (3)
e -> a (4)


#
# # Versions of pcond vectors for R-vine
# #   with different pair-copula family for each edge of the vine
# # for each row u[1:d] of hypercube data,
# # return C_{2|1}(u2|u1), C_{3|12}(u3|u1,u2), ...  C_{d|1..d-1}(ud|u1,...u[d-1])
#
# # parvec = vector of parameters of pair-copulas
# # udat = nxd matrix with uniform scores
# # A = dxd vine array with 1:d on diagonal
# # ntrunc = truncated level, assume >=1
# # pcondmat = matrix of names of conditional cdfs for trees 1,...,ntrunc
# #  (assuming only one needed for permutation symmetric pair-copulas)
# #   pcondmat is empty for diagonal and lower triangle,
# #    and could have ntrunc rows or be empty for rows ntrunc+1 to d-1
# # np = dxd where np[ell,j] is size for parameter th[ell,j]
# #   for pair-copula in tree ell, variables j and A[ell,j]
# #   np=0 on and below diagonal
# # Output:
# # return C_{2|1}(u2|u1), C_{3|12}(u3|u1,u2), ...  C_{d|1..d-1}(u[d]|u[1:(d-1)])
# #rvinellkv.trunc2=function(parvec,udat,A,ntrunc,logdcopmat,pcondmat,np)
# rvinepcond.trunc=function(parvec,udat,A,ntrunc,pcondmat,np)
# { d=ncol(A)  # or ncol(udat)
#   npmax=max(np); th=array(0,c(npmax,d,d)) # format of parameter for vine
#   ii=0;
#   for(ell in 1:ntrunc)
#   { for(j in (ell+1):d)
#     { ipp=1:np[ell,j]
#       th[ipp,ell,j]=parvec[ii+ipp]
#       ii=ii+np[ell,j]
#     }
#   }
#   out=varray2M(A)
#   M=out$mxarray
#   icomp=out$icomp
#   n=nrow(udat)
#   #llkv=rep(0,n)
#   vinepcond=matrix(0,n,d)
#   vinepcond[,1]=udat[,1]
#   v=matrix(0,n,d); vp=matrix(0,n,d); s=matrix(0,n,d);
#   nllk=0
#   # tree 1
#   #for(j in 2:d)
#   #{ ipp=1:np[1,j]
#     #logdcop=match.fun(logdcopmat[1,j])
#     #llkv=llkv+logdcop(udat[,A[1,j]],udat[,j],th[ipp,1,j])
#   #}
#   # tree 2
#   if(ntrunc>=2)
#   { for(j in 2:d)
#     { ipp=1:np[1,j]
#       pcond=match.fun(pcondmat[1,j])
#       if(icomp[1,j]==1) vp[,j]=pcond(udat[,A[1,j]],udat[,j],th[ipp,1,j])
#       v[,j]=pcond(udat[,j],udat[,A[1,j]],th[ipp,1,j])
#     }
#     vinepcond[,2]=v[,2]
#     for(j in 3:d)
#     { if(A[2,j]<M[2,j]) s[,j]=vp[,M[2,j]] else s[,j]=v[,A[2,j]] }
#     #for(j in 3:d)
#     #{ ipp=1:np[2,j]
#       #logdcop=match.fun(logdcopmat[2,j])
#       #llkv=llkv+logdcop(s[,j],v[,j],th[ipp,2,j])
#     #}
#     w=v; wp=vp
#   }
#   # remaining trees
#   if(ntrunc>=3)
#   { for(ell in 3:ntrunc)
#     { for(j in ell:d)
#       { ipp=1:np[ell-1,j]
#         pcond=match.fun(pcondmat[ell-1,j])
#         if(icomp[ell-1,j]==1) vp[,j]=pcond(s[,j],w[,j],th[ipp,ell-1,j])
#         v[,j]=pcond(w[,j],s[,j],th[ipp,ell-1,j])
#       }
#       vinepcond[,ell]=v[,ell]
#       for(j in (ell+1):d)
#       { if(A[ell,j]<M[ell,j]) s[,j]=vp[,M[ell,j]] else s[,j]=v[,A[ell,j]] }
#       #for(j in (ell+1):d)
#       #{ ipp=1:np[ell,j]
#         #logdcop=match.fun(logdcopmat[ell,j])
#         #llkv=llkv+logdcop(s[,j],v[,j],th[ipp,ell,j])
#       #}
#       w=v; # wp=vp  # wp is not used
#     }
#   }
#   if(ntrunc>1 & ntrunc<d)
#   { ell=ntrunc+1
#     for(j in ell:d)
#     { ipp=1:np[ell-1,j]
#       pcond=match.fun(pcondmat[ell-1,j])
#       if(icomp[ell-1,j]==1) vp[,j]=pcond(s[,j],w[,j],th[ipp,ell-1,j])
#       v[,j]=pcond(w[,j],s[,j],th[ipp,ell-1,j])
#       vinepcond[,j]=v[,j]
#     }
#   }
#   if(ntrunc==1)
#   { ell=2
#     for(j in ell:d)
#     { ipp=1:np[ell-1,j]
#       pcond=match.fun(pcondmat[ell-1,j])
#       v[,j]=pcond(udat[,j],udat[,A[1,j]],th[ipp,ell-1,j])
#       vinepcond[,j]=v[,j]
#     }
#   }
#   #llkv
#   vinepcond
# }
#
# #============================================================
#
# library(CopulaModel)
# d=5
# np=matrix(1,d,d)
# ntrunc=4
# udat=matrix(c(.1,.2,.3,.4,.5, .6,.7,.8,.9,.5),2,5,byrow=T)
# parvec=c(2,2,2,2,1.5,1.5,1.5,1.2,1.2,1.1)
# D5=Dvinearray(d)
# pcondmat=matrix("pcondgum",d,d)
#
# outd=rvinepcond.trunc(parvec,udat,D5,ntrunc,pcondmat,np)
# print(outd)
# #     [,1]      [,2]      [,3]      [,4]      [,5]
# #[1,]  0.1 0.4938008 0.7385935 0.8312337 0.8782010
# #[2,]  0.6 0.7328919 0.8830648 0.9754268 0.1403602
#
# outd2=rvinepcond.trunc(parvec,udat,D5,2,pcondmat,np)
# print(outd2)
# #     [,1]      [,2]      [,3]      [,4]       [,5]
# #[1,]  0.1 0.4938008 0.7385935 0.7430672 0.76377507
# #[2,]  0.6 0.7328919 0.8830648 0.9508236 0.08757126
#
# outd1=rvinepcond.trunc(parvec,udat,D5,1,pcondmat,np)
# print(outd1)
# #     [,1]      [,2]      [,3]      [,4]       [,5]
# #[1,]  0.1 0.4938008 0.5364857 0.5842195 0.63198274
# #[2,]  0.6 0.7328919 0.7951641 0.8831572 0.08282512
#
#
# # C-vine
# C5=Cvinearray(d)
# outc=rvinepcond.trunc(parvec,udat,C5,ntrunc,pcondmat,np)
# print(outc)
# #     [,1]      [,2]      [,3]      [,4]      [,5]
# #[1,]  0.1 0.4938008 0.7228406 0.8433683 0.9167192
# #[2,]  0.6 0.7328919 0.8700505 0.9776872 0.1262401
#
# # different truncation levels
# outc3=rvinepcond.trunc(parvec,udat,C5,3,pcondmat,np)
# print(outc3)
# #     [,1]      [,2]      [,3]      [,4]      [,5]
# #[1,]  0.1 0.4938008 0.7228406 0.8433683 0.9319560
# #[2,]  0.6 0.7328919 0.8700505 0.9776872 0.1922732
# outc2=rvinepcond.trunc(parvec,udat,C5,2,pcondmat,np)
# print(outc2)
# #     [,1]      [,2]      [,3]      [,4]      [,5]
# #[1,]  0.1 0.4938008 0.7228406 0.8530008 0.9294355
# #[2,]  0.6 0.7328919 0.8700505 0.9828434 0.2832124
#
# outc1=rvinepcond.trunc(parvec,udat,C5,1,pcondmat,np)
# print(outc1)
# #     [,1]      [,2]      [,3]      [,4]      [,5]
# #[1,]  0.1 0.4938008 0.6592740 0.7794878 0.8646421
# #[2,]  0.6 0.7328919 0.8746494 0.9689105 0.4179746
#
#
# #============================================================
#
# parm=matrix(0,d,d) # format of parameter for vine
# ii=0;
# for(ell in 1:ntrunc)
# { for(j in (ell+1):d)
#   { parm[ell,j]=parvec[ii+1]
#     ii=ii+1
#   }
# }
#
# pcond=pcondgum
#
# # compared with specific case for dvine
# pdchk=udat
# pdchk[,2]=pcond(udat[,2],udat[,1],parm[1,2])
# tem12=pcond(udat[,1],udat[,2],parm[1,2])
# tem32=pcond(udat[,3],udat[,2],parm[1,3])
# pdchk[,3]=pcond(tem32,tem12,parm[2,3])
# tem1g23=pcond(tem12,tem32,parm[2,3])
# tem23=pcond(udat[,2],udat[,3],parm[1,3])
# tem43=pcond(udat[,4],udat[,3],parm[1,4])
# tem4g23=pcond(tem43,tem23,parm[2,4])
# pdchk[,4]=pcond(tem4g23,tem1g23,parm[3,4])
# tem1g234=pcond(tem1g23,tem4g23,parm[3,4])
# tem34=pcond(udat[,3],udat[,4],parm[1,4])
# tem54=pcond(udat[,5],udat[,4],parm[1,5])
# tem5g34=pcond(tem54,tem34,parm[2,5])
# tem2g34=pcond(tem23,tem43,parm[2,4])
# tem5g234=pcond(tem5g34,tem2g34,parm[3,5])
# pdchk[,5]=pcond(tem5g234,tem1g234,parm[4,5])
# print(pdchk)
# #     [,1]      [,2]      [,3]      [,4]      [,5]
# #[1,]  0.1 0.4938008 0.7385935 0.8312337 0.8782010
# #[2,]  0.6 0.7328919 0.8830648 0.9754268 0.1403602
#
# # truncated vine:
# # 1-truncated
# pdchk1=udat
# pdchk1[,2]=pcond(udat[,2],udat[,1],parm[1,2])
# pdchk1[,3]=pcond(udat[,3],udat[,2],parm[1,3])
# pdchk1[,4]=pcond(udat[,4],udat[,3],parm[1,4])
# pdchk1[,5]=pcond(udat[,5],udat[,4],parm[1,5])
# print(pdchk1)
# #     [,1]      [,2]      [,3]      [,4]       [,5]
# #[1,]  0.1 0.4938008 0.5364857 0.5842195 0.63198274
# #[2,]  0.6 0.7328919 0.7951641 0.8831572 0.08282512
#
# # 2-truncated
# pdchk2=udat
# pdchk2[,2]=pcond(udat[,2],udat[,1],parm[1,2])
# tem12=pcond(udat[,1],udat[,2],parm[1,2])
# tem32=pcond(udat[,3],udat[,2],parm[1,3])
# pdchk2[,3]=pcond(tem32,tem12,parm[2,3])
# tem1g23=pcond(tem12,tem32,parm[2,3])
# tem23=pcond(udat[,2],udat[,3],parm[1,3])
# tem43=pcond(udat[,4],udat[,3],parm[1,4])
# tem4g23=pcond(tem43,tem23,parm[2,4])
# pdchk2[,4]=tem4g23
# tem1g234=tem1g23
# tem34=pcond(udat[,3],udat[,4],parm[1,4])
# tem54=pcond(udat[,5],udat[,4],parm[1,5])
# tem5g34=pcond(tem54,tem34,parm[2,5])
# tem2g34=pcond(tem23,tem43,parm[2,4])
# tem5g234=tem5g34
# pdchk2[,5]=tem5g234
# print(pdchk2)
# #     [,1]      [,2]      [,3]      [,4]       [,5]
# #[1,]  0.1 0.4938008 0.7385935 0.7430672 0.76377507
# #[2,]  0.6 0.7328919 0.8830648 0.9508236 0.08757126
#
# #
# # compared with specific case for cvine
#
# pcchk=udat
# tem21=pcond(udat[,2],udat[,1],parm[1,3])
# pcchk[,2]=tem21
# tem31=pcond(udat[,3],udat[,1],parm[1,3])
# tem3g12=pcond(tem31,tem21,parm[2,3])
# pcchk[,3]=tem3g12
# tem41=pcond(udat[,4],udat[,1],parm[1,4])
# tem4g12=pcond(tem41,tem21,parm[2,4])
# tem4g123=pcond(tem4g12,tem3g12,parm[3,4])
# pcchk[,4]=tem4g123
# tem51=pcond(udat[,5],udat[,1],parm[1,5])
# tem5g12=pcond(tem51,tem21,parm[2,5])
# tem5g123=pcond(tem5g12,tem3g12,parm[3,5])
# pcchk[,5]=pcond(tem5g123,tem4g123,parm[4,5])
#
# print(pcchk)
# #     [,1]      [,2]      [,3]      [,4]      [,5]
# #[1,]  0.1 0.4938008 0.7228406 0.8433683 0.9167192
# #[2,]  0.6 0.7328919 0.8700505 0.9776872 0.1262401
#
# # truncated cases
#
# # 3-truncated
# pcchk3=udat
# tem21=pcond(udat[,2],udat[,1],parm[1,3])
# pcchk3[,2]=tem21
# tem31=pcond(udat[,3],udat[,1],parm[1,3])
# tem3g12=pcond(tem31,tem21,parm[2,3])
# pcchk3[,3]=tem3g12
# tem41=pcond(udat[,4],udat[,1],parm[1,4])
# tem4g12=pcond(tem41,tem21,parm[2,4])
# tem4g123=pcond(tem4g12,tem3g12,parm[3,4])
# pcchk3[,4]=tem4g123
# tem51=pcond(udat[,5],udat[,1],parm[1,5])
# tem5g12=pcond(tem51,tem21,parm[2,5])
# tem5g123=pcond(tem5g12,tem3g12,parm[3,5])
# pcchk3[,5]=tem5g123
# print(pcchk3)
# #     [,1]      [,2]      [,3]      [,4]      [,5]
# #[1,]  0.1 0.4938008 0.7228406 0.8433683 0.9319560
# #[2,]  0.6 0.7328919 0.8700505 0.9776872 0.1922732
#
# # 2-truncated
# pcchk2=udat
# tem21=pcond(udat[,2],udat[,1],parm[1,3])
# pcchk2[,2]=tem21
# tem31=pcond(udat[,3],udat[,1],parm[1,3])
# tem3g12=pcond(tem31,tem21,parm[2,3])
# pcchk2[,3]=tem3g12
# tem41=pcond(udat[,4],udat[,1],parm[1,4])
# tem4g12=pcond(tem41,tem21,parm[2,4])
# tem4g123=tem4g12
# pcchk2[,4]=tem4g123
# tem51=pcond(udat[,5],udat[,1],parm[1,5])
# tem5g12=pcond(tem51,tem21,parm[2,5])
# tem5g123=tem5g12
# pcchk2[,5]=tem5g123
# print(pcchk2)
# #     [,1]      [,2]      [,3]      [,4]      [,5]
# #[1,]  0.1 0.4938008 0.7228406 0.8530008 0.9294355
# #[2,]  0.6 0.7328919 0.8700505 0.9828434 0.2832124
#
# # 1-truncated
# pcchk1=udat
# pcchk1[,2]=pcond(udat[,2],udat[,1],parm[1,2])
# pcchk1[,3]=pcond(udat[,3],udat[,1],parm[1,3])
# pcchk1[,4]=pcond(udat[,4],udat[,1],parm[1,4])
# pcchk1[,5]=pcond(udat[,5],udat[,1],parm[1,5])
# print(pcchk1)
# #     [,1]      [,2]      [,3]      [,4]      [,5]
# #[1,]  0.1 0.4938008 0.6592740 0.7794878 0.8646421
# #[2,]  0.6 0.7328919 0.8746494 0.9689105 0.4179746
#


matmult = function(x, y)
{
  if (is.double(x) && is.double(y))
  {
    if (NCOL(x) != NROW(y))
      pbdMPI::comm.stop("non-conformable arguments")

    .Call(R_matmult_dgemm, x, y)
  }
  else
    x %*% y
}

#' Matrix Multiplication
#'
#' Multiplies two distributed matrices, if they are conformable.
#'
#' @details
#' The two shaqs must be distributed \emph{identically}.
#'
#' @section Communication:
#' The operation is completely local.
#'
#' @param x
#' A shaq.
#' @param y
#' A regular matrix, globally owned on all ranks.  Since the number of columns
#' of a shaq should be small, this matrix should be small as well.
#'
#' @return
#' A shaq.
#'
#' @examples
#' \dontrun{
#' library(kazaam)
#' x = ranshaq(runif, 10, 3)
#' y = matrix(1:9, 3, 3)
#'
#' x %*% y
#'
#' finalize()
#' }
#'
#' @name matmult
#' @rdname matmult
NULL

matmult.shaq = function(x, y)
{
  if (ncol(x) != NROW(y))
    comm.stop("non-conformable arguments")

  nrows = nrow(x)
  ncols = NCOL(y)
  Data = DATA(x) %*% y

  shaq(Data, nrows, ncols, checks=FALSE)
}

#' @rdname matmult
#' @export
setMethod("%*%", signature(x="shaq", y="matrix"), matmult.shaq)


library(data.table)
library(kernlab)
library(np)

adf = read.csv("~/Dropbox/css_models/adf.csv")
fdf = read.csv("~/Dropbox/css_models/fdf.csv")

find.threshold = function(y, p, tp.value=.5, tn.value=.5){
    values = array(dim=100)
    thresholds = seq(0,1,length=100)
    for(tix in 1:100){
        t = thresholds[tix]
        tp.rate = sum( y & (p >= t))/sum( y)
        tn.rate = sum(!y & (p <  t))/sum(!y)

        values[tix] = (tp.value*tp.rate + tn.value*tn.rate)
    }
    return(thresholds[which.max(values)])
}

# WHAT THE FUCK -- ...
ca.f =   formula(adf$ca ~ data.matrix(adf[,-c(1:5)]))

ca.lm =       lm(ca.f)#adf$ca ~ adf[,-c(1:4)])
ca.lr =      glm(ca.f, family=binomial)
ca.gam =     gam(ca.f, family=binomial)

ca.svm =      ksvm(ca.f, type="C-svc")
ca.svm.vals = predict(ca.svm)

# THIS IS TAKING A MILLION YEARS
#ca.bw <- npregbw(xdat=data.matrix(adf[,-c(1:4)]), ydat=adf$ca)#, data=adf)
#ca.kr <- npreg(bws = ca.bw, gradients = TRUE)
#

ca.lm.t  = find.threshold(adf$ca, ca.lm$fitted.values)
ca.lr.t  = find.threshold(adf$ca, ca.lr$fitted.values)
ca.gam.t = find.threshold(adf$ca, ca.gam$fitted.values)

# All ~ 86%
sum(adf$ca & (ca.lm$fitted.values  >= ca.lm.t))  /sum(adf$ca)
sum(adf$ca & (ca.lr$fitted.values  >= ca.lr.t))  /sum(adf$ca)
sum(adf$ca & (ca.gam$fitted.values >= ca.gam.t)) /sum(adf$ca)

# All ~ 80%
sum(!adf$ca & (ca.lm$fitted.values  < ca.lm.t))  /sum(!adf$ca)
sum(!adf$ca & (ca.lr$fitted.values  < ca.lr.t))  /sum(!adf$ca)
sum(!adf$ca & (ca.gam$fitted.values < ca.gam.t)) /sum(!adf$ca)

# 80 and 98. -- Better, as a sum. How about -- without the block? Doesn't look important.
sum(adf$ca & ca.svm.vals) /sum(adf$ca)
sum(!adf$ca & !ca.svm.vals) /sum(!adf$ca)
# => 80, 98 ...

# AND NOW -- ... um, also, CV? Uh, ever?
test.people = 1:5 # Not random ... yet. sample(1:21, 5)
test.data  = adf[,]
train.data =
ca.svm =      ksvm(ca.f, type="C-svc")
ca.svm.vals = predict(ca.svm)
sum(adf$ca & ca.svm.vals) /sum(adf$ca)
sum(!adf$ca & !ca.svm.vals) /sum(!adf$ca)


library(Metrics)
#library(h2o)
#h2oServer <- h2o.init()   ##we'd like to try this, but does not initialize
library(data.table)   ## load data in quickly with fread
library(Metrics)
x <- fread("data/train.csv")
test <- fread("data/test.csv")

## prep the species column by moving the test-only UNSPECIFIED CULEX to CULEX ERRATICUS, and re-doing the levels
## logistic regression will complain otherwise
vSpecies<-c(as.character(x$Species),as.character(test$Species))
vSpecies[vSpecies=="UNSPECIFIED CULEX"]<-"CULEX ERRATICUS"
vSpecies<-factor(vSpecies,levels=unique(vSpecies))

## data.table syntax for adding a column; could overwrite the existing column as well
x[,Species2:=factor(vSpecies[1:nrow(x)],levels=unique(vSpecies))]
test[,Species2:=factor(vSpecies[(nrow(x)+1):length(vSpecies)],levels=unique(vSpecies))]

## also add some fields for components of the date using simple substrings
x[,dMonth:=substr(x$Date,6,7)]
x[,dYear:=substr(x$Date,1,4)]
test[,dMonth:=substr(test$Date,6,7)]

## glance at some conditional probabilities
x[,mean(WnvPresent),by="Species"][order(V1)]  ##glance at average by species
x[,mean(WnvPresent),by="Block"][order(V1)]  ##glance at average by block
x[,mean(WnvPresent),by="dMonth"][order(V1)]  ##glance at average by month of year

### Start modeling
## use 2011 as a cross validation year; x1 will include the other three years; x2 will include 2011
x1<-x[dYear!=2011,]
x2<-x[dYear==2011,]

## check sizes of split frames
dim(x1)
dim(x2)

## fit a logistic regression model using just three key fields
fitCv<-glm(WnvPresent ~ dMonth + Species2 + Block, data = x1, family = "binomial")
p2<-predict(fitCv, newdata = x2, type = "response")
## check for a reasonable AUC of the model against unseen data (2011)
auc(x2$WnvPresent,p2)

## now fit a new model to all the data, so that our final submission includes information learned from 2011 as well
fitSubmit<-glm(WnvPresent ~ dMonth + Species2 + Block, data = x, family = "binomial")
levels(test$Species2)
pSubmit<-predict(fitSubmit, newdata = test, type = "response")

## look at the predicted distribution (AUC doesn't care about probabilities; just ordering. It's still a good diagnostic)
summary(pSubmit)

submissionFile<-cbind(test$Id,pSubmit)
colnames(submissionFile)<-c("Id","WnvPresent")
options("scipen"=100, "digits"=8)
#write.csv(submissionFile,"logistic_regression_three_factors.csv",row.names=FALSE,quote=FALSE)


#' Produces a height to radius lookup table from tau = 0.01 to tau=1
#'
#' @param x A vector of heights
#' @param y A vector of radii
#' @param log Logical, indicating whether the relationahip should be fitted on the log
#' scale or not
#' @return A lookup table with coefficients describing the relationship between height
#' and radius at each quantile.
#' @export
#' @author Tom Swinfield
#' @details
#'
#' Created 16-10-10

rq_lut<-function(x, y, log){
        rq_tau<-function(x, y, tau, log){
                if(log){
                        x<-log(x); y<-log(y)
                }

                fit = quantreg::rq(y ~ x, tau = tau )
                a <- coef(fit)[1]
                b <- coef(fit)[2]

                params<-data.frame(tau=tau, a=a, b=b)
                rownames(params)<-NULL
                return(params)
        }
        lut<-lapply((1:100)/100, function(tau) rq_tau(x, y, tau, log))
        lut<-do.call(rbind, lut)
        return(lut)
}

#' Calculate the number of pixels distance to the edge of the image
#'
#' @param z numeric vector of tree heights
#' @param scale the resolution of the imagery
#' @param lut the lookup table of a and b for allometry
#' @param tau the paramter tau for quantile regression
#' @return A numeric vector of distances in pixels
#' @export
#' @author Tom Swinfield (edited by Jon Williams)
#' @details
#'
#' Created 16-10-10
#' Edited 17-11-02

edge.dist<-function(z, scale, lut, tau)
{
        radius<-htod_lookup(z, lut, tau)/2
        radius<-radius/scale
        pixels<-ceiling(radius)
        names(pixels)<-NULL
        return(pixels)
}

#' Calculates the window size for a tree based upon its height
#'
#' @description The scale (pixel size) of the image and the tree height are
#' both used to calculate the window size.
#'
#' @param z numeric vector of tree heights
#' @param scale the resolution of the imagery
#' @param lut the lookup table of a and b for allometry
#' @param tau the paramter tau for quantile regression
#' @return A numeric vector of window sizes in pixels
#' @export
#' @author Tom Swinfield (edited by Jon Williams)
#' @details
#'
#' Created 16-10-10
#' Edited 17-11-02

allom.dist<-function(z, scale, lut, tau)
{
        diam<-htod_lookup(x=z, lut, tau = tau)
        diam<-(diam/scale)
        win.size<-2*round((diam+1)/2)-1
        win.size[win.size<3]<-3
        names(win.size)<-NULL
        return(win.size)
}

#' Converts height to diameter
#'
#' @param x numeric vector of tree heights
#' @param htor_lut a look up table of coefficients coding the relationship between height and radius
#' @param tau the percentile for which the conversion should be made
#' @return A numeric vector of diameters
#' @export
#' @author Tom Swinfield
#' @details
#'
#' Created 16-10-10
htod_lookup<-function(x, lut, tau)
{
        a<-lut[tau,'a']
        b<-lut[tau,'b']
        rad<-(exp(a) * x^b)
        return(rad*2)
}

#' Converts radius to height
#'
#' @param x numeric vector of tree heights
#' @param lut a look up table of coefficients coding the relationship between height and radius
#' @param tau the percentile for which the conversion should be made
#' @return A numeric vector of heights
#' @export
#' @author Tom Swinfield
#' @details
#'
#' Created 16-10-10

rtoh_lookup<-function(x, lut, tau)
{
        a<-lut[tau,'a']
        b<-lut[tau,'b']
        h<-(x/exp(a))^(1/b)
        return(h)
}

#' Converts height to radius for a given percentile
#'
#' @description The funciton should be provided with a lookup table
#' as produced by rq_lut. Results are returned on the real scale and never on the log scale.
#'
#' @param x numeric vector of tree heights
#' @param lut a look up table of coefficients coding the relationship between height and radius
#' @param tau the percentile for which the conversion should be made
#' @param antilog Logical, indicating whether or not the coefficients in lut are on the log scale
#' or not.
#' @return A numeric vector of diameters
#' @export
#' @author Tom Swinfield
#' @details
#'
#' Created 16-10-10

allom_lookup<-function(x, lut, tau, antilog)
{
        rad<-x
        a<-lut[tau,'a']
        b<-lut[tau,'b']
        if(antilog)
                rad<-(exp(a) * x^b)
        else
                rad<-a + x*b
        return(rad*2)
}


pareto<-function(x,mn="Pareto barplot",...){  # x is a vector
x.tab=table(x)
xx.tab=sort(x.tab, decreasing=TRUE,index.return=FALSE)
cumsum(as.vector(xx.tab))->cs
length(x.tab)->lenx
bp<-barplot(xx.tab,ylim=c(0,max(cs)),las=2)
lb<-seq(0,cs[lenx],l=11)
axis(side=4,at=lb,labels=paste(seq(0,100,length=11),"%",sep=""),las=1,line=-1,col="Blue",col.axis="Red")
for(i in 1:(lenx-1)){
segments(bp[i],cs[i],bp[i+1],cs[i+1],col=i,lwd=2)
}
title(main=mn,...)

}


# Fuzzy nearest prototype helper functions: calculate centroids based on actual weighted mean

# data is a data.frame containing all observations
# formula is the format dominant_lc~c+o+v+a+r+s, and dominant_lc is a factor whose levels match column names of data
GetClassMeans = function(formula, data)
{
    DominantFactor = formula.tools::lhs.vars(formula)
    Classes = levels(data[,DominantFactor])
    Covars = formula.tools::rhs.vars(formula)

    combos = expand.grid(Classes=Classes, Covars=Covars)
    ClassMeans = function(x)
    {
        Hmisc::wtd.mean(data[,x["Covars"]], data[,x["Classes"]])
    }
    cm = apply(combos, 1, ClassMeans)
    c.means = matrix(cm, nrow=length(Classes), dimnames=list(Classes, Covars))
    return(c.means)
}

GetClassSDs = function(formula, data)
{
    DominantFactor = formula.tools::lhs.vars(formula)
    Classes = levels(data[,DominantFactor])
    Covars = formula.tools::rhs.vars(formula)

    combos = expand.grid(Classes=Classes, Covars=Covars)
    ClassSDs = function(x)
    {
        sqrt(Hmisc::wtd.var(data[,x["Covars"]], data[,x["Classes"]], normwt = TRUE))
    }
    csd = apply(combos, 1, ClassSDs)
    c.sds = matrix(csd, nrow=length(Classes), dimnames=list(Classes, Covars))
    return(c.sds)
}


 E04SAJ Example Program Results
 E04PT, Interior point method for SOCP problems
 Begin of Options
     Print File                    =                   6     * d
     Print Level                   =                   1     * U
     Print Options                 =                 Yes     * d
     Print Solution                =                  No     * d
     Monitoring File               =                  -1     * d
     Monitoring Level              =                   4     * d
     Socp Monitor Frequency        =                   0     * d

     Infinite Bound Size           =         1.00000E+20     * d
     Task                          =            Minimize     * d
     Stats Time                    =                  No     * d
     Time Limit                    =         1.00000E+06     * d

     Socp Iteration Limit          =                 100     * d
     Socp Max Iterative Refinement =                   9     * d
     Socp Presolve                 =                 Yes     * d
     Socp Scaling                  =                None     * d
     Socp Stop Tolerance           =         1.05367E-08     * d
     Socp Stop Tolerance 2         =         1.05367E-08     * d
     Socp System Formulation       =                Auto     * d
 End of Options

 Status: converged, an optimal solution found
 Final primal objective value -1.951817E+01
 Final dual objective value   -1.951817E+01
 Optimal X:
  x_idx       Value
      0   -1.26819e+00
      1   -4.08429e-01
      2    1.33234e+00


##
## Fit GEE models
##
library(geepack)
library(MuMIn)
library(arm)

source("data functions/standardize-gee.r")
source("data functions/confint-gee.r")
source("data functions/vcov.averaging.geeglm.r")

source("init.r")

hh.all$Ego.VillageID = factor(hh.all$Ego.VillageID)

hh.all$r.bin = cut(hh.all$r, c(0, 0.0039, 0.0078, 0.015, 0.031, 0.063, 0.125, 0.25, 0.5, 1), right=F)
hh.all$r.bin = forcats::fct_drop(hh.all$r.bin)  # `cut()` adds an empty factor "[0.5,1)" -- drop it

##
## kin
## (control + partners and kids + r x distance + r x kids)
##
gee.r = geeglm(HelpObserved ~ Distance + RelativeWealthRank + Ego.Size + Alter.Size + Ego.VillageID +
                 r.bin,
               id=Ego.HH, family="binomial", data=hh.all, corstr="exchangeable", scale.fix=T)

##
## kin
## (control + partners and kids + r x distance + r x kids)
##
gee.kin = geeglm(HelpObserved ~ Distance + RelativeWealthRank + Ego.Size + Alter.Size + Ego.VillageID +
                   r.bin + r.bin:Distance + AnyWivesInAlter + AnyHusbandsInAlter + ChildrenInAlter + r.bin:ChildrenInAlter,
                 id=Ego.HH, family="binomial", data=hh.all, corstr="exchangeable", scale.fix=T)

summary(gee.r)

m.terms = terms(gee.r)

new.data = expand.grid(r.bin = levels(hh.all$r.bin),
                       # set these predictors to their means
                       Distance = mean(hh.all$Distance),
                       RelativeWealthRank = mean(hh.all$RelativeWealthRank),
                       Ego.Size = mean(hh.all$Ego.Size),
                       Alter.Size = mean(hh.all$Alter.Size),
                       Ego.VillageID = unique(hh.all$Ego.VillageID),
                       # set response to zero for now
                       HelpObserved=0)

new.data = predict_gee(gee.r, m.terms, new.data)

new.data %>%
  filter(Ego.VillageID==1) %>%
  ggplot(aes(x=r.bin, y=HelpObserved)) +
  geom_point() +
  geom_pointrange(aes(ymin=tlo, ymax=thi), alpha=0.2) +
  xlab("Coefficient of relatedness") +
  ylab("Probability of farm help") +

  #scale_x_log10(breaks=c(0.0001, 0.0039, 0.0078, 0.015, 0.031, 0.063, 0.125, 0.25, 0.5)) +  # plot relatedness on log scale with breaks at familiar points
  #scale_x_continuous(breaks=c(0.0001, 0.063, 0.125, 0.25, 0.5)) +

  plot_style

fit gee models - relatedness categories.r


#############################################
# Make batch file with different index
# idx1: causal percent, look at Parameters.r for
#       Causal_percent.A <- c(0.05, 0.10, 0.15)
#       Causal_percent   <- Causal_percent.A[idx1]
# So: idx1 = 1 implies causal percent = 0.05
#     idx1 = 2 implies causal percent = 0.10
#     idx1 = 3 implies causal percent = 0.15
############################################
# idx2 : region size,  look at Parameters.r for
# Range.A  <- c(3000, 6000, 9000, 12000, 15000, 18000, 21000, 24000, 27000, 30000)
# Region_L <- Range.A[idx2]
# So: idx2 = 1 implies Region_L = 3k
###########################################
# idx3 : sample size, in loop
#######################################################
# idx4 : % of negative betas, look at Parameters.r for
# Beta1.Sign.A <- c(0, 0.2, 0.5)  # % of betas with negative sign
# Beta1.Sign <- Beta1.Sign.A[idx4]
# So: idx4 = 1 implies Beta1.Sign = 0
#     idx4 = 2 implies Beta1.Sign = 0.2
#     idx4 = 3 implies Beta1.Sign = 0.5
###################################################################
# idx5: upper limit of rare variant freq, look at Parameters.r for
#    CutOff.A <- c(0.03, 0.04, 0.05, 0.06)
#    CutOff   <- CutOff.A [idx5]
# So idx5 = 1 implies CutOff = 0.03 used in the papers of Lin et al.
#    idx5 = 2 implies CutOff = 0.04
#    idx5 = 3 implies CutOff = 0.05
#    idx5 = 4 implies CutOff = 0.06
####################################################################

Beta1.Sign.A <- c(0, 0.2, 0.5)  # % of betas with negative sign
CutOff.A     <- c(0.03, 0.04, 0.05, 0.06)

Causal_percent.A <- c(0.05, 0.10, 0.15)
Range.A          <- c(3000, 6000, 9000, 12000, 15000, 18000, 21000, 24000, 27000, 30000)
#N.Sample.A       <- c(250, 500, 1000)
Is.null.a        <- c(0, 1)
Beta1.IDX        <- 2
CutOff           <- 0.03

#Causal_percent <- Causal_percent.A[idx1]

#Region_L   <- Range.A[idx2]   # Region length, total 4
#Beta1.Sign <- Beta1.Sign.A[idx4]
Is.null    <- 0

Weight_Type <- 1 # beta weights

###############################
# Beta function

Get_LogRR_MAF <- function(MAF, p_min = 0.15, theta_max =4 ,s=4)
   {
   re <- 1 + (theta_max -1) * exp( -s*MAF/p_min)

   return(log(re))
   }

Generate_Covariates <- function(n)
   {
	 X1 <- rnorm(n)
	 X2 <- rbinom(n,1,0.5)

	 return(cbind(X1,X2))
   }

Get_Alpha0_C <- function(X)
   {
	 n  <- dim(X)[1]
	 re <- X[,1] * 0.5 / sqrt(2) + Beta0 /2

   return(re)
   }

Get_Alpha0_Q <- function(X)
   {
	 re <- X[,1] * 0.5 + X[,2] * 0.5
	 return(re)
   }

Get_Weights <- function(MAF, IDX)
   {
	 if(IDX == 1)
      {
		  re <- dbeta(MAF, shape1 = 1, shape2 = 25)
	    }
      else if (IDX == 2)
         {
		     re <- 1/sqrt(MAF*(1 - MAF))
         }

	 return(re)
   }

Get_Beta_Q_MAF <- function(MAF)
   {
	 re <- abs(0.5 * log10(MAF))
	 return(re)
   }

Get_BETA_Q<-function( IDX, MAF)
   {
	 n <- length(MAF)

	 if(IDX == 1)
      {
		  re<-Get_Beta_Q_MAF(MAF) * log(7)
	    }
      else if (IDX == 2)
         {
		     re <- Get_Beta_Q_MAF(MAF) * log(5)
	       }
         else if (IDX == 3)
            {
		        re <- Get_Beta_Q_MAF(MAF) * log(2.0)
	          }

	 return(re)
   }

Get_BETA_C<-function(idx1, idx2, MAF)
   {
	 n <- length(MAF)
   if (idx2 == 1)
      {
	    if (idx1 == 1)
         {
		     re <- Get_Beta_Q_MAF(MAF) * log(90)
	       } else if (idx1 == 2)
            {
		        re <- Get_Beta_Q_MAF(MAF) * log(70)
            } else if (idx1 == 3)
               {
		           re <- Get_Beta_Q_MAF(MAF) * log(50)
	             }
	    } else if (idx2 == 2)
         {
	       if (idx1 == 1)
            {
		        re <- Get_Beta_Q_MAF(MAF) * log(90)/1.25
	          } else if (idx1 == 2)
               {
		           re <- Get_Beta_Q_MAF(MAF) * log(70)/1.25
               } else if (idx1 == 3)
                  {
		              re <- Get_Beta_Q_MAF(MAF) * log(50)/1.25
	                }
	       } else if (idx2 == 3)
            {
	          if (idx1 == 1)
               {
		           re <- Get_Beta_Q_MAF(MAF) * log(90)/1.5
	             } else if (idx1 == 2)
                  {
		              re <- Get_Beta_Q_MAF(MAF) * log(70)/1.5
                  } else if (idx1 == 3)
                     {
		                 re <- Get_Beta_Q_MAF(MAF) * log(50)/1.5
	                   }
	          } else if (idx2 == 4)
               {
	             if (idx1 == 1)
                  {
		              re <- Get_Beta_Q_MAF(MAF) * log(90)/1.75
	                } else if (idx1 == 2)
                     {
		                 re <- Get_Beta_Q_MAF(MAF) * log(70)/1.75
                     } else if (idx1 == 3)
                        {
		                    re <- Get_Beta_Q_MAF(MAF) * log(50)/1.75
	                      }
	             } else if (idx2 == 5)
                  {
	                if (idx1 == 1)
                     {
		                 re <- Get_Beta_Q_MAF(MAF) * log(90)/2.0
	                   } else if (idx1 == 2)
                        {
		                    re <- Get_Beta_Q_MAF(MAF) * log(70)/2.0
                        } else if (idx1 == 3)
                           {
		                       re <- Get_Beta_Q_MAF(MAF) * log(50)/2.0
	                         }
	                } else if (idx2 == 6)
                     {
	                   if (idx1 == 1)
                        {
		                    re <- Get_Beta_Q_MAF(MAF) * log(90)/2.25
	                      } else if (idx1 == 2)
                           {
		                       re <- Get_Beta_Q_MAF(MAF) * log(70)/2.25
                           } else if (idx1 == 3)
                              {
		                          re <- Get_Beta_Q_MAF(MAF) * log(50)/2.25
                              }
                     } else if (idx2 == 7)
                        {
	                      if (idx1 == 1)
                           {
		                       re <- Get_Beta_Q_MAF(MAF) * log(90)/2.5
	                         } else if (idx1 == 2)
                              {
                              re <- Get_Beta_Q_MAF(MAF) * log(70)/2.5
                              } else if (idx1 == 3)
                                 {
		                             re <- Get_Beta_Q_MAF(MAF) * log(50)/2.5
                                 }
                            } else if (idx2 == 8)
                        {
	                      if (idx1 == 1)
                           {
		                       re <- Get_Beta_Q_MAF(MAF) * log(90)/2.75
	                         } else if (idx1 == 2)
                              {
                              re <- Get_Beta_Q_MAF(MAF) * log(70)/2.75
                              } else if (idx1 == 3)
                                 {
		                             re <- Get_Beta_Q_MAF(MAF) * log(50)/2.75
                                 }
                                  }else if (idx2 == 9)
                        {
	                      if (idx1 == 1)
                           {
		                       re <- Get_Beta_Q_MAF(MAF) * log(90)/3
	                         } else if (idx1 == 2)
                              {
                              re <- Get_Beta_Q_MAF(MAF) * log(70)/3
                              } else if (idx1 == 3)
                                 {
		                             re <- Get_Beta_Q_MAF(MAF) * log(50)/3
                                 }
                                 }else if (idx2 == 10)
                        {
	                      if (idx1 == 1)
                           {
		                       re <- Get_Beta_Q_MAF(MAF) * log(90)/3.25
	                         } else if (idx1 == 2)
                              {
                              re <- Get_Beta_Q_MAF(MAF) * log(70)/3.25
                              } else if (idx1 == 3)
                                 {
		                             re <- Get_Beta_Q_MAF(MAF) * log(50)/3.25
                                 }
                        }else { }
   return(re)
   }

###
Get_BETA_C_Delta<-function(idx1, idx2, MAF, Delta)
   {
	 n <- length(MAF)
   if (idx2 == 1)
      {
	    if (idx1 == 1)
         {
		     re <- Get_Beta_Q_MAF(MAF) * log(90)/(1.0 + Delta)
	       } else if (idx1 == 2)
            {
		        re <- Get_Beta_Q_MAF(MAF) * log(70) /(1.0 + Delta)
            } else if (idx1 == 3)
               {
		           re <- Get_Beta_Q_MAF(MAF) * log(50) /(1.0 + Delta)
	             }
	    } else if (idx2 == 2)
         {
	       if (idx1 == 1)
            {
		        re <- Get_Beta_Q_MAF(MAF) * log(90)/(1.25 + Delta)
	          } else if (idx1 == 2)
               {
		           re <- Get_Beta_Q_MAF(MAF) * log(70)/(1.25 + Delta)
               } else if (idx1 == 3)
                  {
		              re <- Get_Beta_Q_MAF(MAF) * log(50)/(1.25 + Delta)
	                }
	       } else if (idx2 == 3)
            {
	          if (idx1 == 1)
               {
		           re <- Get_Beta_Q_MAF(MAF) * log(90)/(1.5 + Delta)
	             } else if (idx1 == 2)
                  {
		              re <- Get_Beta_Q_MAF(MAF) * log(70)/(1.5 + Delta)
                  } else if (idx1 == 3)
                     {
		                 re <- Get_Beta_Q_MAF(MAF) * log(50)/(1.5 + Delta)
	                   }
	          } else if (idx2 == 4)
               {
	             if (idx1 == 1)
                  {
		              re <- Get_Beta_Q_MAF(MAF) * log(90)/(1.75 + Delta)
	                } else if (idx1 == 2)
                     {
		                 re <- Get_Beta_Q_MAF(MAF) * log(70)/(1.75 + Delta)
                     } else if (idx1 == 3)
                        {
		                    re <- Get_Beta_Q_MAF(MAF) * log(50)/(1.75 + Delta)
	                      }
	             } else if (idx2 == 5)
                  {
	                if (idx1 == 1)
                     {
		                 re <- Get_Beta_Q_MAF(MAF) * log(90)/(2.0 + Delta)
	                   } else if (idx1 == 2)
                        {
		                    re <- Get_Beta_Q_MAF(MAF) * log(70)/(2.0 + Delta)
                        } else if (idx1 == 3)
                           {
		                       re <- Get_Beta_Q_MAF(MAF) * log(50)/(2.0 + Delta)
	                         }
	                } else if (idx2 == 6)
                     {
	                   if (idx1 == 1)
                        {
		                    re <- Get_Beta_Q_MAF(MAF) * log(90)/(2.25 + Delta)
	                      } else if (idx1 == 2)
                           {
		                       re <- Get_Beta_Q_MAF(MAF) * log(70)/(2.25 + Delta)
                           } else if (idx1 == 3)
                              {
		                          re <- Get_Beta_Q_MAF(MAF) * log(50)/(2.25 + Delta)
                              }
                     } else if (idx2 == 7)
                        {
	                      if (idx1 == 1)
                           {
		                       re <- Get_Beta_Q_MAF(MAF) * log(90)/(2.5 + Delta)
	                         } else if (idx1 == 2)
                              {
                              re <- Get_Beta_Q_MAF(MAF) * log(70)/(2.5 + Delta)
                              } else if (idx1 == 3)
                                 {
		                             re <- Get_Beta_Q_MAF(MAF) * log(50)/(2.5 + Delta)
                                 }
                            } else if (idx2 == 8)
                        {
	                      if (idx1 == 1)
                           {
		                       re <- Get_Beta_Q_MAF(MAF) * log(90)/(2.75 + Delta)
	                         } else if (idx1 == 2)
                              {
                              re <- Get_Beta_Q_MAF(MAF) * log(70)/(2.75 + Delta)
                              } else if (idx1 == 3)
                                 {
		                             re <- Get_Beta_Q_MAF(MAF) * log(50)/(2.75 + Delta)
                                 }
                                  }else if (idx2 == 9)
                        {
	                      if (idx1 == 1)
                           {
		                       re <- Get_Beta_Q_MAF(MAF) * log(90)/(3 + Delta)
	                         } else if (idx1 == 2)
                              {
                              re <- Get_Beta_Q_MAF(MAF) * log(70)/(3 + Delta)
                              } else if (idx1 == 3)
                                 {
		                             re <- Get_Beta_Q_MAF(MAF) * log(50)/(3 + Delta)
                                 }
                                 }else if (idx2 == 10)
                        {
	                      if (idx1 == 1)
                           {
		                       re <- Get_Beta_Q_MAF(MAF) * log(90)/(3.25 + Delta)
	                         } else if (idx1 == 2)
                              {
                              re <- Get_Beta_Q_MAF(MAF) * log(70)/(3.25 + Delta)
                              } else if (idx1 == 3)
                                 {
		                             re <- Get_Beta_Q_MAF(MAF) * log(50)/(3.25 + Delta)
                                 }
                        }else { }
   return(re)
   }


pdf('nearby_values.pdf')

#read csv file in the working directory
set1 = read.csv(file="/home/stelios/training_set_1.csv", header=TRUE, sep=";")
set2 = read.csv(file="/home/stelios/training_set_2.csv", header=TRUE, sep=";")
set3 = read.csv(file="/home/stelios/training_set_3.csv", header=TRUE, sep=";")

#-------------------------------initializing-----------------------------

#we know that there are 3 clusters.
k=3;
#merge all dataset into one list

#case for taking means from each dataset

#all sets into one dataset
dataset = matrix(nrow=length(set1[,1])+length(set2[,1])+length(set3[,1]),ncol=2);

for (i in 1:length(set1[,1])){
	dataset[[i,1]] = set1[[1]][i];
	dataset[[i,2]] = set1[[2]][i];
}

for (i in (length(set1[,1])+1):(length(set1[,1])+length(set2[,1])) ){
	dataset[[i,1]] = set2[[1]][(i-length(set1[,1]))];
	dataset[[i,2]] = set2[[2]][(i-length(set1[,1]))];
}

for (i in ( length(set1[,1])+length(set2[,1])+1):(  length(set1[,1])+length(set2[,1])+length(set3[,1])  )){
	dataset[[i,1]] = set3[[1]][  (i-length(set1[,1]) - length(set2[,1]) ) ];
	dataset[[i,2]] = set3[[2]][  (i-length(set1[,1]) - length(set2[,1]) ) ];
}

#counting time for algorithm
ptm <- proc.time()

#kind of initializing mean of each class
mean_Ar = matrix(nrow=k,ncol=2);

#kind of initialization
mean_Ar[[1,1]] = 1+mean(dataset[,1])
mean_Ar[[1,2]] = 1+mean(dataset[,2])

mean_Ar[[2,1]] = -1+mean(dataset[,1])
mean_Ar[[2,2]] = -1+mean(dataset[,2])

mean_Ar[[3,1]] = -1+mean(dataset[,1])
mean_Ar[[3,2]] = 1+mean(dataset[,2])

#rnk matrix show where each data point belongs.
#rnk_matrix[1]=k--> k class
rnk_matrix = matrix(nrow=length(dataset[,1]),ncol=1);

par(mfrow=c(2,2))
plot(dataset[,1],dataset[,2],col="green",xlim=c(-1.6,1.6),ylim=c(-1.7,1.7),pch=20,panel.first = grid(),xlab="x",ylab="y")
points(mean_Ar[,1],mean_Ar[,2],col="blue",pch=4)

#-------------------------------K-means-----------------------------
J=abs(sum(dataset));
previous_J=J+10;

#loop with convergence
while(abs(J-previous_J)>0.01){
previous_J=J;

#calculating where each data point belongs, rnk criterion

for (i in 1:length(dataset[,1])){

	rnk_matrix[i] = 1;
	min = dist(rbind(dataset[i,], mean_Ar[1,]))

	for (j in 2:k){
		if(  dist(rbind(dataset[i,], mean_Ar[j,])) <min  ){
			min = dist(rbind(dataset[i,], mean_Ar[j,]))
			rnk_matrix[i] = j;
		}
	}
}

#calculating new mk
for (i in 1:length(dataset[,1])){

	rnk_matrix[i] = 1;
	min = dist(rbind(dataset[i,], mean_Ar[1,]))

	for (j in 2:k){
		if(  dist(rbind(dataset[i,], mean_Ar[j,])) <min  ){
			min = dist(rbind(dataset[i,], mean_Ar[j,]))
			rnk_matrix[i] = j;
		}
	}
}

#for k class
for(t in 1:k){

	#2 for calculating the mk of the k class
	for (i in 1:length(dataset[,1])){

		#select from all the data only those belonging to the k class
		a= which(rnk_matrix==t)

		sum1=matrix(c(0,0),nrow=2,ncol=1);
		for (j in a){
			sum1 = sum1 + dataset[j,]
		}
			mean_Ar[t,] = sum1/length(a)
	}

}

size_class = c(0,0,0)
#---------------------plot first class-----------------------------

a= which(rnk_matrix==1)
tr1=matrix(nrow=length(a),ncol=2)
counter1=1;
for (i in a){
tr1[counter1,1]=dataset[i,1]
tr1[counter1,2]=dataset[i,2]
counter1= counter1+1
}
size_class[1] =counter1;

plot(tr1[,1],tr1[,2],col="red",xlim=c(-1.6,1.6),ylim=c(-1.7,1.7),panel.first = grid(),xlab="x",ylab="y",main=toString(J))

#---------------------plot second class-----------------------------
a= which(rnk_matrix==2)
tr1=matrix(nrow=length(a),ncol=2)
counter1=1;
for (i in a){
tr1[counter1,1]=dataset[i,1]
tr1[counter1,2]=dataset[i,2]
counter1= counter1+1
}
size_class[2] =counter1;
points(tr1[,1],tr1[,2],col="green")

#---------------------plot third class-----------------------------
a= which(rnk_matrix==3)
tr1=matrix(nrow=length(a),ncol=2)
counter1=1;
for (i in a){
tr1[counter1,1]=dataset[i,1]
tr1[counter1,2]=dataset[i,2]
counter1= counter1+1
}
size_class[3] =counter1;
points(tr1[,1],tr1[,2],col="dodgerblue")
points(mean_Ar[,1],mean_Ar[,2],col="black",pch=4)

J=0;
#J formula
for(g in 1:length(dataset[,1])){
		  	a=rnk_matrix[i]
			sum2 = dist(rbind(dataset[g,], mean_Ar[a,]))
			J=J+sum2

}

print(J)

}
#--------------------------------------------while loop----------------------------

#--------------------------------------k-means----package-----------------------
#algorithm k-means-->Hartigan-Wong

ptm=proc.time() - ptm
#needs library stats
library("stats")

ptm2 <- proc.time()
rop=kmeans(dataset,3)
ptm2=proc.time() - ptm2

#---------------------plot first class-----------------------------

a= which(rop[1][[1]]==1)
tr1=matrix(nrow=length(a),ncol=2)
counter1=1;
for (i in a){
tr1[counter1,1]=dataset[i,1]
tr1[counter1,2]=dataset[i,2]
counter1= counter1+1
}

plot(tr1[,1],tr1[,2],col="red",xlim=c(-1.6,1.6),ylim=c(-1.7,1.7),panel.first = grid(),xlab="x",ylab="y",main="using package k-means")

#---------------------plot second class-----------------------------
a= which(rop[1][[1]]==2)
tr1=matrix(nrow=length(a),ncol=2)
counter1=1;
for (i in a){
tr1[counter1,1]=dataset[i,1]
tr1[counter1,2]=dataset[i,2]
counter1= counter1+1
}

points(tr1[,1],tr1[,2],col="green")

#---------------------plot third class-----------------------------
a= which(rop[1][[1]]==3)
tr1=matrix(nrow=length(a),ncol=2)
counter1=1;
for (i in a){
tr1[counter1,1]=dataset[i,1]
tr1[counter1,2]=dataset[i,2]
counter1= counter1+1
}

points(tr1[,1],tr1[,2],col="dodgerblue")
points(rop[[2]][,1],rop[[2]][,2],col="black",pch=4)

#size of each class
t(c(length(which(rnk_matrix==1)),length(which(rnk_matrix==2)),length(which(rnk_matrix==3))))
rop[7]

#centers
mean_Ar
rop[2]

#iterations of kmeans-package
rop[8]

#time
#user kmeans
ptm
#package time
ptm2

dev.off()


convertThetaIter  <- function(theta, thetabar)
{
    dtheta  <- theta - thetabar
    theta[dtheta > .5*pi]  <-  theta[dtheta > .5*pi] - pi
    theta[dtheta < -.5*pi]  <- pi + theta[dtheta < -.5*pi]
    if ( any(abs(dtheta) > .5*pi) )
    {
        theta <- convertThetaIter(theta, thetabar)
    }
    return(theta)
}

## convertThetaNew  <- function(theta, thetabar)
## {
##     dtheta  <- theta - thetabar
##     if ( any(abs(dtheta) > pi ) )
##     {
##         cat("something wrong with theta!\n")
##         exit()
##     }
##     theta[dtheta > .5*pi]  <-  theta[dtheta > .5*pi] - pi
##     theta[dtheta < -.5*pi]  <- pi + theta[dtheta < -.5*pi]
##     if ( any(abs(dtheta) > pi) )
##     {
##         cat("something wrong with theta 2!\n")
##         exit()
##     }
##     return(theta)
## }

## convertTheta  <- function(theta)
## {
##     if ( any(abs(theta) > pi ) )
##     {
##         cat("something wrong with theta!\n")
##         exit()
##     }
##     theta[theta > .5*pi]  <-  theta[theta > .5*pi] - pi
##     theta[theta < -.5*pi]  <- pi + theta[theta < -.5*pi]
##     if ( any(abs(theta) > pi) )
##     {
##         cat("something wrong with theta 2!\n")
##         exit()
##     }
##     return(theta)
## }

simu  <- function(lambda2, k1, k2, alpha, ec, A, index)
{
    dt <- 0.01
    a0 <- 0.01
    e0 <- 1.0
    lambda1 <- 1
    Ncell <- 50
    Nstep <- 40000
    v <- a0*A
    DispWindow  <- seq(28000, 40000)
    ##Selection  <- 28000 + 2400*seq(5)
    Selection  <- 28000 + 100*seq(120)

    nt <- Ncell
    lt <- 1
    output1 <- NULL

    e <- seq(1.2, 1.2, length.out=Ncell)
    theta <- runif(Ncell, -pi/2, pi/2)
    thetabar <- 0
    S <- 0

    ## ############### model I
    for ( i in seq(Nstep) )
    {
        if ( i %% 20 == 0 )
        {
            n <- cbind(cos(theta), sin(theta))
            Q <- cbind(n[,1]*n[,1]-0.5, n[,1]*n[,2], n[,2]*n[,1], n[,2]*n[,2]-0.5)
            Q <- colSums((e-1)*Q)/sum((e-1))
            M <- matrix(Q, nrow=2, ncol=2, byrow=TRUE)
            ##M <- matrix(colMeans(Q), nrow=2, ncol=2, byrow=TRUE)
            eigenvec <- eigen(M)$vectors[,1]
            S <- 2.0*eigen(M)$values[1]
            if(eigenvec[1] < 0)
            {
                eigenvec  <- -eigenvec
            }
            thetabar <- sign(eigenvec[2])*atan(abs(eigenvec[2])/pmax(0.000001, abs(eigenvec[1])))
        }
        Lt <- exp(v*dt*i)
        Force <- max(0, alpha*(Lt-lt))
        e <- e + dt*(Force*abs(cos(theta)) - lambda1*(e-1)) + k1*sqrt(dt)*rnorm(nt, mean=0, sd=1)
        e <- pmax(e, 1)
        theta <- theta - dt*lambda2*S*(e-1)*(theta-thetabar) + k2*sqrt(dt)*rnorm(nt, mean=0, sd=1)
        ##theta <- theta - dt*lambda2*S*(theta-thetabar) + k2*sqrt(dt)*rnorm(nt, mean=0, sd=1)
        theta <- convertThetaIter(theta, thetabar)
        ##theta <- atan2(sin(theta), cos(theta))

        theta1 <- atan(abs(sin(theta))/pmax(0.000001, abs(cos(theta))))
        ndiv=rbinom(1, nt, dt*a0)
        divtheta <- sample(theta1, ndiv)
        lt<-lt*(1+sum(cos(divtheta))/nt)
        nt<-nt+ndiv
        theta<-c(theta, runif(ndiv, -pi/2, pi/2))
        e<-c(e, rep(e0, ndiv))
        A1 <- mean(cos(theta1))
        A2 <- mean(cos(theta1)) - mean(sin(theta1))

        output1 <- rbind(output1, c(Lt, lt, A1, A2, Force, nt, thetabar, S))
    }

    eModelI <- e
    thetaModelI <- theta

################################ model II
    output2 <- NULL
    nt=Ncell
    lt=1
    e <- seq(1.2, 1.2, length.out=Ncell)
    theta <- runif(Ncell, -pi/2, pi/2)

    for ( i in seq(Nstep) )
    {
        if ( i %% 20 == 0 )
        {
            n <- cbind(cos(theta), sin(theta))
            Q <- cbind(n[,1]*n[,1]-0.5, n[,1]*n[,2], n[,2]*n[,1], n[,2]*n[,2]-0.5)
            Q <- colSums((e-1)*Q)/sum((e-1))
            M <- matrix(Q, nrow=2, ncol=2, byrow=TRUE)
            ##M <- matrix(colMeans(Q), nrow=2, ncol=2, byrow=TRUE)
            eigenvec <- eigen(M)$vectors[,1]
            S <- 2.0*eigen(M)$values[1]
            if(eigenvec[1] < 0)
            {
                eigenvec  <- -eigenvec
            }
            thetabar <- sign(eigenvec[2])*atan(abs(eigenvec[2])/pmax(0.000001, abs(eigenvec[1])))
        }
        Lt <- exp(v*dt*i)
        Force <- max(0, alpha*(Lt-lt))
        e <- e + dt*(Force*abs(cos(theta)) - lambda1*(e-1)) + k1*sqrt(dt)*rnorm(nt, mean=0, sd=1)
        e <- pmax(e, 1)
        theta <- theta - dt*lambda2*S*(e-1)*(theta-thetabar) + k2*sqrt(dt)*rnorm(nt, mean=0, sd=1)
        ##theta <- theta - dt*lambda2*S*(theta-thetabar) + k2*sqrt(dt)*rnorm(nt, mean=0, sd=1)
        theta <- convertThetaIter(theta, thetabar)
        ##theta <- atan2(sin(theta), cos(theta))

        theta1 <- atan(abs(sin(theta))/pmax(0.000001, abs(cos(theta))))
        ecut <- e < ec
        theta2 <- theta1 * (1 - ecut) + ecut * runif(nt, 0, pi/2)

        ndiv=rbinom(1, nt, dt*a0)

        divtheta <- sample(theta2, ndiv)
        lt<-lt*(1+sum(cos(divtheta))/nt)
        nt<-nt+ndiv
        theta<-c(theta, runif(ndiv, -pi/2, pi/2))
        e<-c(e, rep(e0, ndiv))
        A1 <- mean(cos(theta1))
        A2 <- mean(cos(theta1)) - mean(sin(theta1))

        output2<-rbind(output2, c(Lt, lt, A1, A2, Force, nt, thetabar, S))
    }

    ##if ( index <= 3 )
    {
        png(paste("plotlt", "_A_", A, "_alpha_", alpha,
                  "_lambda2_", lambda2,
                  "_k1_", k1, "_k2_", k2,
                  "_", index, ".png", sep=''),
            width=1200, height=600)
        par(mfrow=c(2,5))
        plot(eModelI, thetaModelI*180/pi, ylim=c(-90,90))
        abline(h=c(-30,30))
        plot(output1[DispWindow, 1]-output1[DispWindow, 2],
             col = 'blue', ylab="L(t)-l(t)",
             ylim=c(-1,1),
             xlab="timesteps", cex=0.5
             )##, ylim=c(-1,1), cex=0.5)
        abline(h=0, lwd = 2, col='grey')
        plot(output1[DispWindow,5], cex=0.25)
        plot(output1[DispWindow, 3], col='blue', ylim=c(-1, 1))
        lines(output1[DispWindow, 4], col='red')
        lines(output2[DispWindow, 7], col='green', pch=5, type='p')
        abline(h=c(-0.3))
        plot(output1[DispWindow, 8], col='blue', ylim=c(0, 1))

        plot(e, theta*180/pi, ylim=c(-90,90))
        abline(h=c(-30,30))
        plot(output2[DispWindow, 1]-output2[DispWindow, 2],
             col = 'blue', ylab="L(t)-l(t)",
             ylim=c(-1,1),
             xlab="timesteps", cex=0.5
             )
        abline(h=0, lwd = 2, col='grey')
        plot(output2[DispWindow,5], cex=0.25)
        plot(output2[DispWindow, 3], col='blue', ylim=c(-1, 1))
        lines(output2[DispWindow, 4], col='red')
        lines(output2[DispWindow, 7], col='green', pch=5, type='p')
        abline(h=c(-0.3))
        plot(output2[DispWindow, 8], col='blue', ylim=c(0, 1))

        dev.off()
    }

    simu <- NULL
    simu$model1 <- output1[Selection, 1] - output1[Selection, 2]
    simu$model2 <- output2[Selection, 1] - output2[Selection, 2]
    return(simu)
}

baseModels  <- function(lambda2, k1, k2, ec, index, Force)
{
    dt <- 0.01
    a0 <- 0.01
    e0 <- 1.0
    lambda1 <- 1
    Ncell <- 2000
    Nstep <- 10000

    nt <- Ncell
    e <- seq(1.2, 1.2, length.out=Ncell)
    theta <- runif(Ncell, -pi/2, pi/2)
    thetabar <- 0.0
    S  <- 0

    ## ############### model I
    for ( i in seq(Nstep) )
    {
        if ( i %% 20 == 0 )
        {
            n <- cbind(cos(theta), sin(theta))
            Q <- cbind(n[,1]*n[,1]-0.5, n[,1]*n[,2], n[,2]*n[,1], n[,2]*n[,2]-0.5)
            Q <- colSums((e-1)*Q)/sum((e-1))
            M <- matrix(Q, nrow=2, ncol=2, byrow=TRUE)
            eigenvec <- eigen(M)$vectors[,1]
            S <- 2.0*eigen(M)$values[1]
            if(eigenvec[1] < 0)
            {
                eigenvec  <- -eigenvec
            }
            if (abs(eigenvec[1]) < 0.000001)
            {
                thetabar <- sign(eigenvec[2])*pi/2
            }
            else
            {
                thetabar <- sign(eigenvec[2])*atan(abs(eigenvec[2])/pmax(0.000001, abs(eigenvec[1])))
            }
            ##cat(S, thetabar, '\n')
        }
        e <- e + dt*(Force*abs(cos(theta)) - lambda1*(e-1)) + k1*sqrt(dt)*rnorm(nt, mean=0, sd=1)
        e <- pmax(e, 1)
        theta <- theta - dt*lambda2*S*(e-1)*(theta-thetabar) + k2*sqrt(dt)*rnorm(nt, mean=0, sd=1)
        theta <- convertThetaIter(theta, thetabar)
    }

    theta1 <- atan(abs(sin(theta))/pmax(0.000001, abs(cos(theta))))
    ecut <- e < ec
    theta2 <- theta1 * (1 - ecut) + ecut * runif(nt, 0, pi/2)
    A1 <- mean(cos(theta1))
    A2 <- mean(cos(theta1)) - mean(sin(theta1))
    B1 <- mean(cos(theta2))
    B2 <- mean(cos(theta2)) - mean(sin(theta2))

    output <- NULL
    output$values <- c(A1, A2, B1, B2, S, thetabar)
    output$e <- e
    output$theta <- theta

    baseModels  <- output
    return(baseModels)
}

library(foreach)
library(doParallel)

lambda2 <- 0.25
k1 <- 0.1
k2 <- 0.15
alpha <- 2
ec <- 1.6
A  <- 0.8

Alist <- seq(0.6, 1, 0.05)
lambda2list <- seq(0.1, 3, 0.2)
eclist <- seq(1.1, 2, 0.1)
alphalist <- c(0.1, 0.2, 0.3, 0.5, 1, 1.5, 2, 5, 10, 20, 40, 60, 100)
k1list <- seq(0.1, 2, 0.2)
k2list <- seq(0.1, 2, 0.2)

singleRun <- function(Nsample)
{
    resAll <- NULL
    for ( i in seq(Nsample))
    {
        cat(i, '\n')
        res <- simu(lambda2, k1, k2, alpha, ec, A, i)
        resAll$model1 <- c(resAll$model1, res$model1)
        resAll$model2 <- c(resAll$model2, res$model2)
    }
    singleRun <- c(sd(resAll$model1), sd(resAll$model2))
    return(singleRun)
}

paraRun <- function(Nsample)
{
    paraRun <- foreach ( i=seq(Nsample), .export=c("convertTheta", "simu", "lambda2", "k1", "k2", "alpha", "ec", "A"), .combine = list, .multicombine = TRUE ) %dopar%
        simu(lambda2, k1, k2, alpha, ec, A, i)
    return(paraRun)
}

computeSDpara  <- function(nthreads, Nsample)
{
    zz <- file("sd.txt", "w")
    close(zz)

    cl<-makeCluster(nthreads)
    registerDoParallel(cl)
    ##for ( k1 in k1list )
    {
        ##for ( k2 in k2list )
        {
            res <- paraRun(Nsample)
            sd1 <- sd(unlist(lapply(res, "[[", 1)))
            sd2 <- sd(unlist(lapply(res, "[[", 2)))
            cat(lambda2, k1, k2, alpha, ec, A, sd1, sd2, '\n',
                file="sd.txt", sep=',', append=TRUE)
        }
    }
    stopCluster(cl)
}

figure4 <- function(Nsample)
{
    mycol = c("#99CCFF","darkgrey","#FFCCCC","#FF99FF","#99FFCC")
    ##mycol = c("#6666FF","darkgrey","#FFCC99","#FF99FF","#99FFCC")
    mylty = c(1, 1, 1, 1, 1)
    mypch = c(0,1,5,16,2)

    pdf("figure4A.pdf", height=7, width=9)
    par(mar=c(4,6,4,5))
    plot(0, 0, type='n',
         col = 'blue', ylab="L(t)-l(t)",
         ylim=c(-.75,.75),
         xlim=c(0, 120),
         xlab="t", cex.lab=2, cex.axis=1.5
         )
    for ( i in seq(Nsample))
    {
        cat(i, '\n')
        res <- simu(lambda2, k1, k2, alpha, ec, A, i)
        lines(res$model1, pch=mypch[i], lty=mylty[i], col=mycol[i], type='o', lwd=1.5, cex=0.6)
    }
    dev.off()

    pdf("figure4B.pdf", height=7, width=9)
    par(mar=c(4,6,4,5))
    plot(0, 0, type='n',
         col = 'blue', ylab="L(t)-l(t)",
         ylim=c(-.75,.75),
         xlim=c(0, 120),
         xlab="t", cex.lab=2, cex.axis=1.5
         )
    for ( i in seq(Nsample))
    {
        cat(i, '\n')
        res <- simu(lambda2, k1, k2, alpha, ec, A, i)
        lines(res$model2, pch=mypch[i], lty=mylty[i], col=mycol[i], type='o', lwd=1.5, cex=0.6)
    }
    dev.off()
}

figure3 <- function(nthreads, Nsample)
{
    Force <- 0.5
    ForceList <- seq(0, 1.5, 0.05)
    Astat  <- NULL
    Bstat  <- NULL
    Amean <- NULL
    Asd <- NULL
    Bmean <- NULL
    Bsd <- NULL
    cl<-makeCluster(nthreads)
    registerDoParallel(cl)
    for (Force in ForceList )
    {
        cat(Force, '\n')
        res <- foreach ( i=seq(Nsample),
                        .export=c("convertThetaIter", "baseModels", "lambda2", "k1", "k2", "ec"),
                        .combine = list, .multicombine = TRUE ) %dopar%
            baseModels(lambda2, k1, k2, ec, i, Force)
        Astat <- unlist(lapply(lapply(res, "[[", 1), "[[", 2))
        Bstat <- unlist(lapply(lapply(res, "[[", 1), "[[", 4))
        ##sd2 <- sd(unlist(lapply(res, "[[", 2)))
        ##res <- baseModels(lambda2, k1, k2, ec, i, Force)
        ##Astat  <- c(Astat, res$values[2])
        ##Bstat  <- c(Bstat, res$values[4])
        ##cat(res$values, '\n')
        Amean <- c(Amean, mean(Astat))
        Asd <- c(Asd, sd(Astat))
        Bmean <- c(Bmean, mean(Bstat))
        Bsd <- c(Bsd, sd(Bstat))
    }
    stopCluster(cl)
    pdf("figure3.pdf", height=7, width=8)
    par(mar=c(4,6,4,4))
    plot(ForceList, Amean, lwd=3,
         xlab="F", ylab="A",
         lty=2,
         cex.lab=1.5, cex.axis=1.5,
         cex=0.5,
         type='o', ylim=c(-0.1,1))
    ##abline(v=0, lty=4, lwd=2)
    legend("bottomright", c("one population", "two populations"),
           lty=c(2, 1), lwd=2, cex=1.5)
    arrows(ForceList, Amean-3*Asd, ForceList, Amean+3*Asd, lty=1, code=3, angle=90, length=0.05)
    lines(ForceList, Bmean, lwd=3,
          type='o', lty=1, cex=0.5)
    arrows(ForceList, Bmean-3*Bsd, ForceList, Bmean+3*Bsd, lty=1, code=3, angle=90, length=0.05)
    dev.off()
}

figure3(nthreads=20, Nsample=100)
figure4(5)

##computeSDpara(2, 2)

##system("cat run.r > sd.txt")

##z = baseModels(lambda2, k1, k2, ec, i, -0.1)
##cat(z$values, '\n')


## Draft code: do not source file.

modelName <- "bernoulli_logit_glm_rhs"

setwd("~/Desktop/Code/laplace_approximation/Script/")
.libPaths("~/Rlib")

library(rstan)
library(boot)
source("tools/cmdStanTools.r")

###############################################################################
chains <- 1
seed <- 12345
file <- file.path("deliv_cmdstan", paste0(modelName, ".", seed, ".", chains,
                                          ".csv"))

chain_output <- read.table(file, skip = 37, sep = ",")

stanfit <- read_stan_csv(file)
check_div(stanfit)

pars = c("tau", "caux", "lambda[1816]", "lambda[2586]")
parms <- rstan::extract(stanfit, pars = pars)

benchmark <- c(mean(log(parms$tau)),
               mean(log(parms$caux)),
               mean(log(parms$`lambda[1816]`)),
               mean(log(parms$`lambda[2586]`))
               )

write.csv(benchmark, file = "deliv_cmdstan/mean.csv")

print(get_elapsed_time(stanfit))

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

# Get the log mean
# read in benchmark csv output
modelName <- "bernoulli_logit_glm_rhs"
seed <- "12345"
nChain <- 8

pars <- c("tau", "caux")
pars_lambda <- c("lambda[2586]", "lambda[1816]", "lambda[4960]",
                 "lambda[4238]", "lambda[4843]", "lambda[3381]", "lambda[4647]")

pars_f <- c("f[1]", "f[2]", "f[99]", "f[100]")

n_iter <- 12000
n_parm <- length(pars_lambda)
samples_lambda <- array(NA, c(n_iter, n_parm, nChain))

for (i in 2:nChain) {  # should be 1:nChain
  chain_output <- read_stan_csv(file.path("deliv_cmdstan",
                    paste0(modelName, ".", seed, ".", i, ".csv")))

  # compute the mean of the log parameters
  chain_samples <- rstan::extract(chain_output, pars = pars)
  mean_log_sample <-
    lapply(chain_samples, mean_log <- function(x) { mean(log(x)) })

  chain_samples_lambda <- rstan::extract(chain_output, pars = pars_lambda)
  mean_log_sample_lambda <-
    lapply(chain_samples_lambda, mean_log <- function(x) { mean(log(x))} )

  # store all samples for quantile estimation
  samples_lambda[, , i] <- rstan::extract(chain_output, pars = pars_lambda,
                                          permuted = F)

  # compute the 90th quantile for the lambda parameters
  # NOTE - we cannot average estimates of the quantiles!!
  # quantile.90 <-
  #   lapply(chain_samples_lambda, quant <- function(x)
  #     { quantile(log(x), probs = 0.9) })

  # compute the probability log(lambda) is above a certain threshold.
  threshold <- 2.5
  prob_threshold <- function(x, threshold) {
    sum(x > threshold) / length(x)
  }

  prob <- lapply(chain_samples_lambda, prob <- function(x) {
    prob_threshold(x, threshold) } )

  # get the mean for the parameters (i.e. no log scale)
  chain_samples_f <- rstan::extract(chain_output, pars = pars_f)
  mean_logit <-
    lapply(chain_samples_f, mean_bernoulli <- function(x)
      { mean(inv.logit(x)) })

  write.csv(c(mean_log_sample, mean_log_sample_lambda, mean_logit),
            file = paste0("deliv_cmdstan/", modelName, ".logmean.",
                          i, ".csv"))

  write.csv(prob, file = paste0("deliv_cmdstan/", modelName, ".prob",
                                i, ".csv"))

  # write.csv(quantile.90, file = paste0("deliv_cmdstan/", modelName,
  #                                      ".90quantile", i, ".csv"))

  print(paste0(i, " / ", nChain))
}

# compute the quantiles using samples from all 8 chains
samples_lambda_all <- samples_lambda[, , 1]
for (i in 2:nChain) samples_lambda_all <- rbind(samples_lambda_all,
                                                samples_lambda[, , i])

n_pars <- length(pars_lambda)
quantiles_90 <- rep(NA, n_pars)
for (i in 1:n_pars) {
  quantiles_90[i] <- quantile(log(samples_lambda_all[, i]), probs = 0.9)
}

write.csv(quantiles_90, file = paste0("deliv_cmdstan/", modelName,
                                      ".90quantile.csv"))


#' mcell_gene_stat
#'
#' @param mat_id
#'
#' @export

mcell_add_gene_stat = function(mat_id, gstat_id, force=F)
{
	if(!scdb_is_valid()) {
		stop("MCERR - scdb is not initialized, cannot import")
	}
	if(!force & !is.null(scdb_gstat(gstat_id))) {
		return(TRUE)
	}
	if(is.null(scdb_mat(mat_id))) {
		stop("cannot gen gstat for non existing mat ", mat_id)
	}
	downsample_n = scm_which_downsamp_n(scdb_mat(mat_id))
	gstat = scm_gene_stat(mat_id,
								 downsample_n = downsample_n)
	scdb_add_gstat(gstat_id, gstat)
}

#' Calculate basic statistics on a matrix
#'
#' @param mat The input matrix
#' @param niche_quantile A value between 0 and 1.
#'
#' @return Returns a dataset that contains statistic for all genes that passed the filtering stage.
#' Columns starting with ds contain UMI statistics after downsampling,
#' columns starting with n contain UMI statistics after normalizing UMIs so that the number of UMIs
#' per cell sums to 1.
#'
#' The columns are:
#'
#' \describe{
#'   \item{tot}{Total gene expression}
#'   \item{var}{Gene variance}
#'   \item{is_on_count}{Number of cells in which the gene is expressed}
#'   \item{sz_cor}{Correlation with cell size}
#'   \item{sz_cor_norm}{sz_cor after subtracting the trend}
#'   \item{niche_stat}{How many of the genen's umis are found in X\% of the most highly expressing cells. (regularized) }
#'   \item{niche_norm}{niche_stat after subtracting the niche_norm trend: median niche_norm value of genes with similar total expression}
#'   \item{n_mean}{Mean after normalization}
#'   \item{ds_top1}{Largest count, after downsampling}
#'   \item{ds_top2}{2nd largest count, after downsampling}
#'   \item{ds_top3}{3rd largest count, after downsampling}
#'   \item{ds_mean}{Mean on downsampled data}
#'   \item{ds_var}{Variance on downsampled data}
#'   \item{ds_log_varmean}{log2 of ds_var/ds_mean }
#'   \item{ds_vm_norm}{ds_log_varmean after subtracting the trend}
#'   \item{ds_is_on_count}{Number of cells in which the gene is expressed, after down sampling}
#'   \item{downsample_n}{Number of UMIs used for downsampling}
#'
#' }
# #'   \item{max_pk
# #' max_ratio
# #' var_meanpk
# #' ds_var_meanpk
#'
#'
#' @export
#'
scm_gene_stat = function(mat_id,
                         niche_quantile = 0.2, #TODO: change to 0.1?
								 downsample_n = NULL,
								 K_std_n = 1000)
{
  old_seed = .set_seed(get_param("mc_rseed"))

#currently converting to non-sparse. Let's see if this need to be optimized
  scmat = scdb_mat(mat_id)
  mat =scmat@mat
  cat("Calculating gene statistics... ")

  if (niche_quantile >1 | niche_quantile < 0 ) {
    stop("niche_quantile must be between 0 and 1, got ", niche_quantile)
  }

  # filtering cells with too many or too few umis
	f_oversize = colSums(mat) > quantile(colSums(mat), 0.95) * 2 |
							colSums(mat) < 100

	# returns how many of the gene's umis are found in
	# X% of the most highly expressing cells. (regularized)
	quant_mean = function(x, k_reg) {
		n = length(x);
		up=sum(tail(sort(x), n=round(n*niche_quantile))); # sum umis in the top 20%
		return((k_reg+up)/(k_reg+sum(x)));
	}
	N = sum(!f_oversize)

	f_g = rowSums(mat) > 10

	downsample_n = scm_which_downsamp_n(scmat)

	message("will downsamp")
	mat_ds = scm_downsamp(mat, downsample_n)
	message("done downsamp")
	mat_ds = mat_ds[f_g,]
	mat_fg = mat[f_g,]

	message("will gen mat_n")
	mat_n = rescale_sparse_mat_cols(mat_fg, K_std_n/colSums(mat))
#	mat_n = t(t(mat_fg)*(K_std_n/colSums(mat)))
	message("done gen mat_n")

	n_ds = ncol(mat_ds)
	n = ncol(mat)
	stat_on_genes = function(i) {
		g_i = (1+(i-1)*quant):(min(nrow(mat_fg),i*quant))
		mat_gi = as.matrix(mat_fg[g_i,])
		mat_ds_gi = as.matrix(mat_ds[g_i,])
		gstat = data.frame(stringsAsFactors = F,
	   	name = rownames(mat_gi),
			tot = rowSums(mat_gi),
			var = round(matrixStats::rowVars(mat_gi),7),
			niche_stat =
		  		apply(mat_gi, 1, quant_mean, k_reg = 10),
			n_mean = round(matrixStats::rowMeans2(as.matrix(mat_n[g_i,])),7),
			ds_top1 = matrixStats::rowMaxs(mat_ds_gi) ,
			ds_top2 = matrixStats::rowOrderStats(mat_ds_gi, which = n_ds-1) ,
			ds_top3 = matrixStats::rowOrderStats(mat_ds_gi, which = n_ds-2) ,
			is_on_count = matrixStats::rowCounts(mat_ds_gi > 0),
			ds_is_on_count = matrixStats::rowCounts(mat_ds_gi > 0),
			ds_var = round(matrixStats::rowVars(mat_ds_gi),7),
			ds_mean = round(matrixStats::rowMeans2(mat_ds_gi),7))
		return(gstat)
	}
	max_bin = get_param("mc_cores")
	doMC::registerDoMC(max_bin)
	quant = ceiling(nrow(mat_fg)/max_bin)

	res <- plyr::alply(1:max_bin, 1, stat_on_genes, .parallel=TRUE)
	gene_stat = do.call(rbind, res)
	message("done computing basic gstat, will compute trends")

	if(ncol(mat) > 50000) {
		subs = sample(1:ncol(mat),50000)
		ctot = colSums(mat[,subs])
		gene_stat$sz_cor = round(apply(mat_fg[,subs], 1, function(x) { cor(x, ctot) }),3)

	} else {
		ctot = colSums(mat)
		gene_stat$sz_cor = round(apply(mat_fg, 1, function(x) { cor(x, ctot) }),3)
	}

	tot_ord = order(gene_stat$tot)
	cor_sz_ord = gene_stat$sz_cor[tot_ord]
	cmin = median(cor_sz_ord[1:101])
	cmax = median(cor_sz_ord[(length(cor_sz_ord)-101):length(cor_sz_ord)])
	sz_cor_trend = zoo::rollmedian(cor_sz_ord, 101, fill=c(cmin, NA, cmax))

	gene_stat$sz_cor_norm[tot_ord] =
		gene_stat$sz_cor[tot_ord] - sz_cor_trend

	# niche_stat =  how many of the genen's umis are found in
	# 20% of the most highly expressing cells. (regularized)
	niche_sz_ord = gene_stat$niche_stat[tot_ord]
	cmin = median(niche_sz_ord[1:101])
	cmax = median(niche_sz_ord[(length(niche_sz_ord)-101):length(niche_sz_ord)])
	niche_trend = zoo::rollmedian(niche_sz_ord, 101, fill=c(cmin, NA, cmax))

	gene_stat$niche_norm[tot_ord] =
		gene_stat$niche_stat[tot_ord] - niche_trend

	# var/mean
	ds_ord = order(gene_stat$ds_mean)

#	gene_stat$ds_log_varmean = ifelse(gene_stat$ds_mean>0.01, log2((0.001+gene_stat$ds_var)/(gene_stat$ds_mean+0.001)), 0)
	m_reg = 10/N
	gene_stat$ds_log_varmean = log2((m_reg+gene_stat$ds_var)/(m_reg+gene_stat$ds_mean))
	vm_sz_ord = gene_stat$ds_log_varmean[ds_ord]
	cmin = median(vm_sz_ord[1:101])
	cmax = median(vm_sz_ord[(length(vm_sz_ord)-101):length(vm_sz_ord)])
	vm_trend = zoo::rollmedian(vm_sz_ord, 101, fill=c(cmin, NA, cmax))

	gene_stat$ds_vm_norm[ds_ord] =
		gene_stat$ds_log_varmean[ds_ord] - vm_trend

	gene_stat$downsample_n = downsample_n

	# currently not used
	# gene_stat$max_ratio = gene_stat$max_pk/gene_stat$mean_pk
	# gene_stat$var_meanpk = gene_stat$var/gene_stat$mean_pk
	# gene_stat$ds_var_meanpk = gene_stat$ds_var/gene_stat$mean_pk

	rownames(gene_stat) = gene_stat$name

	gene_stat = gene_stat[,c("name","tot","var","is_on_count", "sz_cor","sz_cor_norm",
	                      "niche_stat",  "niche_norm", "n_mean",
	                      "ds_top1", "ds_top2", "ds_top3",
	                      "ds_mean", "ds_var", "ds_log_varmean","ds_vm_norm", "ds_is_on_count", "downsample_n")]

	.restore_seed(old_seed)
	cat("..done\n")

	return(gene_stat)
}


# check Levenshtein's Distance (e.g., misspellings) there can be NO duplicates in the column to be evaluated
# Watch for: Ornithodoros vunkeri; Ornithodoros yukeri; Ornithodoros yunkeri
library(stringdist)
temp <- c()
similar_names <-c()
compared_names <- c()
cutoff_distance <- 2
df2 <- c()
io <- FALSE
for(i in 1:length(df$canonicalName)){
  if(!(df$canonicalName[i] %in% similar_names)){ # testing
    for(j in 1:length(df$canonicalName)){
      score <- stringdist(df$canonicalName[i], df$canonicalName[j], "dl")
      temp <- c(temp, score)
    }
    if(any(temp %in% c(1:cutoff_distance))){
      if(io){
        df2 <- cbind(df2, temp)
        wc = wc + 1
      } else {
        df2 <- as.data.frame(temp)
        rownames(df2) <- df$canonicalName
        io <- TRUE
        wc <- 1
      }
      colnames(df2)[which(colnames(df2) == "temp")] <- df$canonicalName[i]
      similar <- rownames(df2)[which(df2[,wc]==min(df2[,wc][which(df2[,wc]>0)]))]
      comp_name <- rep(df$canonicalName[i], length(similar))
      similar_names <- c(similar_names, similar)
      compared_names <- c(compared_names, comp_name)
    }
    temp <- c()
  }
  if(i %% 10 == 0){
    print(paste('Completed iteration:', i, 'out of', length(df$canonicalName), 'iterations (', round(i/length(df$canonicalName),2)*100,'% DONE)'))
  }
}
print('FINISHED!')
check_mat <- as.data.frame(cbind(compared_names, similar_names)) # create matched names data frame