source("black_scholes.r")

run_simulation <- function(process, strikes, Texp, S0, payoff_maker, plot_title=NA, num_paths_to_plot=FALSE, solver='newton', return_ivols=TRUE){
    # Runs a Monte Carlo simulation using Euler method to calculate the implied volatility smile.
    #
    # Args:
    #     process (function instance): An instance of one of the simulation functions.
    #     strikes (array-like): Array of strikes used to price the call.
    #     Texp (numeric): Time, in years, to simulate process.
    #     S0 (numeric): Initial value for the estimator process, X. Used for the implied vol calculation.
    #     payoff_maker (function): A function returning the 'g' functions to apply to to the final process values.
    #     plot_title (Optional[string]): Title for implied volatility plot. Defaults to NA (no plot).
    #     num_paths_to_plot (Optional[integer or logical]): How many paths should be plotted. Defaults to FALSE (no plot). If TRUE, defaults to 100.
    #     solver (Optional[string]): What root finding method to use for calculating the implied volatility. Can be newton, bisection,
    #         or uniroot. Defaults to newton.
    #     return_ivols (Optional[boolean]): If TRUE, calculate and return the implied volatilities.
    #         Otherwise, don't calculate the implied volatility and just return the price. Defaults to TRUE.
    # Returns:
    #     (vector): A vector of the prices or implied volatilities for a range of strikes.

    # Time the function
    start_time <- Sys.time()

    # Simulate the process using Euler scheme and calculate the implied volatility for a range of strikes. Save the results to a dataframe.
    prices <- process$run_monte_carlo(function(K) payoff_maker(K), strikes, num_paths_to_plot)

    # Print the elapsed time
    cat('\n\nTime Elapsed:', Sys.time()-start_time, '\n\n')

    df <- data.frame(K=strikes, Price=prices)

    # If we don't want to calculate the implied volatility, just print and return the prices.
    if (!return_ivols){
        print(df)
        if (!is.na(plot_title)) plot(strikes, prices, main=plot_title, xlab='K', ylab='Price', type='l', col='blue', las=1)
        return(prices)
    }

    # Otherwise, calculate the implied volatility, add it to the dataframe, and print the prices and implied volatilities
    implied_vols <- tryCatch(calculate_smile(S0, Texp, 0, 0, strikes, prices, plot_smile=!is.na(plot_title), plot_title=plot_title, solver=solver), error=function(e) {print(e); NA})
    df['Implied.Vol'] <- implied_vols
    print(df)

    return(implied_vols)
}


#------------------------------
# library
#------------------------------

library(data.table)
library(magrittr)

#------------------------------
# function
#------------------------------

max_without_na <- function(vec){
	if(all(is.na(vec))) return(0)
	max(vec, na.rm=TRUE)
}

min_without_na <- function(vec){
	if(all(is.na(vec))) return(0)
	min(vec, na.rm=TRUE)
}

duration <- function(vec){
	ma <- max_without_na(vec)
	mi <- min_without_na(vec)
	return(ma - mi)
}

date_features <- function(df){
	data.frame(
		Id = df$Id,
		date_mean	= rowMeans(df[,-1], na.rm=TRUE),
		date_max	= apply(df[,-1], 1, max_without_na),
		date_min	= apply(df[,-1], 1, min_without_na),
		date_dur	= apply(df[,-1], 1, duration),
		date_numna	= apply(df[,-1], 1, . %>% is.na %>% sum)
	)
}

#------------------------------
# main
#------------------------------

data_dir <- file.path("..", "..", "dataset")
input_dir <- file.path("..", "..", "input")

tic <- proc.time()

# load train date
cat("==> Load train date\n")
fread(file.path(data_dir, "train_date.csv"), data.table=FALSE) %>%
	date_features %>%
	fwrite(file.path(input_dir, "train_date_features.csv"), quote=FALSE, sep=",")

# load test date
cat("==> Load test date\n")
fread(file.path(data_dir, "test_date.csv"), data.table=FALSE) %>%
	date_features %>%
	fwrite(file.path(input_dir, "test_date_features.csv"), quote=FALSE, sep=",")

# display computational time
cat("==> Display computational time\n")
calc <- proc.time() - tic
print(calc)


count <- 0
for i in(1:1000){
        if (i%%3==0||i%%5==0) {
          count = count + i
        }
}
print(count)


#user.degree <- read.table("~/Documents/darshan-trace/2013-csr-db/user-degree.txt", quote="\"")
#job.degree <- read.table("~/Documents/darshan-trace/2013-csr-db/job-degree.txt", quote="\"")
#process.degree <- read.table("~/Documents/darshan-trace/2013-csr-db/process-degree", quote="\"")
file.degree <- read.table("~/Documents/darshan-trace/2013-csr-db/file-degree", quote="\"")

pdf(file="/Users/daidong/Documents/gitrepos/triton-private/papers/meta-graph/exps/fdegree.pdf",height=5, width=8,bg="white")
x = file.degree$V1
y = file.degree$V2

s = sum(y)
x2=seq(1, max(x), by=8)
y2=s*x2^(-4)
y3=s*x2^(-2)
y4=s*x2^(-1.2)

plot(log10(x2), log10(y2), type="l", col=2, lwd=3, yaxt="n", xaxt="n", bty="n", xlab="",ylab="", cex = .7,
	xlim=c(0, 7), ylim=c(0, 8))
par(new=TRUE)
plot(log10(x2), log10(y3), type="l", col=3, lwd=3, yaxt="n", xaxt="n", bty="n", xlab="",ylab="", cex = .7,
	xlim=c(0, 7), ylim=c(0, 8))
par(new=TRUE)
plot(log10(x2), log10(y4), type="l", col=4, lwd=3, yaxt="n", xaxt="n", bty="n", xlab="",ylab="", cex = .7,
	xlim=c(0, 7), ylim=c(0, 8))
par(new=TRUE)

plot(log10(x), log10(y), xaxt="n", yaxt="n", xlab="Degree", ylab="Number of Vertices", xlim=c(0, 7), ylim=c(0, 8))

ticks=seq(0, 7, by=1);
labels <- sapply(ticks, function(i) as.expression(bquote(10^ .(i))))
axis(1, at=c(0,1,2,3,4,5,6,7), labels=labels)

ticks=seq(0, 8, by=1);
labels <- sapply(ticks, function(i) as.expression(bquote(10^ .(i))))
axis(2, at=c(0,1,2,3,4,5,6,7,8), labels=labels, las=1)

legend("topright", legend = c(expression(paste(alpha, " = 4")),
	expression(paste(alpha, " = 2")),
	expression(paste(alpha, " = 1"))),
	lty=c(1,1,1),
	col=2:4,
	cex=1.5)

invisible(dev.off())


suppressPackageStartupMessages(library(tidyverse))
suppressPackageStartupMessages(library(caret))
suppressPackageStartupMessages(library(crayon))
library(fastDummies)
library(argparse)
library(keras)

df <- read.csv('../../data/ml/ml_data.csv')

## Custom Colors for cmd line features
red 		<- make_style("red1")
orange 		<- make_style("orange")
yellow 		<- make_style("gold2")
green 		<- make_style("lawngreen")
cloudblue 	<- make_style("lightskyblue")

index <- createDataPartition(df$condition, p=0.8, list=FALSE)

df.train     <- df[index, ]
df.test      <- df[-index, ]

X_train <- df.train[, 2:4] %>%
    select(-condition) %>%
    scale()
Y_train <- to_categorical(df.train$condition)
print(ncol(X_train))
X_test <- df.test[, 2:4] %>%
    select(-condition) %>%
    scale()
Y_test <- to_categorical(df.test$condition)
model <- keras_model_sequential()
model %>%
        layer_dense(units = 16, activation = "relu", input_shape = ncol(X_train)) %>%
        layer_dropout(rate = 0.8) %>%
        layer_dense(units = 16, activation = "relu") %>%
        layer_dropout(rate = 0.6) %>%
        layer_dense(units = 16, activation = "relu") %>%
        layer_dropout(rate = 0.6) %>%
        layer_dense(units = 16, activation = "relu") %>%
        layer_dropout(rate = 0.6) %>%
        layer_dense(units = 16, activation = "relu") %>%
        layer_dropout(rate = 0.6) %>%
        layer_dense(units = 16, activation = "relu") %>%
        layer_dropout(rate = 0.3) %>%
        layer_dense(units = 3, activation = 'sigmoid')
print(model)
history <- model %>% compile(
        loss = 'categorical_crossentropy',
        optimizer = "adam",
        metrics = c('accuracy'),
    )
fitter <- model %>% fit(
        X_train, Y_train,
        epochs = 100,
        batch_size = 5,
        verbose=1,
        validation_split = 0.2,
        callbacks = callback_tensorboard(log_dir = paste("./model/logs_",  "test", "/run_", "a", sep=""))
)
score <- model %>% evaluate(X_test, Y_test)

# pdf(paste("./output/testrun_", loc, "_", run_indx, ".pdf", sep=""))
# print(plot(fitter))

date <- list(df.test[, 1]); predictions <- model %>% predict_classes(X_test)
pred_bool <- list()
for(a in 1:length(predictions)){
    if(predictions[a] == df.test$condition[a]){
        pred_bool <- append(pred_bool, TRUE)
    }else{
        pred_bool <- append(pred_bool, FALSE)
    }
}
data <- data.frame(list(x=date, y=predictions, y1=df.test$condition, y2=unlist(pred_bool)))
colnames(data) <- c("date", "predicted", "truth", "bool")
#conf_mat <- table(factor(predictions, levels=min(df.test$condition):max(df.test$condition)), factor(df.test$condition, levels=min(df.test$condition):max(df.test$condition)))
#write.csv(data, paste("./output/predict_", loc, "_", run_indx, ".txt", sep=""))

cat(bold(cloudblue(paste(rep("---", 10, collapse="")))), "\n")
cat(bold(cloudblue("\t\t Results \n")))
cat(bold(cloudblue(paste(rep("---", 10, collapse="")))), "\n")
if(score$loss < 0.5){
    cat(green(bold('Testing Loss:\t\t', round(score$loss, 3), "\n")))
}else{
    cat(red(bold('Testing Loss:\t\t', round(score$loss, 3), "\n")))
}
if(score$acc > 0.5){
    cat(green(bold('Testing Accuracy:\t', round(score$acc*100, 1), "%\n")))
}else{
    cat(red(bold('Testing Accuracy:\t', round(score$acc*100, 1), "%\n")))
}


library("e1071")
source("../utils.r")
data = read.table('data.txt', header=FALSE)
sink(file = 'results.txt')
samples = list()
samples$X = data[,2:ncol(data)]
samples$Y = data[,1]
reduction = reducePCA(samples$X)
samples$X = reduction$x
# linear
logMessage('Linear')
r = run.experiment(samples, c(1), c(0), c(10,100), 1, "linear")
a = gb.analyze(r$n, r$nu, r$radius, r$rho)
print(a$gb)
print(a$n)
# polynomial
logMessage('Polynomial')
r = run.experiment(samples, c(1,2,3), c(0,1), c(10,100), 1, "polynomial")
a = gb.analyze(r$n, r$nu, r$radius, r$rho)
print(a$gb)
print(a$n)
# gaussian
logMessage('Gaussian')
r = run.experiment(samples, c(1), c(0), c(10,100), 1, "radial")
a = gb.analyze(r$n, r$nu, r$radius, r$rho)
print(a$gb)
print(a$n)
sink()


library(keras)
library(mlbench)

data("BostonHousing")

var.x <- c('crim','zn','indus','nox','rm','age','dis','rad','tax','ptratio','b','lstat')
var.y <- c('medv')
x <- as.matrix(BostonHousing[, var.x])
y <- as.matrix(BostonHousing[, var.y])

model <- keras_model_sequential()
model %>%
  layer_dense(units = 48, activation = 'relu', input_shape = c(12)) %>%
  #layer_dropout(rate = 0.8) %>%
  layer_dense(units = 24, activation = 'relu') %>%
  #layer_dropout(rate = 0.9) %>%
  layer_dense(units = 12, activation = 'relu') %>%
  #layer_dropout(rate = 0.9) %>%
  layer_dense(units = 6, activation = 'relu') %>%
  layer_dense(units = 1)

summary(model)

model %>% compile(
  loss = 'mse',
  optimizer = optimizer_adam(lr = .0001)
)

history <- model %>% fit(
  x, y,
  epochs = 400, batch_size = 64,
  validation_split = 0.3
)
plot(history)


##set working directory
setwd("~/OneDrive - Missouri State University/TEACHING/527 Adv Statistics/2017 - Blend/1 notes/13 MLM")

#import the data
example = read.csv("mlm_example3.csv")

####data screening####
##if your data are in wide format, data screen this way first
##accuracy
summary(example)

##missing data
summary(example)

##outliers
mahal = mahalanobis(example[ , -c(1,2)],
                    colMeans(example[ , -c(1,2)], na.rm = TRUE),
                    cov(example[ , -c(1,2)], use = "pairwise.complete.obs"))
cutoff = qchisq(1-.001, ncol(example[ , -c(1,2)]))
ncol(example[ , -c(1,2)]) ##df
cutoff ##cutoff
summary(mahal < cutoff)
noout = example[mahal < cutoff , ]
summary(noout)

##multicollinearity/additivity
correlation = cor(noout[ , -c(1,2)], use = "pairwise.complete.obs")
symnum(correlation)
correlation

##assumptions
random = rchisq(nrow(example), 7)
fake = lm(random ~ ., data = example[ , -c(1,2)])
fitted = scale(fake$fitted.values)
standardized = rstudent(fake)

##linearity
qqnorm(standardized)
abline(0,1)

##normality
hist(standardized)

##homog / homos
plot(fitted, standardized)
abline(0,0)
abline(v=0)

##run the analysis

##set up the analysis
library(nlme)

#####intercept only model####
##gls = generalized least squares
##ML = maximum likelihood
model1 = gls(latency ~ 1,
             data = noout,
             method = "ML",
             na.action = "na.omit")
summary(model1)

####random intercept only model####
##note we switched to LME function
model2 = lme(latency ~ 1,
             data = noout,
             method = "ML",
             na.action = "na.omit",
             random = ~1|partno)
summary(model2)
anova(model1, model2)

####second level####
model2.1 = lme(latency ~ 1,
             data = noout,
             method = "ML",
             na.action = "na.omit",
             random = list(~1|partno, ~1|trialcode))
summary(model2.1)
anova(model1, model2, model2.1)

####predictor model####
model3 = lme(latency ~ response,
             data = noout,
             method = "ML",
             na.action = "na.omit",
             random = ~1|partno)
summary(model3)
anova(model1, model2, model3)

####random slopes####
model4 = lme(latency ~ response,
             data = noout,
             method = "ML",
             na.action = "na.omit",
             random = ~ response|partno,
             control = lmeControl(msMaxIter = 200))
summary(model4)
anova(model1, model2, model3, model4)

####assumptions from mlm####
screen = lme(latency ~ response,
             data = noout,
             method = "ML",
             na.action = "na.omit",
             random = ~ response|partno,
             control = lmeControl(msMaxIter = 200))

standardized = as.data.frame(scale(screen$residuals))
standardized = standardized$fixed
fitted = scale(fitted.values(screen))

##Linearity
qqnorm(standardized)
abline(0,1)

##normality
hist(standardized)

##homog and s
plot(fitted,standardized)
abline(0,0)
abline(v=0)


# Script about parental age influence
library(RColorBrewer)

# Import and format data:
data_mut <- read.csv("mutation_rate.txt", sep =" ", header=FALSE) # mutation_rate.txt is obtained during the detection of de novo mutation
age_father=read.csv("male_age.txt", sep =" ", header=FALSE) # one column with father age
age_mother=read.csv("female_age.txt", sep =" ", header=FALSE) # one column with mother age
fa=read.csv("father.txt", sep =" ", header=FALSE) # one column with father ID
mo=read.csv("mother.txt", sep =" ", header=FALSE) # one column with mother age
data=cbind(data_mut[,1:2],age_father, age_mother, fa, mo)

# Parental correlation on mutation rate ######
# Simple correlation:

# Linear model for both age
fit <- lm(data[,2] ~ data[,3] + data[,4], data=data)
summary(fit)

# Predict mu with this model
mu_list=vector()
for(i in seq(1,nrow(data))){
    mu = 1.355e-09+(4.588e-10*data[i,3])+(7.936e-11*data[i,4])
    mu_list=c(mu_list, mu)
}
cor.test(mu_list, data[,2], method="pearson")

fit <- lm(data[,2] ~ mu_list)
summary(fit) # show results

png("model.png", width = 1300, height = 850)
par(mar=c(10,15,4,2), mgp=c(3, 3, 0))
plot(mu_list, data[,2], pch=19, xlab="", ylab="", xlim=c(4e-9,1.2e-8), ylim=c(4e-9,1.2e-8),cex=3, cex.lab=2.5, cex.axis=2.5, xaxt="n", yaxt="n")
axis(1, at=c(4.0e-09, 5.0e-09, 6.0e-09, 7.0e-09, 8.0e-09, 9.0e-09, 1.0e-08, 1.1e-08, 1.2e-08),label=c("0.4","0.5","0.6", "0.7", "0.8","0.9","1.0","1.1","1.2"), cex.axis=4)
axis(2, at=c(4.0e-09, 5.0e-09, 6.0e-09, 7.0e-09, 8.0e-09, 9.0e-09, 1.0e-08, 1.1e-08, 1.2e-08),label=c("0.4","0.5","0.6", "0.7", "0.8","0.9","1.0","1.1","1.2"),cex.axis=4, las=2)
mtext(expression("Expected mutation rate x 10"^-8), 1, line=8, cex=3.5)
mtext(expression("Observed mutation rate x 10"^-8), 2, line=9, cex=3.5)
abline(3.765e-13,1.000e+00, lty=2, lwd=3, col="grey40")
text(c(1.15e-08,1.155e-08), c(0.9e-08, 0.95e-08), labels = c("r = 0.54", "p = 0.016"), font=2, cex=3.5)
text(1.00e-8, 1.18e-8, expression(paste(mu, " = 1.36e"^-9, "+ 7.94e"^-11, "× a"[mat], "+ 4.59e"^-10, "× a"[pat])), font=2, cex=2)
dev.off()

# Father correlation ##################################################

linearMod_father <- lm(data[,2] ~ data[,3], data=data)
summary(linearMod_father)
## confidence interval with predict
a <- data[,3]
m <- data[,2]
linearMod_father <- lm(m ~ a)
newx = seq(4,17,by = 0.5)
conf_interval <- predict(linearMod_father, newdata=data.frame(a=newx), interval="confidence",level = 0.95)

png("father_age_pred.png", width = 1300, height = 850)
par(mar=c(9,23,4,2), mgp=c(3, 3, 0))
plot(data[,3], data[,2], pch=19, xlab="", ylab="", xlim=c(3,16), cex=3, cex.lab=2.5, cex.axis=2.5, col="blue", xaxt="n", yaxt="n")
bluetrans <- rgb(204, 229, 255, 255, maxColorValue=255)
polygon(c(newx, rev(newx)), c(conf_interval[,2], rev(conf_interval[,3])),
     col = bluetrans, border = NA)
points(data[,3], data[,2], pch=19, cex=3, cex.lab=2.5, cex.axis=2.5, col="blue")
abline(1.022e-09, 5.393e-10, lwd=3, lty=2, col="darkblue")
axis(1, cex.axis=4)
axis(2, at=c(4.0e-09, 5.0e-09, 6.0e-09, 7.0e-09, 8.0e-09, 9.0e-09, 1.0e-08, 1.1e-08),label=c(expression("0.4 x 10"^-8), expression("0.5 x 10"^-8), expression("0.6 x 10"^-8), expression("0.7 x 10"^-8), expression("0.8 x 10"^-8), expression("0.9 x 10"^-8), expression("1.0 x 10"^-8), expression("1.1 x 10"^-8)),cex.axis=4, las=2)
mtext("Paternal age", 1, line=7, cex=4.5)
mtext("Mutation rate (per generation)", 2, line=20, cex=4.5)
text(c(4.1,4.6), c(1.12e-08, 1.06e-08), labels = c(expression(paste(R[adj]^2," = 0.23")), "p = 0.021"), font=2, cex=3.5)
dev.off()

# Mother effect #################################################
linearMod_mother <- lm(data[,2] ~ data[,4], data=data)
summary(linearMod_mother)
a <- data[,4]
m <- data[,2]
linearMod_mother <- lm(m ~ a)
newx = seq(3,17,by = 0.5)
conf_interval <- predict(linearMod_mother, newdata=data.frame(a=newx), interval="confidence",level = 0.95)

png("mother_age_pred.png", width = 1300, height = 850)
par(mar=c(9,23,4,2), mgp=c(3, 3, 0))
plot(data[,4], data[,2], pch=19, xlab="", ylab="", xlim=c(3,16), cex=3, cex.lab=2.5, cex.axis=2.5, col="red2", xaxt="n", yaxt="n")
pinktrans <- rgb(255, 190, 190, 255, maxColorValue=255)
polygon(c(newx, rev(newx)), c(conf_interval[,2], rev(conf_interval[,3])),
     col = pinktrans, border = NA)
points(data[,4], data[,2], pch=19, cex=3, cex.lab=2.5, cex.axis=2.5, col="red2")
abline(6.200e-09, 1.818e-10, lwd=3, lty=2, col="red3")
axis(1, cex.axis=4)
axis(2, at=c(4.0e-09, 5.0e-09, 6.0e-09, 7.0e-09, 8.0e-09, 9.0e-09, 1.0e-08, 1.1e-08),label=c(expression("0.4 x 10"^-8), expression("0.5 x 10"^-8), expression("0.6 x 10"^-8), expression("0.7 x 10"^-8), expression("0.8 x 10"^-8), expression("0.9 x 10"^-8), expression("1.0 x 10"^-8), expression("1.1 x 10"^-8)),cex.axis=4, las=2)
mtext("Maternal age", 1, line=7, cex=4.5)
mtext("Mutation rate (per generation)", 2, line=20, cex=4.5)
text(c(4.1,4.6), c(1.12e-08, 1.06e-08), labels = c(expression(paste(R[adj]^2," = 0.09")), "p = 0.111"), font=2, cex=3.5)
dev.off()

## Age parents and phasing ##########################################
poo <- read.csv("assigned_each.tab", sep ="\t") # obtained from the phasing script
poo_p_p <- poo$prop_paternal[-20]
poo_p_m <- poo$prop_maternal[-20]
poo_p <- poo$paternal[-20]
poo_m <- poo$maternal[-20]
poo_n_p <- poo$paternal[-20]/poo$tot_pat[-20]
poo_n_m <- poo$maternal[-20]/poo$tot_mat[-20]
poo_np_p <- (poo_n_p)/(poo_n_p+poo_n_m)
poo_np_m <- (poo_n_m)/(poo_n_p+poo_n_m)
poo_i_p <- round((poo$unassigned+poo$assigned)[-20]*poo_np_p)
poo_i_m <- round((poo$unassigned+poo$assigned)[-20]*poo_np_m)
##
data_p <- cbind(data, poo_p_p, poo_p_m)
colnames(data_p)<-c("name", "mut", "p_age", "m_age", "p", "m", "poo_p_p", "poo_p_m")
lim_inf=min(data_p$p_age, data_p$m_age)
lim_sup=max(data_p$p_age, data_p$m_age)
##

## MODEL on upscaled LINEAR
data_i <- cbind(data, poo_i_p, poo_i_m)
colnames(data_i)<-c("name", "mut", "p_age", "m_age", "p", "m", "poo_i_p", "poo_i_m")
lim_inf=min(data_p$p_age, data_p$m_age)
lim_sup=max(data_p$p_age, data_p$m_age)

reg_age_f <- lm(data_i$poo_i_p ~ data_i$p_age)
summary(reg_age_f)
reg_age_m <- lm(data_i$poo_i_m ~ data_i$m_age)
summary(reg_age_m)
cor.test(data_i$poo_i_p, data_i$p_age, method="pearson")
cor.test(data_i$poo_i_m, data_i$m_age, method="pearson")
confint(reg_age_f)
confint(reg_age_m)

## confidence interval
a1=data_i$p_age
m=data_i$poo_i_p
fit<- lm(m ~ a1)
new1 = seq(4,17,by = 1)
conf_interval <- predict(fit, newdata=data.frame(a1=new1), interval="confidence",level = 0.95)
a_f=new1
conf_f=conf_interval
#
a1=data_i$m_age
m=data_i$poo_i_m
fit<- lm(m ~ a1)
new1 = seq(3,17,by = 1)
conf_interval <- predict(fit, newdata=data.frame(a1=new1), interval="confidence",level = 0.95)
a_m=new1
conf_m=conf_interval

# Plot model
png("infer_given.png", width = 1300, height = 850)
par(mar=c(9,12,4,2), mgp=c(3, 3, 0))
plot(data_i$p_age, data_i$poo_i_p, col="blue", pch=19, ylim=c(0,40), xlim=c(0, lim_sup), xlab="", ylab="",cex=3, cex.lab=2.5, cex.axis=2.5, xaxt="n", yaxt="n")
bluetrans <- rgb(204, 229, 255, 255, maxColorValue=255)
polygon(c(a_f, rev(a_f)), c(conf_f[,2], rev(conf_f[,3])), col = bluetrans, border = NA)
pinktrans <- rgb(255, 190, 190, 255, maxColorValue=255)
polygon(c(a_m, rev(a_m)), c(conf_m[,2], rev(conf_m[,3])), col = pinktrans, border = NA)
points(data_i$p_age, data_i$poo_i_p, col="blue", pch=19,cex=3)
points(data_i$m_age, data_i$poo_i_m, col="red2", pch=19,cex=3)
segments(4, 4.8399 + (1.8364*4), 20, 4.8399 + (1.8364*20), lwd=3, lty=2, col="blue")
text(c(14.5,15), c(21.5, 18.5), labels = c(expression(paste(R[adj]^2," = 0.41")), "p = 0.002"), font=2, cex=3, col="blue")
segments(3, 4.6497+ (0.3042*3), 20, 4.6497+ (0.3042*20), lwd=3, lty=2, col="red2")
text(c(14.5,15), c(4.5, 1.5), labels = c(expression(paste(R[adj]^2," = -0.01")), "p = 0.38"), font=2, cex=3, col="red2")
arrows(3,20,3,4.6497+ (0.3042*3), lwd=2, lty=1, col="red2")
arrows(4,20,4,4.8399 + (1.8364*4), lwd=2, lty=1, col="blue")
text(3.5, 22, "Puberty", cex=3.5, font=2)
legend("topleft", legend=c("Maternal", "Paternal"), pch=c(19,19), col=c("red2", "blue"), text.font=2, cex=3.5, bty = "n")
axis(1, cex.axis=4)
axis(2, cex.axis=4, las=2)
mtext("Parental age", 1, line=7, cex=4)
mtext("Upscaled phased mutations", 2, line=8, cex=4)
dev.off()

## Test of the model
# Predict mu with this model
nb_list=vector()
for(i in seq(1,nrow(data))){
    nb = (4.8399 + 1.8364*data[i,3]) + (4.6497+ 0.3042*data[i,4])
    nb_list=c(nb_list, nb)
}
call <- read.csv("../../de_novo_mutation/callability.txt", sep =" ", header=FALSE)
callability=mean(call[,2])
fnr=0.04020232294960846
mu_infer=(nb_list*(1-0.10887096774193548))/(2*callability*(1-fnr))

cor.test(mu_infer, data[,2], method="pearson")
fit <- lm(data[,2] ~ mu_infer)
summary(fit) # show results

png("model_upscaled_mu.png", width = 1300, height = 850)
par(mar=c(10,15,4,2), mgp=c(3, 3, 0))
plot(mu_infer, data[,2], pch=19, xlab="", ylab="", xlim=c(4.0e-9,1.2e-8), ylim=c(4.0e-9,1.2e-8),cex=3, cex.lab=2.5, cex.axis=2.5, xaxt="n", yaxt="n")
axis(1, at=c(4.0e-09, 5.0e-09, 6.0e-09, 7.0e-09, 8.0e-09, 9.0e-09, 1.0e-08, 1.1e-08, 1.2e-08),label=c("0.4", "0.5", "0.6", "0.7", "0.8","0.9","1.0","1.1","1.2"), cex.axis=4)
axis(2, at=c(4.0e-09, 5.0e-09, 6.0e-09, 7.0e-09, 8.0e-09, 9.0e-09, 1.0e-08, 1.1e-08, 1.2e-08),label=c("0.4", "0.5", "0.6", "0.7", "0.8","0.9","1.0","1.1","1.2"),cex.axis=4, las=2)
mtext(expression("Expected mutation rate x 10"^-8), 1, line=8, cex=3.5)
mtext(expression("Observed mutation rate x 10"^-8), 2, line=9, cex=3.5)
abline(-1.064e-09, 1.277, lty=2, lwd=3, col="grey40")
text(c(1.15e-08,1.155e-08), c(1.0e-08, 1.05e-08), labels = c("r = 0.54", "p = 0.016"), font=2, cex=3.5)
text(0.77e-8, 1.165e-8, expression(paste(mu, " =")), font=2, cex=2)
segments(0.8e-8, 1.165e-8, 1.2e-8, 1.165e-8, lwd=2, lty=1)
text(1.0e-8, 1.19e-8, expression(paste("(4.65 + 0.30 × a"[mat], " + 4.84 + 1.84 × a"[pat],") x (1-0.089)")), font=2, cex=2)
text(1.0e-8, 1.14e-8, expression(paste("2 x 2351302179 x (1-0.0402)")), font=2, cex=2)
dev.off()

### Same with Poisson #################################
## MODEL on upscaled POISSON
data_i <- cbind(data, poo_i_p, poo_i_m)
colnames(data_i)<-c("name", "mut", "p_age", "m_age", "p", "m", "poo_i_p", "poo_i_m")
lim_inf=min(data_p$p_age, data_p$m_age)
lim_sup=max(data_p$p_age, data_p$m_age)

# Regression
reg_age_f <- glm(data_i$poo_i_p ~ data_i$p_age, family = poisson)
summary(reg_age_f)
##reg_age_f <- glm(data_i$poo_i_p ~ data_i$p_age*data_i$p, family = poisson)
reg_age_m <- glm(data_i$poo_i_m ~ data_i$m_age, family = poisson)
summary(reg_age_m)
##
a1=data_i$p_age
m=data_i$poo_i_p
fit<- glm(m ~ a1, family = poisson)
new1 = seq(4,17,by = 0.5)
conf_interval <- predict(fit, newdata=data.frame(a1=new1), interval="confidence", type="response", level = 0.95, se.fit = TRUE)
a_f=new1
conf_f=conf_interval$fit
uci_f=conf_interval$fit+1.96*conf_interval$se.fit
lci_f=conf_interval$fit-1.96*conf_interval$se.fit
#
# Female
a1=data_i$m_age
m=data_i$poo_i_m
fit<- glm(m ~ a1, family = poisson)
new1 = seq(3,17,by = 0.5)
conf_interval <- predict(fit, newdata=data.frame(a1=new1), interval="confidence", type="response", level = 0.95, se.fit = TRUE)
a_m=new1
conf_m=conf_interval$fit
uci_m=conf_interval$fit+1.96*conf_interval$se.fit
lci_m=conf_interval$fit-1.96*conf_interval$se.fit
#

##plot
png("infer_given_poisson.png", width = 1300, height = 850)
par(mar=c(9,12,4,2), mgp=c(3, 3, 0))
plot(data_i$p_age, data_i$poo_i_p, col="blue", pch=19, ylim=c(0,40), xlim=c(0, lim_sup), xlab="", ylab="",cex=3, cex.lab=2.5, cex.axis=2.5, xaxt="n", yaxt="n")
bluetrans <- rgb(204, 229, 255, 255, maxColorValue=255)
polygon(c(a_f, rev(a_f)), c(lci_f, rev(uci_f)),col = bluetrans, border = NA)
pinktrans <- rgb(255, 190, 190, 255, maxColorValue=255)
polygon(c(a_m, rev(a_m)), c(lci_m, rev(uci_m)),col = pinktrans, border = NA)
lines(a_f, conf_f, lwd=3, lty=2, col="blue")
lines(a_m, conf_m, lwd=3, lty=2, col="red2")
points(data_i$p_age, data_i$poo_i_p, col="blue", pch=19, cex=3)
points(data_i$m_age, data_i$poo_i_m, col="red2", pch=19, cex=3)
##text(c(9,6.2), c(39, 36), labels = c("nb = exp(2.14+0.089xage)", "p < 0.001"), font=2, cex=3, col="blue")
##text(c(13,10.8), c(6, 3), labels = c("nb = exp(1.35+0.067xage)", "p < 0.01"), font=2, cex=3, col="red2")
legend("topleft", legend=c("Maternal", "Paternal"), pch=c(19,19), col=c("red2", "blue"), text.font=2, cex=3.5, bty = "n")
axis(1, cex.axis=4)
axis(2, cex.axis=4, las=2)
mtext("Parental age", 1, line=7, cex=4)
mtext("Upscaled phased mutations", 2, line=8, cex=4)
dev.off()

### Box plot contribution ##################################################################
png("norm_prop_box.png", width = 1300, height = 850)
##png("norm_prop_box.png", width = 950, height = 850)
par(mar=c(9,17,4,2), mgp=c(3, 3, 0))
boxplot(poo_np_m, poo_np_p, ylim=c(0,1), names=c("",""), ylab="", cex=3, cex.lab=2.5, cex.axis=2.5, col=c("red2","blue"), yaxt="n")
axis(2, cex.axis=3.5, las=2)
mtext("Proportion of phased", 2, line=12, cex=4)
mtext(expression(italic(de~novo)~mutations), 2, line=9, cex=4)
axis(1, at=c(1,2), label=c("Maternal", "Paternal"), cex.axis=4)
dev.off()
#

# Stats
se=sd(poo_np_p)/sqrt(length(poo_np_p))
se
mean(poo_np_p)-(2.1*se)
mean(poo_np_p)+(2.1*se)

# t test ####################################################
t.test(poo_np_p,poo_np_m)


source('~/project/main.r')
library(tidyverse)  # data manipulation
library(cluster)    # clustering algorithms
library(factoextra) # clustering algorithms & visualization

raw_tmp <-arrange(filter(row_refine,車種=='B03'))

raw_tmp <- select(raw_tmp,當事者行動狀態意義,死,受傷)
raw_tmp <- raw_tmp %>% drop_na(當事者行動狀態意義)
raw_tmp$count <- 1
raw_tmp[is.na(raw_tmp)] <- 0
raw_tmp_summary <- (raw_tmp %>% group_by(當事者行動狀態意義) %>%
  summarise_all(sum)
)

raw_tmp_summary$死比率 <- raw_tmp_summary$死 / sum(raw_tmp_summary$死) * 100
raw_tmp_summary$受傷比率 <- raw_tmp_summary$受傷 / sum(raw_tmp_summary$受傷) * 100
raw_tmp_summary$意外比率 <- raw_tmp_summary$count / sum(raw_tmp_summary$count) * 100

raw_tmp_cluster <- select(raw_tmp_summary, 當事者行動狀態意義,受傷比率,意外比率)
raw_tmp_cluster[,1] <- NULL
row.names(raw_tmp_cluster) <- raw_tmp_summary$當事者行動狀態意義

#distance <- get_dist(raw_tmp_cluster)
#fviz_dist(distance, gradient = list(low = "#00AFBB", mid = "white", high = "#FC4E07"))

k2 <- kmeans(raw_tmp_cluster, centers = 3, nstart = 1)
fviz_cluster(k2, main=NULL, data = raw_tmp_cluster, font.family="WenQuanYi Micro Hei Mono")


#hierarchically aggregate multivariate composition data c/p/s using dirchlet.
#start 3 groups, 4 sites, plots w/in site, cores w/in plots.
#works ignoring plots within sites.
#Next add plots in between core and site level.
rm(list=ls())
library(runjags)

#1. generate pseudo data.----
#3 species relative abundances across 4 sites.
spp1 <- c(0.2,0.8,0.5,0.1)
spp2 <- c(0.3,0.1,0.4,0.1)
spp3 <- 1 - (spp1 + spp2)
y <- data.frame(spp1,spp2,spp3)
y <- as.matrix(y)
site_sd <- 0.02

#get some numbevr of pltos and cores within plots.
n.site <- nrow(y)
n.plot <- 15
n.core <- 10

#simulate from dirichlet distribution.
site.list <- list()
for(i in 1:n.site){
  plot.list <- list()
  for(j in 1:n.plot){
      cores <- DirichletReg::rdirichlet(n.core,y[i,])
      cores <- data.frame(cbind(rep(LETTERS[i],n.core),rep(LETTERS[j],n.core),LETTERS[1:n.core],cores))
      colnames(cores) <- c('siteID','plotID','coreID','spp1','spp2','spp3')
      plot.list[[j]] <- cores
  }
  site.list[[i]] <- do.call(rbind,plot.list)
}
dat <- do.call(rbind,site.list)
dat[,4:6] <- sapply(dat[4:6],as.character)
dat[,4:6] <- sapply(dat[4:6],as.numeric)
y <- dat[,4:6]

#core_plot, plot_site factors.
dat$plotID <- paste0(dat$siteID,'_',dat$plotID)
core_plot = dat$plotID
plot_site = dat[seq(1, nrow(dat), 3), ]$siteID

#2. specify JAGS model.----
jags.model = "
model {
#get plot level means.
for(i in 1:N.core){
  for(j in 1:N.spp){
    log(core.hat[i,j]) <- alpha + plot_mu[core_plot[i],j]
  }
  y[i,1:N.spp] ~ ddirch(core.hat[i,1:N.spp])
}

#get site level means.
for(i in 1:N.plot){
  for(j in 1:N.spp){
    #log(plot.hat[i,j]) <- alpha + site_mu[plot_site[i],j]
    log(plot.hat[i,j]) <- site_mu[plot_site[i],j]
  }
  plot_mu[i,1:N.spp] ~ ddirch(plot.hat[i,1:N.spp])
}

#prior
#for(i in 1:N.site){for(j in 1:N.spp){site_mu[i,j] ~ dnorm(0,1E-3)}}
alpha ~ dnorm(0, 1.0E-3)
for(i in 1:N.site){
  site_mu[i,1] <- 0
  for(j in 2:N.spp){
    site_mu[i,j] ~ dnorm(0,1E-3)
    }
}

#map to something useful.
#for(i in 1:N.site){
#  final_mu[i,1] <- alpha
#    for(j in 2:N.spp){
#      final_mu[i,j] <- site_mu[i,j] + alpha
#    }
#  }
}"

#3. Setup JAGS data object.----
jd <- list(y=as.matrix(y), N.site = n.site, N.core = nrow(y), N.plot = length(unique(dat$plotID)), N.spp = ncol(y),
           core_plot = as.factor(core_plot),
           plot_site = as.factor(plot_site))

#4. Run JAGS model.----
test <- run.jags(model = jags.model,
                 data = jd,
                 n.chains = 3,
                 monitor = c('site_mu'),
                 adapt = 200,
                 burnin = 2000,
                 sample = 1000)
out <- summary(test)
spp.sum <- matrix(out[,4], nrow = n.site, ncol = ncol(y))
spp.sum <- boot::inv.logit(spp.sum) / rowSums(boot::inv.logit(spp.sum))
spp.sum

testing_development/hierarchical means ddirch JAGS.r


# insert your working directory path here
Packages <- c("MuMIn", "snow", "data.table")
lapply(Packages, library, character.only = TRUE)

rm(list=ls())
rm(list = ls(all.names = TRUE))

x <- matrix(rnorm(20*10000), ncol=20)
y <- matrix(rnorm(1*10000), ncol=1)
data <- data.frame(y,x)

tmp <- system.time(
{
globalmodel <- lm(y ~ . ,data=data)
options(na.action = "na.fail")

clusterType <- if(length(find.package("snow", quiet = TRUE))) "SOCK" else "PSOCK"
clust <- try(makeCluster(getOption("cl.cores", 16), type = clusterType))
clusterExport(clust, "data")

pdredge <- pdredge(globalmodel, cluster = clust, rank= "AIC")
print(summary(get.models(pdredge, 1)[[1]]))
fwrite(pdredge, "pdredge20x10000x16.csv")
stopCluster(clust)
})

times <- t(data.matrix(tmp))
fwrite(times,"Rtimming.csv", append=TRUE)

quit(save="no")

# end


#Predicting profit based on the year
business_profits = data.frame(
    year = c(2011,2012,2013,2014,2015,2016,2017),
    profit = c(40,43,45,50,54,57,59)
)
model = lm(profit ~ year, data = business_profits)
print(model)


source("data_Poisson.r")

library(rstan)
rstan_options(auto_write = TRUE)
options(mc.cores = 4)

constant_data <- read.csv("../../data/constant_data/Poisson_logCA0_adaptive_J=20.csv")
maxA <- max(constant_data$a0)

#####################
####### Posterior using unnormalised power prior
#####################

compiled.model.unnorm.posterior <- stan_model("stan/simple_Poisson_unnormalised_posterior.stan")

po.data.forposterior <- list(
  N0 = N_0,
  y0 = y_0,
  alpha0 = alpha_0,
  beta0 = beta_0,
  eta = eta,
  nu = nu,
  N = N,
  y = y
)

unnorm.posterior.poisson <- sampling(compiled.model.unnorm.posterior, data = po.data.forposterior)
unnorm.posterior.poisson
pairs(unnorm.posterior.poisson, pars = c("a_0", "lambda"))

### The approximately normalised posterior

library(mgcv)
fit.gam <- mgcv::gam(lc_a0 ~ s(a0), data = constant_data)

approx.normalised.model <- stan_model("stan/simple_Poisson_posterior_normalised_approximate.stan")

Ks <- c(50, 100, 1000, 10000)

get_posterior_K <- function(K){
  pred_a0s <- seq(0, max(constant_data$a0), length.out = K)
  a0_grid <- data.frame(a0 = pred_a0s,
                        lc_pred = predict(fit.gam, newdata = data.frame(a0 = pred_a0s)))
  po.data.forposterior$pred_grid_x <- a0_grid$a0
  po.data.forposterior$pred_grid_y <- a0_grid$lc_pred
  approx.norm.posterior.poisson <- sampling(approx.normalised.model,
                                            data = po.data.forposterior, refresh = 0)
  return(approx.norm.posterior.poisson)
}

system.time(
  all.approximates <- lapply(Ks, get_posterior_K)
)

### Now the normalised posterior
compiled.model.norm.posterior <- stan_model("stan/simple_Poisson_normalised_posterior.stan")

norm.posterior.poisson <- sampling(compiled.model.norm.posterior, data = po.data.forposterior)
norm.posterior.poisson
pairs(norm.posterior.poisson, pars = c("a_0", "lambda"))

##### Analysis of p(a_0 | data)
a0.unnorm <- extract(unnorm.posterior.poisson, 'a_0')$a_0

a0.approx.list <- lapply(Ks, function(k){
  i <- match(k, Ks)
  a0 <- extract(all.approximates[[i]], 'a_0')$a_0
  return(data.frame(a0 = a0, normalisation = paste("K=", k, sep = "")))
} )

a0.norm <- extract(norm.posterior.poisson, 'a_0')$a_0

a0.dt <-
  rbind(
    data.frame(a0 = c(a0.unnorm, a0.norm),
               normalisation = c( rep("none", length(a0.unnorm)),
                                  rep("exact", length(a0.norm)) )
    ),
    do.call(rbind, a0.approx.list)
  )

a0.dt$normalisation <- factor(a0.dt$normalisation,
                                     levels = c("none", paste("K=", Ks, sep = ""), "exact") )

library(ggplot2)

a0_dist <- ggplot(a0.dt, aes(x = a0, fill = normalisation, colour = normalisation)) +
  geom_density() +
  stat_function(fun = function(x) dbeta(x, eta, nu),
                geom = "line", colour = "black", linetype = "longdash") +
  facet_grid(normalisation~., scales = "free") +
  scale_y_continuous("Density", expand = c(0, 0)) +
  scale_x_continuous(expression(a[0]), expand = c(0, 0)) +
  theme_bw(base_size = 20) +
  theme(legend.position = "bottom",
        legend.justification = "centre",
        legend.title = element_blank(),
        strip.background = element_blank(),
        strip.text.y = element_blank(),
        legend.margin = margin(0, 0, 0, 0),
        legend.box.margin = margin(0, 0, 0, 0))

a0_dist

ggsave("../../figures/a0_posterior_Poisson.pdf", a0_dist)
###

unnorm.lambda.dt <- data.frame(lambda = extract(unnorm.posterior.poisson, 'lambda')$lambda)
unnorm.lambda.dt$normalisation <- "none"

app.norm.pars.list <- lapply(seq_along(all.approximates), function(i) {
  x <- all.approximates[[i]]
  pars <- data.frame(
    lambda = extract(x, 'lambda')$lambda,
    normalisation = paste("K=", Ks[i], sep = "")
  )
  return(pars)
})

norm.lambda.dt <- data.frame(lambda = extract(norm.posterior.poisson, 'lambda')$lambda)
norm.lambda.dt$normalisation <- "exact"

posterior.dt <- rbind(unnorm.lambda.dt, norm.lambda.dt, do.call(rbind, app.norm.pars.list))
posterior.dt$normalisation <- factor(posterior.dt$normalisation,
                                     levels = c("none", paste("K=", Ks, sep = ""), "exact") )

lambda_posterior <- ggplot(data = posterior.dt, aes(x = lambda, colour = normalisation, fill = normalisation)) +
  geom_density(alpha = .4) +
  # stat_function(fun = function(x) dgamma(x, shape = a_0*sum(y_0) + alpha_0, rate = a_0*N_0 + beta_0),
  #               geom = "line", colour = "black", linetype = "solid") +
  scale_x_continuous(expression(lambda), expand = c(0, 0)) +
  scale_y_continuous("Density", expand = c(0, 0)) +
  geom_vline(xintercept = true.lambda, linetype = "dashed") +
  theme_bw(base_size = 20) +
  theme(legend.position = "bottom",
        legend.justification = "centre",
        legend.title = element_blank(),
        strip.background = element_blank(),
        strip.text.y = element_blank(),
        legend.margin = margin(0, 0, 0, 0),
        legend.box.margin = margin(0, 0, 0, 0))

lambda_posterior

ggsave("../../figures/parameter_posterior_Poisson.pdf", lambda_posterior, dpi = 400)


##############################################################################
# get_adj_matrix_from_gis

    # Edited by: G Oldford
    # purpose: produce an adjancy matrix
    # Last modified: August, 2020
    # Input: segment_matrix.csv with columns: "Seg_ID","Seg"
    # Output: adjacency_matrix.csv - binary matrix with 1's and 0's indicating
    #         segment neighbours
    #
    # Input example:
    # "Seg_ID","Seg"
    # "55152_s","55152_s"
    # "55152_s","sink"

    #
    # Output example:
    #  matrix object of
    #  0's and 1's indicating neighbours (directed?)
    #  (note, aug 2020: the CSV is not being used - see below)
    #
    # Notes from previous coding work:
    #The input is the segment matrix, which is really two vectors. For each
    #segment in the first column (Seg_ID), the second column (Seg) gives the id
    #of other sections it touches, including itself.

## Ali: take the "segment_matrix.csv" as the input to this function
# output file name is given
get_adj_matrix_from_gis<-function(inputname="segment_matrix.csv",
                                  outputname="adjacency_matrix.csv"){

    # segment_matrix=read.csv("segment_matrix.csv")
    segment_matrix <- read.csv(inputname)
    # obtain the segments in whatever order they are in the file
    segments<-with(segment_matrix, unique(Seg_ID))

    #create a matrix with only 0's in them
    adj_matrix<-matrix(nrow=length(segments),
                       ncol=length(segments),
                       rep(0,length(segments)*length(segments)))
    segment_length<-length(segments)
    rownames(adj_matrix)<-colnames(adj_matrix)<-segments

    for (i in 1:segment_length){
        # find the segments in segment.matrix$Seg where segment.matrix$Seg_ID matches segments[i]
        # index of matching positions - this will be a vector of 1's and NA's
        pos_match<-	match(segment_matrix$Seg_ID,segments[i])

        # keep only the positions where pos.match==1
        adj_segments<-segment_matrix$Seg[!is.na(pos_match)]

        # find the column positions that correspond to the adjacaent segments
        col<-match(adj_segments,segments)

        # the row number should correspond to i
        row<-i

        # assign a value of 1 for all values of row and col
        adj_matrix[row,col]<-1
    }

    # write.table(adj_matrix,
    #             "adjacency_matrix.csv",
    #             row.names=F, sep=",")
    write.table(adj_matrix,
                outputname,
                row.names=F, sep=",")

    # Old Note
    #write.table seems to give problems when reading in "adjacency matrix.csv" -
    # it doesn't recognize that it's a matrix so it creates column rows with headings "X1,X2,X3,..."
    # instead of "1,2,3,..."
    #in order to avoid the problem above return the object:
    return(adj_matrix)

}


# parse a string to decimal
as.numeric("20")    # 20
# parse a hex-string to decimal
as.numeric("0x20")  # 32
# parse a string to hexadecimal
as.hexmode(as.numeric("32")) # "20"
# parse a string to octal
as.octmode(as.numeric("20")) # "24"


## Load libraries used in the process
library(tidyverse)
library(caret)
library(xgboost)

## Load the Dataset - Customer Churn
df <- read_csv('../data/WA_Fn-UseC_-Telco-Customer-Churn.csv')
head(df, 5)

## Exclude Customer_ID and apply 0 to Total Charges -> First Bill
df[is.na(df$TotalCharges) & df$tenure==0 , ]['TotalCharges'] <- 0
df$customerID <- NULL

target <- 'Churn'
feature_categories <- df %>% keep(is.character) %>% colnames()
feature_categories <- setdiff(feature_categories, target)

## converte character to factor for analysis
df <- df %>%  mutate_if(is.character, as.factor)

current_features <- c('tenure', 'MonthlyCharges', 'TotalCharges', 'gender', 'PaymentMethod' , 'Churn', 'Contract')
summary(df[current_features])

options(repr.plot.width = 8, repr.plot.height = 3)
gg1 <- qplot(data=df, x=Churn, y=MonthlyCharges, color=gender, geom='boxplot') + coord_flip()
gg2 <- qplot(data=df, x=TotalCharges, y=MonthlyCharges, color=gender, geom='point')
# gg3 <- qplot(data=df, x=TotalCharges, y=MonthlyCharges, color=Churn, geom='point')

gridExtra::grid.arrange(gg1, gg2, nrow = 1)

## Payment Method
pmnt <-  df %>% group_by(PaymentMethod, Churn) %>% summarise(customers_n = n())
pmnt$PaymentMethod <-  str_remove(str_remove(str_remove(pmnt$PaymentMethod, 'automatic'), '\\('), '\\)')

## plot de 4 graficos em conjunto
color_manual <- c('#2a39ff', '#ff8b24')

gg3 <- qplot(data=df, x=TotalCharges, y=MonthlyCharges, color=Churn, geom='point')
gg3 <- gg3 + scale_color_manual(values=color_manual)
gg4 <- qplot(data = pmnt, x= PaymentMethod , y=customers_n, fill=Churn,  geom='col') + coord_flip()
gg4 <- gg4 + scale_fill_manual(values=color_manual)

gridExtra::grid.arrange(gg4, gg3, nrow = 1)

## Contract and tenure drives to Churn
gg5 <- qplot(data=df, x=tenure, y=MonthlyCharges, color=Churn, geom='point', facets = .~Contract, main='   Contract Type')
gg5 <- gg5 + scale_color_manual(values=color_manual)

gridExtra::grid.arrange(gg5, nrow = 1)

## few steps before run the xgb model

target <- 'Churn'
feature_categories <- df %>% keep(is.factor) %>% colnames()
feature_categories <- setdiff(feature_categories, target)

## function to run the One Hot Enconding -> all features categories
ffm_One_Hot_Encoding_dataframe <- function(dataframe, cols_OneHOtEncoding=c()){
  # ONE HOT ENCODING --------------------------------------------------------
  require(caret)

  for (i in seq_along(cols_OneHOtEncoding)){
    idx_col <- which(colnames(dataframe) == cols_OneHOtEncoding[i])
    formula <- as.formula( paste0('~ ' , cols_OneHOtEncoding[i]))
    dummies <- predict(dummyVars(formula, data = dataframe), newdata = dataframe)
    dataframe <- cbind(dataframe, dummies)
    dataframe[, idx_col] <- NULL
  }
  return(dataframe)
}

df_xgb <- ffm_One_Hot_Encoding_dataframe(df, feature_categories)

df_xgb$Churn <- as.integer(as.factor(df_xgb$Churn)) -1L

## Dataframe structure
## str(df)

dim(df_xgb)[2]

## Finally let's run the model
##

set.seed(458)
idx <- createDataPartition(df_xgb$Churn, p=0.80, list = FALSE)
train <- df_xgb[idx, ]
test <- df_xgb[-idx, ]
idx_target <- which(colnames(df_xgb)==target)

dtrain <- xgb.DMatrix(as.matrix(train[, -idx_target]), label=train[[target]])
dtest <-  xgb.DMatrix(as.matrix(test[, -idx_target]), label=test[[target]])

parameters <- list(objective = "binary:logistic",
                   eval_metric = "auc")

nrounds_xgb <- 100
set.seed(458)
fit.xgb <- xgb.train(params = parameters,
                     data = dtrain,
                     watchlist = list(train = dtrain, eval = dtest),
                     early_stopping_rounds = 5,
                     nrounds = nrounds_xgb,
                     print_every_n = 10,
                     nthread = 2)

xgb_predict <- predict(fit.xgb, as.matrix(test[, -idx_target]))
xgb_predict <- round(xgb_predict)

confusionMatrix(factor(xgb_predict), factor(test$Churn), positive = '1')

## Save the model -> 80% of accuracy
xgb.save(fit.xgb, '../data/xgb_model_acc_80p.model')

## obs. to load the model later just run the command below
## model_xgb <- xgb.load('./data/xgb_model_acc_80p.model')

## importance matrix
importance_matrix <- xgb.importance(colnames(dtrain),
                                    model = fit.xgb)

options(repr.plot.width = 6, repr.plot.height = 4)
xgb.plot.importance(importance_matrix, top_n = 10)

options(repr.plot.width = 5, repr.plot.height = 3)
gg6 <- qplot(data=df, Contract, fill=Churn, ylab='Number of Contracts') + coord_flip()
gg6 <- gg6 + scale_fill_manual(values=color_manual)

print(gg6)

df %>% filter(Churn=='Yes') %>%
  group_by(tenure, Contract) %>%
  summarise( MonthlyCharges=sum(MonthlyCharges),
             TotalCharges=sum(TotalCharges))  %>%
  qplot(data=. ,x=tenure, y=MonthlyCharges,
        geom='area', alpha=0.5, fill=Contract,
        main='    Revenue stopped: Customer Churn = Yes')


#' @name windrose_table_data
#' @title Extract data from windrose objec
#' @description Extract data from windrose objec
#' @usage windrose_table_data(data_rose)
#' @param windroseobj (required) a windrose object
#  @export

windrose_table_data=function(windroseobj) {
aa=na.omit(windroseobj$data)
res=list()
b=rbind(tapply(aa$spd,aa$dir_binned,FUN = max),
        tapply(aa$spd,aa$dir_binned,FUN = mean),
        tapply(aa$spd,aa$dir_binned,FUN = median),
        tapply(aa$spd,aa$dir_binned,FUN = function(x) quantile(x,probs=c(0.95),na.rm=T)))
bb=as.data.frame(bb)
bb$ALL=rbind(max(aa$spd,na.rm=T),
              mean(aa$spd,na.rm=T),
              median(aa$spd,na.rm=T),
              quantile(aa$spd,probs=c(0.95),na.rm=T))
res$table=bb

if ( windroseobj$dirres==22.5) {

names(res$table)=c("N","NNE","NE","ENE", "E","ESE", "SE","SSE",
            "S","SSW", "SW","WSW", "W","WNW","NW","NNW","ALL")
}

if ( windroseobj$dirres==45) {

  names(res$table)==c("N","NE", "E","SE","S","SW","W","NW","ALL")

  }

rownames(res$table)=c("Max","Mean","Median","Q95")

res$calm=data.frame(N_data=nrow(windroseobj$data),
                    Nmissing_data=windroseobj$missing_data,
                    frew_calms=windroseobj$calm_freq)

return(res)

}


xx <- list("01" = list(c("A","B"), "C"),
          "02" = list("C"),
          "03" = list("B", "B"))
## coerce
s <- as(xx, "sequences")
as(s, "data.frame")
## get reference set
as(itemsets(s), "data.frame")

similarity(x, y=NULL, method = c("jaccard", "dice", "cosine", "subset"), strict = FALSE)

dfX

summary(x)

# xt <- as(x, "sequences")

similarity(x@data[1:5,], method = "jaccard", which="items")

data(zaki)
z <- as(zaki, "timedsequences")
similarity(z)

# require equality
similarity(z, strict = TRUE)
## emphasize common
similarity(z, method = "dice")
##
is.subset(z)
is.subset(z, proper = TRUE)

## S4 method for signature 'sequences'
similarity(x, y = NULL,
           method = c("jaccard", "dice", "cosine", "subset"),
           strict = FALSE)

## S4 method for signature 'sequences'
is.subset(x, y = NULL, proper = FALSE)
## S4 method for signature 'sequences'
is.superset(x, y = NULL, proper = FALSE)

summary(Income)
dfIncome <- data.frame(Income)
data("Income")
## find and some rules (we only use 5 rules here) and calculate coverage
rules <- apriori(Income)[1:5]

quality(rules) <- cbind(quality(rules), coverage = coverage(rules))
inspect(rules)


powers = function(m)
   {n = -1
    function()
       {n <<- n + 1
        n^m}}

noncubic.squares = local(
   {squares = powers(2)
    cubes = powers(3)
    cube = cubes()
    function()
       {square = squares()
        while (1)
           {if (square > cube)
               {cube <<- cubes()
                next}
            else if (square < cube)
               {return(square)}
            else
               {square = squares()}}}})

for (i in 1:20)
    noncubic.squares()
for (i in 1:10)
    message(noncubic.squares())


#  James Rekow

disconnectedSubgraphs = function(g, v, numSubgraphs, numSample = NULL){

  #  ARGS: g - input graph
  #        v - number of vertices in the output graphs
  #
  #  RETURNS: disconnectedList - a list of all disconnected subgraphs of g with v vertices, or NULL
  #                              if no such subgraphs exist. That is, each subgraph of g with v
  #                              vertices is included if and only if it's adjacency matrix is the
  #                              v x v zero matrix

  source("uniqueSet.r")

  #  create adjacency matrix for connectivity graph
  adjMat = as.matrix(get.adjacency(conGraph, type = "both"))

  #  STEP 1: create new list
  #  STEP 2: remove elements of list which don't have 0 adjacency matrices

  #  get number of vertices in g
  numVertices = vcount(g)

  pairMat = combn(numVertices, 2)

  #  create a list of all pairs of vertices
  vList = lapply(as.list(1:choose(numVertices, 2)), function(i) pairMat[ , i])

  isDisconnected = function(vVec){

    #  ARGS: vVec - vector of vertices contained in subgraph, where it is known that vVec without
    #               it's last element forms a completely disconnected subgraph
    #
    #  RETURNS: TRUE/FALSE depending on whether or not the vertices in vVec form a completely
    #           disconnected subgraph

    #  number of vertices in vVec
    numV = length(vVec)

    #  create vector of vertices which are already known to form a completely disconnected subgraph
    disconnectedV = vVec[-numV]

    #  check whether there are any edges connecting the newest vertex to the previous disconnected
    #  vertices
    disconnected = !sum(adjMat[ , vVec[numV]][disconnectedV])

    return(disconnected)

  } #  end isDisconnected function

  #  remove all vertex vectors which correspond to subgraphs containing at least one edge from vList
  vList = vList[unlist(lapply(vList, isDisconnected))]

  createNewVList = function(vList, numVertices){

    #  ARGS: vList - input vList
    #
    #  RETURNS: newVList - a list of all of the elements in vList with each element of 1:M not in
    #           a given vList appended to vList separately

    expandVVec = function(vVec, numVertices){

      #  create vector of potential vertices
      baseV = 1:numVertices

      #  select elements from baseV which are not already present in vVec
      newV = baseV[-which(baseV %in% vVec)]

      #  create a list of new vertex vectors, where each element is a vector that is vVec with one
      #  element of newV appended to it, and each element in newV corresponds to exactly one vector
      #  in this newly created list
      vAppendedList = lapply(as.list(newV), function(x) append(vVec, x))

      return(vAppendedList)

    } #  end expandVVec function

    #  create new list of vertex vectors
    newVList = unlist(lapply(vList, function(vVec) expandVVec(vVec = vVec, numVertices = numVertices)),
                      recursive = FALSE)

    return(newVList)

  } #  end createNewVList function

  #  return NULL if every pair of vertices has an edge between them (i.e. conGraph is completely
  #  connected)
  if(length(vList) == 0){
    return(NULL)
  } #  end if

  #  track the number of vertices in each vector of vertices in vList
  numCurrentV = 2

  #  grow the size of the vertex vectors in vList iteratively
  while(numCurrentV < v){

    #  if there are no vectors in vList, return NULL
    if(length(vList) == 0){
      return(NULL)
    } #  end if

    #  update vList
    vList = createNewVList(vList = vList, numVertices = numVertices)

    #  faster to do this after removing duplicate elements, but sorting destroys the assumed property
    #  in isDisconnected that the first n - 1 elements of vVec are already disconnected
    vList = vList[unlist(lapply(vList, isDisconnected))]  #  SLOWS it down a lot. Fix in another manner

    if(!is.null(numSample)){
      vList = sample(vList, numSample, replace = TRUE)
    } #  end if

    vList = vList[which(vList %in% unique(lapply(vList, sort)))]

    if(length(vList) == 0){
      vList = NULL
      break
    } #  end if

    numCurrentV = numCurrentV + 1

  } #  end for loop

  return(vList)

} #  end disconnectedSubgraphs function


model_soilheatflux <- function (netRadiationEquivalentEvaporation = 638.142,
         tau = 0.9983,
         soilEvaporation = 448.24){
    #'- Name: SoilHeatFlux -Version: 1.0, -Time step: 1
    #'- Description:
    #'            * Title: SoilHeatFlux Model
    #'            * Author: Pierre Martre
    #'            * Reference: Modelling energy balance in the wheat crop model SiriusQuality2:
    #'            Evapotranspiration and canopy and soil temperature calculations
    #'            * Institution: INRA/LEPSE Montpellier
    #'            * Abstract: The available energy in the soil
    #'- inputs:
    #'            * name: netRadiationEquivalentEvaporation
    #'                          ** variablecategory : state
    #'                          ** description : net Radiation Equivalent Evaporation
    #'                          ** datatype : DOUBLE
    #'                          ** default : 638.142
    #'                          ** min : 0
    #'                          ** max : 5000
    #'                          ** unit : g m-2 d-1
    #'                          ** uri : http://www1.clermont.inra.fr/siriusquality/?page_id=547
    #'                          ** inputtype : variable
    #'            * name: tau
    #'                          ** description : plant cover factor
    #'                          ** parametercategory : species
    #'                          ** datatype : DOUBLE
    #'                          ** default : 0.9983
    #'                          ** min : 0
    #'                          ** max : 100
    #'                          ** unit :
    #'                          ** uri : http://www1.clermont.inra.fr/siriusquality/?page_id=547
    #'                          ** inputtype : parameter
    #'            * name: soilEvaporation
    #'                          ** description : soil Evaporation
    #'                          ** variablecategory : state
    #'                          ** datatype : DOUBLE
    #'                          ** default : 448.240
    #'                          ** min : 0
    #'                          ** max : 10000
    #'                          ** unit : g m-2 d-1
    #'                          ** uri : http://www1.clermont.inra.fr/siriusquality/?page_id=547
    #'                          ** inputtype : variable
    #'- outputs:
    #'            * name: soilHeatFlux
    #'                          ** description : soil Heat Flux
    #'                          ** variablecategory : rate
    #'                          ** datatype : DOUBLE
    #'                          ** min : 0
    #'                          ** max : 10000
    #'                          ** unit : g m-2 d-1
    #'                          ** uri : http://www1.clermont.inra.fr/siriusquality/?page_id=547
    soilHeatFlux <- tau * netRadiationEquivalentEvaporation - soilEvaporation
    return (list('soilHeatFlux' = soilHeatFlux))
}


subroutine sknotl(x,n,knot,k)
implicit double precision(a-h,o-z)
double precision x(n),knot(n+6),a1,a2,a3,a4
integer     n,k,ndk,j

     # Allocate knots acording to the cutoffs given below

	# Cutoff constants

	 a1 = log(50d0)/log(2d0)  ; a2 = log(100d0)/log(2d0)
	 a3 = log(140d0)/log(2d0) ; a4 = log(200d0)/log(2d0)

	# Cutoff Criteria

        if(n<50)                    { ndk = n }
        else if (n>=50  & n<200)    { ndk = 2.**(a1+(a2-a1)*(n-50.)/150.)  }
        else if (n>=200 & n<800)    { ndk = 2.**(a2+(a3-a2)*(n-200.)/600.)  }
        else if (n>=800 & n<3200)   { ndk = 2.**(a3+(a4-a3)*(n-800.)/2400.)  }
        else if (n>=3200)           { ndk = 200. + float(n-3200)**.2 }

		 k = ndk + 6

     # Allocate Knots  ( note no account is taken of any weighting vector )

	do j=1,3   { knot(j) = x(1) }
	do j=1,ndk { knot(j+3) = x( 1 + (j-1)*(n-1)/(ndk-1) ) }
	do j=1,3   { knot(ndk+3+j) = x(n) }

return
end
subroutine splsm(x,y,w,n,match,nef,spar,dof,smo,s0,cov,ifcov,work)
#This subroutine performs a smoothing spline fit
# This was written by Trevor Hastie in 1990
# It has been modified from the S3 version by Trevor Hastie
# in July 2004, to accommodate the modified sbart routine in R
# and also to accommodate only the gam bakfit routine.
# Note that spar has changed, and we change it here to conform with
# the smooth.spline routine in R
#All arguments are either double precision or integer
#INPUT
#
#x	double length n ; x variable for smoothing
#y	double length n	; y variable for smoothing
#w	double length n ; weights for smoothing, > 0
#n	integer length above
#match 	integer length n -- in S language x[i] == sort(unique(x)[match[i]]
#		match is produced by subroutine namat
#nef	number of unique elements in x; so match has values between 1 and nef+1
#		missing data are given the match number nef+1
#spar	double smoothing parameter -1.5 <spar<1.5; default is 1
#dof	double  equivalent degrees of freedom
#		if dof is 0, spar is used
#               if 0< dof <1, dof = 1
#		if dof >=1, dof is used
#		note: dof does not use the constant term
#ifcov	integer if 1, the unscaled variance information is computed
#work	double workspace of length (10+2*4)*(nef+2)+5*nef+n+15
#
#OUTPUT
#
#x,y,w,n,match,nef  are untouched
#spar	if dof > 1, then spar is that which achieves dof
#dof	the dof of the fitted smooth. Note: even if dof was given
#		as 4, it will be returned as say 3.995 which is what
#		spar produces
#smo	double length n the fitted values, with weighted average 0
#s0	double weighted mean of y
#cov	double length nef the unscaled variance elements for the NONLINEAR
#		and UNIQUE part of smo, in the order of sort(unique(x))
#		cov is lev(i)/w(i) -h(i)/w where h(i) is the hat element from
#		the simple weighted least squares fit. This is passed on
#		to bakfit and used in gamcov
#
# splsm calls (eventually after some memory management dummy calls)
# sbart, the spline routine of Finbarr O'Sullivan, slightly modified
# by Trevor Hastie, 8/2/89

implicit double precision(a-h,o-z)
double precision x(*),y(*),w(*),spar,dof,smo(*),s0,cov(*),work(*)
integer n,match(*),nef
integer ifcov
# work should be (10+2*ld4)*nk+5*nef+n+15 double
# ld4 =4  nk<= nef+2
call splsm1(x,y,w,n,match,nef,spar,dof,smo,s0,cov,ifcov,
#	xin(nef+1),yin(nef+1), win(nef+1),   knot(n+6),
	work(1),   work(nef+2),work(2*nef+3),work(3*nef+4),
	work(3*nef+n+10))
return
end

subroutine splsm1(x,y,w,n,match,nef,spar,dof,smo,s0,lev,ifcov,
		xin,yin,win,knot,
		work)
implicit double precision(a-h,o-z)
double precision x(*),y(*),w(*),spar,dof,smo(*),s0,lev(*),work(*)
integer n,match(*),nef
integer ifcov
double precision xin(nef+1),yin(nef+1),win(nef+1),knot(nef+6)
integer nk,ldnk,ld4,k
double precision xmin,xrange
call suff(n,nef,match,x,y,w,xin,yin,win,work(1))
xmin=xin(1)
xrange=xin(nef)-xin(1)
do i=1,nef {xin(i)=(xin(i)-xmin)/xrange}
call sknotl(xin,nef,knot,k)
nk=k-4
ld4=4
ldnk=1 # p21p nd ldnk is not used
call splsm2(x,y,w,n,match,nef,spar,dof,smo,s0,lev,ifcov,
		xin,yin,win,knot,
#       coef(nk),sout(nef+1),  levout(nef+1), xwy(nk),
#	hs0(nk),           hs1(nk),           hs2(nk),
#       hs3(nk),
#	sg0(nk),           sg1(nk),           sg2(nk),
#       sg3(nk),
#	abd(ld4,nk),   p1ip(ld4,nk),
#       p2ip(ldnk,nk)
	work(1), work(nk+1),   work(nk+nef+2),work(nk+2*nef+3),
	work(2*nk+2*nef+3),work(3*nk+2*nef+3),work(4*nk+2*nef+3),
	work(5*nk+2*nef+3),
	work(6*nk+2*nef+3),work(7*nk+2*nef+3),work(8*nk+2*nef+3),
	work(9*nk+2*nef+3),
	work(10*nk+2*nef+3),work((10+ld4)*nk+2*nef+3),
	work((10+2*ld4)*nk+2*nef+3),
	ld4,ldnk,nk)

return
end
subroutine splsm2(x,y,w,n,match,nef,spar,dof,smo,s0,lev,ifcov,
		xin,yin,win,knot,
		coef,sout,levout,xwy,
		hs0,hs1,hs2,hs3,
		sg0,sg1,sg2,sg3,
		abd,p1ip,p2ip,ld4,ldnk,nk)
implicit double precision(a-h,o-z)
double precision x(*),y(*),w(*),spar,dof,smo(*),s0,lev(*)
integer n,match(*),nef
integer nk,ldnk,ld4
integer ifcov
double precision xin(nef+1),yin(nef+1),win(nef+1),knot(nk+4)
double precision coef(nk),sout(nef+1),levout(nef+1),xwy(nk),
	 	hs0(nk),hs1(nk),hs2(nk),hs3(nk),
         	sg0(nk),sg1(nk),sg2(nk),sg3(nk),
	 	abd(ld4,nk),p1ip(ld4,nk),p2ip(ldnk,*)
#    local variables
integer ispar,icrit,isetup,ier
double precision lspar,uspar,tol,penalt,
		sumwin,dofoff,crit,xbar,dsum,xsbar
double precision yssw, eps
integer maxit
# yssw is an additional parameter introduced in R version of sbart
double precision wmean
crit=0d0
# Note we only allow limited options here
if(dof <= 0d0){
# use spar
  ispar=1
  icrit=3
  dofoff=0d0
  }
else{
  if( dof < 1d0 )dof=1d0
  ispar=0
  icrit=3
  dofoff=dof+1d0
}
#Here we set some default parameters similar to the smooth.spline in R
isetup=0
ier=1
penalt=1d0
lspar= -1.5
uspar= 2.0
tol=1d-4
eps=2d-8
maxit=200
do i=1,nef
       sout(i)=yin(i)*yin(i)
sumwin=0d0
do i=1,nef
	sumwin=sumwin+win(i)
yssw=wmean(nef,sout,win)
s0=wmean(n,y,w)
# which should be equal to wmean(nef,yin,win)
yssw=yssw*(sumwin-s0*s0)

call sbart(penalt,dofoff,xin,yin,win,yssw,nef,knot,nk,
		  coef,sout,levout,crit,
                  icrit,spar,ispar,maxit,
                  lspar,uspar,tol,eps,
		  isetup,
		  xwy,
		  hs0,hs1,hs2,hs3,
		  sg0,sg1,sg2,sg3,
		  abd,p1ip,p2ip,ld4,ldnk,ier)
#return
#now clean up
do i=1,nef {
	win(i)=win(i)*win(i) #we sqrted them in sbart
	}
sbar=wmean(nef,sout,win)
xbar=wmean(nef,xin,win)

#now remove the linear leverage from the leverage for the smooths
# will be altered at this stage
do i=1,nef {lev(i)=(xin(i)-xbar)*sout(i)	}
xsbar=wmean(nef,lev,win)
do i=1,nef {lev(i)=(xin(i)-xbar)**2	}
dsum=wmean(nef,lev,win)
do i=1,nef {
	if(win(i)>0d0) {
		lev(i)=levout(i)/win(i)-1d0/sumwin -lev(i)/(sumwin*dsum)
		}
	else {lev(i)=0d0}
	}
dof=0d0
do i=1,nef {dof=dof+lev(i)*win(i)}
dof=dof+1d0
do i=1,nef
	sout(i)=sout(i)-sbar -(xin(i)-xbar)*xsbar/dsum
call unpck(n,nef,match,sout,smo)
return
end

double precision function wmean(n,y,w)
integer n
double precision y(n),w(n),wtot,wsum
wtot=0d0
wsum=0d0
do i=1,n{
	wsum=wsum+y(i)*w(i)
	wtot=wtot+w(i)
}
if(wtot > 0d0) {wmean=wsum/wtot} else {wmean=0d0}
return
end


set.seed(666)

true.mu <- -.1
true.sigma <- .001
N_0 <- 50

y_0 <- rnorm(N_0, mean = true.mu, sd = true.sigma)

mu_0 <- 0
kappa_0 <- 5
alpha_0 <- 1
beta_0 <- 1

copy <- FALSE

if(copy){
  N <- N_0
  y <- y_0
}else{
  N <- 200
  y <- rnorm(N, mean = true.mu, sd = true.sigma)
}

nu <- 1
eta <- 1


## Written by Eilis
## summarize CNV QC metrics across samples
## provide path to sample qc output (from PennCNV) on command line
## determine thresholds

args<-commandArgs(trailingOnly = TRUE)
fileName<-args[1]
superPop<-args[2]
folder<-dirname(fileName)

## outlier defined as more than 3 SD from mean
nSD<-3

dat<-read.table(fileName, header = TRUE, stringsAsFactors = FALSE)

## use absolute WF
dat$absWF<-abs(dat$WF)

colsToPlot<-c("LRR_SD","BAF_drift","absWF","NumCNV")

sys.variables<-NULL
pdf(paste(folder, "HistogramCNVMetrics.pdf", sep = "/"))
par(mfrow = c(2,2))
par(mar = c(4,4,1,1))
for(colName in colsToPlot){

	hist(dat[,colName], xlab = colName, breaks = 20, main = "")
	mu<-mean(dat[,colName])
	sigma<-sd(dat[,colName])
	abline(v=mu, col = "red")

	abline(v=mu+nSD*sigma, col = "red", lty = 2)
	abline(v=mu-nSD*sigma, col = "red", lty = 2)
	# save thresholds for use with PennCNV filter functions
	sys.variables<-c(sys.variables, mu+nSD*sigma)
}

invisible(dev.off())

sys.variables<-unname(sys.variables)
sys.variables<-signif(sys.variables, 3)

cat(sys.variables) # print so can be saved as bash variables

## create exclusion list
#exclude<-NULL
#for(colName in colsToPlot){
	#mu<-mean(dat[,colName])
	#sigma<-sd(dat[,colName])
	#exclude<-c(exclude, which(dat[,colName] > mu+nSD*sigma))
	#exclude<-c(exclude, which(dat[,colName] < mu-nSD*sigma))
#}
#exclude<-unique(exclude)
#print(paste(length(exclude), "samples excluded for outlier summary statistics"))

#gsub("PennCNVInput/", "", dat[exclude,1])

## compare metrics
pdf(paste(folder, "ScatterplotCNVMetrics.pdf", sep = "/"), height = 8, width = 12)
par(mar = c(4,4,1,1))
par(mfrow = c(2,3))
for(i in 1:3){
	for(j in c((i+1):4)){
		plot(dat[,colsToPlot[i]], dat[,colsToPlot[j]], pch = 16, xlab = colsToPlot[i], ylab = colsToPlot[j])
	}
}
invisible(dev.off())

## check by ethnicity
predPop<-read.csv(superPop)
predPop<-predPop[match(gsub("PennCNVInput/", "", dat$File), predPop$V2),]
pdf(paste(folder, "BoxplotCNVMetricsByPredPop.pdf", sep = "/"))
par(mfrow = c(2,2))
par(mar = c(4,4,1,1))
for(colName in colsToPlot){
boxplot(dat[,colName] ~ predPop$predPop, ylab = colName, main = "", col = rainbow(5))
}
invisible(dev.off())


library(stats)
data <- read.csv("Desktop/Q1 Course/FP/MachineLearningSamples/extra-data/snsdata.csv", header = T)
#check missing values
sapply(data, function(x) sum(is.na(x)))
#use dummy coding to create 2 new columns as there are many missing values in gender column
data$female <- ifelse(data$gender == "F" & !is.na(data$gender), 1, 0)
data$no_gender <- ifelse(is.na(data$gender), 1, 0)
#impute missing value with mean value of each graduation year
ave_age <- ave(data$age, data$gradyear, FUN = function(x) mean(x, na.rm = TRUE))
data$age <- ifelse(is.na(data$age), ave_age, teens$age)
#remove 2 column
data <- data[, -2]
#train a k-means model
sns_model <- kmeans(data, 5)
#take a look at model
sns_model$clusters
sns_model$centers


# load dependences
library(readr)
library(cluster)
library(clValid)
library(mclust)
library(ggplot2)
library(FactoMineR)
library(factoextra)

# load data
points <- read_csv("C:/FShapeX/App/Dataset/points2.csv", col_types = cols(dataset = col_skip(), ethnicity = col_skip(), gender = col_skip()))

# variables
k <- 6

# prepare data
exprs <- scale(points[,-1])
rownames(exprs) <- points$file[1:547]

# check directory
mainDir <- paste("C:/FShapeX/App/Clusters/k", k, sep = "")
ifelse(!dir.exists(mainDir), dir.create(mainDir), FALSE)

set.seed(123)
res.hc <- eclust(exprs, "hclust", k = k, graph = FALSE)

res.pca <- PCA(exprs, ncp = k, graph = FALSE)
res.hcpc <- HCPC(res.pca, nb.clust = k, graph = FALSE)
fviz_cluster(res.hcpc, repel = TRUE, show.clust.cent = TRUE, palette = "jco", ggtheme = theme_minimal(), main = "Factor map", geom = "point")

points$cluster <- res.hc$cluster

png(paste(mainDir, "/", points$cluster, ".png", sep = ""))
plot(res.hcpc, choice = "3D.map")
dev.off()


ksc_center <- function(mem, A, k, cur_center) {
	a <- cbind()
	for(i in 1:length(mem)){
		if(mem[i] == k) {
			if(sum(cur_center)==0) {
				opt_a = matrix(A[i,], nrow=1)
			} else {
				list<-dhat_shift(cur_center, A[i,]);
				tmp<-list$dist
				tmps<-list$optshift
				opt_a <- list$opty
			}
			a <- rbind(a, opt_a)
		}
	}
	if(nrow(a) == 0) {
		ksc = matrix(0, nrow=1, ncol=ncol(A))
		return(ksc)
	}
	b <- a/matrix(rep(sqrt(rowSums(a^2)), times=ncol(a)), nrow=nrow(a))
	M <- t(b)%*%b -  nrow(a) * diag(ncol(a))
	eig <- eigen(M)
	V <- eig$vectors
	D <- eig$values * diag(ncol(M))
	ksc <- matrix(V[,ncol(V)], nrow=1)
	ksc
	if(sum(ksc) < 0) {
		ksc = -ksc
	}
	return(ksc)
}