Home Linkedin Videos Feedback
Modeling 101 - Predicting Binary Outcomes with R, gbm, glmnet, and {caret}
Practical walkthroughs on machine learning, data exploration and finding insight.

### Packages Used in this Walkthrough

{caret} - modeling wrapper, functions, commands
{pROC} - Area Under the Curve (AUC) functions

# load libraries
library(caret)
library(pROC)

A binary outcome is a result that has two possible values - true or false, alive or dead, etc.

We’re going to use two models: gbm (Generalized Boosted Models) and glmnet (Generalized Linear Models). Approaching a new data set using different models is one way of getting a handle on your data. Gbm uses boosted trees while glmnet uses regression.

titanicDF <- read.csv('http://math.ucdenver.edu/RTutorial/titanic.txt',sep='\t')
print(str(titanicDF))
## 'data.frame':	1313 obs. of  5 variables:
##  $ Name    : Factor w/ 1310 levels "Abbing, Mr Anthony",..: 22 25 26 27 24 31 45 46 50 54 ...
##  $ PClass  : Factor w/ 3 levels "1st","2nd","3rd": 1 1 1 1 1 1 1 1 1 1 ...
##  $ Age     : num  29 2 30 25 0.92 47 63 39 58 71 ...
##  $ Sex     : Factor w/ 2 levels "female","male": 1 1 2 1 2 2 1 2 1 2 ...
##  $ Survived: int  1 0 0 0 1 1 1 0 1 0 ...
## NULL

titanicDF$Title <- ifelse(grepl('Mr ',titanicDF$Name),'Mr',ifelse(grepl('Mrs ',titanicDF$Name),'Mrs',ifelse(grepl('Miss',titanicDF$Name),'Miss','Nothing')))

The Age variable has missing data (i.e. NA’s) so we’re going to impute it with the mean value of all the available ages. There are many ways of imputing missing data - we could delete those rows, set the values to 0, etc. Either way, this will neutralize the missing fields with a common value, and allow the models that can’t handle them normally to function (gbm can handle NAs but glmnet cannot):

titanicDF$Age[is.na(titanicDF$Age)] <- median(titanicDF$Age, na.rm=T)

It is customary to have the outcome variable (also known as response variable) located in the last column of a data set:

titanicDF <- titanicDF[c('PClass', 'Age',    'Sex',   'Title', 'Survived')]
print(str(titanicDF))
## 'data.frame':	1313 obs. of  5 variables:
##  $ PClass  : Factor w/ 3 levels "1st","2nd","3rd": 1 1 1 1 1 1 1 1 1 1 ...
##  $ Age     : num  29 2 30 25 0.92 47 63 39 58 71 ...
##  $ Sex     : Factor w/ 2 levels "female","male": 1 1 2 1 2 2 1 2 1 2 ...
##  $ Title   : chr  "Miss" "Miss" "Mr" "Mrs" ...
##  $ Survived: int  1 0 0 0 1 1 1 0 1 0 ...
## NULL

Our data is starting to look good but we have to fix the factor variables as most models only accept numeric data. Again, gbm can deal with factor variables as it will dummify them internally, but glmnet won’t. In a nutshell, dummifying factors breaks all the unique values into separate columns (see my post on Brief Walkthrough Of The dummyVars function from {caret}). This is a caret function:

titanicDF$Title <- as.factor(titanicDF$Title)
titanicDummy <- dummyVars("~.",data=titanicDF, fullRank=F)
titanicDF <- as.data.frame(predict(titanicDummy,titanicDF))
print(names(titanicDF))
##  [1] "PClass.1st"    "PClass.2nd"    "PClass.3rd"    "Age"
##  [5] "Sex.female"    "Sex.male"      "Title.Miss"    "Title.Mr"
##  [9] "Title.Mrs"     "Title.Nothing" "Survived"

As you can see, each unique factor is now separated into it’s own column. Next, we need to understand the proportion of our outcome variable:

prop.table(table(titanicDF$Survived))
##
##      0      1
## 0.6573 0.3427

This tells us that 34.27% of our data contains survivors of the Titanic tragedy. This is an important step because if the proportion was smaller than 15%, it would be considered a rare event and would be more challenging to model.

I like generalizing my variables so that I can easily recycle the code for subsequent needs:

outcomeName <- 'Survived'
predictorsNames <- names(titanicDF)[names(titanicDF) != outcomeName]

Let’s model!

Even though we already know the models we’re going to use in this walkthrough, caret supports a huge number of models. Here is how to get the current list of supported models:

names(getModelInfo())
##   [1] "ada"                 "ANFIS"               "avNNet"
##   [4] "bag"                 "bagEarth"            "bagFDA"
##   [7] "bayesglm"            "bdk"                 "blackboost"
##  [10] "Boruta"              "brnn"                "bstLs"
##  [13] "bstSm"               "bstTree"             "C5.0"
##  [16] "C5.0Cost"            "C5.0Rules"           "C5.0Tree"
##  [19] "cforest"             "CSimca"              "ctree"
##  [22] "ctree2"              "cubist"              "DENFIS"
##  [25] "dnn"                 "earth"               "elm"
##  [28] "enet"                "evtree"              "extraTrees"
##  [31] "fda"                 "FH.GBML"             "FIR.DM"
##  [34] "foba"                "FRBCS.CHI"           "FRBCS.W"
##  [37] "FS.HGD"              "gam"                 "gamboost"
##  [40] "gamLoess"            "gamSpline"           "gaussprLinear"
##  [43] "gaussprPoly"         "gaussprRadial"       "gbm"
##  [46] "gcvEarth"            "GFS.FR.MOGAL"        "GFS.GCCL"
##  [49] "GFS.LT.RS"           "GFS.Thrift"          "glm"
##  [52] "glmboost"            "glmnet"              "glmStepAIC"
##  [55] "gpls"                "hda"                 "hdda"
##  [58] "HYFIS"               "icr"                 "J48"
##  [61] "JRip"                "kernelpls"           "kknn"
##  [64] "knn"                 "krlsPoly"            "krlsRadial"
##  [67] "lars"                "lars2"               "lasso"
##  [70] "lda"                 "lda2"                "leapBackward"
##  [73] "leapForward"         "leapSeq"             "Linda"
##  [76] "lm"                  "lmStepAIC"           "LMT"
##  [79] "logicBag"            "LogitBoost"          "logreg"
##  [82] "lssvmLinear"         "lssvmPoly"           "lssvmRadial"
##  [85] "lvq"                 "M5"                  "M5Rules"
##  [88] "mda"                 "Mlda"                "mlp"
##  [91] "mlpWeightDecay"      "multinom"            "nb"
##  [94] "neuralnet"           "nnet"                "nodeHarvest"
##  [97] "oblique.tree"        "OneR"                "ORFlog"
## [100] "ORFpls"              "ORFridge"            "ORFsvm"
## [103] "pam"                 "parRF"               "PART"
## [106] "partDSA"             "pcaNNet"             "pcr"
## [109] "pda"                 "pda2"                "penalized"
## [112] "PenalizedLDA"        "plr"                 "pls"
## [115] "plsRglm"             "ppr"                 "protoclass"
## [118] "qda"                 "QdaCov"              "qrf"
## [121] "qrnn"                "rbf"                 "rbfDDA"
## [124] "rda"                 "relaxo"              "rf"
## [127] "rFerns"              "RFlda"               "ridge"
## [130] "rknn"                "rknnBel"             "rlm"
## [133] "rocc"                "rpart"               "rpart2"
## [136] "rpartCost"           "RRF"                 "RRFglobal"
## [139] "rrlda"               "RSimca"              "rvmLinear"
## [142] "rvmPoly"             "rvmRadial"           "SBC"
## [145] "sda"                 "sddaLDA"             "sddaQDA"
## [148] "simpls"              "SLAVE"               "slda"
## [151] "smda"                "sparseLDA"           "spls"
## [154] "stepLDA"             "stepQDA"             "superpc"
## [157] "svmBoundrangeString" "svmExpoString"       "svmLinear"
## [160] "svmPoly"             "svmRadial"           "svmRadialCost"
## [163] "svmRadialWeights"    "svmSpectrumString"   "treebag"
## [166] "vbmpRadial"          "widekernelpls"       "WM"
## [169] "xyf"

Plenty to satisfy most needs!!

Gbm Modeling

It is important to know what type of modeling a particular model supports. This can be done using the caret function getModelInfo:

getModelInfo()$gbm$type
## [1] "Regression"     "Classification"

This tells us that gbm supports both regression and classification. As this is a binary classification, we need to force gbm into using the classification mode. We do this by changing the outcome variable to a factor (we use a copy of the outcome as we’ll need the original one for our next model):

titanicDF$Survived2 <- ifelse(titanicDF$Survived==1,'yes','nope')
titanicDF$Survived2 <- as.factor(titanicDF$Survived2)
outcomeName <- 'Survived2'

As with most modeling projects, we need to split our data into two portions: a training and a testing portion. By doing this, we can use one portion to teach the model how to recognize survivors on the Titanic and the other portion to evaluate the model. Setting the seed is paramount for reproducibility as createDataPartition will shuffle the data randomly before splitting it. By using the same seed you will always get the same split in subsequent runs:

set.seed(1234)
splitIndex <- createDataPartition(titanicDF[,outcomeName], p = .75, list = FALSE, times = 1)
trainDF <- titanicDF[ splitIndex,]
testDF  <- titanicDF[-splitIndex,]

Caret offers many tuning functions to help you get as much as possible out of your models; the trainControl function allows you to control the resampling of your data. This will split the training data set internally and do it’s own train/test runs to figure out the best settings for your model. In this case, we’re going to cross-validate the data 3 times, therefore training it 3 times on different portions of the data before settling on the best tuning parameters (for gbm it is trees, shrinkage, and interaction depth). You can also set these values yourself if you don’t trust the function.

objControl <- trainControl(method='cv', number=3, returnResamp='none', summaryFunction = twoClassSummary, classProbs = TRUE)

This is the heart of our modeling adventure, time to teach our model how to recognize Titanic survivors. Because this is a classification model, we’re requesting that our metrics use ROC instead of the default RMSE:

objModel <- train(trainDF[,predictorsNames], trainDF[,outcomeName],
                  method='gbm',
                  trControl=objControl,
                  metric = "ROC",
                  preProc = c("center", "scale"))
## Iter   TrainDeviance   ValidDeviance   StepSize   Improve
##      1        1.2314             nan     0.1000    0.0245
##      2        1.1948             nan     0.1000    0.0192
##      3        1.1594             nan     0.1000    0.0158
...

I truncated most of the lines from the training process but you get the idea. We then can call summary() function on our model to find out what variables were most important:

summary(objModel)
plot of chunk unnamed-chunk-10

##                         var rel.inf
## Title.Mr           Title.Mr 26.2756
## PClass.3rd       PClass.3rd 20.8523
## Sex.male           Sex.male 20.7569
## Sex.female       Sex.female 11.4357
## Age                     Age 10.3042
## PClass.1st       PClass.1st  8.2905
## Title.Mrs         Title.Mrs  1.7515
## Title.Miss       Title.Miss  0.3332
## PClass.2nd       PClass.2nd  0.0000
## Title.Nothing Title.Nothing  0.0000

We can find out what tuning parameters were most important to the model (notice the last lines about trees, shrinkage and interaction depth:

print(objModel)
## Stochastic Gradient Boosting
##
## 986 samples
##  10 predictor
##   2 classes: 'nope', 'yes'
##
## Pre-processing: centered, scaled
## Resampling: Cross-Validated (3 fold)
...
## Tuning parameter 'shrinkage' was held constant at a value of 0.1
## ROC was used to select the optimal model using  the largest value.
## The final values used for the model were n.trees = 100,
##  interaction.depth = 1 and shrinkage = 0.1.

### Evaluate gbm model

There are two types of evaluation we can do here, raw or prob. Raw gives you a class prediction, in our case yes and nope, while prob gives you the probability on how sure the model is about it’s choice. I always use prob, as I like to be in control of the threshold and also like to use AUC score which requires probabilities, not classes. There are situations where having class values can come in handy, such as with multinomial models where you’re predicting more than two values.

We now call the predict function and pass it our trained model and our testing data. Let’s start by looking at class predictions and using the caret postResample function to get an accuracy score:

predictions <- predict(object=objModel, testDF[,predictorsNames], type='raw')
head(predictions)
## [1] yes  nope yes  nope nope nope
## Levels: nope yes
print(postResample(pred=predictions, obs=as.factor(testDF[,outcomeName])))
## Accuracy    Kappa
##   0.8135   0.5644

The accuracy tells us that our model is correct 81.35% of the time - not bad…

Now let’s look at probabilities:

# probabilites
library(pROC)
predictions <- predict(object=objModel, testDF[,predictorsNames], type='prob')
head(predictions)
##      nope    yes
## 1 0.07292 0.9271
## 2 0.76058 0.2394
## 3 0.43309 0.5669
## 4 0.67279 0.3272
## 5 0.67279 0.3272
## 6 0.54616 0.4538

To get the AUC score, you need to pass the yes column to the roc function (each row adds up to 1 but we’re interested in the yes, the survivors):

auc <- roc(ifelse(testDF[,outcomeName]=="yes",1,0), predictions[[2]])
print(auc$auc)
## Area under the curve: 0.825

The AUC is telling us that our model has a 0.825 AUC score (remember that an AUC ranges between 0.5 and 1, where 0.5 is random and 1 is perfect).

Glmnet Modeling

Let’s change gears and try this out on a regression model. Let’s look at what modeling types glmnet supports and reset our outcome variable as we’re going to be using the numerical outcome instead of the factor.

getModelInfo()$glmnet$type
## [1] "Regression"     "Classification"
outcomeName <- 'Survived'

set.seed(1234)
splitIndex <- createDataPartition(titanicDF[,outcomeName], p = .75, list = FALSE, times = 1)
trainDF <- titanicDF[ splitIndex,]
testDF  <- titanicDF[-splitIndex,]

We re-run some of the basic training and prediction functions with some slight changes:

objControl <- trainControl(method='cv', number=3, returnResamp='none')
objModel <- train(trainDF[,predictorsNames], trainDF[,outcomeName], method='glmnet',  metric = "RMSE", trControl=objControl)
predictions <- predict(object=objModel, testDF[,predictorsNames])
auc <- roc(testDF[,outcomeName], predictions)
print(auc$auc)
## Area under the curve: 0.857

plot(varImp(objModel,scale=F))
plot of chunk unnamed-chunk-10

#################################################
# data prep
#################################################

# load data
titanicDF <- read.csv('http://math.ucdenver.edu/RTutorial/titanic.txt',sep='\t')
titanicDF$Title <- ifelse(grepl('Mr ',titanicDF$Name),'Mr',ifelse(grepl('Mrs ',titanicDF$Name),'Mrs',ifelse(grepl('Miss',titanicDF$Name),'Miss','Nothing')))
titanicDF$Age[is.na(titanicDF$Age)] <- median(titanicDF$Age, na.rm=T)

# miso format
titanicDF <- titanicDF[c('PClass', 'Age',    'Sex',   'Title', 'Survived')]

# dummy variables for factors/characters
titanicDF$Title <- as.factor(titanicDF$Title)
titanicDummy <- dummyVars("~.",data=titanicDF, fullRank=F)
titanicDF <- as.data.frame(predict(titanicDummy,titanicDF))
print(names(titanicDF))

# what is the proportion of your outcome variable?
prop.table(table(titanicDF$Survived))

# save the outcome for the glmnet model
tempOutcome <- titanicDF$Survived

# generalize outcome and predictor variables
outcomeName <- 'Survived'
predictorsNames <- names(titanicDF)[names(titanicDF) != outcomeName]

#################################################
# model it
#################################################
# get names of all caret supported models
names(getModelInfo())

titanicDF$Survived <- ifelse(titanicDF$Survived==1,'yes','nope')

# pick model gbm and find out what type of model it is
getModelInfo()$gbm$type

# split data into training and testing chunks
set.seed(1234)
splitIndex <- createDataPartition(titanicDF[,outcomeName], p = .75, list = FALSE, times = 1)
trainDF <- titanicDF[ splitIndex,]
testDF  <- titanicDF[-splitIndex,]

# create caret trainControl object to control the number of cross-validations performed
objControl <- trainControl(method='cv', number=3, returnResamp='none', summaryFunction = twoClassSummary, classProbs = TRUE)

# run model
objModel <- train(trainDF[,predictorsNames], as.factor(trainDF[,outcomeName]),
                  method='gbm',
                  trControl=objControl,
                  metric = "ROC",
                  preProc = c("center", "scale"))

# find out variable importance
summary(objModel)

# find out model details
objModel

#################################################
# evalutate model
#################################################
# get predictions on your testing data

# class prediction
predictions <- predict(object=objModel, testDF[,predictorsNames], type='raw')
head(predictions)
postResample(pred=predictions, obs=as.factor(testDF[,outcomeName]))

# probabilities
predictions <- predict(object=objModel, testDF[,predictorsNames], type='prob')
head(predictions)
postResample(pred=predictions[[2]], obs=ifelse(testDF[,outcomeName]=='yes',1,0))
auc <- roc(ifelse(testDF[,outcomeName]=="yes",1,0), predictions[[2]])
print(auc$auc)

# pick model gbm and find out what type of model it is
getModelInfo()$glmnet$type

# save the outcome for the glmnet model
titanicDF$Survived  <- tempOutcome

# split data into training and testing chunks
set.seed(1234)
splitIndex <- createDataPartition(titanicDF[,outcomeName], p = .75, list = FALSE, times = 1)
trainDF <- titanicDF[ splitIndex,]
testDF  <- titanicDF[-splitIndex,]

# create caret trainControl object to control the number of cross-validations performed
objControl <- trainControl(method='cv', number=3, returnResamp='none')

# run model
objModel <- train(trainDF[,predictorsNames], trainDF[,outcomeName], method='glmnet',  metric = "RMSE", trControl=objControl))

# get predictions on your testing data
predictions <- predict(object=objModel, testDF[,predictorsNames])

library(pROC)
auc <- roc(testDF[,outcomeName], predictions)
print(auc$auc)

postResample(pred=predictions, obs=testDF[,outcomeName])

# find out variable importance
summary(objModel)
plot(varImp(objModel,scale=F))

# find out model details
objModel

# display variable importance on a +/- scale
vimp <- varImp(objModel, scale=F)
results <- data.frame(row.names(vimp$importance),vimp$importance$Overall)
results$VariableName <- rownames(vimp)
colnames(results) <- c('VariableName','Weight')
results <- results[order(results$Weight),]
results <- results[(results$Weight != 0),]

par(mar=c(5,15,4,2)) # increase y-axis margin.
xx <- barplot(results$Weight, width = 0.85,
              main = paste("Variable Importance -",outcomeName), horiz = T,
              xlab = "< (-) importance >  < neutral >  < importance (+) >", axes = FALSE,
              col = ifelse((results$Weight > 0), 'blue', 'red'))
axis(2, at=xx, labels=results$VariableName, tick=FALSE, las=2, line=-0.3, cex.axis=0.6)

################################################
# advanced stuff
################################################

# boosted tree model (gbm) adjust learning rate and and trees
gbmGrid <-  expand.grid(interaction.depth =  c(1, 5, 9),
                        n.trees = 50,
                        shrinkage = 0.01)

# run model
objModel <- train(trainDF[,predictorsNames], trainDF[,outcomeName], method='gbm', trControl=objControl, tuneGrid = gbmGrid, verbose=F)

# get predictions on your testing data
predictions <- predict(object=objModel, testDF[,predictorsNames])

library(pROC)
auc <- roc(testDF[,outcomeName], predictions)
print(auc$auc)


set.seed(666)

true.lambda <- 2
N_0 <- 200
y_0 <- rpois(N_0, lambda = true.lambda)

N <- 100
y <- rpois(N, lambda = true.lambda)

alpha_0 <- 2
beta_0 <- 2

nu <- 1
eta <- 1


# 4. faza: Analiza podatkov

logisticna <- function(x) { 100 / (1 + exp(-x)) }
logisticna_inv <- function(y) { log(y / (100 - y)) }
logisticna_breaks <- . %>% logisticna() %>% extended_breaks()() %>% logisticna_inv()

logisticna_trans <- trans_new("logistična funkcija", logisticna, logisticna_inv)

primerjava_rasti_log <- primerjava_rasti %>% mutate(delez=logisticna_inv(delez))

graf7 <- ggplot(primerjava_rasti_log %>% filter(drzava %in% c("Islandija", "Nizozemska", "Norveška", "Bolgarija", "Turčija", "Grčija")),
                aes(x=leto, y=delez, col=drzava)) +
  geom_point() + ggtitle("Primerjava rasti držav z največjo in najmanjšo rastjo") +
  xlab("leto") + ylab("delež v %") + facet_grid(. ~ drzava) + stat_smooth(method="lm") +
  coord_trans(y=logisticna_trans) + scale_y_continuous(breaks=logisticna_breaks,
                                                       labels=logisticna) +
  theme(axis.text.x=element_text(angle=45, vjust=0.5, hjust=1))

bolgarija = c('Bolgarija')
rasti_b <- primerjava_rasti_log %>% filter(drzava=="Bolgarija")
rasti_b$vrsta <- "podatki"
names(rasti_b)[names(rasti_b) == "delez"] <- "rast"
model7b <- lm(rast~leto, data=rasti_b)
pr <- predict(model7b, data.frame(leto=seq.int(2020, 2025, 1)))
napoved_rasti_b <- data.frame(leto = c(2020, 2021, 2022, 2023, 2024, 2025), rast = c(pr[1], pr[2], pr[3], pr[4], pr[5], pr[6]))
napoved_rasti_b$drzava <- bolgarija
napoved_rasti_b$vrsta <- "napoved"
skupne_rasti_b <- rbind(rasti_b, napoved_rasti_b)

turcija = c('Turčija')
rasti_t <- primerjava_rasti_log %>% filter(drzava=="Turčija")
rasti_t$vrsta <- "podatki"
names(rasti_t)[names(rasti_t) == "delez"] <- "rast"
model7t <- lm(rast~leto, data=rasti_t)
prt <- predict(model7t, data.frame(leto=seq.int(2020, 2025, 1)))
napoved_rasti_t <- data.frame(leto = c(2020, 2021, 2022, 2023, 2024, 2025), rast = c(prt[1], prt[2], prt[3], prt[4], prt[5], prt[6]))
napoved_rasti_t$drzava <- turcija
napoved_rasti_t$vrsta <- "napoved"
skupne_rasti_t <- rbind(rasti_t, napoved_rasti_t)

grcija = c('Grčija')
rasti_g <- primerjava_rasti_log %>% filter(drzava=="Grčija")
rasti_g$vrsta <- "podatki"
names(rasti_g)[names(rasti_g) == "delez"] <- "rast"
model7g <- lm(rast~leto, data=rasti_g)
prg <- predict(model7g, data.frame(leto=seq.int(2020, 2025, 1)))
napoved_rasti_g <- data.frame(leto = c(2020, 2021, 2022, 2023, 2024, 2025), rast = c(prg[1], prg[2], prg[3], prg[4], prg[5], prg[6]))
napoved_rasti_g$drzava <- grcija
napoved_rasti_g$vrsta <- "napoved"
skupne_rasti_g <- rbind(rasti_g, napoved_rasti_g)

napoved_rasti <- rbind(skupne_rasti_b, skupne_rasti_g, skupne_rasti_t)

graf7a <- ggplot(napoved_rasti, aes(x=leto, y=rast, col=drzava, shape=vrsta)) +
  geom_point() + ggtitle("Napoved rasti držav z največjo rastjo") +
  xlab("leto") + ylab("delež v %") + facet_grid(. ~ drzava) + stat_smooth(method="lm") +
  coord_trans(y=logisticna_trans) + scale_y_continuous(breaks=logisticna_breaks,
                                                       labels=logisticna)

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

primerjava_rasti_komunikacije_log <- primerjava_rasti_komunikacije %>% mutate(delez=logisticna_inv(delez))

graf8 <- ggplot(primerjava_rasti_komunikacije_log %>% filter(drzava %in% c("Latvija", "Estonija", "Danska", "Bolgarija", "Italija")),
                aes(x=leto, y=delez, col=drzava)) +
  geom_point() + ggtitle("Primerjava rasti držav z največjo in najmanjšo stopnjo komunikacije") +
  xlab("leto") + ylab("delež v %") + facet_grid(. ~ drzava) + stat_smooth(method="lm") +
  coord_trans(y=logisticna_trans) + scale_y_continuous(breaks=logisticna_breaks,
                                                       labels=logisticna) +
  theme(axis.text.x=element_text(angle=45, vjust=0.5, hjust=1))

komunikacija_b <- primerjava_rasti_komunikacije_log %>% filter(drzava=="Bolgarija")
komunikacija_b$vrsta <- "podatki"
names(komunikacija_b)[names(komunikacija_b) == "delez"] <- "rast"
model8b <- lm(rast~leto, data=komunikacija_b)
prb <- predict(model8b, data.frame(leto=seq.int(2020, 2025, 1)))
napoved_komunikacije_b <- data.frame(leto = c(2020, 2021, 2022, 2023, 2024, 2025), rast = c(prb[1], prb[2], prb[3], prb[4], prb[5], prb[6]))
napoved_komunikacije_b$drzava <- bolgarija
napoved_komunikacije_b$vrsta <- "napoved"
skupna_komunikacija_b <- rbind(komunikacija_b, napoved_komunikacije_b)

danska <- c('Danska')
komunikacija_d <- primerjava_rasti_komunikacije_log %>% filter(drzava=="Danska")
komunikacija_d$vrsta <- "podatki"
names(komunikacija_d)[names(komunikacija_d) == "delez"] <- "rast"
model8d <- lm(rast~leto, data=komunikacija_d)
prd <- predict(model8d, data.frame(leto=seq.int(2020, 2025, 1)))
napoved_komunikacije_d <- data.frame(leto = c(2020, 2021, 2022, 2023, 2024, 2025), rast = c(prd[1], prd[2], prd[3], prd[4], prd[5], prd[6]))
napoved_komunikacije_d$drzava <- danska
napoved_komunikacije_d$vrsta <- "napoved"
skupna_komunikacija_d <- rbind(komunikacija_d, napoved_komunikacije_d)

estonija <- c('Estonija')
komunikacija_e <- primerjava_rasti_komunikacije_log %>% filter(drzava=="Estonija")
komunikacija_e$vrsta <- "podatki"
names(komunikacija_e)[names(komunikacija_e) == "delez"] <- "rast"
model8e <- lm(rast~leto, data=komunikacija_e)
pre <- predict(model8e, data.frame(leto=seq.int(2020, 2025, 1)))
napoved_komunikacije_e <- data.frame(leto = c(2020, 2021, 2022, 2023, 2024, 2025), rast = c(pre[1], pre[2], pre[3], pre[4], pre[5], pre[6]))
napoved_komunikacije_e$drzava <- estonija
napoved_komunikacije_e$vrsta <- "napoved"
skupna_komunikacija_e <- rbind(komunikacija_e, napoved_komunikacije_e)

italija <- c('Italija')
komunikacija_i <- primerjava_rasti_komunikacije_log %>% filter(drzava=="Italija")
komunikacija_i$vrsta <- "podatki"
names(komunikacija_i)[names(komunikacija_i) == "delez"] <- "rast"
model8i <- lm(rast~leto, data=komunikacija_i)
pri <- predict(model8i, data.frame(leto=seq.int(2020, 2025, 1)))
napoved_komunikacije_i <- data.frame(leto = c(2020, 2021, 2022, 2023, 2024, 2025), rast = c(pri[1], pri[2], pri[3], pri[4], pri[5], pri[6]))
napoved_komunikacije_i$drzava <- italija
napoved_komunikacije_i$vrsta <- "napoved"
skupna_komunikacija_i <- rbind(komunikacija_i, napoved_komunikacije_i)

latvija <- c('Latvija')
komunikacija_l <- primerjava_rasti_komunikacije_log %>% filter(drzava=="Latvija")
komunikacija_l$vrsta <- "podatki"
names(komunikacija_l)[names(komunikacija_l) == "delez"] <- "rast"
model8l <- lm(rast~leto, data=komunikacija_l)
prl <- predict(model8l, data.frame(leto=seq.int(2020, 2025, 1)))
napoved_komunikacije_l <- data.frame(leto = c(2020, 2021, 2022, 2023, 2024, 2025), rast = c(prl[1], prl[2], prl[3], prl[4], prl[5], prl[6]))
napoved_komunikacije_l$drzava <- latvija
napoved_komunikacije_l$vrsta <- "napoved"
skupna_komunikacija_l <- rbind(komunikacija_l, napoved_komunikacije_l)

napoved_komunikacije <- rbind(skupna_komunikacija_b, skupna_komunikacija_d, skupna_komunikacija_e,
                              skupna_komunikacija_i, skupna_komunikacija_l)

graf8a <- ggplot(napoved_komunikacije, aes(x=leto, y=rast, col=drzava, shape=vrsta)) +
  geom_point() + ggtitle("Napoved komunikacije državljanov z oblastmi") +
  xlab("leto") + ylab("delež v %") + facet_grid(. ~ drzava) + stat_smooth(method="lm") +
  coord_trans(y=logisticna_trans) + scale_y_continuous(breaks=logisticna_breaks,
                                                       labels=logisticna) +
  theme(axis.text.x=element_text(angle=45, vjust=0.5, hjust=1))


#playing around with housing data
#thanks to Eric @ AARL --> https://www.aaarl.ca/
#install.packages('readxl')

library(readxl)
Housing_Training_Set_csv <- read_excel("J:/Projects/Professional/Autodidactics/Data Analytics AARL/Part02/Housing Training Set.csv.xlsx")
View(Housing_Training_Set_csv)

#install.packages('readr')
library(readr)

Housing_Training_Set_csv2 <- read_csv("J:/Projects/Professional/Autodidactics/Data Analytics AARL/Part02/Housing Training Set.csv.xlsx")
View(Housing_Training_Set_csv)

housing<-Housing_Training_Set_csv

#previewing the top/bottom of the dataset
head(housing)
tail(housing)

#selecting certain rows
housing[1:3,]

#picking a column
housing$SalePrice

#CASE SENSITIVITY EXISTS
View(housing)

housing[10,5]
housing$LotArea[10]

#these should be self-evident
summary(housing)
colnames(housing)

plot(housing$LotArea, housing$SalePrice, main="Sales Price vs. Lot Area", col="red", type="s")
plot(housing$MSSubClass, housing$OverallCond, main="Overall Condition vs. MS Sub Class", col="purple")
plot(housing$LotFrontage, housing$BsmtFinSF1, main="Basement Finished Square Feet vs. Lot Frontage", col="green")
#convert non-numeric cols for plotting
plot(as.factor(housing$Alley),housing$BsmtUnfSF)

#unsquared correlation coeff
cor(housing$SalePrice,housing$LotArea)

#remove outliers
housingCleaned<-housing[which(housing$LotArea<50000),]
plot(housingCleaned$LotArea,housingCleaned$SalesPrice)
cor(housingCleaned$SalePrice,housingCleaned$LotArea)

#adding cols
housingCleaned$Age<-2018-housingCleaned$YearBuilt

housingCleaned$Age[2]
housingCleaned$YearBuilt[2]
plot(housingCleaned$Age, housingCleaned$SalePrice)

#gimme the usual
mean(housingCleaned$SalePrice)
median(housingCleaned$SalePrice)
mode(housingCleaned$SalePrice)#SCAM!

# Create the function for mode ourselves
getmode <- function(v) {
  uniqv <- unique(v)
  uniqv[which.max(tabulate(match(v, uniqv)))]
}

getmode(housingCleaned$SalePrice)

#le regulier
min(housingCleaned$SalePrice)
max(housingCleaned$SalePrice)
sd(housingCleaned$SalePrice)

#install.packages('psych')
library('psych')
describe(housingCleaned$SalePrice)

library(readxl)
housingTrain <- read_excel("J:/Projects/Professional/Autodidactics/Data Analytics AARL/Part02/Housing Training Set.csv.xlsx")
View(housingTrain)

housingTest <- read_excel("J:/Projects/Professional/Autodidactics/Data Analytics AARL/Part02/Housing Testing Set.csv.xlsx")
View(housingTest)

#linear model function
reg01<-lm(SalePrice~LotArea, data=housingTrain)
plot(reg01)
summary(reg01)

#add factors
reg02<-lm(SalePrice~LotArea+as.factor(Fireplaces)+OverallQual, data=housingTrain)
summary(reg02)

reg03<-lm(SalePrice~LotFrontage + as.factor(Foundation) + as.factor(BsmtQual) + as.factor(BsmtCond) + as.factor(BsmtExposure) + TotalBsmtSF + GarageArea + as.factor(GarageQual), data=housingTrain)
plot(reg03)
summary(reg03)

#predict stuff
prd01<-predict(reg01,data.frame(LotArea=c(1000,50)), interval="confidence")
prd01

prd02<-predict(reg01, housingTest, interval="confidence")
prd02

#doesn't work due to unexpected vals
prd03<-predict(reg03, housingTest, interval="confidence")

install.packages('forecast')
install.packages('TTR')

library(readr)
library(forecast)
library(TTR)

#data obtained from investing.com
usdCad<-read_excel("J:/Projects/Professional/Autodidactics/Data Analytics AARL/Part02/USD CAD Historical Data.csv.xlsx")
summary(usdCad)
View(usdCad)

#declare time series and plot
usdCad$Price<-ts(usdCad$Price, start=c(2006,01,01),frequency=52)
plot(usdCad$Price, main="USD/CAD", xlab="Date", ylab="Exchange Rate",col="green")
exDecomp<-decompose(usdCad$Price)
plot(exDecomp)

#aggregation of seasons by year on the same plot
seasonplot(usdCad$Price)
tsdisplay(usdCad$Price)

#seasonal decomposition using another function
plot(stl(usdCad$Price, s.window="period"))

#moving averages
usdcad_sma_10<-SMA(usdCad$Price, 10)
usdcad_sma_25<-SMA(usdCad$Price, 25)
usdcad_sma_100<-SMA(usdCad$Price, 100)

plot(usdCad$Price)
plot(usdcad_sma_10, type='l')
plot(usdcad_sma_25, type='l')
plot(usdcad_sma_100, type='l')

#forecasting
usdcad_sma_forecast<-forecast(usdcad_sma_10, 10)
plot(usdcad_sma_forecast)

#changing the timeline affects the results!
usdcad_sma_forecast2<-forecast(usdcad_sma_100, 100)
plot(usdcad_sma_forecast2)

#verify dat
usdCad2017=read_excel("J:/Projects/Professional/Autodidactics/Data Analytics AARL/Part02/usdcad_2017.csv.xlsx")
plot(usdcad_sma_forecast2$mean)
par(new=1)
plot(usdCad2017$Price[1:16], col='red', type='l')

#autoregression model (better for non-stationary predictions, i.e. random processes)
usdcad_AR<-ar.ols(usdCad$Price, order.max=202)
usdcad_AR
summary(usdcad_AR)
usdcad_ar_forecast<-forecast(usdcad_AR,17)
plot(usdcad_ar_forecast)#blue region indicates prediction

#quick sanity check
plot(usdcad_ar_forecast$mean)
par(new=TRUE)
plot(usdCad2017$Price[1:17], col='red', type='l')

#Let's take a look at some oil price data
oily=read_excel("J:/Projects/Professional/Autodidactics/Data Analytics AARL/Part02/Crude Oil WTI Futures Historical Data.csv.xlsx")
oily$Price<-ts(oily$Price, start=c(2006,01,01),frequency = 52)
plot(oily$Price, type="l")

#install.packages("vars")#Vector Auto Regression (generalization of AR w/ >1 variable)
library(vars)
endo<-data.frame(oily$Price, usdCad$Price)#endogenous analysis (internal)
var1<-VAR(y=endo, p=5)
summary(var1)

var1_predict<-predict(var1, n.ahead=17)#attempt to look at the near future
plot(var1_predict$fcst$usdCad.Price[,1],type='l')

par(new=TRUE)
plot(usdCad2017$Price[1:17], col='green', type='l')#verify


#To print matrix

data = c(55,66,77,89,90,60)
value = matrix(data,nrow = 3,ncol = 2,byrow = T)
print(value)

#To print Diagonal Matrix

diagonal = diag(c(data),3,3)
print(diagonal)

#To print Identity Matrix

identity = diag(c(1),3,3)
print(identity)


## Dale W.R. Rosenthal, 2018
## You are free to distribute and use this code so long as you attribute
## it to me or cite the text.
## The legal disclaimer in _A Quantitative Primer on Investments with R_
## applies to this code.  Use or distribution without these comment lines
## is forbidden.
library(xts)
library(quantmod)
library(Quandl)

# Get TED spread
ted <- Quandl("FRED/TEDRATE", type="xts")/100
colnames(ted) <- c("TED")

# Get S&P 500, Russell 2000, and ETF returns
adj.close <- 6  # 6th field is adjusted close
equity.tickers <- c("^GSPC","^RUT","SPY","IWM","UN","UL","RELX","RENX","BHP","BBL")
prices <- getSymbols(equity.tickers[1], source="yahoo", auto.assign=FALSE,
                         return.class="xts")[,adj.close]
for (i in 2:length(equity.tickers)) {
  prices.tmp <- getSymbols(equity.tickers[i], source="yahoo",
                         auto.assign=FALSE, return.class="xts")[,adj.close]
  prices <- cbind(prices, prices.tmp)
}
equity.names <- c("SPX","RUT","SPY","IWM","UN","UL","RELX","RENX","BHP","BBL")
colnames(prices) <- equity.names

# compute differences

# Now we join all of the datasets together
alldata.full <- cbind(ted, differences)["2007/"]


install.packages("rstan", repos = "https://cloud.r-project.org/", dependencies = TRUE)
library(rstan)

y <- read.table("hw4data_stan.txt")
N <- length(y[,1])

plot(density(y[,1]))
plot(density(y[,2]))
plot(density(y[,3]))
plot(density(y[,4]))

## stan data
stan_data <- list(N = N, y = y, K = 3, D = 4)

write("// Stan model

      data {
        int N; // sample size
        int D; // dimension of observed vars
        int K; // number of latent groups
        vector[D] y[N]; // data
      }

      parameters {
        ordered[K] mu; // locations of hidden states
        vector<lower = 0>[K] sigma; // variances of hidden states
        simplex[K] theta[D]; // mixture components
      }

      model {
        vector[K] obs[D];

        // priors
        for(k in 1:K){
          mu[k] ~ normal(0,10);
          sigma[k] ~ inv_gamma(1,1);
        }

        for(d in 1:D){
          theta[d] ~ dirichlet(rep_vector(2.0, K));
        }

        // likelihood
        for(d in 1:D){
          for(i in 1:N) {
            for(k in 1:K) {
              obs[d][k] = log(theta[d][k]) + normal_lpdf(y[i][d] | mu[k], sigma[k]);
            }
            target += log_sum_exp(obs[d]);
          }
        }
      } ",

"stan_model.stan")

## check
stanc("stan_model.stan")

## save filepath
stan_model <- "stan_model.stan"

## fit
fit <- stan(file = stan_model, data = stan_data, warmup = 500, iter = 1000, chains = 4, cores = 2, thin = 1)

## check it out
fit

## look at posterior
posterior <- extract(fit)
hist(posterior$mu)

## some other diagnostics
traceplot(fit)
stan_dens(fit)
stan_hist(fit)

## try out some variational inference methods in Stan...
m <- stan_model(file = "stan_model.stan")
fit2 <- vb(m, data = stan_data, algorithm = "meanfield")
fit2


# Example : 2.5B   Chapter : 2.5   Pageno : 88
# Inverse of the given matrices
B<-matrix(c(4,8,3,7),ncol=2)
C<-matrix(c(6,6,6,0),ncol=2)
S<-matrix(c(1,1,1,0,1,1,0,0,1),ncol=3)
B1<-solve(B)
C1<-solve(C)
S1<-solve(S)
print("Inverses of given matrices ")
print(B1)
print(C1)
print(S1)


##### rmse function
rmse <- function(y, yhat){

	yhat[yhat < 0] = 0
	r = sqrt(mean((y - yhat)^2));
	return(r);
}
##### rmsle function
rmsle <- function(y, yhat){

	yhat[yhat < 0] = 0
	r = sqrt(mean((log(y+1) - log(yhat+1))^2));
	return(r);
}
#################################################################
# RMSLE based Objective function t
rmsle_objfun <- function(beta,y,x){

	yhat = x%*%beta;
	yhat[yhat <0] =0;
	res <- rmsle(y,yhat)
	#n = length(y);
	#attr(res, "gradient") <- -t((log(y+1) - log(yhat+1))/(yhat+1))%*%x/(n*res);
	return(res);
}
# RMSLog_Yratio based Objective function
rmslyr_objfun <- function(beta,yr,x){

	yrhat = x%*%beta;

	res <- sqrt(mean((log(yr) - log(yrhat))^2));
	return(res);
}
# RMSE based Objective function
rmse_objfun <- function(beta,y,x){

	yhat = x%*%beta;

	res <- sqrt(mean((y - yhat)^2));
	return(res);
}

###################################################################
single_test <- function(dtest,params,onresids=F){
	test.x = as.matrix(dtest$X)
	if (onresids){

		yratio_hat <- test.x %*% params
		test.yhat <- yratio_hat*dtest$yhat_prev + yratio_hat - 1
	}
	else{
		test.yhat <- test.x %*% params
	}
  test.yhat[test.yhat < 0] = 0
	test.rmsle <- rmsle(dtest$Y, test.yhat)
	return(list(rmsle = test.rmsle,yhat=test.yhat))

}
single_fit <- function(dtrain,init.param,onresids=F){

	train.x = as.matrix(dtrain$X)
	if(onresids){
		optim.y = dtrain$yratio
		# oout = nlm(rmslyr_objfun, init.param, optim.y,train.x);
		# oout = nlm(rmse_objfun, init.param, optim.y,train.x);

		oout =  optim(init.param, rmslyr_objfun, gr = NULL, optim.y, train.x, method = "BFGS", control=list((maxit = 1E3)));
	}
	else{
		optim.y = dtrain$Y
		# oout = nlm(rmsle_objfun, init.param, optim.y,train.x);

		oout =  optim(init.param, rmsle_objfun, gr = NULL, optim.y, train.x, method = "BFGS", control=list((maxit = 1E3)));
	}

	# fminval = oout$minimum
	# params = oout$estimate
	fminval = oout$value
	params = oout$par

	if (onresids){
		yratio_hat <- train.x %*% params
		train.yhat <- yratio_hat*dtrain$yhat_prev + yratio_hat - 1

	}
	else{
		train.yhat <- train.x %*% params
	}
	train.rmsle <- rmsle(dtrain$Y, train.yhat)

	res = list(params = params, fminval = fminval, train.rmsle = train.rmsle)
	return(res)
}
mycortest <- function(X,Y){
	randind = sample(1:length(Y),length(Y))
	pY = Y[randind]

	par(mfrow=c(2,1))

	plot(X,Y,main=round(cor(X,Y),2));
	abline(h=0,lwd=2,col='red')
	#mod = lm(formula = Y[X>300] ~ X[X>300])
	#abline(a=mod$coef[1],b=mod$coef[2],col='green',lwd=2)

	plot(X,pY,main=round(cor(X,pY),2))
	abline(h=0,lwd=2,col='red')

}

###################################################################
nfold_jknife <- function(dall,Nf,test_frac,init.param,onresids=F,fullres = F){
	N = length(dall$Y)
	Ntest = floor(N*test_frac)
	set.seed(59);

	params = matrix(0,Nf,length(init.param))
	fminval = rep(0,Nf)
	train.rmsle = rep(0,Nf)
	test.rmsle = rep(0,Nf)
  if(fullres==T){
    test.inds = matrix(0,Ntest,Nf)
    test.pred = matrix(0,Ntest,Nf)
  }
	for (i in 1:Nf){
		test_inds = sample(1:N, Ntest);
		test.X = dall$X[test_inds,]
		test.Y = dall$Y[test_inds]
		train.X = dall$X[-test_inds,]
		train.Y = dall$Y[-test_inds]

		if(onresids){
			test.yhat_prev = dall$yhat_prev[test_inds]
			test.yratio = dall$yratio[test_inds]
			train.yhat_prev = dall$yhat_prev[-test_inds]
			train.yratio = dall$yratio[-test_inds]

			dtrain = list(X = train.X, Y = train.Y, yhat_prev = train.yhat_prev, yratio = train.yratio)
			dtest = list(X = test.X, Y = test.Y, yhat_prev = test.yhat_prev, yratio = test.yratio)
		}else{
			dtrain = list(X = train.X, Y = train.Y)
			dtest = list(X = test.X, Y = test.Y)
		}
		r <- single_fit(dtrain,init.param,onresids)

		# Store the results
		params[i,] <- r$params
		fminval[i] <- r$fminval
		train.rmsle[i] <- r$train.rmsle
    rtest = single_test(dtest,r$params,onresids)
		test.rmsle[i] <- rtest$rmsle
    if(fullres==T){
      test.pred[,i] = rtest$yhat
      test.inds[,i] = test_inds
    }
		cat(sprintf('JK-iter %i, train rmsle %.6f, test rmsle %.6f\n',i,train.rmsle[i],test.rmsle[i]))
		flush.console()
	}
  if(fullres==T){
    res = list(params=params,fminvals = fminval, train.rmsle = train.rmsle, test.rmsle = test.rmsle, test.inds = test.inds, test.pred = test.pred)
  }else{
	  res = list(params=params,fminvals = fminval, train.rmsle = train.rmsle, test.rmsle = test.rmsle)
  }
  cat(sprintf('AggRes:: median(train rmsle) %.6f, median(test rmsle) %.6f\n',median(train.rmsle),median(test.rmsle)))
  flush.console()
	return(res)
}

rmsle_fun <- function(beta,y,x){
n = length(y);
yhat = x%*%beta;
yhat[yhat <0] =0;
res <- sqrt(mean((log(y+1) - log(yhat+1))^2));
#attr(res, "gradient") <- -t((log(y+1) - log(yhat+1))/(yhat+1))%*%x/(n*res);
return(res);
}

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

FitValidatePredictAll <- function(y.train, x.train, x.lead, model1, model2, model3, beta1, beta2, beta3){

n = length(y.train);
loss.train = rep(0,4); ### seg1, seg2, seg3, overall
loss.test = rep(0,4);  ### seg1, seg2, seg3, overall
### do a training-test split (80-20)
### fit on training, validate on test and return joint fit coefficients
set.seed(39);
samp = sample(1:n, floor(0.8*n));
x.tr = x.train[samp,];
y.tr = y.train[samp];
x.te = x.train[-samp,];
y.te = y.train[-samp];

#####################################################################
### Fit on the training -seg1
#####################################################################
x1 = as.matrix(cbind(1, x.tr[x.tr$seg==1, model1]));
y1 = y.tr[x.tr$seg ==1];
p1 = length(model1)+1;
mod1 =  optim(beta1, rmsle_fun, gr = NULL, y1, x1 , method = "BFGS");

### Predict on test -seg1
x1.te = as.matrix(cbind(1, x.te[x.te$seg==1, model1]));
y1.te = y.te[x.te$seg ==1];
pred1.te = x1.te%*%mod1$par;
pred1.te[pred1.te <0] =0;

### compute loss
#loss.train[1] = mod1$minimum;
loss.test[1] = rmsle(y1.te, pred1.te);

#################################################################33
### Fit on the training -seg2
###################################################################
x2 = as.matrix(cbind(1, x.tr[x.tr$seg==2, model2]));
y2 = y.tr[x.tr$seg ==2];
p2 = length(model2)+1;
mod2 =  optim(beta2, rmsle_fun, gr = NULL, y2, x2, method = "BFGS");

### Predict on test -seg2
x2.te = as.matrix(cbind(1, x.te[x.te$seg==2, model2]));
y2.te = y.te[x.te$seg ==2];
pred2.te = x2.te%*%mod2$par;
pred2.te[pred2.te <0] =0;

### compute loss
#loss.train[2] = mod2$minimum;
loss.test[2] = rmsle(y2.te, pred2.te);

#################################################################33
### Fit on the training -seg3
###################################################################
x3 = as.matrix(cbind(1, x.tr[x.tr$seg==3, model3]));
y3 = y.tr[x.tr$seg ==3];
p3 = length(model3)+1;
mod3 =  optim(beta3, rmsle_fun, gr = NULL, y3, x3, method = "BFGS");

### Predict on test -seg3
x3.te = as.matrix(cbind(1, x.te[x.te$seg ==3, model3]));
y3.te = y.te[x.te$seg ==3];
pred3.te = x3.te%*%mod3$par;
pred3.te[pred3.te <0] =0;

### compute loss
#loss.train[3] = mod3$minimum;
loss.test[3] = rmsle(y3.te, pred3.te);

#######################################################################
### Compute Overall loss
#######################################################################
fit = rep(0,nrow(x.tr));
fit[x.tr$seg ==1] = x1%*%mod1$par;
fit[x.tr$seg ==2] = x2%*%mod2$par;
fit[x.tr$seg ==3] = x3%*%mod3$par;
fit[fit <0] =0;

pred.te = rep(0,nrow(x.te));
pred.te[x.te$seg ==1] = x1.te%*%mod1$par;
pred.te[x.te$seg ==2] = x2.te%*%mod2$par;
pred.te[x.te$seg ==3] = x3.te%*%mod3$par;
pred.te[pred.te <0] =0;

loss.train[1] = rmsle(y.tr[x.tr$seg ==1], fit[x.tr$seg ==1]);
loss.train[2] = rmsle(y.tr[x.tr$seg ==2], fit[x.tr$seg ==2]);
loss.train[3] = rmsle(y.tr[x.tr$seg ==3], fit[x.tr$seg ==3]);
loss.train[4] = rmsle(y.tr, fit);
loss.test[4] = rmsle(y.te, pred.te);

##########################################################################
### Generate prediction for the leaderboard
##########################################################################
x1.lead = as.matrix(cbind(1, x.lead[x.lead$seg==1, model1]));
x2.lead = as.matrix(cbind(1, x.lead[x.lead$seg==2, model2]));
x3.lead = as.matrix(cbind(1, x.lead[x.lead$seg==3, model3]));

pred.lead = rep(0, nrow(x.lead));
pred.lead[x.lead$seg ==1] = x1.lead%*%mod1$par;
pred.lead[x.lead$seg ==2] = x2.lead%*%mod2$par;
pred.lead[x.lead$seg ==3] = x3.lead%*%mod3$par;
pred.lead[pred.lead <0] =0;

r = list(loss.train = loss.train, loss.test = loss.test, seg1.beta = mod1$par, seg2.beta = mod2$par,
seg3.beta = mod3$par, pred.lead = pred.lead);
return(r);
}


### FIRST PART

calcCurvature <- function(trip,nlag) {

  ib=seq(2,nrow(trip)-1)
  ia=ib-1
  ic=ib+1
  A_x = trip$x[ia]
  B_x = trip$x[ib]
  C_x = trip$x[ic]
  A_y = trip$y[ia]
  B_y = trip$y[ib]
  C_y = trip$y[ic]
  D = 2 * (A_x*(B_y - C_y) + B_x*(C_y - A_y) + C_x*(A_y - B_y) )
  U_x = ((A_x^2 + A_y^2) * (B_y - C_y) + (B_x^2 + B_y^2) * (C_y - A_y) + (C_x^2 + C_y^2) * (A_y - B_y)) / D
  U_y = ((A_x^2 + A_y^2) * (C_x - B_x) + (B_x^2 + B_y^2) * (A_x - C_x) + (C_x^2 + C_y^2) * (B_x - A_x)) / D
  R = sqrt((A_x - U_x)^2 + (A_y - U_y)^2)
  #   cur <- data.table(center_x = c(NA, U_x, NA),
  #                     center_y = c(NA, U_y, NA),
  #                     radius = c(NA, R, NA))
  mlag <- nlag
  if (nlag %% 2 == 0) {
    mlag <- nlag + 1
  }
  f21 <- rep(1/mlag,mlag)
  smth_x <- filter(U_x, f21, sides=2)
  smth_y <- filter(U_y, f21, sides=2)
  smth_R <- filter(R, f21, sides=2)
  cur_smooth <- data.table(center_x = c(NA, smth_x, NA),
                           center_y = c(NA, smth_y, NA),
                           radius = c(NA, smth_R, NA))
  return(cur_smooth)
}

speedDistribution <- function(trip)
{

  vitesse = 3.6*sqrt(diff(trip$x,1,1)^2 + diff(trip$y,1,1)^2)/20

  vitesse5 = 3.6*sqrt(diff(trip$x,5,1)^2 + diff(trip$y,5,1)^2)/20

  vitesse10 = 3.6*sqrt(diff(trip$x,10,1)^2 + diff(trip$y,10,1)^2)/20

  vitesse20 = 3.6*sqrt(diff(trip$x,20,1)^2 + diff(trip$y,20,1)^2)/20

  tangacel = 3.6*sqrt(diff(trip$x,1,2)^2 + diff(trip$y,1,2)^2)/20

  tangacel5 = 3.6*sqrt(diff(trip$x,5,2)^2 + diff(trip$y,5,2)^2)/20

  tangacel10 = 3.6*sqrt(diff(trip$x,10,2)^2 + diff(trip$y,10,2)^2)/20

  tangacel20 = 3.6*sqrt(diff(trip$x,20,2)^2 + diff(trip$y,20,2)^2)/20

  cur <- calcCurvature(trip,1)
  cur5 <- calcCurvature(trip,5)
  cur10 <- calcCurvature(trip,10)
  cur20 <- calcCurvature(trip,20)

  acelnorm = c(rep(NA,1),vitesse)/cur$radius
  acelnorm5 = c(rep(NA,5),vitesse5)/cur5$radius
  acelnorm10 = c(rep(NA,10),vitesse10)/cur10$radius
  acelnorm20 = c(rep(NA,20),vitesse20)/cur20$radius

  aceltotal = acelnorm + c(rep(NA,2),tangacel)
  aceltotal5 = acelnorm5 + c(rep(NA,10),tangacel5)
  aceltotal10 = acelnorm10 + c(rep(NA,20),tangacel10)
  aceltotal20 = acelnorm20 + c(rep(NA,40),tangacel20)

  dist = sum(vitesse)
  acel = diff(vitesse,1,1)

  features = c( cbind(quantile(vitesse, seq(0.05,1, by = 0.05)),
                   quantile(vitesse5, seq(0.05,1, by = 0.05)),
                   quantile(vitesse10, seq(0.05,1, by = 0.05)),
                   quantile(vitesse20, seq(0.05,1, by = 0.05)),
                   quantile(tangacel, seq(0.05,1, by = 0.05)),
                   quantile(tangacel5, seq(0.05,1, by = 0.05)),
                   quantile(tangacel10, seq(0.05,1, by = 0.05)),
                   quantile(tangacel20, seq(0.05,1, by = 0.05)),
                   quantile(cur$radius[is.finite(cur$radius) ] , seq(0.05,1, by = 0.05), na.rm = T),
                   quantile(cur5$radius[is.finite(cur5$radius) ] , seq(0.05,1, by = 0.05), na.rm = T),
                   quantile(cur10$radius[is.finite(cur10$radius) ] , seq(0.05,1, by = 0.05), na.rm = T),
                   quantile(cur20$radius[is.finite(cur20$radius) ] , seq(0.05,1, by = 0.05), na.rm = T),
                   quantile(acelnorm, seq(0.05,1, by = 0.05), na.rm = T),
                   quantile(acelnorm5, seq(0.05,1, by = 0.05), na.rm = T),
                   quantile(acelnorm10, seq(0.05,1, by = 0.05), na.rm = T),
                   quantile(acelnorm20, seq(0.05,1, by = 0.05), na.rm = T),
                   quantile(aceltotal, seq(0.05,1, by = 0.05), na.rm = T),
                   quantile(aceltotal5, seq(0.05,1, by = 0.05), na.rm = T),
                   quantile(aceltotal10, seq(0.05,1, by = 0.05), na.rm = T),
                   quantile(aceltotal20, seq(0.05,1, by = 0.05), na.rm = T),
                   quantile(acel, seq(0.05,1, by = 0.05)))
              ,
                   length(trip[,1]), var(vitesse), var(vitesse5), var(vitesse10), var(vitesse20),
                   var(tangacel), var(tangacel5), var(tangacel10), var(tangacel20),
                   var(acelnorm,na.rm = T), var(acelnorm5,na.rm = T), var(acelnorm10,na.rm = T),
                   var(acelnorm20,na.rm = T), var(acel,na.rm = T))

  return(features)
}

### SECOND PART (BASED ON DEXUAN'S CODE)

features2 <- function(trip)
{
  v = NULL
  angle = NULL
  acceleration = NULL
  deceleration = NULL
  turning_speed = NULL
  distancesum = 0
  shift = -1

  for(i in 2:length(trip[,1])){
    dist = sqrt((trip$x[i-1] - trip$x[i])^2 + (trip$y[i-1] - trip$y[i])^2)
    v = rbind(v,dist)
    distancesum = distancesum + dist

    flag = 1
    if(i > 2){
      if(v[i-1] >= v[i-2]){
        acceleration = rbind(acceleration, (v[i-1]-v[i-2]))

        if(flag == 0){
          shift = shift + 1
          flag = 1
        }

      }
      else{
        deceleration = rbind(deceleration, (v[i-2]-v[i-1]))
        if(flag == 1){
          shift = shift + 1
          flag = 0
        }

      }

      dist_2 = sqrt((trip$x[i-2] - trip$x[i])^2 + (trip$y[i-2] - trip$y[i])^2)
      if(v[i-1]*v[i-2] != 0){
        cosin = (v[i-1]*2+v[i-2]*2-dist_2*2)/(2*v[i-1]*v[i-2])
      }
      else{
        cosin = -1
      }
      angle = rbind(angle,(pi-acos(max(min(cosin, 1), -1))))
      temp = angle[i-2]*(v[i-1]+v[i-2])/2
      #if temp>0:
      turning_speed = rbind(turning_speed,temp)
    }

  }

  features = c(cbind(quantile(v, seq(0.05,1, by = 0.05)),
                 quantile(angle, seq(0.05,1, by = 0.05)),
                 quantile(acceleration, seq(0.05,1, by = 0.05)),
                 quantile(deceleration, seq(0.05,1, by = 0.05)),
                 quantile(turning_speed, seq(0.05,1, by = 0.05))),
                 var(v),var(angle),var(acceleration),var(deceleration),
                 var(turning_speed),distancesum,shift)

  return(features)

}


#' Optimal Rank Beta
#'
#' This finds recommends a beta value between two extremes where the rank correlation between the two extremes best agrees.
#'
#' @param g An igraph graph object
#' @param comp.left The beta on the left for comparison
#' @param comp.right The beta on the right for comparison
#' @param starting.beta The beta value to start when starting the optimization
#' @export
#' @examples
#' pii(g, pii.beta = optimal.rank.beta(g))
#'

optimal.rank.beta <-  function(g, comp.left = -0.9, comp.right = -0.5, starting.beta = -0.8) {
  rc.diff <- function(b, g, comp.left = comp.left, comp.right = comp.right) {
      p <- pii(g, pii.beta = b)
      pii.left <- pii(g, pii.beta = comp.left)
      pii.right <- pii(g, pii.beta = comp.right)
      rc.left = cor(p, pii.left, method = "spearman")
      rc.right = cor(p, pii.right, method = "spearman")
      return(abs(rc.left - rc.right))
    }

  o <- optim( par = c(starting.beta), fn = rc.diff, gr = NULL,
              g = g, comp.right = comp.right, comp.left = comp.left, method = 'Brent',
              lower = -1, upper = -0.001)
  cross.point <- o$par
  attr(cross.point, 'spearman.correlation') <- cor(pii(g, pii.beta = cross.point), pii(g, pii.beta = cross.point), method = 'spearman')
  attr(cross.point, 'approx') <- o$value
  return(cross.point)
}


setwd("C:\\Users\\shalini\\Desktop\\Rprograms")
getwd()
dir()
data(Titanic)
str(Titanic)
View(Titanic)

# read AR data converted from titanic data from website http://www.cs.toronto.edu/~delve/
#data/titanic/desc.html
titan <- read.table("./dataset.data", header=F)
View(titan)

names(titan) <- c("Class","Age", "Sex", "Survived")
View(titan)

install.packages("arules")
library(arules)
search()

# find association rules with default settings
#supp=0.1, ; 2) conf=0.8, 3) maxlen=10,
#rules.all <- apriori(titanic.raw)
rules.all <- apriori(titan)
quality(rules.all) <- round(quality(rules.all), digits=3)
rules.all

inspect(rules.all)

#---------------------------------start here-----------------------------------#

#rules with rhs containing "Survived" only

#restricted rules
#rules <- apriori(titanic.raw, control = list(verbose=F), parameter = list(minlen=2, supp=0.005, conf=0.8),appearance = list(rhs=c("Survived=No", "Survived=Yes"),default="lhs"))
rules <- apriori(titan, control = list(verbose=F), parameter = list(minlen=2, supp=0.005, conf=0.8),appearance = list(rhs=c("Survived=no", "Survived=yes"),default="lhs"))
quality(rules) <- round(quality(rules), digits=2)
rules.sorted <- sort(rules, by="lift")
inspect(rules.sorted)

#restricting LHS
rules <- apriori(titan, control = list(verbose=F),parameter = list(minlen=3, supp=0.002, conf=0.7),appearance = list(rhs=c("Survived=yes"),lhs=c("Class=1st", "Class=2nd", "Class=3rd","Age=child", "Age=adult"),default="none"))
quality(rules) <- round(quality(rules), digits=4)
rules.sorted <- sort(rules, by="lift")
inspect(rules.sorted)

#plotting AR
install.packages("arulesViz")
library(arulesViz)
search()

plot(rules.all)
plot(rules.all, method="grouped")

#another dataset market basket
data(Groceries)
inspect(Groceries[1:5])  #to see first 5 transactions

# Create an item frequency plot for the top 10 items
itemFrequencyPlot(Groceries,topN=10,type="absolute")

# Get the rules
rules <- apriori(Groceries, parameter = list(supp = 0.001, conf = 0.8))

# Show the top 5 rules, but only 2 digits
options(digits=2)
inspect(rules[1:5])
summary(rules)  #summary statistics


## Load some packages that will be useful
library(mgcv) # load the MGCV package with Simon Wood's gam() functions
library(readr) # Hadley Wickham's package for reading in data easily
library(ggplot2) # for plotting with ggplot
library(ggfortify) # for autoplot

##################################################################################################
## We'll first examine the bias-variance tradeoff in a simplified form with a small exercise.
## If you remember, this tradeoff is one of the concepts behind finding the optimal amount of smoothing.
## We'll fit linear regressions to parts of the data, increasing the number of parts from 1 to 10.
##################################################################################################

# First, read in the bioluminescence data.
# Sources is the number of bioluminescent plankton seen in each water sample
# SampleDepth is the depth of the water sample, in m
# Station is the ID of the location at which multiple water samples were taken
ISIT <- read_tsv(url('https://github.com/aeda2021/2021_master/raw/main/raw-data/ISIT.txt')) # tsv for tab-separated values

# Subset it to one station. This is what we'll work with for now.
ISITsub <- subset(ISIT, Station == 8)

# Plot the data
ggplot(ISITsub, aes(x=SampleDepth, y=Sources)) +
	geom_point()

# Now you can fit a linear regression to the ISITsub dataset, with Sources as the response and SampleDepth as the explanatory variable
# Please call the output "mod1", as I've started to fill in for you

# Q1: What was your code for fitting a linear regression of Sources vs. SampleDepth?
mod1 <- lm(Sources ~ SampleDepth, data = ISITsub)

# We'll predict the mean response and confidence intervals from this model and save the output
ISITsub$mod1 <- predict(mod1)
ISITsub$mod1lwr <- predict(mod1, interval='confidence', level=0.95)[,'lwr']
ISITsub$mod1upr <- predict(mod1, interval='confidence', level=0.95)[,'upr']

# Now plot the linear model fit to the full dataset on top of the data
ggplot(ISITsub, aes(x=SampleDepth, y=Sources)) +
	geom_point() +
	geom_line(aes(y=mod1)) +
	geom_ribbon(aes(ymin=mod1lwr, ymax=mod1upr), alpha=0.3)

# Q2: Use your skills from earlier in this course and evaluate this linear model (autoplot may be useful here). How does this fit look to you? Does a linear regression look reasonable? Any well-justified answer is appropriate.
#First, I'm checking the assumptions.
hist(mod1$residuals) #histogram of residuals
autoplot(mod1, smooth.colour = NA)
#The residual vs. fitted plot has a pattern that looks like a hill, which indicates that
#a line is an appropriate fit to this data. In the Q-Q plot, the points deviate from the
#line on the left and right sides, suggesting that it may violate the assumption that the
#residuals are normally distributed. The histogram of residuals also appears skewed to the
#right. In the scale-location plot, the vertical spread of the points varies across the
#fitted values, which violates the assumption that variance of Y is similar across X.
#There are points in the lower right corner of the residuals vs. leverage plot, which violates
#the assumption that the results do not depend on a small proportion of the data.
#In my opinion, the data violate the assumptions of the linear model, so it would not be
#appropriate to use a linear model here.

# For comparison, let's fit linear models to two halves of the data. This involves a fair bit of coding in R, so please ask for help understanding the code where things are confusing.
# First, we have to find the halves of the data
quants2 <- quantile(ISITsub$SampleDepth, probs=seq(0, 1, by=0.5)) # define the ends and the half-way point in the data with the quantile function
ISITsub$split2 <- cut(ISITsub$SampleDepth, breaks=quants2, include.lowest=TRUE, labels=1:2)

# Q3: In your own words, what does the cut() function do? How are we using it here?
#The cut() function breaks the x values into groups based on whatever breaks you specify and labels it.
#Here, we used the cut() function to identify which elements were in the low half versus the high half
#of the data based on sample depth. We labeled them as 1 or 2. X values below 1589.5 were assigned a 1 and
#x values above 1589.5 were assigned a 2. Then, we saved it (ISITsub$split2).

# Next, let's fit a linear model to each subset (half) of the data. We do this in a loop to make it easier.
mod2s <- vector('list', length=2) # A list to hold each of our models in a single, convenient object
ISITsub$mod2 <- ISITsub$mod2lwr <- ISITsub$mod2upr <- NA # Initialize the variables we'll use and fill with NA
for(i in 1:length(mod2s)){ # Loop through each model
	mod2s[[i]] <- lm(Sources ~ SampleDepth, data=ISITsub[ISITsub$split2==i,]) # Fit a linear regression to the appropriate subset of the data. Now see why we made the split2 vector?
	ISITsub$mod2[ISITsub$split2==i] <- predict(mod2s[[i]]) # Now predict from that model. Notice we're only predicting for part of the data.
	ISITsub$mod2lwr[ISITsub$split2==i] <- predict(mod2s[[i]], interval='confidence', level=0.95)[,'lwr'] # Same for the confidence intervals
	ISITsub$mod2upr[ISITsub$split2==i] <- predict(mod2s[[i]], interval='confidence', level=0.95)[,'upr']
}

# Plot the data, the 1-model fit, and the 2-model fit
# There will be an odd 3rd line segment connecting the end of the first model fit to the beginning of the second model fit. Just pretend it's not there.
ggplot(ISITsub, aes(x=SampleDepth, y=Sources)) +
	geom_point() +
	geom_line(aes(y=mod1)) +
	geom_ribbon(aes(ymin=mod1lwr, ymax=mod1upr), alpha=0.3) +
	geom_line(aes(y=mod2, color='red')) +
	geom_ribbon(aes(ymin=mod2lwr, ymax=mod2upr), alpha=0.3, fill='red')

# Q4: Has the fit between the model and the data improved? What's the downside of continuing the split the data into finer and finer chunks and fitting more models?
#The fit between the model and the data has improved. The downside to continuing with this method is that
#each time you split the data you reduce the sample size, thus increasing the uncertainty.

# Now, it's your turn. Please fit 10 linear regression models. I'd recommend using the 2-model code above as a guide and tweaking it.
quants10 <- quantile(ISITsub$SampleDepth, probs=seq(0, 1, by=0.1))
ISITsub$split10 <- cut(ISITsub$SampleDepth, breaks=quants10, include.lowest=TRUE, labels=1:10)
mod10s <- vector('list', length=10)
ISITsub$mod10 <- ISITsub$mod10lwr <- ISITsub$mod10upr <- NA
for(i in 1:length(mod10s)){ # Loop through each model
    mod10s[[i]] <- lm(Sources ~ SampleDepth, data=ISITsub[ISITsub$split10==i,]) # Fit a linear regression to the appropriate subset of the data.
    ISITsub$mod10[ISITsub$split10==i] <- predict(mod10s[[i]]) # Now predict from that model. Notice we're only predicting for part of the data.
    ISITsub$mod10lwr[ISITsub$split10==i] <- predict(mod10s[[i]], interval='confidence', level=0.95)[,'lwr'] # Same for the confidence intervals
    ISITsub$mod10upr[ISITsub$split10==i] <- predict(mod10s[[i]], interval='confidence', level=0.95)[,'upr']
}

# Now plot the 10 models on top of the data and on top of the 1- and 2-model fits. The plot with the data, 1-model, and 2-model fit is probably a useful guide here.
ggplot(ISITsub, aes(x=SampleDepth, y=Sources)) +
    geom_point() +
    geom_line(aes(y=mod1)) +
    geom_ribbon(aes(ymin=mod1lwr, ymax=mod1upr), alpha=0.3) +
    geom_line(aes(y=mod2, color='red')) +
    geom_ribbon(aes(ymin=mod2lwr, ymax=mod2upr), alpha=0.3, fill='red') +
    geom_line(aes(y=mod10, color='blue')) +
    geom_ribbon(aes(ymin=mod10lwr, ymax=mod10upr), alpha=0.3, fill='blue')

# Q5: Compare your 10-model fit to the 1-model fit. Which model's predictions are furthest from the observed data? Which model has the widest confidence bounds? How does this (or does this not) illustrate the bias-variance tradeoff?
#The 1-model fit is furthest from the observed data. The 10-model fit has the widest confidence bounds.
#This illustrates the bias-variance trade-off because the 1-model is biased with relatively low variance
#whereas the 10-model fit is less biased but it has high variance.

####################################################
## Now you'll fit some GAMs and evaluate your models
####################################################
#install.packages("maps") # if needed
library(maps) # has map data in it

# load the data
spdata <- readRDS(url('https://github.com/aeda2021/2021_master/raw/main/raw-data/gadusmorhua.rds')) # load the spdata data.frame with abundance and environmental data from cod surveys
spdata$presfit01 <- as.numeric(spdata$presfit) # make a vector that's nice for plotting
spdata <- spdata[order(spdata$presfit01),] # order the data from absent to present for ease of plotting

# examine the data
head(spdata) # look at the dataset
summary(spdata)

# make a map of the data
world <- map_data('world')

ggplot() +
	geom_polygon(data=world, aes(x=long, y=lat, group=group), color='black', fill=NA) + # the map
	xlim(-100, -45) +
	ylim(23, 62) +
	geom_point(data=spdata, aes(x=lon, y=lat, color=presfit, alpha=0.1), size=0.01) # the data points. note that because the dataframe is sorted from absent to present, the presences are plotted on top of the absences

# Q6: Based on the map, do you think cod prefer warmer or cooler waters? Why do you think that?
#I think cod prefer colder water because there were more presence occurrences in the north (i.e. New England
#and Canada) compared to the south (i.e. the Gulf up to the mid-Atlantic).

# Q7: Plot cod presence/absence (the presfit vector) vs. the bottom temperature (SBT.actual). At what range of temperatures have cod been observed?
ggplot(spdata, aes(x=SBT.actual, y=presfit01)) +
    geom_point()
#Cod have been observed at temperatures between about 0 and 18 degrees celsius.

# Q8: Fit a GAM for presfit against SBT.actual. Check the model. Does it look like the assumptions have been met? Why or why not?
modg <- gam(presfit01 ~ s(SBT.actual), data = spdata)
gam.check(modg)
#The assumptions have not been met because:
    #1) the points do not fall along the 1-to-1 line in the deviance residuals vs. theoretical quantiles plot,
        #indicating that the residuals are not normally distributed.
    #2) the residuals vs. linear predictor plot has a strong linear pattern,
        #indicating that the residuals are not evenly distributed about the linear predictor.
    #3) the histogram of residuals also confirms that the residuals are not normally distributed.
    #4) the response vs. fitted values plot is binomial.

# Q9: Fit a new GAM with a more appropriate error structure and save it as "mod2". The gam() function takes the same family= argument as does glm(). Which error structure and link function did you choose?
mod2 <- gam(presfit01 ~ s(SBT.actual), data = spdata, family = binomial)
#I chose to use binomial because the data consists of 0s and 1s.

# Q10: Check your mod2 GAM. Does it look like the assumptions have been met? Make sure to read the text output as well as look at the graphs. If something doesn't look right, what would you do to fix it?
gam.check(mod2)
#It looks like the assumptions have been met to an extent. The assumptions for mod2 are met to a greater extent than modg, but they are not perfect.
#Full convergence was achieved after 11 iterations and the Hessian was positive definite.
#The p-value is 0.12, indicating that k is not too low.
#In the deviance residuals vs. theoretical quantiles plot, the points fall closer to the 1-to-1 line, indicating that the residuals are more normally distributed.
#The residuals vs. linear predictor plot has a strong linear pattern. This does not meet the assumption that the residuals are evenly distributed about the linear predictor.
#The histogram of residuals is bimodal, which violates the assumption that the residuals are normally distribution. However, the distribution appears more similar to a normal
#distribution than the corresponding plot for modg.
#Due to the binomial data, the plot of response vs. fitted values is difficult to interpret. Typically, if the points fall along a straight line, it would
#indicate that the model explains much of the variation in the data.

# Q11: Interpret your mod2 GAM (summary function). How much deviance is explained? Is the SBT.actual term significant at alpha=0.05? How wiggly do you expect the smooth fit to be?
summary(mod2)
#The SBT.actual term is significant at alpha=0.05 because the p-value is less than 2e-16.
#The estimated degrees of freedom (edf) is 8.959, so I expect the smooth fit to be quite wiggly.
#About 26.5% of the deviance is explained.

# Now let's make predictions from our last model (mod2) and plot them.
nd <- data.frame(SBT.actual = seq(-5,30, by=0.5)) # make a data.frame of new explanatory variables
nd$mod2 <- predict(mod2, newdata=nd, type='response') # predict on the scale of the response
nd$mod2se <- predict(mod2, newdata=nd, type='response', se.fit=TRUE)$se.fit # get the standard errors of the fit

ggplot(spdata, aes(x=SBT.actual, y=presfit01)) +
	geom_point() +
	geom_line(data=nd, aes(x=SBT.actual, y=mod2, color='red')) +
	geom_ribbon(data=nd, aes(x=SBT.actual, ymin=mod2-mod2se, ymax=mod2+mod2se), alpha=0.3, fill='red', inherit.aes=FALSE)

# Q12: Does the fit look realistic? Why or why not? Does it look overfit? Why or why not?
#The fit does look realistic because it shows that cod are more likely to be present in colder waters, as suggested by our initial map.
#I think it could be overfit because there bimodal peaks. I would expect cod to have an optimal temperature range, which would resemble a unimodal curve
#because their thermal tolerance would decline away from that temperature.

# Q13: This dataset is actually a concatenation of seven different surveys which each have slightly different abilities to catch cod. Fit a new GAM that includes a categorical predictor for survey (the region vector). Based on AIC, which model would you choose? How confident would you be?
modsurv <- gam(presfit01 ~ s(SBT.actual) + factor(region), data = spdata, family=binomial)
gam.check(modsurv) #Hessian positive definite, p-value is 0.61
AIC(mod2,modsurv)
#Based on the AIC scores, I would choose the model that includes a categorical predictor for survey because it has the lower AIC score.
#This model has an AIC score of ~8315 whereas the model that only includes SBT has an AIC score of about 9116. The deltaAIC is greater than
#10, providing substantial support that the model that includes survey is the better model given our data. As a result, I am confident stating that
#this (modsurv) is the better model.


Horner <- function(Coef_Polinomio, x0) {
  # Creación de la función,
  #recibe los coeficientes del polinomio
  #y el punto a evaluar.
  TerminoInd <- Coef_Polinomio[1]
  Coef_Polinomio <- Coef_Polinomio[-1]
  #Guarda el término de independiente en una
  #variable aparte de los coeficientes que
  #acompañan algún valor de "x".
  P_x0  <- Coef_Polinomio[length(Coef_Polinomio)]
  P1_x0 <- Coef_Polinomio[length(Coef_Polinomio)]
  j <- length(Coef_Polinomio)-1
  #Guarda los coeficientes no independientes
  #del polinomio en dos variables,
  #y se inicializa la variable iterativa.
  while (j>0) {
    P_x0  <- x0*P_x0 + Coef_Polinomio[j]
    P1_x0 <- x0*P1_x0 + P_x0
    j <- j-1
  }
  #Se aplica el Método de Horner para
  #calcular el valor del polinomio en x0
  #y el valor de su derivada en x0.
  P_x0 <- (x0*P_x0)+TerminoInd
  #Se suma el término independiente al polinomio,
  #pero no a la derivada, ya que en la
  #derivada este término desaparece.
  cat(paste("P(", x0, ") =", P_x0,
            "\nP'(", x0, ") =", P1_x0))
}
#Se imprimen los resultados.
#Siendo P_x0 el valor del polinomio en x0 y
#P1_x0 el valor de la derivada en x0.

HornerC <- function(Coef_Polinomio, x0) {
  Coef_Polinomio  <- as.complex(Coef_Polinomio)
  #Los coeficientes pasan a ser tratados como números complejos.
  TerminoInd      <- Coef_Polinomio[1]
  Coef_Polinomio  <- Coef_Polinomio[-1]
  P_x0  <- Coef_Polinomio[length(Coef_Polinomio)]
  P1_x0 <- Coef_Polinomio[length(Coef_Polinomio)]
  j <- length(Coef_Polinomio)-1
  while (j>0) {
    P_x0  <- x0*P_x0 + Coef_Polinomio[j]
    P1_x0 <- x0*P1_x0 + P_x0
    j <- j-1
  }
  P_x0 <- (x0*P_x0)+TerminoInd
  cat(paste("P(", x0, ") =", P_x0,
            "\nP'(", x0, ") =", P1_x0))
}

install.packages("signal")
library(signal)
Operaciones <- 0
#Se instala un paquete para utilizar
#la función "polyval" más adelante y se
#inicia el número de operaciones PRINCIPALES en 0.

Seno_Taylor <- function(n){
  Taylor_Pol <- c()
  for(i in 0:n){
    Taylor_Pol <- c(Taylor_Pol,0)
    Taylor_Pol <- c(Taylor_Pol,((-1)^i)/factorial(2*i+1))
    Operaciones <- Operaciones + 1
  }
  return(Taylor_Pol)
}
#Esta función recibe un valor de "n"
#y devuelve los coeficientes del polinomio de Taylor
#de grado "n" de la función seno.

Norm <- function(vect1,vect2){
  error_relativo <- 0
  err <- 0
  for(i in 1:length(vect1)){
    error_relativo <- error_relativo + abs(vect1[i]-vect2[i])
    Operaciones <- Operaciones + 1
    err <- err + abs(vect1[i])
    Operaciones <- Operaciones + 1
  }
  return((error_relativo/err)-1)
}
#Se define una función que recibe imágenes de dos
#funciones en los mismos puntos, y devuelve una forma
#de medir el error que hay entre ellas.
#En este caso se calcula este error como un ponderado
#de los valores absolutos de las restas entre valores.

Taylor <- function(error_minimo){
  test_val <- c()
  for(i in seq(from=-pi/64,to=pi/64,by=0.001)){
    test_val <- c(i,test_val)
  }
  #Se generan varios valores en el intervalo de interés
  #y se guardan en la variable "test_val".
  iteraciones <- 0
  n <- 0
  e_rel <- 1
  #Se inicializan varias variables.
  #El número de iteraciones en 0, el grado del
  #polinomio de Taylor en 0, y el error relativo en 1.
  cat("Iteracion =",iteraciones,"\n")
  #Se muestra la iteración en la que va el código.
  Aprox_Pol <- Seno_Taylor(n)
  Pol_Ant <- polyval(Aprox_Pol[length(Aprox_Pol):1],test_val)
  #Se inicializa el polinomio de aproximación en grado 0
  #y se evaluan los datos de prueba en él.
  Operaciones <- Operaciones + 1
  while(e_rel>error_minimo){
    n <- n+1
    Operaciones <- Operaciones + 1
    Aprox_Pol <- Seno_Taylor(n)
    Pol_Act <- polyval(Aprox_Pol[length(Aprox_Pol):1],test_val)
    #La función polyval evalúa el vector de puntos en el
    #polinomio, dados sus coeficientes en orden descendente.
    Operaciones <- Operaciones + 1
    e_rel <- Norm(Pol_Ant,Pol_Act)
    iteraciones <- iteraciones+1
    cat("Iteracion =",iteraciones,"\n")
    cat("Error Relativo =",e_rel,"\n")
    Pol_Ant <- Pol_Act
  }
  #Se lleva a cabo la aproximación de Taylor.
  #A cada iteración se eleva el grado del polinomio de
  #aproximación en 1, se evaluan los datos de prueba en él,
  #y se compara con los valores anteriores bajo la norma
  #definida arriba. Esto se repite hasta que el error sea
  #menor al valor ingresado por el usuario.
  cat("Polinomio =",Aprox_Pol,"\n")
  cat("Operaciones =",Operaciones,"\n")
  #Se imprimen los coeficientes del polinomio
  #que mejor aproxima la función en el intervalo
  #dado y el número de operaciones principales
  #que se realizaron.
}

install.packages("limSolve")
install.packages("signal")
library(signal)
library(limSolve)
#Se instalan dos paquetes, uno para poder utilizar la función
#"polyval", y el otro para utilizar la función "Solve" más adelante.

Norma_f <- function(p){
  inf <- 0
  ans <- c(0,0)
  for(i in seq(from=-pi/64,to=pi/64,by=0.001)){
    y = abs(sin(i)-polyval(p[length(p):1],i))
    Operaciones <- Operaciones + 1
    if(y<inf){
      inf <- y
      ans[1] <- inf
      ans[2] <- i
    }
  }
  return(ans)
}
#Esta función estima el valor de la norma que usa el
#método de Remez, devuelve el valor de la norma y
#el punto del intervalo en dónde da dicho valor.
#La función seno ya está predeterminada en el código.

Remez <- function(n,error_min){
  #El usuario debe ingresar el error_min, el cual es el epsilon
  #que aparece en el resúmen del método, y el "n" para la
  #cantidad de datos a tomar al comienzo.
  Iteraciones <- 0
  Operaciones <- 0
  Ptos_Muestra <- c()

  #USAR DATOS UNIFORMEMENTE ELEGIDOS:
  dx = (pi/32)/(n+1)
  for(x in seq(from=-pi/64,to=pi/64,by=dx)){
    Ptos_Muestra <- c(Ptos_Muestra,x)
  }
  #USAR DATOS ALEATORIAMENTE ELEGIDOS
  #Ptos_Muestra <- runif((n+2),min=-pi/64,max=pi/64)

  #Se toman "n+2" datos distribuidos uniformemente en el
  #intervalo de interés.
  while(TRUE){
    cat("Iteracion =",Iteraciones,"\n")
    A <- matrix(Ptos_Muestra,n+2,n+2)
    for(i in seq(from=1,to=n+2,by=1)){
      A[i,1] <- 1
      A[i,n+2] <- (-1)**i
    }
    for(i in seq(from=1,to=n+2,by=1)){
      for(j in seq(from=1,to=n+2,by=1)){
        if(j!=1 && j!=(n+2)){
          A[i,j] <- A[i,j]^j
        }
      }
    }
    #Se crea la matriz que codifica el sistema de
    #ecuaciones linealess que hay que resolver.
    b <- c()
    for(i in Ptos_Muestra){
      b <- rbind(b,sin(i))
    }
    #Se crea el vector que codifica el otro lado de la
    #igualdad del sistema de ecuaciones lineales; en este
    #caso la función "f" es seno.
    B <- Solve(A,b)
    #Se usa el comando "Solve" para hallar la solución "x"
    #al sistema de ecuaciones lineales Ax=b.
    Operaciones <- Operaciones + 1
    Pol <- B[0:n+1]
    e <- B[n+2]
    #Se guardan los coeficientes del polinomio y el error.
    norma <- Norma_f(Pol)
    #Se estima la norma entre el polinomio y el seno.
    cat("Error =",abs(norma[1]-abs(e)),"\n")
    if(abs((norma[1]-abs(e)))<=error_min){
      return(Pol)
      #Se revisa la condición de parada.
    }else{
      E = norma[2]
      for(j in 1:length(Ptos_Muestra)){
        if(E<=Ptos_Muestra[j]){
          Ptos_Muestra[j] <- E
          Iteraciones <- Iteraciones + 1
          break
          #Se agrega el punto (en donde la norma equivale a la
          #resta entre el seno y el polinomio) al conjunto de "n+2"
          #valores y se retira el punto más cercano a éste.
        }
      }
    }
  }
}


rm(list = ls())
setwd("D:/vaibhav/trend nxt/topgear/R Community/Automobile Price")
data = read.csv("Automobile_price_data__Raw.csv")

# Replace '?' in the data with NA
data[data == "?"] = NA

na_count_col = as.data.frame(sapply(data, function(y) sum(length(which(is.na(y))))))
na_count_col

# I decieded to remove normalized.losses column as the comumn has 41 missing values
data = data[,-2]

na_count_row = rowSums(is.na(data))
na_count_row
sum(na_count_row > 0)

# I decieded to remove 12 rows with NA value from the dataset
data = data[complete.cases(data),]

# Converting categorical variables to numerical data
factor_columns = which(as.numeric(sapply(data, is.factor)) == 1)
for (i in factor_columns) {
  data[,i] = as.numeric(data[,i])
}
str(data)

# Normalization
scaled.data = as.data.frame(scale(data[,-25]))
scaled.data$price = data$price

# Breaking down to 80% training and 20% testing dataset
samples = sample(1:193, 39)
training = scaled.data[-samples,]
testing = scaled.data[samples,]

# Model Training with Artificial Neural Network
# We take all the features into account
features = names(scaled.data)
features = paste(features[!features %in% "price"], collapse = "+")
formula = paste("price ~ ", features, collapse = "+")
formula = as.formula(formula)

library(neuralnet)
NN = neuralnet(formula = formula, hidden = c(20,10,5), linear.output = T, threshold = 0.1, stepmax = 1e+9, data = training)
plot(NN)

##
## NOTE: Using Neural Network takes quiet a bit of time to train
## Since method of training is unspecified in the problem statement
## we could have used linear regression(lm) for simplicity
##

# Prediction
predictions = compute(NN, testing[,1:24])
predictions$net.result

# Error Calculations
# 1.Mean Absolute Error
sum(abs(predictions$net.result - testing$price)) / nrow(testing)
# 2. RMS Error
(sum((predictions$net.result - testing$price)**2) / nrow(testing)) ** 0.5
# 3. Relative Absolute Error
T.bar = sum(testing$price)/nrow(testing)
sum(abs(predictions$net.result - testing$price)) / sum(abs(testing$price - T.bar))
# 4. Relative Squared Error
(sum((predictions$net.result - testing$price)**2) / sum((testing$price - T.bar)**2)) ** 0.5
# Coefficient of Determination
pred.bar = mean(predictions$net.result)
pred.sd = sd(predictions$net.result)
test.bar = mean(testing$price)
test.sd = sd(testing$price)
(sum((predictions$net.result-pred.bar)*(testing$price-test.bar)) / (nrow(testing)*pred.sd*test.sd)) ** 2


hofcon = c(1, 1, rep(NA, 2^20 - 2))
for (n in 3 : (2^20))
  {hofcon[n] =
       hofcon[hofcon[n - 1]] +
       hofcon[n - hofcon[n - 1]]}


#' Specify turnover constraints using a version derived by Doug Martin
#' @param returns, stock returns in xts format.
#' @param mu.target, default is NULL, specify the target mean return
#' @param wts.inital, the initial weight
#' @param toc, the turnover cost
#' @param long.only, default is TRUE, specify if long only constraint is required
#' @param printDandA, default is FALSE, specify if print the D and A matrix
#' @details use \code{table.Performance.pool} to check available metrics. recoded SharpeRatio
#' @author Doug Martin, Kirk Li  \email{kirkli@@stat.washington.edu}
#' @seealso \code{\link{turnoverOpt}}}
#' @keywords turnover, constraints
#' @examples
#' @export

TurnoverOpt_doug <- function(returns,mu.target = NULL,wts.initial,toc,
                        long.only = TRUE,printDandA = FALSE){
  nassets <- ncol(returns)
  nobs = nrow(returns)
  returns0 = matrix(rep(0,nassets*nobs),ncol = nassets)
  # Use 3 sets of variables wts, wtsBuy, wtsSell
  # Construct  returns matrix to yield 3Nx3N covariance matrix
  returns <- cbind(returns,returns0,returns0)
  # Compute 3Nx3N block diag. cov.mat with 0's except in first NxN block
  cov.mat <- cov(returns)
  Dmat <- 2*cov.mat
  # Compute "nearest" positive definite covariance matrix (Higham,1988)
  Dmat <- make.positive.definite(Dmat)
  dvec <- rep(0,3*nassets) #no linear part in this problem

  # Build components of constraint matrix A
  cSum <- c(rep(1,nassets),rep(0,2*nassets))
  cWts = rbind(diag(1,nassets),diag(-1,nassets),diag(1,nassets))
  dimnames(cWts)[[2]] = paste("cWts",1:nassets,sep = "")
  cTurnover <- c(rep(0,nassets),rep(-1,nassets),rep(-1,nassets))
  cWtsBuy <- rbind(diag(0,nassets),diag(1,nassets),diag(0,nassets))
  dimnames(cWtsBuy)[[2]] = paste("cWtsBuy",1:nassets,sep = "")
  cWtsSell = rbind(diag(0,nassets),diag(0,nassets),diag(1,nassets))
  dimnames(cWtsSell)[[2]] = paste("cWtsSell",1:nassets,sep = "")

  muVec <- apply(returns,2,mean)

  if(!is.null(mu.target)){
    # Constraint A matrix
    cMean = muVec
    # A matrix with mean return constraint
    Amat <- cbind(cSum, cMean, cWts,cTurnover,
                cWtsBuy, cWtsSell)
    # Constraints b vector
    bvec <- c(1,mu.target, wts.initial, -toc, rep(0,2*nassets))
    n.eq <- 2+nassets  # First n.eq constraints are equalities
  } else {
    # GMV portfolio - no mean return constraint
    Amat <- cbind(cSum, cWts,cTurnover,
                cWtsBuy, cWtsSell)
    bvec <- c(1,wts.initial,-toc,rep(0,2*nassets))
    n.eq <- 1 + nassets # First n.eq constraints are equalities
  }

  #optional long only constraint
  if(long.only == TRUE){
    if ( length(wts.initial[wts.initial<0]) > 0 ){
      stop("Long-Only specified but some initial weights are negative")
    }
    cLongOnly <- rbind(diag(nassets),diag(0,nassets),diag(0,nassets))
    dimnames(cLongOnly)[[2]] = paste("longOnly",1:nassets,sep = "")
    Amat <- cbind(Amat, cLongOnly)
    bvec <- c(bvec,rep(0,nassets))
  }
if(printDandA) {print(Dmat);print(round(t(Amat),3))}

  solution <- solve.QP(Dmat,dvec,Amat,bvec,meq=n.eq)

  port.var <- solution$value
  wts = solution$solution[1:nassets]
  wts.buy <- solution$solution[(nassets+1):(2*nassets)]
  wts.sell <- solution$solution[(2*nassets+1):(3*nassets)]
  turnover <- sum(wts.buy,wts.sell)
  port.mu <- wts%*%(muVec[1:nassets])
  out = list(wts = wts, wts.buy = wts.buy,wts.sell=wts.sell,
       turnover = turnover,
       port.var=port.var,port.mu=port.mu)
  lapply(out,round,3)
}

#TurnoverOpt_doug(returns, mu.target = NULL, wts.initial = rep(.1,10),toc = .6)


# Example : 3   Chapter : 6.6     Page No: 357
# Jordans theorem and Jordan Matrix
J<-matrix(c(5,0,0,1,5,0,0,1,5),ncol=3)
Jev<-eigen(J)$values
JT<-t(J)
JTev<-eigen(JT)$values
print("Jordans theorem says that both J and transpose of J are similar")
print(Jev)
print(JTev)