setwd("C:\\Users\\anush\\OneDrive\\Desktop\\final")
getwd()
library(factoextra)
library(purrr)
library(cluster)
library(fclust)
library(ppclust)
library(dplyr)
library(ClusterR)
data <- read.csv("C:\\Users\\anush\\OneDrive\\Desktop\\final\\ORIGINAL.csv")
data[is.na(data$L1.norm.)]
data[is.na(data$BTC.)]
rownames(data) <- data$Date
data.frame <- as.data.frame(data)
# print(data.frame)
# data.scaled <- scale(data.frame[,2:3])
data.scaled <- data.frame[,4:5]
#ELBOW METHOD ----------------------------------------------------------->
# function to compute total within-cluster sum of square
# wss <- function(k) {
#   kmeans(data.scaled, k, nstart = 10 )$tot.withinss
# }
#
# # Compute and plot wss for k = 1 to k = 15
# k.values <- 1:15
#
# # extract wss for 2-15 clusters
# wss_values <- map_dbl(k.values, wss)
#
# plot(k.values, wss_values,
#      type="b", pch = 19, frame = FALSE,
#      xlab="Number of clusters K",
#      ylab="Total within-clusters sum of squares")

# fviz_nbclust(na.omit(data.scaled), kmeans, method = "wss")# k = 4

#ELBOW METHOD -------------------------------------------------------->

#silhouette method --------------------------------------------------------->
# fviz_nbclust(na.omit(data.scaled), kmeans, method = "silhouette")# k = 3
#---------------------------------------------------------------------------->

#Gap strategy -------------------------------------------------------------->
# set.seed(123)
# gap_stat <- clusGap(data.scaled, FUN = kmeans, nstart = 25,
#                     K.max = 10, B = 50)
# print(gap_stat, method = "firstmax")
# fviz_nbclust(na.omit(data.scaled), kmeans, method = "gap_stat")
#---------------------------------------------------------------------------->
#Fuzzy C means clustering -------------------------------------------------->
# res.fcm <- fcm(na.omit(data.scaled), centers=4)
# as.data.frame(res.fcm$u)[,]
# res.fcm3 <- ppclust2(res.fcm, "fanny")
#
# cluster::clusplot(data.frame[,4:5], res.fcm3$cluster,
#                   main = "Clusters",
#                   color=TRUE, labels = 2, lines = 2, cex=1)
# summary(res.fcm)
# res.fcm2 <- ppclust2(res.fcm, "kmeans")
# fviz_cluster(res.fcm2, data = na.omit(data.scaled),
# ellipse.type = "convex",
# palette = "jco",
# repel = TRUE)
#--------------------------------------------------------------------------->

#Gaussian mixture model----------------------------------------------------->

# dim(data.scaled)
# gmm = GMM(data.scaled, 2, dist_mode = "maha_dist", seed_mode = "random_subset", km_iter = 10,em_iter = 10, verbose = F)
#
# # predict centroids, covariance matrix and weights
# pr = predict_GMM(data.scaled, gmm$centroids, gmm$covariance_matrices, gmm$weights)
# print(pr)
# opt_gmm = Optimal_Clusters_GMM(data.scaled, max_clusters = 10, criterion = "BIC",
#
#                                dist_mode = "maha_dist", seed_mode = "random_subset",
#
#                                km_iter = 10, em_iter = 10, var_floor = 1e-10,
#
#                                plot_data = T)
# k = 2
#----------------------------------------------------------------------------->

#kmeans + GMM ---------------------------------------------------------------->


## 1. Hyperparameters ##

set.seed(1)
library(caret)
train_indices <- createDataPartition(y = dc_listings[["tidy_price"]],
                                     p = 0.8,
                                     list = FALSE)
train_listings <- dc_listings[train_indices,]
test_listings <- dc_listings[-train_indices,]

## 2. Hyperparameter Optimization ##

set.seed(1)
library(caret)
train_indices <- createDataPartition(y = dc_listings[["tidy_price"]],
                                     p = 0.8,
                                     list = FALSE)
train_lisitings <- dc_listings[train_indices,]
test_lisitings <- dc_listings[-train_indices,]
knn_grid <- expand.grid(k = 1:20)

## 3. Using our Hyperparameter Grid ##

set.seed(1)
library(caret)
train_indices <- createDataPartition(y = dc_listings[["tidy_price"]],
                                     p = 0.8,
                                     list = FALSE)
train_listings <- dc_listings[train_indices,]
test_listings <- dc_listings[-train_indices,]
knn_grid <- expand.grid(k = 1:20)
train_control <- trainControl(method = "cv", number = 5)
knn_model <- train(tidy_price ~ accommodates + bedrooms + bathrooms,
                   data = train_listings,
                   method = "knn",
                   trControl = train_control,
                   preProcess = c("center", "scale"),
                   tuneGrid = knn_grid)

## 6. Hyperparameters and Cross-validation ##

times_test_data_used <- 1 # The test data should only be touched after we have our final model!

Data Analyst in R/Step 6 - Predictive Modeling and Machine Learning in R/2. Machine Learning Fundamentals in R/5. Hyperparameter Optimization.r


# 4. faza: Analiza podatkov

# Po desetletjih ###############################################################

povprecne_starosti_tabela <- izvajalci_ostalo %>%
  mutate(Desetletje=(Leto%/%10*10)) %>%
  group_by(Desetletje) %>%
  summarise_at(vars(-c(Leto,
                       Izvajalec,
                       Ustanovitev,
                       Izvor,
                       Spol,
                       Festival,
                       Lokacija,
                       Grofija)),
                    funs(mean(., na.rm=TRUE)))

model <- lm(Starost ~ Desetletje, data = povprecne_starosti_tabela)
novo_desetletje <- data.frame(Desetletje = 2020)
predict(model, novo_desetletje)
napoved <- novo_desetletje %>% mutate(Starost = predict(model, .))

povprecne_starosti <- ggplot(povprecne_starosti_tabela,
                             aes(x = Desetletje, y = Starost)) +
  geom_point(color = 'darkgreen',
             size = 2) +
  geom_smooth(method = lm, formula=y~x, fullrange=TRUE) +
  geom_point(data=napoved, aes(x = Desetletje, y = Starost),
             color = 'red',
             size = 5) +
  labs(title = "Povprečna starost izvajalcev - po desetletjih")

# Po letih #####################################################################

povprecne_starosti_tabela_leta <- izvajalci_ostalo %>%
  group_by(Leto) %>%
  summarise_at(vars(-c(Izvajalec,
                       Ustanovitev,
                       Izvor,
                       Spol,
                       Festival,
                       Lokacija,
                       Grofija)),
               funs(mean(., na.rm=TRUE)))

model_leta <- lm(Starost ~ Leto, data = povprecne_starosti_tabela_leta)
nova_leta <- data.frame(Leto = c(2018:2029))
predict(model_leta, nova_leta)
napoved_leta <- nova_leta %>% mutate(Starost = predict(model_leta, .))

povprecne_starosti_leta <- ggplot(povprecne_starosti_tabela_leta,
                             aes(x = Leto, y = Starost)) +
  geom_point(color = 'darkgreen',
             size = 2) +
  geom_smooth(method = lm, formula=y~x, fullrange=TRUE) +
  geom_point(data=napoved_leta, aes(x = Leto, y = Starost),
             color = 'red',
             size = 2) +
  labs(title = "Povprečna starost izvajalcev - po letih")


#Q5. The number 512 is interesting because it is equal to the sum of its digits raised to some power: 5 + 1 + 2 = 8, and 83 = 512. Another example of a number with this property is 614656 = 284.
#We shall define an to be the nth term of this sequence and insist that a number must contain at least two digits to have a sum.
#You are given that a2 = 512 and a10 = 614656.
#Find a30.

List<BigInteger> a = new List<BigInteger>();

for (int b = 2; b < 400; b++) {
    BigInteger value = b;
    for (int e = 2; e < 50; e++) {
        value *= b;

        if (DigitSum(value) == b) {
            a.Add(value);
        }
        if (a.Count > 50) break;
    }
    if (a.Count > 50) break;
}


t=9
v=16
r=3
sw2=2.847
qvalue=qtukey(1-0.05,t,v)
W=qvalue*sqrt(sw2/r)
W
 # any pair of treatment means having a difference between corresponding
#sample means exceeding 4.9 would be declared significantly different


arithmeticMean <- function(a, b) { (a + b)/2 }
geometricMean <- function(a, b) { sqrt(a * b) }

arithmeticGeometricMean <- function(a, b) {
  rel_error <- abs(a - b) / pmax(a, b)
  if (all(rel_error < .Machine$double.eps, na.rm=TRUE)) {
    agm <- a
    return(data.frame(agm, rel_error));
  }
  Recall(arithmeticMean(a, b), geometricMean(a, b))
}

agm <- arithmeticGeometricMean(1, 1/sqrt(2))
print(format(agm, digits=16))


library(ggplot2)
# plot.vsTerms
# total=as.data.table(total)
# max_terms <- max(total[, Terms])
# dt_false <-
#     density(total[Markov_Success1 == FALSE, Terms], from = 0, to = max_terms)
# dt_true <-
#     density(total[Markov_Success1 == TRUE, Terms], from = 0, to = max_terms)
#
# density_point_x <- dt_true$x[dt_false$y < dt_true$y][[1]]
# density_point_x <- round(density_point_x)
# density_point_y <- dt_true$y[dt_false$y < dt_true$y][[1]]
# geom_point(aes(x = density_point_x, y = density_point_y), colour = "grey50")

plot.vs=function(total,variable="Terms"){
    total=as.data.frame(total)
    Terms=rep(total$Terms,3)
    Nchar=rep(total$Nchar,3)
    Nchar_Digits=rep(total$Nchar_Digits,3)
    Avrg_Digits=rep(total$Avrg_Digits,3)
    Markov_Success=c(total$Markov_Success1,total$Markov_Success2,total$Markov_Success3)
    Type=rep(c("First Order Markov","Second Order Markov","
    Chinese Remainder Theorem"),each=10000);Type=as.factor(Type)
    newTotal=data.frame(Terms,Nchar,Nchar_Digits,Avrg_Digits,Markov_Success,Type)
    p= ggplot(newTotal,aes_string(x=variable))+
        geom_density(alpha = 0.5, aes(fill=Markov_Success,group = Markov_Success))+
        facet_wrap(~Type)+
        ggtitle(paste("Success_Failure related to",variable))
    if(variable=="Avrg_Digits"){
        p=p+xlim(0,10)
    }
    p
}
plot.vs2=function(total){
    total=as.data.frame(total)
    Terms=rep(total$Terms,3)
    Nchar=rep(total$Nchar,3)
    Nchar_Digits=rep(total$Nchar_Digits,3)
    Avrg_Digits=rep(total$Avrg_Digits,3)
    Markov_Success=c(total$Markov_Success1,total$Markov_Success2,total$Markov_Success3)
    Type=rep(c("First Order Markov","Second Order Markov","
               Chinese Remainder Theorem"),each=10000);Type=as.factor(Type)
    newTotal=data.frame(Terms,Nchar,Nchar_Digits,Avrg_Digits,Markov_Success,Type)
    ggplot(newTotal, aes(x = Terms, y = Nchar_Digits, colour = Markov_Success)) +
        geom_point(aes(group = Markov_Success), size = .2, alpha = .2) +
        geom_density2d(aes(group = Markov_Success), size = .5)+
        facet_wrap(~Type)
}


# TECOA166
#Sheetal Singh

# Funcions for particular action

replace_na <- function(data) {
  cat("\nBefore Replace:-\n")
  print(data)

  data[is.na(data[,2]),2] <- round(mean(data$Age,na.rm = TRUE))
  data[is.na(data[,3]),3] <- round(mean(data$Salary,na.rm = TRUE))

  cat("\nAfter Replace:-\n")
  print(data)
}

delete_na <- function(data) {
  cat("\nBefore Delete:-\n")
  print(data)

  newdata<-na.omit(data)

  cat("\nAfter Delete:-\n")
  print(newdata)
}

age_outlier <- function(data) {
  #install.packages("outliers")
  library(outliers)
  find_age_outlier<- which(outlier(data$Age, logical=TRUE))
  cat("\nRow with Age Outlier:-\n")
  print(data[find_age_outlier,])
}

salary_outlier <- function(data) {
  #install.packages("outliers")
  library(outliers)
  find_salary_outlier<- which(outlier(data$Salary, logical=TRUE))
  cat("\nRow with Salary Outlier:-\n")
  print(data[find_salary_outlier,])
}

delete_outliers <- function(data) {
  cat("\nBefore Delete:-\n")
  print(data)

  #install.packages("outliers")
  library(outliers)
  find_age_outlier<- which(outlier(data$Age, logical=TRUE))
  newdata<-data[-find_age_outlier,]

  find_salary_outlier<- which(outlier(newdata$Salary, logical=TRUE))
  newdata<-newdata[-find_salary_outlier,]

  cat("\nAfter Delete:-\n")
  print(newdata)
}

encoding_categorical <- function(data) {
  cat("\nBefore Encoding:-\n")
  print(data)

  data$Country <- factor(data$Country , levels=c('France','Spain','Germany'),labels=c(1,2,3))
  data$Purchased <- factor(data$Purchased , levels=c('Yes','No'),labels=c(1,0))

  cat("\nAfter Encoding:-\n")
  print(data)
}

feature_scaling <- function(data) {
  data[is.na(data[,2]),2] <- round(mean(data$Age,na.rm = TRUE)) # replace NA before Feature Scaling
  data[is.na(data[,3]),3] <- round(mean(data$Salary,na.rm = TRUE))

  cat("\nBefore Feature Scaling:-\n")
  print(data[,2:3])

  newdata = scale(data[,2:3])

  cat("\nAfter Feature Scaling:-\n")
  print(newdata)
}

# Main Program Starts form here
data <- read.csv("Data.csv", header=TRUE, fileEncoding = "UTF-8-BOM") # load dataset
while (TRUE)
{
  # Display Menu
  cat("\n\nMenu:-
1. Replace missing/NULL values with mean
2. Delete rows with missing/NULL values
3. Show Age Outlier
4. Show Salary Outlier
5. Delete rows with outliers
6. Encoding of categorical data
7. Feature scaling
8. Exit\n\n")

  # Take input form user
  ch = as.integer(readline(prompt="Enter Your Choice: "))

  # Perform action specified by user
  switch(ch,
         replace_na(data),
         delete_na(data),
         age_outlier(data),
         salary_outlier(data),
         delete_outliers(data),
         encoding_categorical(data),
         feature_scaling(data))

  if(ch==8){break}
}


#hierarchical clustering
id1 <- sample(1:dim(iris)[1], 30) #taking 30 observations
id1
irisSample <- iris[id1,]  #extracting those 30 points
irisSample$Species <- NULL
irisSample
hc <- hclust(dist(irisSample), method="ave") #ave,single
plot(hc, hang = -1, labels=iris$Species[id1])
# cut tree into 4 clusters
rect.hclust(hc, k=4)
groups <- cutree(hc, k=4) #store observation placement in cluster
groups

?hclust


sample_size=c(5,4,6,5)
#l1=y1bar-y3bar
#l2=y2bar-y4bar
# We can rewrite the contrasts in the following form:
#l1=y1bar+0*y2bar-y3bar+0*y4bar
#l2=0*y1bar+y2bar+0*y3bar-y4bar
# thus we identify a1 = 1, a2 = 0, a3 =-1, a4 = 0 and b1 =0, b2 = 1, b3 =0, b4 =-1
a=c(1,0,-1,0)
b=c(0,1,0,-1)
test=0
i=1
while(i<=length(sample_size)){
  test=test+(a[i]*b[1])/sample_size[i]
  i=i+1
}
print(test)
if(test==0){
  print("hence the contrasts are orthogonal.")
}else{
  print("hence the contrasts are not orthogonal")
}


 ZGELSY Example Program Results

 Least squares solution
 ( 1.1669,-3.3224) ( 1.3486, 5.5027) ( 4.1764, 2.3435) ( 0.6467, 0.0107)

 Tolerance used to estimate the rank of A
   1.00E-02
 Estimated rank of A
      3


data()
data("women")
print(women)
x=lm(weight~height, data=women)
print(x)
y<-data.frame(height=75)
y1<-predict(x,y)
print(y1)
x=lm(height~weight, data=women)
y<-data.frame(weight=170)
y1<-predict(x,y)
print(y1)
#question1
data(trees)
print(trees)
p=lm(Volume ~ Height, data=trees)
print(p)
q<-data.frame(Height=100)
q1<-predict(p,q)
print(q1)

#question2
print(getwd())
setwd("E:/code/R")
f<-read.csv("Iris.csv")
print(f)
#plot(f)
plot(PetalLengthCm~SepalLengthCm,data=f)


phys <- c(15,  12,  8,   8,   7,   7,   7,   6,   5,   3)
hist <- c(10,  25,  17,  11,  13,  17,  20,  13,  9,   15)

model = lm(formula = hist ~ phys, x=TRUE, y=TRUE)

answer <- model$coefficients[2:2]

write(round(answer, 3), stdout())


library(lme4)
library(tidyverse)
setwd("./Documents/grad_school_classes/nba-movement-data")

#read data for public model
first_df <- read.csv("./data/multi_level_model_first.csv")
#standardize first model prediction
first_df$first_model_value <- (first_df$first_model_value - mean(first_df$first_model_value)) / sd(first_df$first_model_value)
#seperate into train/test
first_train_df <- first_df[c(0:75000),]
first_test_df <- first_df[c(75000:nrow(df)),]
#train multilevel model
first_model <- glmer(SHOT_MADE_FLAG ~  first_model_value + (1 |shot_zone:shot_cluster), data=first_train_df,family=binomial(link="logit"),control=glmerControl(optimizer="bobyqa",optCtrl=list(maxfun=2e5)))

#read data for private model
second_df <- read.csv("./data/multi_level_model_second.csv")
second_df$sec_model_value <- (second_df$sec_model_value - mean(second_df$sec_model_value)) / sd(second_df$sec_model_value)
second_train_df <- second_df[c(0:75000),]
second_test_df <- second_df[c(75000:nrow(df)),]
second_model <- glmer(SHOT_MADE_FLAG ~  sec_model_value + (1 | shot_zone:shot_cluster), data=second_train_df,family=binomial(link="logit"),control=glmerControl(optimizer="bobyqa",optCtrl=list(maxfun=2e5)))

#get predictions
first_predictions <- predict(first_model,newdata=first_test_df,type="response")
#round to 0,1
guesses <- round(first_predictions)
truth <- first_test_df$SHOT_MADE_FLAG
#compare with ground truth
accuracy <- sum(guesses == truth) / length(truth)
print("FIRST MODEl ACCURACY")
print(accuracy)

second_predictions <- predict(second_model,newdata=test_df,type="response")
guesses <- round(second_predictions)
truth <- second_test_df$SHOT_MADE_FLAG
accuracy <- sum(guesses == truth) / length(truth)
print("SECOND MODEl ACCURACY")
print(accuracy)


findfactors <- function(num) {
  x <- NULL
  firstprime<- 2; secondprime <- 3; everyprime <- num
  while( everyprime != 1 ) {
    while( everyprime%%firstprime == 0 ) {
      x <- c(x, firstprime)
      everyprime <- floor(everyprime/ firstprime)
    }
    firstprime <- secondprime
    secondprime <- secondprime + 2
  }
  x
}

print(findfactors(1027*4))


stdz <- function(x, weight=NULL){
  if(is.null(weight)){
    weight <- rep(1, length(x))
  }
  x <- x-wtd.mean(x, weight, na.rm=TRUE)
  x <- x/sqrt(wtd.var(x, weight, na.rm=TRUE))
  x
}


suppressWarnings(source("library.R"))
# Package options
suppressWarnings(ggthemr('fresh'))  # ggplot theme
opts_knit$set(progress=FALSE, verbose=FALSE)
opts_chunk$set(echo=FALSE, fig.align="center", fig.width=10, fig.height=6.35, results="asis")
options(knitr.kable.NA = '')

source("team_helper_functions.r")

ProjectData <- read.csv("input/data.csv", na.strings=c(""," ","NA"), header=TRUE) # Loading data
ProjectData <- clean(ProjectData)
ProjectData <- data.matrix(ProjectData)
ProjectData_INITIAL <- ProjectData

factor_attributes_used = c(2:ncol(ProjectData))
factor_attributes_used <- intersect(factor_attributes_used, 1:ncol(ProjectData))
ProjectDataFactor <- ProjectData[,factor_attributes_used]
ProjectDataFactor <- data.matrix(ProjectDataFactor)

## Steps 1-2: Check the Data
rownames(ProjectDataFactor) <- paste0("Obs.", sprintf("%02i", 1:nrow(ProjectDataFactor)))
# print(round(my_summary(ProjectDataFactor), 2))

## Step 3: Check Correlations
MIN_VALUE = 0.5
correlations_thres <- round(cor(ProjectDataFactor),2)
correlations_thres[abs(correlations_thres) < MIN_VALUE]<-NA
# print(correlations_thres, scale=TRUE)

## Step 4: Choose number of factors
UnRotated_Results<-principal(ProjectDataFactor, nfactors=ncol(ProjectDataFactor), rotate="none",score=TRUE)
UnRotated_Factors<-round(UnRotated_Results$loadings,2)
UnRotated_Factors<-as.data.frame(unclass(UnRotated_Factors))
colnames(UnRotated_Factors)<-paste("Comp",1:ncol(UnRotated_Factors),sep="")

# Here is how we use the `PCA` function
Variance_Explained_Table_results<-PCA(ProjectDataFactor, graph=FALSE)
Variance_Explained_Table<-Variance_Explained_Table_results$eig
Variance_Explained_Table_copy<-Variance_Explained_Table

rownames(Variance_Explained_Table) <- paste("Component", 1:nrow(Variance_Explained_Table), sep=" ")
colnames(Variance_Explained_Table) <- c("Eigenvalue", "Pct of explained variance", "Cumulative pct of explained variance")

# print(round(Variance_Explained_Table, 2))

eigenvalues  <- Variance_Explained_Table[, "Eigenvalue"]
df           <- cbind(as.data.frame(eigenvalues), c(1:length(eigenvalues)), rep(1, length(eigenvalues)))
colnames(df) <- c("eigenvalues", "components", "abline")
iplot.df(melt(df, id="components")) ## PLOT

## Step 5: Interpret the factors
factor_selection_criterion = "manual"
manual_numb_factors_used = 6 # only used in manual case
factors_selected = manual_numb_factors_used

rotation_used = "varimax"
Rotated_Results<-principal(ProjectDataFactor, nfactors=max(factors_selected), rotate=rotation_used,score=TRUE)
Rotated_Factors<-round(Rotated_Results$loadings,2)
Rotated_Factors<-as.data.frame(unclass(Rotated_Factors))
colnames(Rotated_Factors)<-paste("Comp.",1:ncol(Rotated_Factors),sep="")

sorted_rows <- sort(Rotated_Factors[,1], decreasing = TRUE, index.return = TRUE)$ix
Rotated_Factors <- Rotated_Factors[sorted_rows,]
Rotated_Factors_thres <- Rotated_Factors
Rotated_Factors_thres[abs(Rotated_Factors_thres) < MIN_VALUE]<-NA
colnames(Rotated_Factors_thres)<- colnames(Rotated_Factors)
rownames(Rotated_Factors_thres)<- rownames(Rotated_Factors)
# print(Rotated_Factors_thres, scale=TRUE)

## Step 6:  Save factor scores
NEW_ProjectData <- round(Rotated_Results$scores[,1:factors_selected,drop=F],2)
colnames(NEW_ProjectData)<-paste("Component(Factor)",1:ncol(NEW_ProjectData),sep=" ")

print(t(head(NEW_ProjectData, 10)), scale=TRUE)

# Part 2: Customer Segmentation
ProjectData <- ProjectData_INITIAL # reset initial data

colnames <- colnames(ProjectData)
attribute_names <- c("Is_Resigning", "YearsInCurrentRole", "YearsWithCurrManager", "YearsSinceLastPromotion", "TotalWorkingYears", "JobLevel", "MonthlyIncome", "Department", "PerformanceRating", "EducationField", "DistanceFromHome", "Education", "PercentSalaryHike", "Age", "JobRole", "NumCompaniesWorked")
segmentation_attributes_used = match(attribute_names, colnames(ProjectData))
profile_attributes_used = segmentation_attributes_used
numb_clusters_used = 6

segmentation_attributes_used <- intersect(segmentation_attributes_used, 1:ncol(ProjectData))
profile_attributes_used <- intersect(profile_attributes_used, 1:ncol(ProjectData))

ProjectData_segment <- ProjectData[,segmentation_attributes_used]
ProjectData_profile <- ProjectData[,profile_attributes_used]

ProjectData_scaled <- apply(ProjectData, 2, function(r) if (sd(r)!=0) (r-mean(r))/sd(r) else 0*r)

## Step 3. Select Segmentation Variables
max_data_report = 10
profile_with = "hclust" #  "hclust" or "kmeans"
distance_used = "euclidean" # "euclidean", "maximum", "manhattan", "canberra", "binary" or "minkowski
hclust_method = "ward.D"
kmeans_method = "Lloyd" # "Hartigan-Wong", "Lloyd", "Forgy", "MacQueen").

euclidean_pairwise <- as.matrix(dist(head(ProjectData_segment, max_data_report), method="euclidean"))
euclidean_pairwise <- euclidean_pairwise*lower.tri(euclidean_pairwise) + euclidean_pairwise*diag(euclidean_pairwise) + 10e10*upper.tri(euclidean_pairwise)
euclidean_pairwise[euclidean_pairwise==10e10] <- NA
rownames(euclidean_pairwise) <- colnames(euclidean_pairwise) <- sprintf("Obs.%02d", 1:max_data_report)

Hierarchical_Cluster_distances <- dist(ProjectData_segment, method=distance_used)
Hierarchical_Cluster <- hclust(Hierarchical_Cluster_distances, method=hclust_method)

# Display dendogram
# hcd <- as.dendrogram(Hierarchical_Cluster)
# plot(hcd)
# rect.hclust(Hierarchical_Cluster, k=numb_clusters_used, border="red")

# TODO: Draw dendogram with red borders around the 3 clusters

num <- nrow(ProjectData) - 1
df1 <- cbind(as.data.frame(Hierarchical_Cluster$height[length(Hierarchical_Cluster$height):1]), c(1:num))
colnames(df1) <- c("distances","index")
iplot.df(melt(head(df1, 30), id="index"), xlab="Number of Components", ylab = "Distances")

cluster_memberships_hclust <- as.vector(cutree(Hierarchical_Cluster, k=numb_clusters_used)) # cut tree into as many clusters as numb_clusters_used
cluster_ids_hclust=unique(cluster_memberships_hclust)

ProjectData_with_hclust_membership <- cbind(ProjectData, cluster=cluster_memberships_hclust)
hclust_data <- as.data.frame(ProjectData_with_hclust_membership)
write.csv(ProjectData_with_hclust_membership, "output/hclust.csv")
table(hclust_data$cluster, hclust_data$Is_Resigning)

kmeans_clusters <- kmeans(ProjectData_segment,centers= numb_clusters_used, iter.max=2000, algorithm=kmeans_method)
ProjectData_with_kmeans_membership <- cbind(ProjectData,cluster =kmeans_clusters$cluster)
kmeans_data <- as.data.frame(ProjectData_with_kmeans_membership)
write.csv(ProjectData_with_kmeans_membership, "output/kmeans.csv")

cluster_memberships_kmeans <- kmeans_clusters$cluster
cluster_ids_kmeans <- unique(cluster_memberships_kmeans)

data <- read.csv("output/kmeans.csv", na.strings=c(""," ","NA"), header=TRUE) # Loading data
data <- clean(data)
desc <- describeBy(data, data$cluster, mat = TRUE)

if (profile_with == "hclust"){
  cluster_memberships <- cluster_memberships_hclust
  cluster_ids <-  cluster_ids_hclust
}
if (profile_with == "kmeans"){
  cluster_memberships <- cluster_memberships_kmeans
  cluster_ids <-  cluster_ids_kmeans
}

# WE WILL USE THESE IN THE CLASSIFICATION PART LATER
NewData = matrix(cluster_memberships,ncol=1)
population_average = matrix(apply(ProjectData_profile, 2, mean), ncol=1)
colnames(population_average) <- "Population"
Cluster_Profile_mean <- sapply(sort(cluster_ids), function(i) apply(ProjectData_profile[(cluster_memberships==i), ], 2, mean))
if (ncol(ProjectData_profile) <2)
  Cluster_Profile_mean=t(Cluster_Profile_mean)
colnames(Cluster_Profile_mean) <- paste("Seg.", 1:length(cluster_ids), sep="")
cluster.profile <- cbind (population_average,Cluster_Profile_mean)

print(round(cluster.profile, 2))

ProjectData_scaled_profile = ProjectData_scaled[, profile_attributes_used,drop=F]

Cluster_Profile_standar_mean <- sapply(sort(cluster_ids), function(i) apply(ProjectData_scaled_profile[(cluster_memberships==i), ,drop = F], 2, mean))
if (ncol(ProjectData_scaled_profile) < 2)
  Cluster_Profile_standar_mean = t(Cluster_Profile_standar_mean)
colnames(Cluster_Profile_standar_mean) <- paste("Seg ", 1:length(cluster_ids), sep="")

iplot.df(melt(cbind.data.frame(idx=as.numeric(1:nrow(Cluster_Profile_standar_mean)), Cluster_Profile_standar_mean), id="idx"), xlab="Profiling variables (standardized)",  ylab="Mean of cluster")

population_average_matrix <- population_average[,"Population",drop=F] %*% matrix(rep(1,ncol(Cluster_Profile_mean)),nrow=1)
cluster_profile_ratios <- (ifelse(population_average_matrix==0, 0,Cluster_Profile_mean/population_average_matrix))
colnames(cluster_profile_ratios) <- paste("Seg.", 1:ncol(cluster_profile_ratios), sep="")
rownames(cluster_profile_ratios) <- colnames(ProjectData)[profile_attributes_used]
## printing the result in a clean-slate table
print(round(cluster_profile_ratios-1, 2))

Rotated_Factors_thresx <- cluster_profile_ratios-1
Rotated_Factors_thresx[abs(Rotated_Factors_thresx) < 0.1]<-NA
colnames(Rotated_Factors_thresx)<- colnames(cluster_profile_ratios)
rownames(Rotated_Factors_thresx)<- rownames(cluster_profile_ratios)

print(round(Rotated_Factors_thresx, 2))

a <- table(ProjectData_with_hclust_membership)


##Raster= raster
##Suavizado=output raster
##output_plots_to_html
##showplots
##Ventana=selection 3x3;5x5;9x9;13x13
##Metodo=selection media;mediana;maximo;minimo;moda

type<-Ventana
type1<-Metodo

library(raster)

if(type==0){celda <- 3}
if(type==1){celda <- 5}
if(type==2){celda <- 9}
if(type==3){celda <- 13}

print(paste(celda,"x",celda))
ventana<-matrix(1,nrow=celda,ncol=celda)

if(type1==0){suaveraster<-focal(Raster[[1]],w=ventana,fun=mean,na.rm=TRUE); print("Se aplico la media")}
if(type1==1){suaveraster<-focal(Raster[[1]],w=ventana,fun=median,na.rm=TRUE); print("Se aplico la mediana")}
if(type1==2){suaveraster<-focal(Raster[[1]],w=ventana,fun=max,na.rm=TRUE); print("Se aplico la maxima")}
if(type1==3){suaveraster<-focal(Raster[[1]],w=ventana,fun=min,na.rm=TRUE); print("Se aplico la minima")}
if(type1==4){suaveraster<-focal(Raster[[1]],w=ventana,fun=modal,na.rm=TRUE); print("Se aplico la moda")}

Suavizado <- suaveraster


divisors <- function (n) {
  Filter( function (m) 0 == n %% m, 1:(n/2) )
}

table = sapply(1:19999, function (n) sum(divisors(n)) )

for (n in 1:19999) {
  m = table[n]
  if ((m > n) && (m < 20000) && (n == table[m]))
    cat(n, " ", m, "\n")
}


# Assignment: ASSIGNMENT 00
# Name: Bagam, Naveen
# Date: 2021-12-12

# Basics

## Add 8 and 5

> 8+5
[1] 13

## Subtract 6 from 22

> 6-22
[1] -16

## Multiply 6 by 7

 6*7
[1] 42

## Add 4 to 6 and divide the result by 2

> (4+6)/2
[1] 5

## Compute 5 modulo 2

> 5%%2
[1] 1

## Assign the value 82 to the variable x
## Print x

> x<-82
> x
[1] 82

## Assign the value 41 to the variable y
## Print y

> y <- 41
> y
[1] 41

## Assign the output of x + y to the variable z
## Print z

> z<-x+y
> z
[1] 123

## Assign the string value "DSC520" to the variable class_name
## Print the value of class_name

> class_name = "DSC520"
> class_name
[1] "DSC520"

## Assign the string value of TRUE to the variable is_good
## Print the value of is_good

> is_good = TRUE
> is_good
[1] TRUE
>

## Check the class of the variable is_good using the `class()` function

> class(is_good)
[1] "logical"
>

## Check the class of the variable z using the `class()` function

> class(z)
[1] "numeric"
>

## Check the class of the variable class_name using the class() function
> class(class_name)
[1] "character"
>


library(Rglpk)
library(ggplot2)

dim <- 2

N1 <- 5
N2 <- 5

# the points of sets A and B
P <- matrix(
  runif(dim*N1 + dim*N2,0,1),
  ncol=dim,byrow=T
)

# the matrix A defining the lhs of the conditions
A <- cbind(P * c(rep(-1,N1),rep(1,N2)), c(rep(1,N1),rep(-1,N2)))

# the objective function - no optimization necessary
obj <- rep(0, dim+1)

# the vector b defining the rhs of the conditions
b <- rep(-1, N1+N2)

# by default GLPK assums positive boundaries for the
# variables. but we need the full set of real numbers.
bounds <- list(
  lower = list(ind = 1:(dim+1), val = rep(-Inf, dim+1)),
  upper = list(ind = 1:(dim+1), val = rep(Inf, dim+1))
)

# solving the linear program
s <- Rglpk_solve_LP(obj, A, rep("<=", N1+N2), b, bounds=bounds)

df <- as.data.frame(P)

par(pty="s")
p <- plot(P,col=c(rep("red",N1),rep("blue",N2)), xlab="x", ylab="y",
     cex=1, pch=16, xlim=c(0,1), ylim=c(0,1))

p

plt <- ggplot()

# status 0 means that a solution was found
if(s$status == 0) {
  h1 = s$solution[1]
  h2 = s$solution[2]
  beta = s$solution[3]

  # drawing the separating line
  if(h2 != 0) {
    abline(beta/h2,-h1/h2)
  } else {
    abline(v=-beta/h1)
  }
} else {
  cat("Not linearly separable.")
}


# Always generate the same data
set.seed(111)

# Number of samples
sample_size = 3000
iteration_count = 200
training_size = 0.8 * sample_size
validation_size = 0.1 * sample_size
test_size = 0.1 * sample_size

###################################################################
# To generate the waveform data we use mlbench
# mlbench uses Breiman's original waveform source modified for R
library(mlbench)
waves = mlbench.waveform(sample_size)
data = data.frame(cbind(waves$x, waves$class))

# Create train, test and validation sets for the entire data
training_set = data[1:training_size, ]
validation_set = data[(training_size + 1):(training_size + validation_size), ]
test_set = data[(training_size + validation_size + 1):(training_size + validation_size + test_size), ]
###################################################################

###################################################################
# Compute parameters for w1
w1_covar = var(training_set[training_set$X22 == 1, 1:21])
w1_mean = apply(training_set[training_set$X22 == 1, 1:21], 2, mean)
w1_variance = apply(training_set[training_set$X22 == 1, 1:21], 2, var)
###################################################################

###################################################################
# Compute parameters for w2
w2_covar = var(training_set[training_set$X22 == 2, 1:21])
w2_mean = apply(training_set[training_set$X22 == 2, 1:21], 2, mean)
w2_variance = apply(training_set[training_set$X22 == 2, 1:21], 2, var)
###################################################################

###################################################################
# Compute parameters for w3
w3_covar = var(training_set[training_set$X22 == 3, 1:21])
w3_mean = apply(training_set[training_set$X22 == 3, 1:21], 2, mean)
w3_variance = apply(training_set[training_set$X22 == 3, 1:21], 2, var)
###################################################################

###################################################################
# Mixtools will be used to compute parameters for Gaussian
library(mixtools)

# The maximum posssible error is equal to number of elements in validation
min_error = nrow(validation_set)

# We will sample 9 numbers with replacement from the following list
c_values = seq(from = 0, to = 2, by = 0.1)

# The best means
w11_mean_p = w12_mean_p = w13_mean_p = w21_mean_p = w22_mean_p = w23_mean_p = w31_mean_p = w32_mean_p = w33_mean_p = rep(0, 3)

# Now we randomly sample the
for (i in 1:iteration_count) {
	print (i)

	# Sample 9 random values from the set with replacement
	c_sample = c_values[sample(1:length(c_values), 9, replace = TRUE)]

	# Compute the classification error
	error = 0
	for (i in 1:nrow(validation_set)) {
		# Consider the ith vector in the validation_set
		vec = as.matrix(validation_set[i, ])

		# Compute density for w1
		w11_density = dmvnorm(vec[1:21], mu = w1_mean + c_sample[1] * w1_var, sigma = w1_covar)
		w12_density = dmvnorm(vec[1:21], mu = w1_mean + c_sample[2] * w1_var, sigma = w1_covar)
		w13_density = dmvnorm(vec[1:21], mu = w1_mean + c_sample[3] * w1_var, sigma = w1_covar)
		# We assume that each of the gaussians has equal probability
		w1_density = w11_density + w12_density + w13_density

		# Compute density for w2
		w21_density = dmvnorm(vec[1:21], mu = w2_mean + c_sample[4] * w2_var, sigma = w2_covar)
		w22_density = dmvnorm(vec[1:21], mu = w2_mean + c_sample[5] * w2_var, sigma = w2_covar)
		w23_density = dmvnorm(vec[1:21], mu = w2_mean + c_sample[6] * w2_var, sigma = w2_covar)
		# We assume that each of the gaussians has equal probability
		w2_density = w21_density + w22_density + w23_density

		# Compute density for w3
		w31_density = dmvnorm(vec[1:21], mu = w3_mean + c_sample[7] * w3_var, sigma = w3_covar)
		w32_density = dmvnorm(vec[1:21], mu = w3_mean + c_sample[8] * w3_var, sigma = w3_covar)
		w33_density = dmvnorm(vec[1:21], mu = w3_mean + c_sample[9] * w3_var, sigma = w3_covar)
		# We assume that each of the gaussians has equal probability
		w3_density = w31_density + w32_density + w33_density

		# If wrongly labelled then we count it as an error
		category = which.max(c(w1_density, w2_density, w3_density))
		if (category != vec[22]) {
			error = error + 1
		}
	}

	# If the error is smaller than the current error
	if (error < min_error) {
		min_error = error
		w11_mean_p = w1_mean + c_sample[1] * w1_var
		w12_mean_p = w1_mean + c_sample[2] * w1_var
		w13_mean_p = w1_mean + c_sample[3] * w1_var
		w21_mean_p = w2_mean + c_sample[4] * w2_var
		w22_mean_p = w2_mean + c_sample[5] * w2_var
		w23_mean_p = w2_mean + c_sample[6] * w2_var
		w31_mean_p = w3_mean + c_sample[7] * w3_var
		w32_mean_p = w3_mean + c_sample[8] * w3_var
		w33_mean_p = w3_mean + c_sample[9] * w3_var
	}
}
###################################################################

# Compute the classification error
error = 0
for (i in 1:nrow(test_set)) {
	# Consider the ith vector in the validation_set
	vec = as.matrix(test_set[i, ])

	# Compute density for w1
	w11_density = dmvnorm(vec[1:21], mu = w11_mean_p, sigma = w1_covar)
	w12_density = dmvnorm(vec[1:21], mu = w12_mean_p, sigma = w1_covar)
	w13_density = dmvnorm(vec[1:21], mu = w13_mean_p, sigma = w1_covar)
	# We assume that each of the gaussians has equal probability
	w1_density = w11_density + w12_density + w13_density

	# Compute density for w2
	w21_density = dmvnorm(vec[1:21], mu = w21_mean_p, sigma = w2_covar)
	w22_density = dmvnorm(vec[1:21], mu = w22_mean_p, sigma = w2_covar)
	w23_density = dmvnorm(vec[1:21], mu = w23_mean_p, sigma = w2_covar)
	# We assume that each of the gaussians has equal probability
	w2_density = w21_density + w22_density + w23_density

	# Compute density for w3
	w31_density = dmvnorm(vec[1:21], mu = w31_mean_p, sigma = w3_covar)
	w32_density = dmvnorm(vec[1:21], mu = w32_mean_p, sigma = w3_covar)
	w33_density = dmvnorm(vec[1:21], mu = w33_mean_p, sigma = w3_covar)
	# We assume that each of the gaussians has equal probability
	w3_density = w31_density + w32_density + w33_density

	# If wrongly labelled then we count it as an error
	category = which.max(c(w1_density, w2_density, w3_density))
	if (category != vec[22]) {
		error = error + 1
	}
}

# If the error is smaller than the current error
if (error < min_error) {
	min_error = error
	w11_mean_p = w1_mean + c_sample[1] * w1_var
	w12_mean_p = w1_mean + c_sample[2] * w1_var
	w13_mean_p = w1_mean + c_sample[3] * w1_var
	w21_mean_p = w2_mean + c_sample[4] * w2_var
	w22_mean_p = w2_mean + c_sample[5] * w2_var
	w23_mean_p = w2_mean + c_sample[6] * w2_var
	w31_mean_p = w3_mean + c_sample[7] * w3_var
	w32_mean_p = w3_mean + c_sample[8] * w3_var
	w33_mean_p = w3_mean + c_sample[9] * w3_var
}

rate = error / nrow(test_set)


require(rms)
set.seed(1)
x1 <- rnorm(100)
x2 <- rnorm(100)
y <- x1 + x2 + rnorm(100)
x1[1:10] <- NA
a <- aregImpute(~ y + x1 + x2)
f <- fit.mult.impute(y ~ x1 + x2, ols, a, data=data.frame(x1,x2,y),
                     n.impute=3, fit.reps=TRUE)
## Show how fit.mult.impute estimates sigma^2
s <- 0
for(i in 1 : 3) s <- s + f$fits[[i]]$stats['Sigma']
c(s / 3, f$stats['Sigma'])

anova(f, test='Chisq')
## Make sure the chi-squares and sums of squares are not from one of the models
for(i in 1 : 3) print(anova(f$fits[[i]], test='Chisq'))


# https://www.r-bloggers.com/rsi2-with-position-sizing/
# Attach the quantmod and TTR packages.
# You can install packages via:
# install.packages(c(“quantmod”,”TTR”))
library(quantmod)
library(TTR)
# Pull SPL data from Yahoo! Finance
getSymbols("SPL.AX", from="2007-01-01", to="2018-01-09")
SPL<-SPL[complete.cases(SPL),]                                                  # Delete NA

# Calculate the RSI indicator
rsi <- RSI(Cl(SPL),2) # Calculate Close-to-Close returns
# (this assumes we open/close our positions
# at each day's close)
ret <- ROC(Cl(SPL))
ret[1] <- 0 # Define our position-sizing function
rsi2pos <- function(ind, indIncr=5, posIncr=0.25) {
# Inputs:
# ind : indicator vector
# indIncr : indicator value increments/breakpoints
# posIncr : position value increments/breakpoints

# Initialize result vector
size <- rep(0,NROW(ind)) # Long
size <- ifelse(ind < 4*indIncr, (1-posIncr*3), size)
size <- ifelse(ind < 3*indIncr, (1-posIncr*2), size)
size <- ifelse(ind < 2*indIncr, (1-posIncr*1), size)
size <- ifelse(ind < 1*indIncr, (1-posIncr*0), size) # Short
size <- ifelse(ind > 100-4*indIncr, 3*posIncr-1, size)
size <- ifelse(ind > 100-3*indIncr, 2*posIncr-1, size)
size <- ifelse(ind > 100-2*indIncr, 1*posIncr-1, size)
size <- ifelse(ind > 100-1*indIncr, 0*posIncr-1, size)

# Today's position (size) is based on today's
# indicator, but we need to apply today’s position
# to the Close-to-Close return at tomorrow's close.
size <- lag(size) # Replace missing signals with no position
# (generally just at beginning of series)
size[is.na(size)] <- 0 # Return results
return(size)
}

# Calculate signals using the 'rsi2pos()' function
sig <- rsi2pos(rsi, 5, 0.25) # Break out the long (up) and short (dn) signals
sigup <- ifelse(sig > 0, sig, 0)
sigdn <- ifelse(sig < 0, sig, 0) # Calculate equity curves
eq_up <- cumprod(1+ret*sigup)
eq_dn <- cumprod(1+ret*sigdn)
eq_all <- cumprod(1+ret*sig)          # Replicate Michael's nice chart (again)

png(filename = "20090430_rsi2_replication.png")
plot.zoo(cbind(eq_up,eq_dn), plot.type = "single",
    ylab = c("Long", "Short"), col = c("green","red"),
    main = "RSI(2) Strategy With Position Scaling")
dev.off()

# Calculate signals using the 'rsi2pos()' function
# with new values
sig <- rsi2pos(rsi, 10, 0.3) # Break out the long (up) and short (dn) signals
sigup <- ifelse(sig > 0, sig, 0)
sigdn <- ifelse(sig < 0, sig, 0) # Calculate equity curves
eq_up <- cumprod(1+ret*sigup)
eq_dn <- cumprod(1+ret*sigdn)
eq_all <- cumprod(1+ret*sig) # Re-plot equity curves using updated values

png(filename = "20090501_rsi2_updated.png")
plot.zoo(cbind(eq_up,eq_dn), plot.type = "single",
         ylab = c("Long", "Short"), col = c("green","red"),
         main = "Updated RSI(2) Strategy With Position Scaling:n")
dev.off()


#Find the first 8 happy numbers
happies <- c()
i <- 1L
while(length(happies) < 8L)
{
   if(is.happy(i)) happies <- c(happies, i)
   i <- i + 1L
}
happies


###############################################################
#
# Mark Cembrowski, Janelia Research Campus, Nov 7 2016
#
# This script plots the average expression, +/- SD, across
# a list of genes for each cell type in the dataset.
#
###############################################################

singleCellMultigene <- function(theGenes,rMax=-1,quiet=T){

	theClasses <- c('pyramidal CA1','oligodendrocytes',
			'interneurons','astrocytes_ependymal',
			'microglia','endothelial-mural')

	subMeta <- subset(scMeta,tissue=='ca1hippocampus')

	allStats <- as.data.frame(matrix(nrow=0,ncol=4))
	allMeans <- as.data.frame(matrix(nrow=0,ncol=nrow(subMeta)))

	geneInMat <- theGenes[theGenes%in%rownames(scHip)]
	subMat <- scHip[geneInMat,]

	for (curClass in theClasses){
		toKeep <- subMeta$level1class==curClass

		# Print out total number of entries.
		if(!quiet){
			print(paste('For class',curClass,'the number of cells is',sum(toKeep)))
		}

		curMat <- subMat[,toKeep]
		curStats <- c( mean(apply(curMat,1,mean)),
				sd(apply(curMat,1,mean)),
				mean(apply(curMat,1,mean))-sd(apply(curMat,1,mean)),
				mean(apply(curMat,1,mean))+sd(apply(curMat,1,mean)))

		allStats <- rbind(allStats,curStats)

		curMeans <- apply(curMat,1,mean)
		allMeans <- rbind(allMeans,curMeans)
		colnames(allMeans) <- names(curMeans)
		rownames(allMeans)[nrow(allMeans)] <- curClass
	}
	rownames(allStats) <- theClasses
	colnames(allStats) <- c('mean','sd','lo','hi')
	allStats[,'grp'] <- rownames(allStats)

	allMeansMelt <- melt(as.matrix(allMeans))
	colnames(allMeansMelt) <- c('grp','gene','mean')

	colourRule <- c('astrocytes_ependymal'='blue',
			'interneurons'='purple','microglia'='green',
			'oligodendrocytes'='brown','endothelial-mural'='red','pyramidal CA1'='grey')

	gg <- ggplot(allStats,aes(x=grp,y=mean)) + geom_bar(stat='identity',aes(colour=grp),fill='white')
	gg <- gg + geom_point(data=allMeansMelt,alpha=0.3,aes(colour=grp))
	gg <- gg + geom_errorbar(aes(ymin=mean,ymax=hi),width=0.5)
	gg <- gg + theme_bw() + scale_color_manual(values=colourRule)
	gg <- gg + scale_x_discrete(limits=c('pyramidal CA1','interneurons','oligodendrocytes',
				'astrocytes_ependymal','endothelial-mural','microglia'))
	if(rMax>0){
		gg <- gg + scale_y_continuous(lim=c(0,rMax))
	}
	print(gg)

}


rm(list=ls())
library(sas7bdat)
library(Hmisc)

crack<-read.sas7bdat("crack.sas7bdat")

#1
crack$crack_spread <- crack$gas_price-crack$oil_price
crack$d_crack_spread <- 100*crack$crack_spread/crack$CPI
crack$lagd_crack_spread <- Lag(crack$d_crack_spread, +1)
crack$cap_util <- crack$production/crack$capacity

#2
reg1 <- lm(d_crack_spread ~ cap_util + lagd_crack_spread, data=crack)
summary(reg1)

#3
reg2 <- lm(production ~ year, data=crack)
summary(reg2)

reg3 <- lm(capacity ~ year, data=crack)
summary(reg3)


radiomarketingData<- read.csv("radiomarketing.csv")

plot(radiomarketingData$Radio,radiomarketingData$Sales)

set.seed(100)
trainindices_1= sample(1:nrow(radiomarketingData), 0.7*nrow(radiomarketingData))

train.Radio = radiomarketingData[trainindices_1,]

test.radio.problem = radiomarketingData[-trainindices_1,]

model_1<- lm(Sales~Radio,data=train.Radio)

summary(model_1)

predict_2<- predict(model_1,test.radio.problem[-2])


# Compute multivariate ESS using multiESS function of mcmcse package

## Load libraries

library(mcmcse)

## Read chains

chains <- read.table(file="chain01.csv", header=FALSE, sep=",")

## Compute multivariate ESS using INSE MC covariance estimation

print(multiESS(chains, covmat=mcse.initseq(chains)$cov))

## Compute multivariate ESS batch mean MC covariance estimation

print(multiESS(chains))

# print(multiESS(chains, covmat=mcse.multi(chains)$cov)) # Same as print(multiESS(chains))


library(caret)
library(ggfortify)
library(rpart)
library(rpart.plot)
library(RSQLite)
library(DBI)
library(randomForest)
library(e1071)

classify_knn = function(pca.data, obs_data, point, k){
  neighs = get_nn(pca.data, point, k)
  neigh_data = obs_data[neighs,]
  return(names(which.max(table(neigh_data$fld))))
}

get_nn = function(d, point, k){
  point = d[point, ]
  dists = sort(sqrt(rowSums((t(t(d) - point))^2)))
  close_points = names(dists)[2:k]
  return(close_points)
}

base_dir<- "C:/Users/Jeff/Documents/research/Sadler_3rdPaper/manuscript/"
data_dir<- paste(base_dir, "Data/", sep="")
fig_dir <- paste(base_dir, "Figures/general/", sep="")
db_filename <- "floodData.sqlite"
print(paste(data_dir, db_filename))
con = dbConnect(RSQLite::SQLite(), dbname=paste(data_dir, db_filename, sep=""))

dbListTables(con)

df = dbReadTable(con, 'for_model')
df = subset(df, rain_daily_sum>0.1) # only look at days that have over 0.1 in of rainfall
df = df[!is.na(df$gw_daily_avg),] # remove null gw values
short_names = c('rd', 'rhr', 'rhmxtime', 'r15', 'r15mxtime', 'r3d', 'gw', 'td', 'tr15mx', 'trhrmx', 'wdd', 'wvd',  'wvh', 'nfld', 'fld', 'evnme', 'evdte')
colnames(df) = short_names

in_col_names = c('rd', 'rhr', 'r15', 'r3d', 'gw', 'td', 'wvd', 'tr15mx', 'trhrmx')
out_col_name = 'fld'
data = df[, c(in_col_names, out_col_name)]
data$fld = df$fld>0

# pca
pca_data = data.frame(scale(data))
pca = prcomp(pca_data)
pca$x = -pca$x
pca$rotation=-pca$rotation
p = ggplot(pca$x[,c(1,2)], aes(x=PC1, y=PC2, colour=data[, out_col_name], label=rownames(pca$x)))
p + geom_point() +geom_text()
point = "19"
neighs = get_nn(pca$x, "1697", 11)
data[neighs,]

data$fld = factor(data$fld)
prt = createDataPartition(data$fld, p=0.7)
train_ind = prt$Resample1

# knn
for (row_name in row.names(pca$x)){
  data[row_name, 'pred_knn'] = classify_knn(pca$x, data, row_name, 5)
}
kfit = knn(pca$x[train_ind, ], pca$x[-train_ind, ], data[train_ind, 'fld'], k=5)
table(data[-train_ind, 'fld'], kfit)

# svm
svm_fit = svm(x=pca$x[train_ind,], y=data[train_ind, 'fld'])
svm_pred = predict(svm_fit, pca$x[-train_ind,])
table(data[-train_ind, out_col_name], svm_pred)

# decision tree
fmla = as.formula(paste(out_col_name, "~", paste(in_col_names, collapse="+")))

fit = rpart(fmla, method='class', data=data[train_ind, ], minsplit=2)
printcp(fit)

tiff(paste(fig_dir, "Plot2.tif"), width=9, height=6, units='in', res = 300)
rpart.plot(fit, under=TRUE, cex=0.9, extra=1, varlen = 6)
dev.off()
rpart.plot(fit, under=TRUE, cex=0.9, extra=1, varlen = 6)

pfit<- prune(fit, cp=fit$cptable[which.min(fit$cptable[,"xerror"]),"CP"])
rpart.plot(pfit, under=TRUE, cex=0.9, extra=1, varlen = 6)

pred = predict(pfit, data[train_ind, in_col_names], type = 'class')
true_fld = data[train_ind, 'fld']
print('DT train')
table(data[train_ind, out_col_name], pred)

pred = predict(pfit, data[-train_ind, in_col_names], type = 'class')
true_fld = data[train_ind, 'fld']
print('DT test')
table(data[-train_ind, out_col_name], pred)

# creating predictive model
forest = randomForest(fmla, data = data[train_ind, ], importance = TRUE, type="classification", nodesize=2)

# check on training data
pred = predict(forest, data[train_ind, in_col_names])
true_fld = data[train_ind, 'fld']
print('RF train')
print(sum(pred == true_fld)/length(true_fld))
table(data[train_ind, out_col_name], pred)

# check on testing data
pred = predict(forest, data[-train_ind, in_col_names])
true_fld = data[-train_ind, 'fld']
print('RF test')
table(data[-train_ind, out_col_name], pred)
forest$importance


# NOTE: This is the first thing I've ever written in R!
# I had to learn R to solve this programming problem during the competition.
# I'm very proud of this code.

f <- file("stdin")
on.exit(close(f))

T <- readLines(f)
T <- strsplit(T, " ")

testcases <- as.numeric(T[[1]])

for(q in 1:testcases) {
    testcase_input = T[[q+1]]
    A = as.numeric(testcase_input[[1]])
    B = as.numeric(testcase_input[[2]])
    V = as.numeric(testcase_input[[3]])

    constants = pi/(4*A**2)
    f_of_y = function(x){
        return((4*A*log(x) + 2*B**2 - 2*B*sqrt(4*A*log(x)+B**2)))
    }

    goal = V
    accuracy = .2
    test_inp = 1
    test_result = integrate(f_of_y, 1, test_inp)[[1]]

    step_sizes = list(.01, .05, .1, .2, 1, 5, 10)
    step_pos = length(step_sizes)
    last_val = -1

    while (!((goal-accuracy) <=  test_result && test_result <= (goal+accuracy))) {
        poss_new_val = integrate(f_of_y, 1, test_inp+step_sizes[[step_pos]])[[1]]*constants
        #print(step_pos)
        #print(poss_new_val)
        if (poss_new_val > goal+accuracy){
            if(step_pos != 1){
                step_pos = step_pos - 1
                next
            }
        } else {
            test_inp = step_sizes[[step_pos]] + test_inp
            test_result = poss_new_val
        }
        #print("last")
        #print(last_val)
        #print("test")
        #print(test_result)
        # Check if the code is getting stuck in a loop
        # If it is, break, since the actual value is nearby
        if(last_val == test_result){
            break
        }
        last_val = test_result
    }

    # Test to see if there's a better fit nearby
    ret = test_inp
    min_err = abs(V - test_result)

    # Make sure the range of the inputs fit the range of the problem/function
    left_bound = max(1, test_inp-.5)
    for(i in seq(left_bound, test_inp+.5, .01)){
        res = integrate(f_of_y, 1, i)[[1]]*constants
        err = abs(V-res)
        if(err < min_err){
            min_err = err
            ret = i
        }
    }

    ret = format(round(ret, 2), nsmall = 2)
    write(ret, stdout())
}


###########################################################################
#       Pricing European Put Options Through Simulated Levy Processes
#       Research proposed by Liming Feng, Zisheng Chen, and Xiong Lin
#               University of Illinois, Urbana-Champaign
#
# Created by Joseph Loss on 12/17/2018
# Co-developers: Yuchen Duan (UIUC MSFE) and Daniel Liberman (UIC Finance)
#
# Algorithm 1: Simulating a Normal Inverse Gaussian process through a Brownian subordination
#
###########################################################################
# set.seed(2017)
library(tictoc)

no_of_simulations.1 <-  256 * 10 ^ 3
no_of_simulations.2 <- (256 * 4) * 10 ^ 3
no_of_simulations.3 <- (256 * 8) * 10 ^ 3
no_of_simulations.4 <- (256 * 16) * 10 ^ 3
no_of_simulations.5 <- (256 * 32) * 10 ^ 3
no_of_simulations.6 <- (256 * 64) * 10 ^ 3

no_of_simulations.list <- c(no_of_simulations.1, no_of_simulations.2,
                            no_of_simulations.3, no_of_simulations.4,
                            no_of_simulations.5, no_of_simulations.6)

for (i in 1:6)
{
  # Input Parameters --------------------------------------------------------
  # taken from Feng et al, pg.22-23
  alpha = 15;
  beta = -5;
  delta = 0.5;
  r = 0.05;
  q = 0.02;
  s0 = 100;
  K = s0;
  T = 0.5;
  N = 1.0;

  # no_of_simulations = no_of_simulations.list[i];       # run through difference total no_of_simulations back-to-back
  no_of_simulations = no_of_simulations.3;       # change number of iterations here

  # calculate mu using the formula given at the top of pg. 19
  mu = r - q + delta*(sqrt(alpha^2 - (beta+1)^2) - sqrt(alpha^2 - beta^2));

  # calculate gamma using the formula given in the Algorithm 1 pseudocode
  gamma = sqrt(alpha^2 - beta^2)

  stock_prc <- rep(0, no_of_simulations)       # create array of possible stock_prices (1 for each iteration)
  put_prc <- rep(0, no_of_simulations)         # create array of possible put_prices (1 for each iteration)
  call_prc <- rep(0, no_of_simulations)        # create array of possible call_prices (1 for each iteration)
  euro_vanilla_put <- rep(0, no_of_simulations)
  nigv <- rep(0, no_of_simulations)            # create NIG random vector

  # Box-Muller Function Template --------------------------------------------
  BoxMuller <- function()
  {
    n = 2 * N
    z = numeric(n)

    u1 = runif(n / 2, 0, 1)
    u2 = runif(n / 2, 0, 1)

    z1 = sqrt(-2 * log(u1)) * cos(2 * pi * u2)      # half of normal variates
    z2 = sqrt(-2 * log(u1)) * sin(2 * pi * u2)      # other half
    z[seq(1, n, by = 2)] = z1                   # interleave
    z[seq(2, n, by = 2)] = z2                   # two halves

    return(z1)                                # return half
  }

  # Algorithm 1: Normal Inverse Gaussian, Monte-Carlo Simulation --------------------------------------------
  for (j in 1:no_of_simulations)
  {
    # Step 1: Generate G1 and compute zeta --------------------------------------------------
    G1 <- BoxMuller()           # generate standard normal random variable G1
    Z <- (G1^2)/gamma              # compute Z

    zeta <- rep(0, N)
    for (i in 1:N)
    {
      zeta[i] = (1/gamma)*((delta*T) + (0.5*Z[i]) - sqrt((delta*T*Z[i]) + (Z[i]^2)/4))
    }

    # Step 2: Generate uniform random variable U on (0,1) -----------------------------------
    Uniform <- function()       # function to generate uniform r.v. using Algorithm 1, Step 2, on pg. 17
    {
      U = runif(N, 0, 1)
      zt <- rep(0, N)
      for (i in 1:N)
      {
        if (U[i] < (delta*T) / ((delta*T) + gamma * zeta[i])) {
          zt[i] = zeta[i]
        } else  {
          zt[i] = (delta ^ 2 * T^2) / (gamma ^ 2 * zeta[i])
        }
      }
      return(zt)
    }

    zt = Uniform()          # generate zt using uniform function above

    # Step 3: Generate StdNorm variable G2 -------------------------------------------------
    G2 <- rnorm(1,0,1)

    St <- rep(0, N)        # create empty vector for St
    Xt <- rep(0, N)        # create empty vector for Xt

    for (i in 1:N)
    {
      Xt[i] = mu * T + beta * zt[i] + sqrt(zt[i]) * G2[i]     # compute Xt = mu*t + beta*zt + sqrt(zt)*G2
      St[i] = s0 * exp(Xt[i])                         # from pg 16. compute St = S0 * e^(Xt)
    }

    stock_prc[j] = St[N]                                  # reassign variable, ie St = ST (stock value at maturity)
    put_prc[j] = exp(-r*T) * max(0, K - stock_prc[j])     # compute put price at maturity
    call_prc[j] = exp(-r*T) * max(0, stock_prc[j] - K)    # compute call price at maturity
    nigv[j] = Xt[N]

    # Section 5.4, pg.19: European Vanilla Options -------------------------------------------
    # We also calculate the option value "V" using the formula given in Section 5.4.

    # note that the resulting output is identical
    # to the result we generated through St = S0 * e^(Xt) above.
    euro_vanilla_put[j] = s0 * exp(-r * T) * max(0, K/s0 - exp(log(stock_prc[j] / s0)))

  }
  # END MonteCarlo Simulation --------------------------------------------------------------
  # ----------------------------------------------------------------------------------------
}

  # Average the computed prices: -----------------------------------------------------------
  "NIG Stock Price (t=T)"
  sum(stock_prc) / no_of_simulations

  NIG_Put_Value <- sum(euro_vanilla_put) / no_of_simulations
  "NIG Put Value: "
  NIG_Put_Value

  # NIG_Put_Prc <- sum(put_prc) / no_of_simulations
  # "NIG Put Value: "
  # NIG_Put_Prc
  # euro_vanilla_put.value <- sum(euro_vanilla_put) / no_of_simulations
  # "European Vanilla Put Value: "
  # euro_vanilla_put.value

  # values.table <- cbind(NIG_Put_Prc, euro_vanilla_put.value)
  # values.table

  toc(log = TRUE)
  tic.clearlog()
  tic.clear()

# Model Benchmarking & Verification ------------------------------------------------------------------
# NIG Verification --------------------------------------------------------
library(GeneralizedHyperbolic)      # testing our NIG model with GeneralizedHyperbolic built-in "rnig"

GenHyp.NIG <- rnig(no_of_simulations, delta=delta, alpha=alpha, beta=beta)+mu
algo1.NIG <- nigv

par(mfrow=c(1,2))       # Plot NIG distributions

# GeneralizedHyperbolic NIG Histogram
GenHyp.NIG.hist <-
  hist(GenHyp.NIG,
       breaks = 40,
       col = "grey",
       main = "GeneralizedHyperbolic NIG")
xfit <- seq(min(GenHyp.NIG), max(GenHyp.NIG), length = 40)
yfit <- dnorm(xfit, mean = mean(GenHyp.NIG), sd = sd(GenHyp.NIG))
yfit <- yfit * diff(GenHyp.NIG.hist$mids[1:2]) * length(GenHyp.NIG)
lines(xfit, yfit, col = "blue", lwd = 3)

# Algorithm 1 NIG Histogram
algo1.NIG.hist <-
  hist(algo1.NIG,
       breaks = 40,
       col = "grey",
       main = "Algorithm 1 NIG")
xfit <- seq(min(algo1.NIG), max(algo1.NIG), length = 40)
yfit <- dnorm(xfit, mean = mean(algo1.NIG), sd = sd(algo1.NIG))
yfit <- yfit * diff(algo1.NIG.hist$mids[1:2]) * length(algo1.NIG)
lines(xfit, yfit, col = "blue", lwd = 3)

# NIG Mean Comparison
GenHyp.NIG.mu <- (mean(rnig(no_of_simulations, delta=delta, alpha=alpha, beta=beta)+mu))
GenHyp.NIG.mu
algo1.NIG.mu = mean(nigv)                            # our NIG
algo1.NIG.mu

nig_comparison_table <- cbind(algo1.NIG.mu, GenHyp.NIG.mu)
nig_comparison_table

(algo1.NIG.mu - GenHyp.NIG.mu)/GenHyp.NIG.mu         # computed difference in model means

nig_comparison_table

# RQuantLib::EuropeanOption('put',s0,K,q,r,T,0.191)


N0 <- 100
y0 <- 10

library(rstan)
rstan_options(auto_write = TRUE)

options(mc.cores = 4)
rstan:::rstudio_stanc("stan/simple_bernoulli_prior.stan")

#### Sampling from the "prior"
compiled.model.prior <- stan_model("stan/simple_bernoulli_prior.stan")

cc <- 1/2
dd <- 1/2
bb.data <- list(
  N0 = N0,
  y0 = y0,
  c = cc,
  d = dd,
  a_0 = .4
)

prior.bern <- sampling(compiled.model.prior, data = bb.data)
prior.bern

pairs(prior.bern)

log.c_a0 <- bridgesampling::bridge_sampler(prior.bern)

get_c_a0_bernoulli <- function(y0, n0, cc, dd, a_0){
  ans <- lbeta(a_0 * y0 + cc, a_0 *(n0 -y0) + dd)
  return(ans)
}

get_c_a0_bernoulli(
  y0 = bb.data$y0,
  n0 = bb.data$N0,
  cc = bb.data$c,
  dd = bb.data$d,
  a_0 = bb.data$a_0
)
log.c_a0

anaughts <- seq(0, 2, length.out = 100)
c_a0 <- function(x) {
  get_c_a0_bernoulli(
      y0 = bb.data$y0,
      n0 = bb.data$N0,
      cc = bb.data$c,
      dd = bb.data$d,
      a_0 = x
    )
}
MaLs <- sapply(anaughts, c_a0)

plot(anaughts, MaLs, xlab = expression(a[0]), main = "Bernoulli",
     ylab = expression(log(c(a[0]))), type = "l")

plot(anaughts, exp(MaLs), xlab = expression(a[0]),
     ylab = "Marginal likelihood", type = "l")

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

## New data
### will draw from the same process for simplicity
N <- 1000
y <- 200

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

delta <- 1
nu <- 1
bb.data.forposterior <- list(
  N0 = N0,
  y0 = y0,
  c = cc,
  d = dd,
  delta = delta,
  nu = nu,
  N = N,
  y = y
)

unnorm.posterior.bern <- sampling(compiled.model.unnorm.posterior, data = bb.data.forposterior)
unnorm.posterior.bern
pairs(unnorm.posterior.bern, pars = c("a_0", "theta"))

### Now the normalised prior

compiled.model.norm.posterior <- stan_model("stan/simple_bernoulli_posterior_normalised.stan")

norm.posterior.bern <- sampling(compiled.model.norm.posterior, data = bb.data.forposterior)
norm.posterior.bern
pairs(norm.posterior.bern, pars = c("a_0", "theta", "lp__"))

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

a0.dt <- data.frame(a0 = c(a0.unnorm, a0.norm),
                    normalisation = c( rep("unnormalised", length(a0.unnorm)),
                                       rep("normalised", length(a0.norm)) )
)

library(ggplot2)
ggplot(a0.dt, aes(x = a0, fill = normalisation, colour = normalisation)) +
  geom_density() +
  stat_function(fun = function(x) dbeta(x, delta, nu),
                geom = "line", colour = "black", linetype = "longdash") +
  ggtitle("Bernoulli") +
  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()


#A set of linear algebra benchmarks
#Based on post at http://blog.revolutionanalytics.com/2014/10/revolution-r-open-mkl.html
args = commandArgs(trailingOnly=TRUE)
if (length(args)==0) {
  stop("Need to supply an output filename to this script", call.=FALSE)
}
filename = args[1]
print(paste("Output will be saved to ",filename))
# Initialization
set.seed (1)
m <- 10000
n <-  5000
A <- matrix (runif (m*n),m,n)

# Matrix multiply
sprintf("Matrix multiply two  %d by %d matrices", m,n)
mat_time=system.time (B <- crossprod(A))
print(mat_time)
#Extract just the elapsed time
mat_time = mat_time[3]

# Cholesky Factorization
print(paste("Cholesky Factorization of ",dim(B)[1],"by",dim(B)[2],"matrix"))
chol_time=system.time (C <- chol(B))
print(chol_time)
#Extract just the elapsed time
chol_time = chol_time[3]

# Singular Value Deomposition
m <- 10000
n <- 2000
A <- matrix (runif (m*n),m,n)
print(paste("SVD of ",dim(A)[1],"by",dim(A)[2],"matrix"))
svd_time=system.time (S <- svd (A,nu=0,nv=0))
print(svd_time)
#Extract just the elapsed time
svd_time = svd_time[3]

# Principal Components Analysis
m <- 10000
n <- 2000
A <- matrix (runif (m*n),m,n)
print(paste("prcomp of ",dim(A)[1],"by",dim(A)[2],"matrix"))
pca_time=system.time (P <- prcomp(A))
print(pca_time)
#Extract just the elapsed time
pca_time = pca_time[3]

# Linear Discriminant Analysis
library('MASS')
g <- 5
k <- round (m/2)
A <- data.frame (A, fac=sample (LETTERS[1:g],m,replace=TRUE))
train <- sample(1:m, k)
print("Linear Discriminant Analysis")
lda_time=system.time (L <- lda(fac ~., data=A, prior=rep(1,g)/g, subset=train))
print(lda_time)
#Extract just the elapsed time
lda_time = lda_time[3]

#construct the output data frame
output = data.frame(MatMul=mat_time,Chol=chol_time,SVD=svd_time,PCA=pca_time,LDA=lda_time)
saveRDS(output,file=filename)


install.packages("plotly")
library(plotly)

# experimento completamente al azar

x <- seq(1, 100, length=100)

fd <- dgeom(x = x,  prob = 0.2)

plot_ly(x = x , y = fd, type = 'scatter', mode='lines', fill = 'tozeroy')

fp <- pgeom(x ,  prob = 0.5 )
plot_ly(x = x , y = fp, type = 'scatter', mode='lines', fill = 'tozeroy')

# cada semana una persona participa en un juego de loteria en donde la prob de ganar es p = 10 -6  Cuantas semenas promedio debe participar
# hasta ganar la loteria


library(repr); options(repr.plot.res = 100, repr.plot.width = 6, repr.plot.height = 6) # Change plot sizes (in cm) - this bit of code 6s only relevant i6 you are using a jupyter notebook - ignore otherwise

genome <- read.csv('../data/GenomeSize.csv',stringsAsFactors = T)

head(genome)

library(repr); options(repr.plot.res = 100, repr.plot.width = 10, repr.plot.height = 10)

pairs(genome)

pairs(genome, col=genome$Suborder)

library(repr); options(repr.plot.res = 100, repr.plot.width = 8, repr.plot.height = 8) # change plot size

# create a small data frame:
dat <- data.frame(A = c("a", "b", "c", "d", "e"), B = c(1, 2, 3, 4, 5))
dat[1, ] # select row 1 (all columns selected)

dat[, 2] # select column 2 (all rows selected)

dat[2, 1] # select row 2, column 1

morpho_vars <- c(4, 7, 8, 12, 14) # store the indices
pairs(genome[, morpho_vars], col = genome$Suborder)

cor(genome[, morpho_vars], use = "pairwise")

cor.test(genome$GenomeSize, genome$TotalLength, use = "pairwise")

genome$logGS <- log(genome$GenomeSize)

genome$logGS <- log(genome$GenomeSize)
genome$logBW <- log(genome$BodyWeight)
genome$logTL <- log(genome$TotalLength)
genome$logFL <- log(genome$ForewingLength)
genome$logFA <- log(genome$ForewingArea)

str(genome)

logmorpho <- c(17,18,19,20,21)

pairs(genome[, logmorpho], col=genome$Suborder)

cor(genome[, logmorpho], use='pairwise')

myColours <- c('red', 'blue') # Choose two colours
mySymbols <- c(1,3) # And two different markers
colnames(genome)

library(repr); options(repr.plot.res = 100, repr.plot.width = 6, repr.plot.height = 6) # change plot size

plot(logBW ~ GenomeSize , data = genome, #Now plot again
col = myColours[Suborder], pch = mySymbols[Suborder],
xlab='Genome size (pg)', ylab='log(Body weight) (mg)')

legend("topleft", legend=levels(genome$Suborder), #Add legend at top left corner
       col= myColours, pch = mySymbols)

nullModelDragon <- lm(logBW ~ 1, data = genome, subset = Suborder ==  "Anisoptera")
genomeSizeModelDragon <- lm(logBW ~ logGS, data = genome, subset =  Suborder == "Anisoptera")

summary(genomeSizeModelDragon)

anova(genomeSizeModelDragon)

sum(resid(nullModelDragon) ^ 2)

sum(resid(genomeSizeModelDragon) ^ 2)

genomeSizeModelDamsel <- lm(logBW ~ logGS, data=genome,subset=Suborder=='Zygoptera')

myCol <- c('red','blue')
library(repr); options(repr.plot.res = 100, repr.plot.width = 8, repr.plot.height = 8) # change plot size
plot(logBW ~ logGS, data=genome, col=myCol[Suborder], xlab='log Genome Size (pg)', ylab='log Body Weight (g)')

abline(genomeSizeModelDragon, col='red')

par(mfrow = c(2, 2), mar = c(5, 5, 1.5, 1.5))
plot(genomeSizeModelDragon)

par(mfrow = c(2, 2), mar = c(5, 5, 1.5, 1.5))
plot(genomeSizeModelDamsel)


closest_pair_brute <-function(x,y,plotxy=F) {
    xy = cbind(x,y)
    cp = bruteforce(xy)
    cat("\n\nShortest path found = \n From:\t\t(",cp[1],',',cp[2],")\n To:\t\t(",cp[3],',',cp[4],")\n Distance:\t",cp[5],"\n\n",sep="")
    if(plotxy) {
        plot(x,y,pch=19,col='black',main="Closest Pair", asp=1)
        points(cp[1],cp[2],pch=19,col='red')
        points(cp[3],cp[4],pch=19,col='red')
    }
    distance <- function(p1,p2) {
        x1 = (p1[1])
        y1 = (p1[2])
        x2 = (p2[1])
        y2 = (p2[2])
        sqrt((x2-x1)^2 + (y2-y1)^2)
    }
    bf_iter <- function(m,p,idx=NA,d=NA,n=1) {
        dd = distance(p,m[n,])
        if((is.na(d) || dd<=d) && p!=m[n,]){d = dd; idx=n;}
        if(n == length(m[,1])) { c(m[idx,],d) }
        else bf_iter(m,p,idx,d,n+1)
    }
    bruteforce <- function(pmatrix,n=1,pd=c(NA,NA,NA,NA,NA)) {
        p = pmatrix[n,]
        ppd = c(p,bf_iter(pmatrix,p))
        if(ppd[5]<pd[5] || is.na(pd[5])) pd = ppd
        if(n==length(pmatrix[,1]))  pd
        else bruteforce(pmatrix,n+1,pd)
    }
}


# Reviewing the best practices

# A. Bar plots
# 1. Dynamite plots
# Plot wt vs. fcyl
ggplot(mtcars, aes(x = fcyl, y = wt)) +
  # Add a bar summary stat of means, colored skyblue
  stat_summary(fun.y = mean, geom = "bar", fill = "skyblue") +
  # Add an errorbar summary stat std deviation limits
  stat_summary(fun.data = mean_sdl, fun.args = list(mult = 1), geom = "errorbar", width = 0.1)

# 2. Position dodging
# Define a dodge position object with width 0.9
posn_d <- position_dodge(width = 0.9)

# For each summary stat, update the position to posn_d
ggplot(mtcars, aes(x = fcyl, y = wt, color = fam, fill = fam)) +
  stat_summary(fun.y = mean, geom = "bar", position = posn_d, alpha = 0.5) +
  stat_summary(fun.data = mean_sdl, fun.args = list(mult = 1), width = 0.1, position = posn_d, geom = "errorbar")

# 3. Using aggregate data. The dataframe has been developed as a summary of the initial mtcars dataframe using cyl as the group by column
# Using mtcars_cyl, plot mean_wt vs. cyl
ggplot(mtcars_by_cyl, aes(x = cyl, y = mean_wt)) +
  # Add a bar layer with identity stat, filled skyblue
  geom_bar(stat = "identity", fill = "skyblue")

ggplot(mtcars_by_cyl, aes(x = cyl, y = mean_wt)) +
  geom_col(aes(width = prop), fill = "skyblue") +
  # Add an errorbar layer
  geom_errorbar(
    # ... at mean weight plus or minus 1 std dev
    aes(ymin = mean_wt - sd_wt, ymax = mean_wt + sd_wt),
    # with width 0.1
    width = 0.1
  )

# B. Heatmaps
# 1. Heat maps
# Using barley, plot variety vs. year, filled by yield
ggplot(barley, aes(x = year, y = variety, fill = yield)) +
  # Add a tile geom
  geom_tile()

# Previously defined
ggplot(barley, aes(x = year, y = variety, fill = yield)) +
  geom_tile() +
  # Facet, wrapping by site, with 1 column
  facet_wrap(facets = vars(site), ncol = 1) +
  # Add a fill scale using an 2-color gradient
  scale_fill_gradient(low = "white", high = "red")

# A palette of 9 reds
red_brewer_palette <- brewer.pal(9, "Reds")

# Update the plot
ggplot(barley, aes(x = year, y = variety, fill = yield)) +
  geom_tile() +
  facet_wrap(facets = vars(site), ncol = 1) +
  # Update scale to use n-colors from red_brewer_palette
  scale_fill_gradientn(colors = red_brewer_palette)

# 2. Heat map alternatives
# The heat map we want to replace
# Don't remove, it's here to help you!
ggplot(barley, aes(x = year, y = variety, fill = yield)) +
  geom_tile() +
  facet_wrap( ~ site, ncol = 1) +
  scale_fill_gradientn(colors = brewer.pal(9, "Reds"))

# Using barley, plot yield vs. year, colored and grouped by variety. As there is a time element present it makes sense to use a line graph
ggplot(barley, aes(x = year, y = yield, color = variety, group = variety)) +
  # Add a line layer
  geom_line() +
  # Facet, wrapping by site, with 1 row
  facet_wrap( ~ site, nrow = 1)

# Using barely, plot yield vs. year, colored, grouped, and filled by site
ggplot(barley, aes(x = year, y = yield, color = site, group = site, fill = site)) +
  # Add a line summary stat aggregated by mean
  stat_summary(fun.y = mean, geom = "line") +
  # Add a ribbon summary stat with 10% opacity, no color
  stat_summary(fun.data = mean_sdl, fun.args = list(mult = 1), geom = "ribbon", alpha = 0.1, color = NA)

# C. Typical problems with plots. Not enough details are included when creating the plots
# Initial plot
growth_by_dose <- ggplot(TG, aes(dose, len, color = supp)) +
  stat_summary(fun.data = mean_sdl,
               fun.args = list(mult = 1),
               position = position_dodge(0.1)) +
  theme_classic()

# View plot
growth_by_dose

# Change type
TG$dose <- as.numeric(as.character(TG$dose))

# Plot
growth_by_dose <- ggplot(TG, aes(dose, len, color = supp)) +
  stat_summary(fun.data = mean_sdl,
               fun.args = list(mult = 1),
               position = position_dodge(0.2)) +
  theme_classic()

# View plot
growth_by_dose

# Change type
TG$dose <- as.numeric(as.character(TG$dose))

# Plot
growth_by_dose <- ggplot(TG, aes(dose, len, color = supp)) +
  stat_summary(fun.data = mean_sdl,
               fun.args = list(mult = 1),
               position = position_dodge(0.2)) +
  stat_summary(fun.y = mean,
               geom = "line",
               position = position_dodge(0.1)) +
  theme_classic() +
  # Adjust labels and colors:
  labs(x = "Dose (mg/day)", y = "Odontoblasts length (mean, standard deviation)", color = "Supplement") +
  scale_color_brewer(palette = "Set1", labels = c("Orange juice", "Ascorbic acid")) +
  scale_y_continuous(limits = c(0,35), breaks = seq(0, 35, 5), expand = c(0,0))

# View plot
growth_by_dose


## Absolute error vals for the whole range (including outliers)
rf_error_vals = abs(w$Time.s. - w$pred_rfe)
hist(rf_error_vals, main = "", xlab = "", ylab="")

## Relative error including outliers
rf_rel_ev = sapply(rf_error_vals, function(x) x/253)
hist(rf_rel_ev, main = "", xlab = "", ylab="")
rug(rf_rel_ev)

library(dplyr)

## Eliminate outliers
no_outliers = quantile(w$Time.s., probs = c(0.05, 0.95))
no_outliers_df = data.frame(w$Time.s., w$pred_rfe)
dd = no_outliers_df %>% filter(no_outliers_df$w.Time.s. >= no_outliers[1] & no_outliers_df$w.Time.s. <= no_outliers[2])
range_no_outliers = max(dd$w.Time.s.) - min(dd$w.Time.s.)
no_outliers_rf_error = abs(dd$w.Time.s. - dd$w.pred_rfe)
no_outliers_rf_rel_error = sapply(no_outliers_rf_error, function(x) x/range_no_outliers)

## Plot the maximum relative error per quantile
cdf = quantile(no_outliers_rf_rel_error, seq(0.01,1,0.01))
no_outliers_median_rel_error = sapply(seq(1,100,1),
                                      function(x) median(no_outliers_rf_rel_error[no_outliers_rf_rel_error < cdf[x]]))

plot(cdf, type="l", lwd=2, xlim=c(0,100), ylim=c(0.0, 1.0), xaxs="i", yaxs="i", xlab="", ylab="Relative error", axes = F)
title(xlab="Percentage of programs", line=2)
axis(1, at=seq(0,100,5))
axis(2, at=seq(0.0, 2.0, 0.05), las = 2)
## Draw grid with abline because of custom ticks
abline(h=seq(0.0, 2.0, 0.05), col = "#666666", lty=3)
abline(v=seq(0, 100, 5), col = "#666666", lty=3)

#segments(0, 0.3635588566, 95, 0.3635588566, lty=3, col = "black")
#segments(95, 0, 95, 0.3635588566, lty=3)
#segments(0, 0.2516858783, 90, 0.2516858783, lty=3)
#segments(90, 0, 90, 0.2516858783, lty=3)
#abline(v=95, col="red")
#abline(h=0.3635588566, lty=3, col = "black")
#abline(v=90, col = "blue")
#abline(h=0.2516858783, lty=3, col = "black")
#points(95, 0.3635588566, pch=16)
#points(90, 0.2516858783, pch=16)

## Add median error
lines(no_outliers_median_rel_error, col="black", lwd=2, lty=6)
#abline(h=0.05847, lty=3)
#segments(100, 0, 100, 0.05847, lty=3)
#points(100,0.05847, pch=16)
## Add legend
legend("topleft", title="Type of error", c("Maximum error", "Median error"), col=c("black", "black"), lwd=c(1,1), lty=c(1,6))


#' Numeric summary
#'
#' @description Compute summary statistics for numeric variable
#'
#' @param x numeric vector
#' @param minimal return minimal version (default = F)
#'
#' @return tibble
#' @export
#'
#' @examples
#'
#' x <- c(rnorm(10),NA,10)
#'
#' x
#'
#' num_summary(x)
#'

num_summary <- function(x, minimal = F){

  if(is.numeric(x) == F){
    stop("x must be numeric")
  }

  if(minimal == F){
    out <-
      dplyr::tibble(
        n = length(x),
        na = sum(is.na(x)),
        negative = sum(x < 0, na.rm = T),
        equal_zero = sum(x == 0, na.rm = T),
        positive = sum(x > 0, na.rm = T),
        min  = min(x, na.rm = T),
        p25  = quantile(x,probs = .25, na.rm = T),
        p50  = median(x, na.rm = T),
        p75  = quantile(x,probs = .75, na.rm = T),
        max = max(x, na.rm = T),
        mode = ifelse(length(na.omit(x) ) < 3, NA_real_ ,relper::num_mode(na.omit(x))),
        mean = mean(x, na.rm = T),
        cv = relper::cv(x)
      )
  }else{
    out <-
      dplyr::tibble(
        n = length(x),
        min  = min(x, na.rm = T),
        p25  = quantile(x,probs = .25, na.rm = T),
        p50  = median(x, na.rm = T),
        p75  = quantile(x,probs = .75, na.rm = T),
        max = max(x, na.rm = T),
        mode = ifelse(length(na.omit(x)) < 3, NA_real_ ,relper::num_mode(na.omit(x))),
        mean = mean(x, na.rm = T),
        cv = relper::cv(x)
      )
  }

  return(out)

}


#' Mode for numeric values
#'
#' @description Find the high density value
#'
#' @param x numeric vector
#'
#' @return numeric value
#' @export
#'
#' @examples
#'
#' x <- rnorm(100)
#'
#' num_mode(x)
#'

num_mode <- function(x){

  if(!is.numeric(x)){
    stop("x must be numeric.")
  }

  d <- density(na.omit(x))

  return(d$x[which.max(d$y)])

}


library(quantmod)
library(ggplot2)

####Petrobras
petr <- getSymbols("petr4.sa", src = "yahoo", from = "2013-01-01",
                  to = "2020-12-01", auto.assign = FALSE)
head(petr)
tail(petr)
summary(petr)
str(petr)

ggplot(petr, aes(x = index(petr), y = petr[,6])) + geom_line(color = "darkblue") +
  ggtitle("Série de preços da PETR4") +
  xlab("Data") + ylab("Preço ($)") + theme(plot.title = element_text(hjust = 0.5)) +
  scale_x_date(date_labels = "%b %y", date_breaks = "6 months")

####ITAU

itub <- getSymbols("itub4.sa", src = "yahoo", from = "2013-01-01",
                  to = "2020-12-01", auto.assign = FALSE)
head(itub)
tail(itub)
summary(itub)
str(itub)

ggplot(itub, aes(x = index(itub), y = itub[,6])) + geom_line(color = "darkblue") +
  ggtitle("Série de preços da ITUB4") +
  xlab("Data") + ylab("Preço ($)") + theme(plot.title = element_text(hjust = 0.5)) +
  scale_x_date(date_labels = "%b %y", date_breaks = "6 months")

######EMBRAER

embr <- getSymbols("embr3.sa", src = "yahoo", from = "2013-01-01",
                   to = "2020-12-01", auto.assign = FALSE)
head(embr)
tail(embr)
summary(embr)
str(embr)

ggplot(embr, aes(x = index(embr), y = embr[,6])) + geom_line(color = "darkblue") +
  ggtitle("Série de preços da EMBR4") +
  xlab("Data") + ylab("Preço ($)") + theme(plot.title = element_text(hjust = 0.5)) +
  scale_x_date(date_labels = "%b %y", date_breaks = "6 months")

######Magazine Luiza
mglu <- getSymbols("mglu3.sa", src = "yahoo", from = "2013-01-01",
                   to = "2020-12-01", auto.assign = FALSE)
head(mglu)
tail(mglu)
summary(mglu)
str(mglu)

ggplot(mglu, aes(x = index(mglu), y = mglu[,6])) + geom_line(color = "darkblue") +
  ggtitle("Série de preços da MGLU4") +
  xlab("Data") + ylab("Preço ($)") + theme(plot.title = element_text(hjust = 0.5)) +
  scale_x_date(date_labels = "%b %y", date_breaks = "6 months")

########RETORNOS

ret_petr<- yearlyReturn(petr)
ret_itub<- yearlyReturn(itub)
ret_embr<- yearlyReturn(embr)
ret_mglu<- yearlyReturn(mglu)

retornos <- cbind(ret_petr, ret_itub, ret_embr, ret_mglu)

retorno_medio <- rbind(mean(retornos[,1]), mean(retornos[,2]), mean(retornos[,3]), mean(retornos[,4]))

ativos <- c('PETR4', 'ITUB4', 'EMBR3', 'MGLU4')

rownames(retorno_medio) <- ativos

#####Matriz de Covariância

mat_cov <- cov(retornos)

rownames(mat_cov) <- ativos
colnames(mat_cov) <- ativos

mat_cov

####Montando carteira de investimentos

library(IntroCompFinR)
rf <- 0.02

short_selling <- F

invest_portfolio <- tangency.portfolio(retorno_medio, mat_cov,
                   rf, shorts = short_selling)
invest_portfolio

ativos

# Calculo da carteira com a menor risco possÃvel
carteira_min_risco <- globalMin.portfolio(retorno_medio, mat_cov, shorts = short_selling)

carteira_min_risco

# compute portfolio frontier
fronteira_eficiente <- efficient.frontier(retorno_medio, mat_cov, nport = 40, shorts = short_selling)

fronteira_eficiente

attributes(fronteira_eficiente)

# VisualizaÃ§ao da saida

plot(fronteira_eficiente, plot.assets=TRUE, col="blue", pch=16)

points(carteira_min_risco$sd, carteira_min_risco$er, col="green", pch=10, cex=2)
points(invest_portfolio$sd, invest_portfolio$er, col="red", pch=10, cex=2)

text(carteira_min_risco$sd, carteira_min_risco$er, labels="Risco Minimo", pos=2)
text(invest_portfolio$sd, invest_portfolio$er, labels="Carteira Eficiente", pos=2)

tangente <- (invest_portfolio$er - rf)/invest_portfolio$sd
abline(a = rf, b=tangente, col="green", lwd=2)


# Statistics One, Lecture 3, example script
# Read data, plot histograms, get descriptives

# load library
library(psych)

# read data from table
ratings<-read.table("data/stats1_ex01.txt",header=T)

# describe "ratings"
class(ratings)

# list column names
names(ratings)

# layout: 4 histograms on one page
layout(matrix(c(1,2,3,4), 2, 2, byrow = TRUE))

# plot the histograms
hist(ratings$RedTruck, xlab = 'Rating')
hist(ratings$WoopWoop, xlab = 'Rating')
hist(ratings$HobNob, xlab = 'Rating')
hist(ratings$FourPlay, xlab = 'Rating')

# statistics table
describe(ratings)


library(igraph)

edges <- read.csv("PATH")
nodes <- read.csv("PATH")

head(edges)
head(nodes)

my_graph <- graph_from_data_frame(d = edges, vertices = nodes, directed =
                                      FALSE)
plot(my_graph)

degree(my_graph)
V(my_graph)$vertex_degree <- degree(my_graph)
plot(my_graph, vertex.size=V(my_graph)$vertex_degree)
plot(my_graph, layout = layout.fruchterman.reingold(my_graph))

station_degree <- degree(my_graph)
write.csv(station_degree, file = "FILE_NAME.csv")

degree(my_graph)
V(my_graph)$vertex_degree <- degree(my_graph)
plot(my_graph, vertex.size=V(my_graph)$vertex_degree)

neighbors(my_graph, "80")

betweenness(my_graph, normalized = FALSE)

station_between <- betweenness(my_graph, normalized = FALSE)
write.csv(station_between, file = "FILE_NAME.csv")

eig_g <- eigen_centrality(my_graph)
write.csv(eig_g, file = "FILE_NAME.csv")
eig_g_sort <- sort(eig_g[[1]], decreasing=T)

edge_density(my_graph)

mean_distance(my_graph)


require(Hmisc)

n <- 1000
set.seed(1)
d <- data.frame(sbp   =round(rnorm(n, 120, 10)),
                dbp   =round(rnorm(n, 80, 10)),
                age   =round(rnorm(n, 50, 10), 1),
                days  =sample(c(0,30,60,90), n, TRUE),
                S1    =Surv(2*runif(n)), S2=Surv(runif(n)),
                race  =sample(c('Asian', 'Black/AA', 'White'), n, TRUE),
                sex   =sample(c('Female', 'Male'), n, TRUE),
                treat =sample(c('A', 'B'), n, TRUE),
                region=sample(c('North America','Europe'), n, TRUE),
                meda  =sample(0:1, n, TRUE), medb=sample(0:1, n, TRUE))

d <- upData(d, labels=c(sbp='Systolic BP', dbp='Diastolic BP',
                 race='Race', sex='Sex', treat='Treatment',
                 days='Time Since Randomization',
                 S1='Hospitalization', S2='Re-Operation',
                 meda='Medication A', medb='Medication B'),
            units=c(sbp='mmHg', dbp='mmHg', age='years', days='days'))

s <- summaryS(age + sbp + dbp ~ days + region + treat,  data=d)
plotp(s, groups='treat')

plotp(s, groups='treat', fitter=loess)

# Show both points and smooth curves:
plotp(s, groups='treat', fitter=loess, showpts=TRUE)

# Use loess to estimate the probability of two different types of events as
# a function of time
s <- summaryS(meda + medb ~ days + treat + region, data=d)
plotp(s, groups='treat', fitter=loess)

# Demonstrate dot charts of summary statistics
s <- summaryS(age + sbp + dbp ~ region + treat, data=d, fun=mean)
plotp(s, groups='treat', height=200)

# Compute parametric confidence limits for mean, and include sample sizes
f <- function(x) {
  x <- x[! is.na(x)]
  c(smean.cl.normal(x, na.rm=FALSE), n=length(x))
}
s <- summaryS(age + sbp + dbp ~ region + treat, data=d, fun=f)

mu <- markupSpecs$html   # in Hmisc
lab <- paste0(mu$overbar('X'), ' ± t0.975 × s')
plotp(s, groups='treat', funlabel=lab)

## Stratify by region and treat fit an exponential distribution to
## S1 and S2 and estimate the probability of an event within 0.5 years

f <- function(y) {
  hazard <- sum(y[,2]) / sum(y[,1])
  1. - exp(- hazard * 0.5)
}

s <- summaryS(S1 + S2 ~ region + treat, data=d, fun=f)
plotp(s, groups='treat', funlabel='Prob[Event Within 6m]',
      xlim=range(pretty(s$y)))

## Demonstrate combined use of fun and sfun
## First show the same quantile intervals used in panel.bppplot by
## default, stratified by region and day

#d <- upData(d, days=round(days / 30) * 30)
g <- function(y) {
  probs <- c(0.05, 0.125, 0.25, 0.375)
  probs <- sort(c(probs, 1 - probs))
  y <- y[! is.na(y)]
  w <- hdquantile(y, probs)
  m <- hdquantile(y, 0.5, se=TRUE)
  se <- as.numeric(attr(m, 'se'))
  c(Median=as.numeric(m), w, se=se, n=length(y))
}
s <- summaryS(sbp + dbp ~ days + region, fun=g, data=d)
plotp(s, groups='region', sfun=mbarclpl)

# Similar but use back-to-back spike histograms
s <- summaryS(sbp + dbp ~ days + region, data=d)
plotp(s, groups='region', sfun=medvpl, alphaSegments=0.6)
### ???

## Show Wilson confidence intervals for proportions, and confidence
## intervals for difference in two proportions
g <- function(y) {
  y <- y[!is.na(y)]
  n <- length(y)
  p <- mean(y)
  se <- sqrt(p * (1. - p) / n)
  structure(c(binconf(sum(y), n), se=se, n=n),
            names=c('Proportion', 'Lower', 'Upper', 'se', 'n'))
}
s <- summaryS(meda + medb ~ days + region, fun=g, data=d)
plotp(s, groups='region', sfun=mbarclpl)


# Balance Test for one covariate
#'
#' @importFrom estimatr lm_robust
#' @importFrom rlang enexpr
#' @importFrom stats pf
#' @importFrom stats formula
#' @importFrom rlang f_lhs
#' @importFrom rlang f_rhs
#'
#'
balance_test <- function(baseline = NULL,
                         data = NULL,
                         treat_levels = NULL,
                         treat_labels = NULL,
                         ctrl = NULL,
                         subset = NULL,
                         weights = NULL,
                         cluster = NULL,
                         ...) {
  # data shape
  use <- clean_RCTdata(
    baseline,
    data = data,
    treat_levels = treat_levels,
    treat_labels = treat_labels,
    subset = subset,
    weights = weights,
    cluster = cluster
  )

  # calculate mean value in each arm
  y <- use$outcome
  d <- use$design[, -1]
  w <- use$weights

  ctrl <- as.logical(1 - rowSums(d))
  mu0 <- wtd_mean(y[ctrl], w[ctrl])
  mu1 <- apply(d, 2, function(x) {
    treated <- as.logical(x)
    wtd_mean(y[treated], w[treated])
  })
  mu <- c(mu0, mu1)

  # implement F-test
  reg <- estimatr::lm_robust(
    y ~ 1 + d,
    weights = w,
    clusters = use$cluster,
    ...
  )

  fstat <- reg$fstatistic
  p_fstat <- pf(fstat[1], fstat[2], fstat[3], lower.tail = FALSE)

  # output
  data.frame(
    x = all.vars(f_lhs(baseline)),
    item = c(
      treat_labels[1],
      gsub(all.vars(f_rhs(baseline)), "", names(mu1)),
      "fstat",
      "df1",
      "df2",
      "p-value"
    ),
    val = c(mu, fstat[1], fstat[2], fstat[3], p_fstat)
  )
}

# Balance Test by F-test of Overall Significance in Linear Regression
#'
#' @importFrom dplyr bind_rows
#'
balance_test_multi_var <- function(covariate = NULL,
                                   treat = NULL,
                                   data = NULL,
                                   treat_levels = NULL,
                                   treat_labels = NULL,
                                   ctrl = NULL,
                                   subset = NULL,
                                   weights = NULL,
                                   cluster = NULL,
                                   ...) {
  # order of experimental arms
  order_d <- reorder_arms(treat_levels, treat_labels, ctrl)

  # list of model
  model <- lapply(covariate, function(x) formula(paste(x, "~", treat)))

  # implement F-test
  res <- lapply(
    model,
    balance_test,
    data,
    order_d$levels,
    order_d$labels,
    ctrl,
    enexpr(subset),
    enexpr(weights),
    enexpr(cluster),
    ...
  )
  res <- bind_rows(res)

  # convert factor
  res$item <- factor(
    res$item,
    c(order_d$labels, "fstat", "df1", "df2", "p-value")
  )

  # output
  res
}


row.vars <- function(x, na.rm=F) {
    x <- x - rowMeans(x, na.rm=na.rm)
    if (na.rm)
        n <- rowSums(!is.na(x))
    else
        n <- ncol(x)
    rowSums(x^2,na.rm=na.rm)/(n-1)
    }
row.sds <- function(...) {
    sqrt(row.vars(...))
}


#May 25, 2018
#Fitting a dirichlet to 3 species abundances, predicted by an intercept and two covariates.
#This solution presented by Martyn Plummer
#clear environment, load packages.
rm(list = ls())
library(runjags)

#simulate data.
n <- 100
y1 <- round(rnorm(n, 100, 5))
mat <- rnorm(length(y1), 10, 3)
map <- rnorm(length(y1),100,10)
y1 <- y1 + round(mat*-3) + round(map*1)
y2 <- round(rnorm(n, 100, 5))
y3 <- round(rnorm(n, 100, 5))
spp.y <- as.matrix((data.frame(y1,y2,y3)))
y <- spp.y / rowSums(spp.y)
x <- as.matrix(cbind(rep(1,nrow(y)),mat,map)) #x predictors, including intercept

#Specify JAGS model.
dirichlet.model = "
model {
  #setup priors for each species
  alpha ~ dnorm(0, 1.0E-3)
  for(i in 1:N.x){
  beta[i,1] <- 0
  for (j in 2:N.spp) {
    beta[i,j] ~ dnorm(0, 1.0E-3)
      }
    }

  #implement dirlichet
  for (i in 1:N){
    for (j in 1:N.spp){
      log(a0[i,j]) <- alpha + inprod(beta[,j], x[i,])
    }
    y[i,1:N.spp] ~ ddirch(a0[i,1:N.spp])
  }

  #map to original parameterization
  for (j in 1:N.spp) {
    m[1,j] <- alpha + beta[1,j]
    for (i in 2:N.x){
      m[i,j] <- beta[i,j]
    }
  }

} #close model loop.
"

#Setup JAGS data object, fit JAGS model.
jags.data <- list(y = y, x = x,
                  N = nrow(y), N.spp = ncol(y), N.x = ncol(x))
jags.out <- runjags::run.jags(dirichlet.model,
                     data=jags.data,
                     adapt = 200,
                     burnin = 2000,
                     sample = 2000,
                     n.chains=3,
                     monitor=c('m'))
#summarize output.
out <- summary(jags.out)

###visualize.
#extract mean parameter matrix.
parms <- (matrix(out[grep('m', rownames(out)),4],nrow = (ncol(x)),ncol = (ncol(y))))
#multiply parameters by predictors to get predicted values.
pred.list <- list()
for(i in 1:ncol(y)){
  pred.list[[i]] <- exp(x %*% parms[,i])
}
pred.list <- (as.matrix(do.call('cbind', pred.list)))
pred.list <- pred.list / rowSums(pred.list)

#Plot predicted vs. observed and the 1:1 line.
par(mfrow = c(1,3))
for(i in 1:ncol(y)){
  plot(y[,i] ~ pred.list[,i])
  r.sq <- summary(lm(y[,i] ~ pred.list[,i]))$r.squared
  abline(0,1, lwd = 2)
  txt <- paste0('R2 = ',round(r.sq,2))
  mtext(txt, side = 3, line = -2, adj = 0.05)
}


df = NULL

# Fixed parameters
theta <- .01
lambda <- 1
gR <- .02
phi <- 0

# Initialize dynamic process
Rcurr <- 10
Acurr <- 2
Aalt  <- 10

df = NULL # initialize a dataframe
dfalt = NULL # initialize a dataframe
name = "A"
namealt = "B"

for (t in 1:250) # do for this many periods
{
  gA <- theta*(Rcurr^lambda)/(Acurr^(1-phi)) # calculate growth in k/y given current k/y
  df = rbind(df, data.frame(t,Acurr,gA,name)) # add to dataframe
  Acurr <- (1+gA)*(Acurr) # update current k/y for next period
  gA <- theta*(Rcurr^lambda)/(Aalt^(1-phi))
  dfalt = rbind(dfalt, data.frame(t,Aalt,gA,namealt)) # add to dataframe
  Aalt <- (1+gA)*(Aalt)
  Rcurr <- (1+gR)*Rcurr
}

colnames(dfalt) <- c("t","Acurr","gA","name")
dfgraph = rbind(df,dfalt)
dfgraph$ratio <- dfgraph$gA/theta

# Initialize theoretical relationship
fig <- plot_ly(dfgraph,
    x = ~ratio,
    y = ~gA,
    color = ~name,
    frame = ~t,
    text = ~t,
    hoverinfo = "text",
    type = 'scatter',
    mode = 'markers',
    marker = list(size = 15)
  ) %>% animation_opts(frame=0, transition=0)
fig <- fig %>% animation_slider(
  hide = T
)
fig <- fig %>% animation_button(
  x = 1, xanchor = "right", y = 0.4, yanchor = "bottom"
)
fig <- layout(fig, title = list(text = 'Dynamics of productivity growth', x=0),
              xaxis = list(title = 'Ratio of R/A'),
              yaxis = list (title = 'Growth rate',range=c(0,.06))
)

api_create(fig, filename = "me-gA-dynamics")


mutate <- function(solution, probability, variance, range) {
    mutated_solution <- solution

    for (index in 1:length(mutated_solution)) {
        val <- mutated_solution[index]
        random <- runif(1, 0, 1)

        if (probability > random) {
            addition <- rnorm(1, mean=0, sd=sqrt(variance))
            mutation <- val + addition
            while (mutation < -range || mutation > range) {
                addition <- rnorm(1, mean=0, sd=sqrt(variance))
                mutation <- val + addition
            }
            mutated_solution[index] = mutation
        }
    }

    mutated_solution
}

range <- 5
values <- seq(from=-range, to=range, by=.01)
solution <- sample(values, size=10, replace=TRUE)
probability <- 0.5
variance <- 0.05

mutated_solution = mutate(solution, probability, variance, range)

print("Solution")
sprintf("%.5f", solution)
plot(solution)

print("Mutated Solution")
sprintf("%.5f", mutated_solution)
plot(mutated_solution)

# Plot normal distribution
x <- seq(-range, range, by = .1)
y <- dnorm(x, mean = 0, sd = sqrt(variance))
plot(y, main = "Normal Distribution")


library(MASS)
getPriorProbabilities <- function (dset, column) {
  dsetLength <- dim(dset)[1]
  return (table(dset[, column]) / dsetLength)
}

# getCovMatrix <- function(dset, expectation) {
#   featureTypesCount <- dim(dset)[2]
#   dsetLength <- dim(dset)[1]
#   cov <- matrix(0, nrow = featureTypesCount - 1, ncol = featureTypesCount - 1)
#
#   for (i in 1:dsetLength) {
#     currentFeature <- as.matrix(dset[i, 1:featureTypesCount - 1], nrow = 1)
#
#     tmp <- t(currentFeature - expectation) %*% (currentFeature - expectation)
#     cov <- cov + tmp
#   }
#   cov <- cov / (dsetLength - 1)
#
#   return(cov)
# }

getCovMatrix <- function(dset, expectation) {
  dsetMatrix <- as.matrix(dset[, 1:2])
  featuresCount <- dim(dsetMatrix)[2]
  dsetLength <- dim(dsetMatrix)[1]
  cov <- matrix(0, featuresCount, featuresCount)
  for (i in 1:dsetLength) {
    cov <- cov + t(t(c(dsetMatrix[i,] - expectation))) %*% t(c(dsetMatrix[i, ] - expectation))
  }
  cov <- cov / (dsetLength - featuresCount)
  return(cov)
}

# getLikelihood <- function(point, expectation, covMatrix) {
#   covMatrixInverse <- solve(covMatrix)
#   a <- -(t(expectation) %*% covMatrixInverse %*% expectation) / 2
#   b <- t(point) %*% covMatrixInverse %*% expectation
#
#   return(a + b)
# }

# standard normal distribution formula
getLikelihood <- function(x, expectation, sigma) {
  a <- sqrt((2 * pi) ^ dim(sigma)[1] * det(sigma)) ^ -1
  b <- exp(t(x - expectation) %*% solve(sigma) %*% (x - expectation) / -2)
  return(a * b)
}

getLdfProbability <- function(dset, classesColumn, className, point, lambda, covMatrix, expectations) {
  featuresCount <- length(point)
  croppedDset <- dset[which(dset[, classesColumn] == className), ]
  dsetLength <- dim(dset)[1]

  prior <- getPriorProbabilities(dset, classesColumn)[className]
  # print(prior)

  expectations <- array(dim = featuresCount)
  for (i in 1:featuresCount) {
    expectations[i] <- mean(croppedDset[, i])
  }

  covMatrix <- getCovMatrix(dset, expectations)

  # lambda = rep(1, featuresCount)
  likelihood <- getLikelihood(point, expectations, covMatrix)

  probability <- lambda * prior * likelihood;
  return (probability)
}

ldfClassifier <- function(point, dset) {
  featuresCount <- length(point)
  classes <- unique(dset[, 3])
  classesCount <- length(classes)
  scores <- array(dim = classesCount)

  for (i in 1:classesCount) {
    scores[i] <- getLdfProbability(dset, 'class', classes[i], point, lambdas[i], covMatrix, expectations)
  }
  # print(scores)
  return(classes[which.max(scores)])
}

# mu1 <- c(0, 0)
# mu2 <- c(4, 4)
# sig1 <- matrix(c(2, 0.9, 0.9, 2), 2, 2)
# sig2 <- matrix(c(0.5, 0, 0, 2), 2, 2)
# dset1 <- mvrnorm(250, mu1, sig1)
# dset2 <- mvrnorm(250, mu2, sig2)
# dset <- rbind(cbind(dset1, 1),cbind(dset2, 2))

dset = data.frame(x = double(), y = double(), class = character())

dset <- rbind(dset, data.frame(x = 0, y = 2, class = 1))
dset <- rbind(dset, data.frame(x = 2, y = 0, class = 1))
dset <- rbind(dset, data.frame(x = 2.5, y = 2.5, class = 1))
dset <- rbind(dset, data.frame(x = 3, y = 2, class = 1))

dset <- rbind(dset, data.frame(x = 2, y = 4.5, class = 2))
dset <- rbind(dset, data.frame(x = 4.5, y = 2, class = 2))
dset <- rbind(dset, data.frame(x = 3.1, y = 5.5, class = 2))
dset <- rbind(dset, data.frame(x = 5, y = 3, class = 2))

#
# dset <- rbind(dset, data.frame(x = 2, y = 0, class = 1))
# dset <- rbind(dset, data.frame(x = 0, y = 2, class = 1))
# dset <- rbind(dset, data.frame(x = 1.3, y = 0.7, class = 1))
# dset <- rbind(dset, data.frame(x = 0.8, y = 1.5, class = 1))
# dset <- rbind(dset, data.frame(x = 0.9, y = 1.8, class = 1))
# dset <- rbind(dset, data.frame(x = 1.7, y = 0.8, class = 1))
#
# dset <- rbind(dset, data.frame(x = 2, y = 2, class = 2))
# dset <- rbind(dset, data.frame(x = 0, y = 0, class = 2))
# dset <- rbind(dset, data.frame(x = 1.7, y = 1.9, class = 2))
# dset <- rbind(dset, data.frame(x = 0.3, y = 0.1, class = 2))

# plot(dset[ ,1], dset[ ,2], pch=21, bg=c("green","blue")[dset[ ,3]])

# print(plugInClassifier(c(0, 0), dset))
# # print(getPlugInProbability(dset, 3, 1, c(0, 0), 1))

## generating map
colors <- c("1" = "green", "2" = "blue")
xs <- seq(from = -5, to = 7, by = 0.1)
ys <- seq(from = -5, to = 8, by = 0.1)
## lambdas <- runif(2, min=1, max=100)
lambdas = c(1, 1)
print(lambdas)

all <- length(xs) * length(ys)
progress = 1
for (i in xs) {
  for (j in ys) {
    cat("\rProcessing point", progress, "of", all)
    progress <- progress + 1
    result <- ldfClassifier(c(i, j), dset)
    points(i, j, col = colors[result], pch = 21)
  }
}
cat("\rDone.                      \n")

# library(plotly)
#
# xs <- seq(from = -5, to = 7, by = 0.1)
# ys <- seq(from = -5, to = 8, by = 0.1)
# z <- c()
#
#
# for (y in ys) {
#   curr <- c()
#   for (x in xs) {
#     arg <- c(x, y)
#     value <- ldfClassifier(c(x, y), dset)
#
#     curr <- c(curr, value)
#   }
#   z <- rbind(z, curr)
# }
#
#
# fig <- plot_ly(
#   type = 'contour',
#   x = ~xs,
#   y = ~ys,
#   z = ~z)
# fig


# QLearning.r
#
#

## -Functions

#
#  Max(Q[next state, all actions])
#

Max <- function(x) {

  allactions <- which(x>=0,arr.ind=TRUE)

  rt <- 0

  for(i in 1:length(allactions)) {

    if( x[i] > 0 ) rt <- x[i]

  }

  return( rt )

}

#
# Convert the elements of matrix into percentage by dividing
# the non-zero elements by the largest elememt.
#

percent <- function(x) { round( (x  / max(Q)) * 100 ) }

#
#  Get R matrix from spreadsheet
#

getRewardMatrix <- function() {

     file.csv <- file.choose()      # Select file

     read.file <- read.csv(file.csv,
                       stringsAsFactors = FALSE,
                       header = FALSE)

     # Tidy up data frame

     read.file <- read.file[-c(1,2),]   # Remove rows

     read.file <- read.file[,-c(1)]     # Remove column

     # Convert to a matrix

     m <- matrix(as.numeric(unlist(read.file)), nrow=nrow(read.file))

     return(m)

}

# Get Reward Matrix from CSV file

R <- getRewardMatrix()

## - Initialse matrices and variables

# Initialise the Q matrix ( the brain )

Q <- matrix(rep(0,length(R)), nrow = nrow(R), ncol = ncol(R))

Gamma <- 0.8      # Set the Gamma factor ( between 0 to 1 )

oldQ <- Q         # Used to calculate the error

error <- c()      # Initialise the error vector

# Set random seed

set.seed(1234)

## - Compute the Q Matrix

# Repeat for each episode

for( episode in 1:100) { # Could use a 'while' instead of 'for'

  print(paste("Episode: ", episode, sep=""))

# Select at random a current state

  state <- sample(nrow(R), 1, replace = TRUE)

# Repeat while state is not equal to the goal

  while(TRUE) {

    action <- which(R[state,] >= 0, arr.ind = TRUE)

    if( length(action) !=1) { # Number of actions available
        action <- sample(action, 1, replace=TRUE) }

# Update the entry in the Q matrix

   Q[state, action] <- R[state, action] +
                       Gamma * Max(Q[action,])

   # Check if goal has been reached

   if( state == action) break

   state <- action   # Changed position

  }

# Update error matrix

  error[episode] <- sum(abs(oldQ - Q))

  oldQ <- Q

}

finalQ <- percent(Q)

## - Analyse the results of the Q-Learning algorithm

# Plot the error

plot(error, type="l")


#' as.symmetric
#'
#' Convert a regular R matrix into a packed symmetric matrix, whether or not
#' the input matrix was symmetric. Test for symmetry with \code{band::isSym()}
#' and NOT R's \code{isSymmetric()}.
#'
#' @details
#' The storage scheme is packed symmetric storage, so only the diagonal and
#' the specified triangle are stored.
#'
#' @param x
#' A matrix containing numeric, integer, or logical data.
#' @param triangle
#' A single character, either "u" or "l" for upper or lower, respectively.
#' This determines which triangle is used to create the packed storage matrix.
#' The default is the upper triangle.  Case is ignored.
#'
#' @return
#' A symmetric matrix.
#'
#' @examples
#' x <- matrix(1:25, nrow=5)
#' # use the upper triangle. note that 'x' is not symmetric, but the return is
#' as.symmetric(x)
#'
#' # lower triangle
#' as.symmetric(x, 'l')
#'
#' @references \url{http://www.netlib.org/lapack/lug/node123.html}
#' @seealso \code{\link{isSym}}, \code{\link{kdim}}, and \code{\link{classes}}
#' @keywords Casters
#' @export
as.symmetric <- function(x, triangle="u")
{
  check.is.matrix(x)
  if (!is.numeric(x) && !is.logical(x))
    stop("argument 'x' must contain numeric, integer, or logical data")

  check.is.char(triangle)

  triangle <- tolower(triangle)
  if (triangle != "u" && triangle != "l")
    stop("argument 'triangle' must be one of 'u' for upper or 'l' for lower")

  out <- .Call(R_tosymmetric, x, triangle)

  ret <- symmat(Data=out, dim=dim(x), triangle=triangle)

  ret
}