annotatoR

Code Appendix

2017-03-23T00:00:00+00:00

This is the code appendix attached to the report Predicting Student Success in a MOOC

library(dplyr)
library(maps)
library(maptools)
library(countrycode)
library(glmnet)
library(nnet)
library(caret)
library(gbm)
library(e1071)
library(randomForest)
library(pROC)

Each of the files are drawn from each run of the course and then compiled later with an additonal variable that describes which run the datum came from.

stats <- read.csv("~/Documents/Entrepreneurship101/Run1/Entrepreneurship_101_1st_run%2Fshow_answer_stats_by_user.csv")
users <- read.csv("~/Documents/Entrepreneurship101/Run1/Entrepreneurship_101_1st_run%2Fperson_course.csv", stringsAsFactors = FALSE)
staff <- read.csv("~/Documents/Entrepreneurship101/Run1/Entrepreneurship_101_1st_run%2Fuser_info_combo.csv")
problems <- read.csv("~/Documents/Entrepreneurship101/Run1/Entrepreneurship_101_1st_run%2Fperson_problem.csv")

stats2 <- read.csv("~/Documents/Entrepreneurship101/Run2/Entrepreneurship_101_2nd_run%2Fshow_answer_stats_by_user.csv")
users2 <- read.csv("~/Documents/Entrepreneurship101/Run2/Entrepreneurship_101_2nd_run%2Fperson_course.csv", stringsAsFactors = FALSE)
staff2 <- read.csv("~/Documents/Entrepreneurship101/Run2/Entrepreneurship_101_2nd_run%2Fuser_info_combo.csv")
problems2 <- read.csv("~/Documents/Entrepreneurship101/Run2/Entrepreneurship_101_2nd_run%2Fperson_problem.csv")

stats3 <- read.csv("~/Documents/Entrepreneurship101/Run3/Entrepreneurship_101_3rd_run%2Fshow_answer_stats_by_user.csv")
users3 <- read.csv("~/Documents/Entrepreneurship101/Run3/Entrepreneurship_101_3rd_run%2Fperson_course.csv", stringsAsFactors = FALSE)
staff3 <- read.csv("~/Documents/Entrepreneurship101/Run3/Entrepreneurship_101_3rd_run%2Fuser_info_combo.csv")
problems3 <- read.csv("~/Documents/Entrepreneurship101/Run3/Entrepreneurship_101_3rd_run%2Fperson_problem.csv")

Once the data are loaded we want to narrow down some predictors. Each of these predictors are selected alongside of the user_id variable so that we can utilize dplyr’s left_join() function to join by user id. The stats dataframe describes the number of problems that the student attempted in the course. The users dataframe describes; whether or not a student viewed the course, whether or not the student became certified, the student’s country code based on their ip address, their latitude and longitude, their year of birth, gender, grade in the course, their time they began the course, the last time they accessed the course, their video plays count, whether they were honor or verified track, and their number of forum posts. I also altered a variable to show their age instead of their year of birth. This was done by taking the computer outputted current year and subtracting the student’s year of birth: mutate(age = as.integer(format(Sys.Date(), "%Y")) - YoB). mutate() will create that new variable and then I just deselect the YoB varaible using, dplyr::select(-YoB).

Some of the user accounts were staff members so I used one of the datasets to track which ones were staff members and then removed those accounts before the analysis.

The problems dataframe was my experiment in checking the importance of whether or not a student completed the first homework assignment. This was done simply by taking the data of all homework assignments completed and just grabbing the first one, indexprob <- which(problems$problem_nid == 1), then selecting the accounts where the student completed that assignment, staff <- staff %>% dplyr::select(user_id, is_staff), and finally assigning this new boolean variable eager that shows whether or not the first assignment was completed for every student.

The students that did not access the forum at all were given NA values. I just assume here that this is equivalent to accessing the forum 0 times and replace all of the NAs with 0’s. The same is true for n_attempted, if the student never viewed the course they received an NA as the number of problems attempted, but this is equivalent to saying they attempted 0 problems.

Finally, I clean up some missing value data points and join all of the dataframes together into one, StudentStats.

xFormData <- function(dfStats, dfUsers, dfStaff, dfProblems) {
# Function to clean data into one data frame for analysis
# All of the variables with 'roles' are just NA
# Viewed: Boolean flag, indicating that the user visited the course at least once
# Certified: Boolean flag, indicating that the user earned a certificate in the course
# -------------------------------------------------------------------------------------
stats <- dfStats %>% dplyr::select(user_id, n_attempted, n_perfect)
users <- dfUsers %>% dplyr::select(user_id, viewed, certified, 
                                   cc_by_ip, latitude, longitude, YoB, 
                                   gender, grade, start_time, last_event, 
                                   nplay_video, mode, nforum_posts) %>% 
  mutate(age = as.integer(format(Sys.Date(), "%Y")) - YoB) %>% 
  dplyr::select(-YoB)
staff <- staff %>% dplyr::select(user_id, is_staff)
staff$is_staff <- as.factor(staff$is_staff)

problems <- dfProblems %>% select(user_id, problem_nid, problem_raw_score)
indexprob <- which(problems$problem_nid == 1)
problems <- problems[indexprob,]
problems <- problems %>% mutate(eager = problem_raw_score == 1)
problems <- problems %>% select(user_id, eager)

users$viewed <- as.factor(users$viewed)
users$certified <- as.factor(users$certified)
# Those students that weren't in the forum data did not access 
# the forum so set nforum = 0
users$nforum_posts[which(is.na(users$nforum_posts))] <- 0
users$gender[users$gender == "o"] <- NA
users$gender[users$gender == ""] <- NA
users$gender[users$gender == "null"] <- NA
users$gender <- as.factor(users$gender)
unique(users$gender)
users$mode <- as.factor(users$mode)
StudentStats <- left_join(users, stats, by = "user_id")
StudentStats <- left_join(StudentStats, staff, by = "user_id")
StudentStats <- left_join(StudentStats, problems, by = "user_id")
staffindex <- which(StudentStats$is_staff == 1)
StudentStats <- StudentStats[-staffindex,]
# The NAs mean the student never viewed the course
StudentStats$n_attempted[is.na(StudentStats$n_attempted)] <- 0 
StudentStats$n_perfect[is.na(StudentStats$n_perfect)] <- 0
return(StudentStats)
}

Now we can run this previous function on each run’s dataframes and we will get 3 dataframes, 1 for each run. Then we simply join those dataframes by a quick rowbind and create another variable that describes which run those data came from.

studentstats1 <- xFormData(stats, users, staff, problems) %>% mutate(Run = "run1")
studentstats2 <- xFormData(stats2, users2, staff2, problems2) %>% mutate(Run = "run2")
studentstats3 <- xFormData(stats3, users3, staff3, problems3) %>% mutate(Run = "run3")
StudentStats <- rbind(studentstats1, studentstats2, studentstats3)
StudentStats$Run <- as.factor(StudentStats$Run)
StudentStats$eager[which(is.na(StudentStats$eager))] <- FALSE
StudentStats$nplay_video[which(is.na(StudentStats$nplay_video))] <- 0
StudentStats$eager <- as.factor(StudentStats$eager)
StudentStats$certified <- as.factor(StudentStats$certified)

Since we are performing predictions I subset the data into a trianing and a test set. I take the first 100,000 rows for the training set and leave the rest for the test set. This way when I go to check how the models are performing I don’t have a skewed sense of how well it’s done. Recall we use the AUC as our metric.

# How many people scored above 60% but did not receive a certificate?
summary(StudentStats[StudentStats$grade > .6,]$certified)
set.seed(890522)
o<-order(runif(dim(StudentStats)[1]))
stats.train <- StudentStats[o[1:100000],]
stats.pred <- StudentStats[o[100001:dim(StudentStats)[1]],]
stats.train$cc_by_ip <- as.factor(stats.train$cc_by_ip)
levels(stats.train$certified) <- c(0, 1)

I separated the character variables out from the numerical ones to take a closer look at the times (which are currently just character vectors).

train_numr = StudentStats[, sapply(StudentStats, is.numeric)]
train_char = StudentStats[, sapply(StudentStats, is.character)]
cat("Numerical column count : ", dim(train_numr)[2], 
    "; Character column count : ", dim(train_char)[2])

Now I just grep for the dates and isolate them into two different vectors. One is the hour of the day pertaining to the student’s start_time and last_event, and the other is simply the date and time of both variables.

train_date = train_char[,grep("2015-01-01", train_char),]
train_char = train_char[, !colnames(train_char) %in% colnames(train_date)]
train_date = sapply(train_date, function(x) strptime(x, "%Y-%m-%d %H:%M:%S"))
train_date = do.call(cbind.data.frame, train_date)

train_time = train_date[,colnames(train_date) %in% c("start_time", "last_event")]
train_time = data.frame(sapply(train_time, function(x) strftime(x, "%H:%M:%S")))
train_hour = as.data.frame(sapply(train_time, 
                                  function(x) as.numeric(as.character(substr( x ,1, 2)))))

This displays a histogram of the hour of the data these actions were logged. It does seem natural that there is a mode during the (after-work hours, or after-school day). The high number of actions at midnight I believe is either ill-founded data inputting or could be a mistake in my own parsing of the data.

par(mfrow=c(1,2))
for(i in 1:2) hist(train_hour[,i], main = paste(colnames(train_hour)[i], 
                                                "hourly"), breaks = c(0:24), 
                   xlab="", ylab="")

I wanted to take a look at where the students were coming from in the world so I grabbed all of the country codes from the cc_by_ip variable and matched them up with a dictionary of country names and country codes I found in an R package called countrycode. The purpose of translating the country codes to country names is that I want to make a heat map of all the students’ locations but the method for rendering the heat map only takes country names.

After translating the country codes to country names I realize that some of the country names from this dictionary do not match the country names from the dictionary used by the heat map package. So I have to clean up some of these names to make them match.

cc <- na.omit(stats.train$cc_by_ip)
cc[cc == ""] <- NA
cc <- na.omit(cc)
ccnames <- countrycode(cc,"iso2c","country.name")
ccnames <- as.character(ccnames)

ccnames[ccnames == "United States"] <- "USA"
ccnames[ccnames == "Russian Federation"] <- "Russia"
ccnames[ccnames == "Venezuela, Bolivarian Republic of"] <- "Venezuela"
ccnames[ccnames == "Taiwan, Province of China"] <- "Taiwan"
ccnames[ccnames == "Korea, Republic of"] <- "South Korea"
ccnames[ccnames == "Viet Nam"] <- "Vietnam"

ccnames <- as.data.frame(ccnames)
colnames(ccnames) <- "cc_by_ip"

Now that I have my list of country names I just render a heat map using the code block below.

mapWORLD <- map('world', fill=TRUE, plot=FALSE)
nms <- sapply(strsplit(mapWORLD$names,  ':'),  function(x)x[1])
WORLDpolygons <- map2SpatialPolygons(mapWORLD,  IDs = nms,  CRS('+proj=longlat'))

mapCountries = function(df, feat){
  dat = data.frame(table(df[,feat]))
  names(dat) = c("country", "value")
  
  idx <- match(unique(nms),  dat$country)
  dat2 <- data.frame(value = dat$value[idx], country = unique(nms))
  row.names(dat2) <- unique(nms) 
  WORLDsp <- SpatialPolygonsDataFrame(WORLDpolygons,  data = dat2)
  spplot(WORLDsp['value'], main=paste(feat, "frequency"), col.regions=rev(heat.colors(21)))
}
mapCountries(ccnames, "cc_by_ip")

Narrow down predictors on the training dataset and the test dataset.

# classes <- class.ind(stats.train$certified)
stats.train.subset <- stats.train %>% select(certified, cc_by_ip, 
                                             age, gender, nplay_video, 
                                             nforum_posts, n_attempted, eager, Run)
stats.pred.subset <- stats.pred %>% select(certified, cc_by_ip, 
                                           age, gender, nplay_video, 
                                           nforum_posts, n_attempted, eager, Run)

stats.train.subset <- na.omit(stats.train.subset)
stats.pred.subset <- na.omit(stats.pred.subset)

Use tuning with 10-fold cross validation to determine optimal hyperparamters based on the ROC metric.

nnetGrid <- expand.grid(.size = 1:10, .decay = c(0, .1, 1, 2))
maxSize <- max(nnetGrid$.size)
numWts <- 1*(maxSize * (length(colnames(stats.train.subset)) + 1) + maxSize + 1)
set.seed(450)
ctrl <- trainControl(method = "cv", number = 10, classProbs = TRUE)
# only use certain predictors described in models later `stats.train.subset[,3:8]`
nnetFit <- train(x = stats.train.subset[,3:8], y = stats.train.subset[,1],
                 method = "nnet",
                 metric = "ROC",
                 preProcess = c("center", "scale", "spatialSign"),
                 tuneGrid = nnetGrid,
                 trace = FALSE,
                 maxit = 2000,
                 MaxNWts = numWts,
                 trControl = ctrl,
                 verbose = TRUE)
# > nnetFit
# Neural Network 
# 
# 86261 samples
#     6 predictor
#     2 classes: 'No', 'Yes' 
# 
# Pre-processing: centered (4), scaled (4), spatial sign transformation (4), ignore (2) 
# Resampling: Cross-Validated (10 fold) 
# Summary of sample sizes: 77636, 77635, 77635, 77634, 77635, 77635, ... 
# Resampling results across tuning parameters:
# ...
# Accuracy was used to select the optimal model using  the largest value.
# The final values used for the model were size = 7 and decay = 0.1

Run the neural net with the tuned hyperparameters. Then check the predictions using the AUC metric.

nn <- nnet(certified ~ age + gender + nplay_video + nforum_posts + eager, 
           data = stats.train.subset, 
           size = 7, 
           decay = .4) # decay slightly changed from tuning due to improved results

nnpredictions <- predict(nn, newdata = stats.pred.subset, type = "class")
table(NNpredictions, stats.pred.subset$certified)

nnpredictions <- as.factor(nnpredictions)
levels(nnpredictions) <- c(0,1)
nnpredictions <- as.numeric(as.vector(nnpredictions))
nnroc <- roc(stats.pred.subset$certified, nnpredictions)
auc(nnroc)

train.svm <- svm(as.factor(certified) ~ age + gender + nplay_video + nforum_posts + eager, 
                 type='C-classification', 
                 kernel='radial', 
                 cachesize=2000, 
                 probability=TRUE, 
                 cost=1, 
                 data = stats.train.subset)

svmpredictions <- predict(train.svm, stats.pred.subset)
table(svmpredictions, stats.pred.subset$certified)

svmpredictions <- as.factor(svmpredictions)
levels(svmpredictions) <- c(0,1)
svmpredictions <- as.numeric(as.vector(svmpredictions))
svmroc <- roc(stats.pred.subset$certified, svmpredictions)
auc(svmroc)

train.Forest <- randomForest(formula = as.factor(certified) ~ age + gender + 
                               nplay_video + nforum_posts + eager, 
                             data = stats.train.subset, 
                             ntree = 2000, 
                             importance = TRUE, 
                             na.action=na.omit)

rfpredictions <- predict(train.Forest, stats.pred.subset)
table(rfpredictions, stats.pred.subset$certified)

rfpredictions <- as.factor(rfpredictions)
levels(rfpredictions) <- c(0,1)
rfpredictions <- as.numeric(as.vector(rfpredictions))
rfroc <- roc(stats.pred.subset$certified, rfpredictions)
auc(rfroc)

Build an ensemble of the three previous models and predict each observation using a voting tactic where if two or more models predict 0, the result is 0, and vice-versa. This did not prove as strong as the SVM on its own.

preds <- data.frame(nnpredictions, svmpredictions, rfpredictions)
preds$jointpred <- round((nnpredictions + svmpredictions + rfpredictions)/3)

jointpredictions <- as.numeric(as.vector(preds$jointpred))
jointroc <- roc(stats.pred.subset$certified, jointpredictions)
auc(jointroc)

Code Appendix was originally published by Mike Chaykowsky at annotatoR on March 23, 2017.

Kaggle Competition Ensemble Model

2017-03-09T00:00:00+00:00

After the data imputation of the Give Me Some Credit Kaggle competition, I utilized the caret package to do some model tuning and determine optimal hyperparameters. Shown below are the XGBoost and GBM models and how I determined the hyperparameters for each.

XGBoost tuning

XGBoost is also a tree-based method similar to Random Forest, however, xgboost utilizes boosting whereas random forest uses bagging. Both methods attempt to acheive lower error, but in different ways. Error comes from bias an variance. A very complex model has low bias and high variance, and a very simple model has high bias and low variance. Random forest attempts to reduce the variance of a very complex model of descision trees, which are each there own individual models. XGBoost reduces bias of a large number of weak learners where each of these weak learners will build upon each other in an almost nested fashion. XGBoost takes many parameters. Some of the parameters here were selected just to increase iterations towards the idea that if it runs longer it will perform better, and others has a more rigorous approach. First, all of the variables must have no factors, so data.matrix does this for us (also there really aren’t any). We want to use a gradient boosting tree with a small step size, which eta is defined to be 0.01. max_depth refers to the trees discussed earlier, this was fairly abitrarily set to 50 after observing the default value. Setting subsample to 0.5 means that XGBoost randomly collected half of the data instances to grow trees and this will prevent overfitting. This is essential to the model because this is the issue that random forest runs into. So XGBoost is a perfect balance of lack of overfit by applying these weak learners on random resamples of the data. Then since we set subsample to 0.5, we also have to set colsample_bytree to 0.5. These parameters are passed into xgboost and then the number of iterations was set high to 500 and verbose = 1 just means that we get to see how the model progresses as it’s running based on the training AUC value.

xgbModel <- function(dfTrain, dfTest) {
  test_names <- names(dfTest)
  train_names <- names(dfTrain)
  intersect_names <- intersect(test_names, train_names)
  
  training <- xgb.DMatrix(data = data.matrix(dfTrain[intersect_names]),label=(dfTrain[,c("SeriousDlqin2yrs")]))
  
  # subsample - setting it to 0.5 means that XGBoost randomly collected half of the data instances to grow 
  # trees and this will prevent overfitting. 
  # colsample_bytree - subsample ratio of columns when constructing each tree.
  param <- list(objective = "binary:logistic", booster = "gbtree", eta = 0.01, max_depth = 50,
                subsample = 0.5, colsample_bytree = 0.5)
  
  train.xgb <- xgboost(data = training, params = param, nrounds = 500, verbose = 1, eval_metric="auc")
  
  train.xgb
}

GBM tuning

The caret package allows you to cross-validate on multiple hyperparameters and define a metric to check for the optimal values. Since Kaggle uses AUC (or area under the ROC curve), I utilized the ROC metric for tuning. I asked the function to check for interaction.depth and shrinkage. Any more than that and this code will run for a very long time. You can see the output displayed below. The labels were given names “good” and “bad” so the results are legible.

require(caret)
Train$SeriousDlqin2yrs <- as.factor(Train$SeriousDlqin2yrs)
levels(Train$SeriousDlqin2yrs) <- c("Good", "Bad")
caretGrid <- expand.grid(interaction.depth=c(5, 10), n.trees = 500,
                   shrinkage=c(0.01, 0.001), n.minobsinnode = 5)
metric <- "ROC"
trainControl <- trainControl(method="cv", number=10, classProbs = TRUE)
gbm.caret <- train(SeriousDlqin2yrs ~ ., data=Train, distribution="bernoulli", method="gbm",
              trControl=trainControl, verbose=TRUE, 
              tuneGrid=caretGrid, metric=metric, bag.fraction=0.3)

# Stochastic Gradient Boosting 
# 
# 150000 samples
#     10 predictor
#      2 classes: 'Good', 'Bad' 
# 
# No pre-processing
# Resampling: Cross-Validated (10 fold) 
# Summary of sample sizes: 135000, 135000, 134999, 134999, 135001, 135000, ... 
# Resampling results across tuning parameters:
# 
#   shrinkage  interaction.depth  Accuracy   Kappa    
#   0.001       5                 0.9331600  0.0000000
#   0.001      10                 0.9331600  0.0000000
#   0.010       5                 0.9374467  0.2608611
#   0.010      10                 0.9376333  0.2711224
# 
# Tuning parameter 'n.trees' was held constant at a value of 500
# Tuning parameter 'n.minobsinnode' was
#  held constant at a value of 5
# Accuracy was used to select the optimal model using  the largest value.
# The final values used for the model were n.trees = 500, interaction.depth = 10, shrinkage = 0.01
#  and n.minobsinnode = 5.

Here I loaded in the dataframes from the data imputation post.

library(dplyr)
library(e1071)
library(randomForest)
library(gbm)
library(xgboost)
Train <- read.csv("training_imputed.csv")
Test <- read.csv("test_imputed.csv")
Train$X <- NULL
Test$X <- NULL
Test$SeriousDlqin2yrs <- NULL

## Gradient Boosting Machine model as defined above in model tuning section
#    args: dfTrain -> the training dataframe required
# --------------------------------------------------------------
GBMModel <- function(dfTrain) {
  GB <- gbm(dfTrain$SeriousDlqin2yrs ~ ., data=dfTrain, n.trees=5000,
            keep.data=FALSE, shrinkage=0.01, bag.fraction=0.3,
            interaction.depth=10)
  GB
}

## Random Forest model
#    args: dfTrain -> the training dataframe required
# --------------------------------------------------------------
forestModel <- function(dfTrain) {
  train.Forest <- randomForest(formula = as.factor(SeriousDlqin2yrs) ~ ., 
                               data = dfTrain, ntree = 2000, importance = TRUE, 
                               na.action=na.omit)
  train.Forest
}

There’s a lot behind the choices of kernel in a support vector machine, so I think I will save this discussion for a separate post and focus on the model development here. I also ended up not even using this model in the ensemble so it is only here to show that SVM does not work well for this question.

## Support Vector Machine model
#    args: dfTrain -> the training dataframe required
# --------------------------------------------------------------
svmModel <- function(dfTrain) {
  train.svm <- svm(as.factor(SeriousDlqin2yrs) ~ ., 
                   type='C-classification', kernel='radial', 
                   cachesize=2000, probability=TRUE, cost=1, 
                   data = dfTrain)
  train.svm
}

The XGBoost was discussed above along with the hyperparameters.

## Support Vector Machine model
#    args: dfTrain -> the training dataframe required
#          dfTest -> the test dataframe required
# --------------------------------------------------------------
xgbModel <- function(dfTrain, dfTest) {
  test_names <- names(dfTest)
  train_names <- names(dfTrain)
  intersect_names <- intersect(test_names, train_names)
  
  training <- xgb.DMatrix(data = data.matrix(dfTrain[intersect_names]),label=(dfTrain[,c("SeriousDlqin2yrs")]))
  
  # subsample - setting it to 0.5 means that XGBoost randomly collected half of the data instances to grow 
  # trees and this will prevent overfitting.
  # colsample_bytree - subsample ratio of columns when constructing each tree.
  param <- list(objective = "binary:logistic", booster = "gbtree", eta = 0.01, max_depth = 50,
                subsample = 0.5, colsample_bytree = 0.5)
  
  train.xgb <- xgboost(data = training, params = param, nrounds = 500, verbose = 1, eval_metric="auc")
  
  train.xgb
}

Here I put together an ensemble of all the previous models described above. The SVM is commented out because it did not improve AUC score when submitted to Kaggle.

## Ensemble model
#    args: dfTrain -> the training dataframe required
#          dfTest -> the test dataframe required
# --------------------------------------------------------------
ensemble <- function(dfTrain, dfTest) {
  #SVM commented out because does not improve AUC score
  models <- list(rfs=forestModel(dfTrain),
                           gbs=GBMModel(dfTrain),
                           #svm=svmModel(dfTrain),
                           xgb=xgbModel(dfTrain, dfTest))
  models
}

The ensemblePredictions() function will output the final prediction probabilities to a .csv file ready to be submitted to Kaggle. The main aspect here that needs improvement is the weights on the individual models. I simply upweighted the most effective models based on their individual AUC score in the ensemble of all three. The XGBoost performed the best so it was upweighted the most, then the GBM, then the RF. These weights are fairly arbitrary and more trial and error than anything else.

## Support Vector Machine model
#    args: model -> the ensemble model used to predict
#          dfTrain -> the training dataframe required
#          dfTest -> the test dataframe required
# --------------------------------------------------------------
ensemblePredictions <- function(model, train, test) {
  pred <- predict(model$rfs, test, type = 'prob')[,2]
  pred2 <- predict(model$gbs, test, n.trees = 5000)
  #pred3 <- predict(model$svm, test)
  
  test_names <- names(test)
  train_names <- names(train)
  intersect_names <- intersect(test_names, train_names)

  testDataXGB <- xgb.DMatrix(data = data.matrix(test[,intersect_names]))
  pred4 <- predict(xgb1,testDataXGB)
  
  pred <- data.frame(Id = seq.int(nrow(test)), ProbabilityRF=pred, 
                     ProbabilityGBM=pred2, ProbabilityXGB=pred4)
  pred$ProbabilityGBM <- 1/(1+exp(-pred$ProbabilityGBM)) # sigmoid function to convert to probability
  
  # After submitting each model individually, this upweights models with greater individual AUC
  pred$Probability <- ((pred$ProbabilityGBM)*4 + pred$ProbabilityRF + (pred$ProbabilityXGB)*20)/25
  
  pred <- pred %>% dplyr::select(Id, Probability)
  write.csv(pred, file="probabilities4-1-20train.csv", row.names=FALSE)
}

ensemble.models <- ensemble(Train, Test)
ensemblePredictions(ensemble.models, Train, Test)

Kaggle Competition Ensemble Model was originally published by Mike Chaykowsky at annotatoR on March 09, 2017.

Student Success in Entrepreneurship 101

2016-12-21T00:00:00+00:00

Student Success in Entrepreneurship 101 was originally published by Mike Chaykowsky at annotatoR on December 21, 2016.

Data Imputation of Credit Risk Kaggle

2016-12-21T00:00:00+00:00

I’m finally beginning a Kaggle competition of my own, Give Me Some Credit. I’ve decided for my first Kaggle I will try an already completed competition and see where I would’ve placed if the competition was in session. Then maybe later I will try a live one. Also, I will update my progress in multiple posts. This first post consists of dealing with the missing data using data imputation methods.

library(ggplot2)
library(lattice)

Models can not be evaluated on missing data without some processing. So if we are given a dataset with NA values, we must develop a technique to either repeal or replace them. In some cases we may just remove the NA values. But this is not always the best method. If we just remove the missing values, we can cause more variable estimates, or even worse we could cause biased estimates. Here we look at the option to replace the NA values. One benefit to replacing the NA values is that they may contain important information. We want to deal with the missing values in a way that causes minimum harm to our inference or prediction. The missing values can be missing at random or not at random. If they are missing at random there is no pattern to the way they are missing from the variable and no pattern to how they are missing compared to other variables. The other possibility is that the missing values have some pattern and are missing due to a systematic issue with data collection.

One of the simplest ways of imputing for missing values is just to impute the mean of that variable across the non-missing values. Issues with this method are that it understates variability in the variable. This method is also not making any attempt to obtain the associations between the variables.

Another method of imputing for the missing values is to do regression-based imputation, which is the method described below in R. We have a dataset from the Give me Some Credit Kaggle competition where the purpose is to predict whether or not someone will default on their credit, or in terms of the data: predict a binary response SeriousDlqin2yrs.

Train <- read.csv('cs-training.csv', header=TRUE,comment.char="")
Train$X <- NULL # Removes redundant indexing

set.seed(890522)
o<-order(runif(dim(Train)[1])) # Create index to randomly subset data

SeriousDlqin2yrs <- Train$SeriousDlqin2yrs[o[1:(.2*(dim(Train)[1]))]]
Train$SeriousDlqin2yrs <- NULL

N_var <- length(colnames(Train)) # Number of variables
N_obs <- length(Train$age) # Number of Observations
Test <- read.csv('cs-test.csv', header=TRUE, comment.char="")
Test$X <- NULL # Removes redundant indexing
Test$SeriousDlqin2yrs <- NULL # Removes redundant indexing

credit.train <- Train[o[1:(.2*(dim(Train)[1]))],]
credit.pred <- Train[o[(.2*(dim(Train)[1])+1):(.25*(dim(Train)[1]))],]

Below is a bar chart describing the number of NA values for each variable. We can see that MonthlyIncome has the most missing values and NumberOfDependents has missing values and the remaining variables do not. However, the DebtRatio variable contains innacurate information so we will also do regression imputation on these values.

train_na <- as.data.frame(sapply(credit.train, function(x) sum(is.na(x))))
train_na <- data.frame(names = row.names(train_na), count = train_na[,1])

barchart(as.factor(names) ~ count, data = train_na, title = "Number of NA counts per variable")

We take the data frame, do linear regression to solve for the variable in question, and then update the values in the data frame. Much like a Gibbs sampler, we hope that running this repeatedly will cause us to converge to a better value for Monthly Income, Debt Ratio, and Number of Dependents than, say, the mean of the data set.

Update_MI <- function(df,index) {
  # Updates 0 and NA values of Monthly Income
  #
  # Args:
  #   df: data frame of observations
  #
  # Returns:
  #   dataframe w/ updated values
  LinReg <- lm(MonthlyIncome ~ .,df) # Performs linear regression for Monthly Income using all other variales
  df$MonthlyIncome[index] <- predict(LinReg,df[index,]) # Imputes for Monthly Income
  print(paste("MI: ",df$MonthlyIncome[index[1]]),sep="") # Check for convergence
  return(df)
}

Update_NoD <- function(df,index) {
  # Updates NA values of Number of Dependents
  #
  # Args:
  #   df: data frame of observations
  #
  # Returns:
  #   dataframe w/ updated values
  LinReg <- lm(NumberOfDependents ~ .,df) # Performs linear regression for Monthly Income using all other variales
  df$NumberOfDependents[index] <- predict(LinReg,df[index,]) # Imputes for Number of Dependents
  print(paste("NoD: ",df$NumberOfDependents[index[1]]),sep="") # Check for convergence
  return(df)
}

Update_DR <- function(df,index) {
  # Updates Debt Ratio for Monthly Income = 0 or NA
  #
  # Args:
  #   df: data frame of observations
  #
  # Returns:
  #   dataframe w/ updated values
  LinReg <- lm(DebtRatio ~ .,df) # Performs linear regression for Debt Ratio using all other variales
  df$DebtRatio[index] <- predict(LinReg,df[index,]) # Imputes for Debt Ratio
  print(paste("DR: ",df$DebtRatio[index[1]]),sep="") # Check for convergence
  return(df)
}

Impute <- function(df) {
  # Imputes NA values in the data frame using linear regression
  #
  # Args:
  #   df: data frame of observations
  #
  # Returns:
  #   data frame with imputed values for Monthly Income, Debt Ratio, and Number of Dependents
  na.NoD.index <- which(is.na(df$NumberOfDependents)) # Observations with Number of Dependents = NA
  na.MI.index <- which(is.na(df$MonthlyIncome)) # Observations with Monthly Income = NA
  zero.MI.index <- which(df$MonthlyIncome == 0) # Observations with Monthly Income = 0
  zero.na.MI.index <- sort(c(na.MI.index,zero.MI.index)) # Observations with Monthly Income = 0 or NA
  
  Debt_Hold <- df$DebtRatio[zero.na.MI.index] # Stores Debt Values where Debt Ratio could not be calculated
  df$DebtRatio[zero.na.MI.index] <- NA # Replaces Debt Values with NA
  
  mean_NoD <- mean(df$NumberOfDependents,na.rm=TRUE) # Mean Number of Dependents
  mean_DR <- mean(df$DebtRatio,na.rm=TRUE) # Mean Debt Ratio
  mean_MI <- mean(df$MonthlyIncome,na.rm=TRUE) # Mean Monthly Income
  
  df$DebtRatio[zero.na.MI.index] <- mean_DR # Insert Mean Number of Dependents as init for Observations with Monthly Income = 0 or NA
  df$NumberOfDependents[na.NoD.index] <- mean_NoD # Insert Mean Number of Dependents as init for Observations with NoD = NA
  
  # Imputation
  for(i in 1:20) {
    df <- Update_MI(df,zero.na.MI.index)
    df <- Update_NoD(df,na.NoD.index)
    df <- Update_DR(df,zero.na.MI.index)
  }
  
  df$DebtRatio[zero.na.MI.index] <- Debt_Hold / df$MonthlyIncome[zero.na.MI.index] # Replace DR with original debt divided by imputed MI
  df$MonthlyIncome[zero.MI.index] <- 0 # Reset MI for those with original MI = 0 
  df$NumberOfDependents[df$NumberOfDependents < 0] <- 0 # Set NoD = 0 if imputed NoD < 0
  
  return(df)
}

Below we can see the values of each variable converging by looping through the linear models 20x as shown in the code above. The values actually converge more quickly than 20 iterations, in some cases only 3 iterations showed near convergence.

Train <- Impute(credit.train)
Train$SeriousDlqin2yrs <- SeriousDlqin2yrs
Test <- Impute(credit.pred)

Just to double check that the NA values do not exist anymore we can take a look at the NA sums over each variable and see they they have been replaced.

train_na2 <- as.data.frame(sapply(Train, function(x) sum(is.na(x))))
train_na2 <- data.frame(names = row.names(train_na2), count = train_na2[,1])

train_na2

##                                   names count
## 1  RevolvingUtilizationOfUnsecuredLines     0
## 2                                   age     0
## 3  NumberOfTime30.59DaysPastDueNotWorse     0
## 4                             DebtRatio     0
## 5                         MonthlyIncome     0
## 6       NumberOfOpenCreditLinesAndLoans     0
## 7               NumberOfTimes90DaysLate     0
## 8          NumberRealEstateLoansOrLines     0
## 9  NumberOfTime60.89DaysPastDueNotWorse     0
## 10                   NumberOfDependents     0
## 11                     SeriousDlqin2yrs     0

Data Imputation of Credit Risk Kaggle was originally published by Mike Chaykowsky at annotatoR on December 21, 2016.

Random Transposition with Naive Markov Chain Monte Carlo

2016-09-30T00:00:00+00:00

The goal here is to naively run through the entire support of permuting the integers of length $m$ and then determining the ones that are “big” permutations, i.e. $\Sigma i x_i > k$.

So more formally, suppose we want a random permutation $x = (x_1, x_2, … , x_m)$ of the integers $1, … , m$ that satisfies $\Sigma i x_i > k$. For a given value of $m$, there are $n(k)$ of these, so each should have probability $\frac{1}{n(k)}$. However, finding these permutation is computationally infeasible for moderate $m$ (as it requires checking $m!$ permutations).

Suppose we are at state $x$ (a particular permutation). Define a neighbor of $x$ as a permutation satisfying the constraint that is achieved by switching two elements of $x$. Suppose $x$ has $N(x)$ neighbors. Let $y$ be one of those neighbors, and $y$ has $N(y)$ neighbors. These quantities are easy to calculate as it only requires checking $\choose{m,2}$ permutations, much smaller than $m!$. At each iteration, randomly select a neighbor and move to it with probability $min(1, \frac{N(x)}{N(y)})$. Then the stationary distribution is the one we wanted. $p_{xy}$ is the probability that we are at $x$ and move to $y$. Suppose $N(y)$ is less than $N(x)$. First we need to be offered a move to $y$, with probability $\frac{1}{N(x)}$. Then, because $N(y)$ is less than $N(x)$, we necessarily move to it. So $p_{xy} = \frac{1}{N(x)}$. $p_{xy}$ is the chance that we move from $y$ to $x$, so first we must be offered $x$, with probability $\frac{1}{N(y)}$, then we must decide to move there, with probability $\frac{N(y)}{N(x)})$ so $p_{yx} = \frac{1}{N(x)}$ as well. Since the transition probabilities are the same, the stationary probabilities for $x$ and $y$ must also be the same (from the above).

This code runs through every permutation and gives the size $k$ of the permutations that are one two-swap away from each other. Then the average of the permuations gives the stationary distribution. We can see in the graphs below that the line graph converges on the stationary distribution and the histogram represents the frequency of permutation sizes.

So we can see an algorithm emerge here where

Given $x^t$
Generate $Y_t \sim g(y - x^t)$
Take $X^{t+1} = \begin{cases} Y_t \text{ with probability } \text{min}\{1, \frac{f(Y_t)}{f(x^t)}\} \\ x^t \text{ otherwise} \end{cases}$

To get a better sense of this problem, let us look at a deck of cards that need to be shuffled. The rules of the shuffle are that at each time step, choose two positions $i$ and $j$ randomly in the deck. Take the cards at those positions, and swap them. If the Markov chain $P$ is defined by these transitions, is $P$ irreducible? Yes: it is not hard to show that with a sequence of $n$ pair swaps, we can generate any permutation we want. Is $P$ aperiodic? Yes: if we allow the possibility of $i$ and $j$ being the same card we have self-loops. So $P$ is ergodic and converges to its stationary distribution. This Markov chain is reversible, and moreover $P$ is entirely symmetric so $\pi_x = \pi_y$. This tells us that after running long enough, this random transposition will sample each permutation of the deck of cards with equal probability.

Our goal here is to essentially explore the entire support of the density according to its probability. Because of its symmetric features, it spends about half the time of the simulation running over areas of the support it has already been to. Our method is very similar to Accept-Reject method in the sense that the instrumental distribution is the same density $g$ as in rejection method. We can see on the line plots of sizes according to their index that for some intervals of time the sequence does not change at all because the cooresponding $Y_i$’s are being rejected. This is one area where we can see a difference between this method and Accept-Reject method. This sampling will have repeated occurences of the same value since rejection of $Y$ brings about repetition of $X^{t}$ at time $t+1$.

One can imagine that when the acceptance system is offered an area of the support that it hasn’t been to in a while, it wants to go there. However, keep in mind that the acceptance probability does not depend on the symmetric proposal density $g$. Changing $g$ will give different values of $Y_t$’s but the dependence does not exist. But there does exist a dependence between the candidate distribution and the current state of the chain. Actually, a high acceptance rate does not indicate the method is doing what we want it to. The algorithm may just be moving to slowly across the support. If the acceptance rate is low, the algorithm may be moving more quickly over the support and reaches the “borders”, exploring regions with low probability under $f$.

Size <- function(List){
  # Calculates "Size" of Permutation
  #
  # Args:
  #   List: Permutation whose size is to be calculated
  #
  # Returns:
  #   Size of Vector
  M <- length(List)
  return(sum(List * seq(1:M)))
}

Neighbors <- function(List,k){
  # Finds 2 swap neighbors of a given Permutation still larger than k
  #
  # Args:
  #   List: Permuation whose neighbors we want
  #   k: size of a permutation required to be "big"
  #
  # Returns:
  #   Returns list with number of neighbors and all the neighbors
  M <- length(List)
  max_nNeighbors <- factorial(M) / (factorial(2) * factorial(M-2)) #M choose 2
  List_Neighbors <- vector("list",round(max_nNeighbors)) # initializes list of Neighbors
  nNeighbors <- 0 # initializes count of number of neighbors
  l <- 1 # initializes index for list of neighbors
  
  #walks through all 2 swap permutations (neighbors)
  for (i in 1:(M-1)) {
    for(j in (i+1):M) {
      swap2 <- List
      swap2[i] <- List[j]
      swap2[j] <- List[i]
      size <- Size(swap2)
      if (size > k){ # if neighbor is big
        List_Neighbors[[l]] <- swap2 # store neighbor
        nNeighbors <- nNeighbors + 1 # increments number of neighbors
        l <- l + 1
      }
    }
  }
  return(c(nNeighbors,List_Neighbors))
}

BigListAvg <- function(M,k) {
  # Calculates average size of Permutations with size > k
  #
  # Args:
  #   M: Length of sequence 
  #   k: size of a permutation required to be "big"
  #
  # Returns:
  #   Average size of big Permutations
  max_list <- c(seq(1:M)) # Largest Permutation
  max_size <- Size(max_list) # Largest Size
  if (k > max_size){
    stop(paste('k larger than maximum size: ', max_size, sep=''))
  }
  
  X <- max_list # initializes X at largest permutation
  tempX <- Neighbors(X,k)
  nX <- tempX[[1]] # number of neighbors for X
  neighbors <- tempX[2:(nX + 1)] # all the neighbors of X
  sizes <- c() # initializes vector of sizes
  j <- 0 # initializes index for vector of sizes
  
  for (i in 1:100){
    Y <- neighbors[[runif(1,1,nX + 1)]] # randomly chooses neighbor of X
    tempY <- Neighbors(Y,k)
    nY <- tempY[[1]] # number of neighbors for X
    p <- min(1, nX/nY) # probability of moving from X to Y
    U <- runif(1,0,1)
    if (U < p) {
      X <- Y
      nX <- nY
      neighbors <- tempY[2:(nY + 1)]
    }
    j <- j + 1
    sizes[j] <- Size(X) # records size of current permutation
  }
  par(mfrow=c(1,2))
  plot(sizes[20:j],type="l", main = paste("M = ", M, "and k =", k)) # remove first 20 iterations to unbias stationary dist
  hist(sizes, breaks = 30)
  avg_size <- mean(sizes) # calculates mean size of all big permutations walked through
  cat("The average size is",avg_size)
}

BigListAvg(10,350)

## The average size is 359.21

BigListAvg(50,42000)

## The average size is 42079.5

BigListAvg(100,330000)

## The average size is 330806.4

Random Transposition with Naive Markov Chain Monte Carlo was originally published by Mike Chaykowsky at annotatoR on September 30, 2016.

Untitled

2016-09-25T00:00:00+00:00

I wanted to annotate this out for everyone to read in case you wanted to take a look through it. This is an exploratory analysis of a completely random publicly available dataset found here from Piwowar HA, Vision TJ (2013). I had no prior knowledge of the data’s contents, but developed an understanding through some quick charts. Let’s take a look.

library(dplyr)
library(tidyr)
library(ggplot2)
library(knitr)
library(rgeos)
library(maps)
library(maptools)
library(gridExtra)
library(magrittr)

The first thing we want to know is how the data are delimited so we can decide how to read in the file for analysis. readLine() allows us to take a look at the rawdata which will give insight as to how the data are structured. All of those little \t’s that you see are the tabs. That’s how we know the data are tab delimited.

# Data are tab delimited
lines1 <- readLines("rawdata.txt", warn = FALSE)

head(lines1)

## [1] "pmid\tpubmed_issn\tpubmed_essn\tpubmed_year_published\tpubmed_date_in_pubmed\tpubmed_authors\tpubmed_journal\tpubmed_number_authors\tauthor_first_authors_first_name\tauthor_first_author_female\tauthor_first_author_male\tauthor_first_author_gender_not_found\tfirst_author_num_prev_pubs\tfirst_author_num_prev_pmc_cites\tfirst_author_year_first_pub\tfirst_author_num_prev_microarray_creations\tfirst_author_num_prev_oa\tfirst_author_num_prev_genbank_sharing\tfirst_author_num_prev_pdb_sharing\tfirst_author_num_prev_swissprot_sharing\tfirst_author_num_prev_geoae_sharing\tfirst_author_num_prev_geo_reuse\tfirst_author_num_prev_multi_center\tfirst_author_num_prev_meta_analysis\tauthor_last_author_first_name\tlast_first_author_female\tlast_first_author_male\tlast_first_author_gender_not_found\tlast_author_num_prev_pubs\tlast_author_num_prev_pmc_cites\tlast_author_year_first_pub\tlast_author_num_prev_microarray_creations\tlast_author_num_prev_oa\tlast_author_num_prev_genbank_sharing\tlast_author_num_prev_pdb_sharing\tlast_author_num_prev_swissprot_sharing\tlast_author_num_prev_geoae_sharing\tlast_author_num_prev_geo_reuse\tlast_author_num_prev_multi_center\tlast_author_num_prev_meta_analysis\taddress\tinstitution\tcountry\tgrant_numbers\tnum_grant_numbers\tnih_is_nci\tnih_is_nhlbi\tnih_is_ncrr\tnih_is_niehs\tnih_is_ninds\tnih_is_niddk\tnih_is_nigms\tnih_is_nichd\tnih_is_niaid\tpubmed_medline_status\tpubmed_is_review\tpubmed_is_humans\tpubmed_is_animals\tpubmed_is_mice\tpubmed_is_fungi\tpubmed_is_bacteria\tpubmed_is_plants\tpubmed_is_viruses\tpubmed_is_cultured_cells\tpubmed_is_cancer\tpubmed_is_open_access\tpubmed_is_effectiveness\tpubmed_is_diagnosis\tpubmed_is_prognosis\tpubmed_is_core_clinical_journal\tpubmed_is_clinical_trial\tpubmed_is_randomized_controlled_trial\tpubmed_is_meta_analysis\tpubmed_is_comparative_study\tpubmed_is_multicenter_study\tpubmed_is_validation_study\tpubmed_is_funded_stimulus\tpubmed_is_funded_nih_extramural\tpubmed_is_funded_nih_intramural\tpubmed_is_funded_non_us_govt\tpubmed_in_genbank\tpubmed_in_pdb\tpubmed_in_swissprot\tis_geo_reuse\tpubmed_number_times_cited_in_pmc\tfound_by_highwire\tfound_by_scirus\tfound_by_googlescholar\tportal_pmids_found_by_pmc\tpubmed_in_geo\tin_arrayexpress\tin_ae_or_geo\tcountry_clean\tinstitution_clean\tinstitution_hospital_or_medlcal\tinstitution_rank\tinstitution_sector\tinstitution_output\tinternational_collaboration\tinstitution_norm_sjr\tinstitution_norm_citation_score\tjournal_2008_cites\tjournal_impact_factor\tjournal_5yr_impact_factor\tjournal_immediacy_index\tjournal_num_articles_2008\tjournal_cited_halflife\tjournal_policy_tri\tjournal_policy_requires_microarray_accession\tjournal_policy_says_must_deposit\tjournal_policy_at_least_requests_sharing_microarray\tjournal_policy_mentions_any_sharing\tjournal_policy_general_statement\tjournal_policy_requests_accession\tjournal_policy_mentions_exceptions\tjournal_policy_mentions_consequences\tjournal_policy_contains_word_microarray\tjournal_policy_contains_word_MIAME_MGED\tjournal_policy_contains_word_arrayexpress\tjournal_policy_contains_word_geo_omnibus\tjournal_policy_requests_sharing_other_data\tpmid:1\tnum_grants\tlongest_num_years\tfirst_year\tlast_year\tcumulative_years\tsum_avg_dollars\tsum_sum_dollars\tmax_max_dollars\tnih_institutes\tgrant_activity_codes\thas_R01_funding\thas_T32_funding\thas_P01_funding\thas_R21_funding\thas_P30_funding\thas_P50_funding\thas_U01_funding\thas_R37_funding\thas_K_funding\thas_U_funding\tnum_post2004_morethan500k\tnum_post2003_morethan500k\tnum_post2005_morethan500k\tnum_post2006_morethan500k\tnum_post2007_morethan500k\tnum_post2003_morethan750k\tnum_post2004_morethan750k\tnum_post2005_morethan750k\tnum_post2006_morethan750k\tnum_post2007_morethan750k\tnum_post2003_morethan1000k\tnum_post2004_morethan1000k\tnum_post2005_morethan1000k\tnum_post2006_morethan1000k\tnum_post2007_morethan1000k"
## [2] "19450518\t0092-8674\t1097-4172\t2009\t38508.375\tMu??oz MJ;P??rez Santangelo MS;Paronetto MP;de la Mata M;Pelisch F;Boireau S;Glover-Cutter K;Ben-Dov C;Blaustein M;Lozano JJ;Bird G;Bentley D;Bertrand E;Kornblihtt AR\tCell\t14\tManuel\t0\t0\t0\t15\t146\t1995\t1\t0\t2\t0\t0\t0\t0\t0\t0\tAlberto\t0\t1\t0\t85\t1184\t1992\t1\t0\t10\t0\t0\t0\t0\t0\t0\t\"Laboratorio de Fisiolog??a y Biolog??a Molecular, Departamento de Fisiolog??a, Biolog??a Molecular y Celular, IFIBYNE-CONICET, Facultad de Ciencias Exactas y Naturales, Universidad de Buenos Aires, Ciudad Universitaria, Argentina.\"\tCiudad Universitaria\tArgentina\tGM58613\t1\t0\t0\t0\t0\t0\t0\t1\t0\t0\tindexed for MEDLINE\t0\t1\t0\t0\t0\t0\t0\t0\t1\t1\t0\t0\t1\t0\t0\t0\t0\t0\t0\t0\t0\t0\t1\t0\t1\t0\t0\t0\t0\t1\t0\t1\t1\t0\t0\t0\t0\tArgentina\tCiudad Universitaria\t0\t\t\t\t\t\t\t142064\t31.253\t30.149\t6.126\t348\t8.8\t2\t1\t1\t1\t1\t1\t2\t0\t0\t1\t1\t0\t0\t1\t19450518\t4\t6\t2003\t2008\t24\t2992315\t17953888\t416950\tGM\tR01\t1\t0\t0\t0\t0\t0\t0\t0\t0\t0\t0\t0\t0\t0\t0\t0\t0\t0\t0\t0\t0\t0\t0\t0\t0"                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                       
## [3] "16267287\t0021-9193\t1098-5530\t2005\t37237.375\tAlbanesi D;Mansilla MC;Schujman GE;de Mendoza D\tJ Bacteriol\t4\tDaniela\t1\t0\t0\t12\t60\t2000\t0\t0\t0\t0\t0\t0\t0\t0\t0\tDiego\t0\t1\t0\t63\t459\t1978\t1\t0\t10\t0\t0\t0\t0\t0\t0\t\"Instituto de Biolog??a Molecular y Celular de Rosario (IBR-CONICET) and Departamento de Microbiolog??a, Facultad de Ciencias Bioqu??micas y Farmac??uticas, Universidad Nacional de Rosario, Argentina.\"\tUniversidad Nacional de Rosario\tArgentina\t\t0\t0\t0\t0\t0\t0\t0\t0\t0\t0\tindexed for MEDLINE\t0\t0\t0\t0\t0\t1\t0\t0\t0\t0\t0\t0\t0\t0\t0\t0\t0\t0\t0\t0\t0\t0\t0\t0\t1\t0\t0\t0\t0\t3\t1\t0\t0\t0\t0\t0\t0\tArgentina\tUniversidad Nacional de Rosario\t0\t1314\tHigher educ.\t1234\t46.52\t1.03\t0.86\t58715\t3.636\t3.748\t0.892\t909\t9.6\t2\t1\t1\t1\t1\t0\t2\t0\t2\t1\t0\t1\t1\t1\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t"                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                    
## [4] "17420266\t0022-1007\t1540-9538\t2007\t37786.375\tHorikawa K;Martin SW;Pogue SL;Silver K;Peng K;Takatsu K;Goodnow CC\tJ Exp Med\t7\tKeisuke\t0\t1\t0\t16\t56\t1984\t0\t0\t0\t0\t0\t0\t0\t0\t0\tChristopher\t0\t1\t0\t284\t4578\t1992\t1\t2\t4\t0\t0\t2\t0\t0\t0\t\"Immunogenomics Laboratory, The Australian Phenomics Facility, The John Curtin School of Medical Research, The Australian National University, Canberra 0200, Australia.\"\tThe Australian National University\tAustralia\t\t0\t0\t0\t0\t0\t0\t0\t0\t0\t0\tindexed for MEDLINE\t0\t0\t1\t1\t0\t0\t0\t0\t0\t0\t0\t0\t0\t0\t0\t0\t0\t0\t0\t0\t0\t0\t0\t0\t1\t0\t0\t0\t0\t5\t1\t0\t0\t0\t1\t1\t1\tAustralia\tAustralian National University\t1\t205\tHigher educ.\t9409\t49.98\t1.03\t1.42\t67322\t15.463\t15.504\t3.078\t245\t8.2\t2\t1\t1\t1\t1\t1\t2\t0\t2\t1\t1\t0\t0\t1\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t"                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                         
## [5] "15802471\t0027-8424\t1091-6490\t2005\t37045.375\tSrikhanta YN;Maguire TL;Stacey KJ;Grimmond SM;Jennings MP\tProc Natl Acad Sci U S A\t5\tYogitha\t0\t0\t1\t7\t99\t1998\t0\t0\t3\t0\t0\t0\t0\t0\t0\tMichael\t0\t1\t0\t49\t564\t1992\t0\t0\t20\t0\t0\t0\t0\t0\t0\t\"School of Molecular and Microbial Science and Institute for Molecular Bioscience, University of Queensland, St. Lucia, Brisbane, Queensland 4072, Australia.\"\tUniversity of Queensland\tAustralia\t\t0\t0\t0\t0\t0\t0\t0\t0\t0\t0\tindexed for MEDLINE\t0\t0\t0\t0\t0\t1\t0\t0\t0\t0\t0\t0\t0\t0\t0\t0\t0\t0\t0\t0\t0\t0\t0\t0\t1\t0\t0\t0\t0\t10\t1\t0\t1\t1\t0\t0\t0\tAustralia\tUniversity of Queensland\t0\t\t\t\t\t\t\t416018\t9.38\t10.228\t1.635\t3508\t7.4\t2\t1\t1\t1\t1\t1\t2\t1\t0\t1\t1\t0\t1\t1\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t"                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                   
## [6] "11526234\t0027-8424\t1091-6490\t2001\t35707.41736\tWatts RA;Hunt PW;Hvitved AN;Hargrove MS;Peacock WJ;Dennis ES\tProc Natl Acad Sci U S A\t6\tR\t0\t0\t1\t4\t74\t2001\t0\t0\t1\t0\t0\t0\t0\t0\t0\tE\t0\t0\t1\t82\t1303\t1978\t0\t0\t30\t1\t1\t0\t0\t0\t0\t\"CSIRO Plant Industry, Canberra, ACT 2601, Australia.\"\t\tAustralia\t\t0\t0\t0\t0\t0\t0\t0\t0\t0\t0\tindexed for MEDLINE\t0\t0\t1\t0\t0\t0\t1\t0\t0\t0\t0\t0\t0\t0\t0\t0\t0\t0\t1\t0\t0\t0\t0\t0\t0\t1\t0\t0\t0\t9\t1\t0\t1\t0\t0\t0\t0\tAustralia\t\t0\t\t\t\t\t\t\t416018\t9.38\t10.228\t1.635\t3508\t7.4\t2\t1\t1\t1\t1\t1\t2\t1\t0\t1\t1\t0\t1\t1\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t"

So to read in this file we will use data.table with sep = "\t". This tells R that instead of a typical excel file that is delimited with commas (.csv), we are now delimited with tabs. Some of you may notice the occasional ?? occurring in the data. This is actually in the original dataset and not a product of reading error through R. Future analysis could attempt to remove these inconsistencies before any learning algorithm is implemented. fill = TRUE is necessary here because the data have portions of unequal rows, so read.table fills the remainder of the row to keep constant dimension.

rawdata <- read.table("rawdata.txt", header = TRUE, sep = "\t", 
                      fill = TRUE, quote = "", comment.char = "",row.names = NULL, 
                      stringsAsFactors = FALSE)

dim(rawdata)

## [1] 11603   158

Now we use our trusty str() to take a much closer look at the structured dataset.

# Observe all variables
str(rawdata, list.len=ncol(rawdata))

One good thing to do before looking at multicollinearity or varaible relationships is to break up the data into numerical and character. rawdata[, sapply(rawdata, is.numeric)] takes the dataset and runs over the columns asking if each value is numeric, if it is then we subset those columns of rawdata and assign them to a new object called data_numr.

I also took all of the blank spaces in the character matrix and gave them a value of NA.

# Break up character and numerical
data_numr = rawdata[, sapply(rawdata, is.numeric)]
data_char = rawdata[, sapply(rawdata, is.character)]
data_char[data_char==""] = NA

Now we try to get a sense of how many NA values we are working with. sapply(data\_numr, function(x) sum(is.na(x))) will run through and ask if each value is an NA, and if it is is.na() will give a TRUE, and summing all of those TRUEs gives the number of NA values. Then we just row bind the data into one big data frame and only take the non-zero ones. Setting breaks <- c(50,100,250,500,1000,2000,5000,10000) allows us to define the breaks in the histogram directly later on. If you run table(all\_na) you will see where aes(x = count, fill=type) comes from.

num_na = sapply(data_numr, function(x) sum(is.na(x)))
char_na = sapply(data_char, function(x) sum(is.na(x)))
all_na = rbind(data.frame(count=num_na, type="Numerical"), 
               data.frame(count=char_na, type="Character"))
# table(all_na)
all_na = data.frame(all_na)
all_na = all_na[all_na$count>0,]

breaks <- c(50,100,250,500,1000,2000,5000,10000)

ggplot(all_na, aes(x = count, fill=type)) +  
  geom_histogram(alpha=0.7) + 
  scale_x_log10(limits=c(50,12000), breaks=breaks) + 
  labs(title="Histogram of Feature Count per NA Count", size=24, face="bold") + 
  xlab("NA Count") + ylab("Feature Count")

We can see there are various amounts of missing data throughout the features, so I will take a closer look at a few of them. This is just percent calculation dividing the missing data and the number of rows. !is.na() does the opposite of is.na(), it gives TRUEs for all of the non-NA values. cat() will perform whatever function or operation we are asking, and then follow up the result with some text. So in this case I used it to just calculate the percentage and then followed it by "% data available".

cat((sum(!is.na(rawdata$sum_avg_dollars))/dim(rawdata)[1])*100, "% data available")

## 26.40696 % data available

# journal_immediacy_index - the average number of times an article is cited in the year it is published
cat((sum(!is.na(rawdata$journal_immediacy_index))/dim(rawdata)[1])*100, "% data available")

## 91.37292 % data available

cat((sum(!is.na(rawdata$found_by_googlescholar))/dim(rawdata)[1])*100, "% data available")

## 100 % data available

From looking at our data earlier, we saw that two variables had country names in them. Upon closer inspection, one of them is called country_clean which is a cleaned up version of the original country column. This is great for us because it saves us work in cleaning the country names. So we want to see the distribution of these names in a heat map across the world map. For this we will begin with the map() function, or as I like to call it, Dora’s function.

The map() function has a number of databases, one of which is entitled world, which gives us a clear look at the world map, delineated by countries. If we take a look within our mapWORLD there’s a variable called $names. Some of the elements in $names contain a :. We will break each of these character strings at the colon and only select the first character string after the split for our new variable nms. (e.g. if I have Sweden:Oland, strsplit() will break the string into two strings by splitting it at the : and dividing it in two. Then we only select the first element of this division, which is the piece we actually want).

Now we need to convert things from ‘Dora’s function’ map() to something that our sp package can use. That’s where map2SpatialPolygons() comes in. (This code is straight out of “Applied Spatial Data Analysis with R” Bivand et al, in case you are interested) We pass this function our map() output, our IDs, and then specify the proj4string argument as CRS('+proj=longlat'). CRS stands for ‘coordinate reference system’ and +proj=longlat is accepted for geographical coordinates, which essentially means we have a vector of a bunch of latitudes and longitudes. We will see soon why we needed to create this variable.

Now we make the function that actually draws the heat map on the world map. mapCountries accepts a data frame and a feature from that dataframe to construct the heat map. We already know what we want to pass this function (our data frame of character features and the variable with country names). dat becomes our data frame, which we create from the column in df that is the feature passed into the function. The interesting part to this line of code is the use of table(). table() orders all of the factor levels and then gives the count that they occur. names() gives us the character strings of our variable names, if we pass the names of our data frame the two values country (string of 50 state abbreviations) and value, we are forcing the variable names to be these values and therefore we have an ordered set of country names and then value as the number of occurences.

Now we create a vector of the positions where country names in dat$country and in nms align, this is saved as idx. We now create a data frame dat2 that contains all of the unique country names that occur in nms and then the number of times that name occurs in the entire variable column from our train_char. All data frames have row names, but they kind of go unnoticed. Here we utilize them and give them the names of the countries that occur in nms. Now we have perfect country names and counts.

Remember a long time ago when we made the WORLDpolygons object that included that mess created by map2SpatialPolygons()? Well now we get to use that mess with the SpatialPolygonsDataFrame() function. This is the final formatting needed to pass through spatial data for plotting. Finally, our function will use the spplot() function from the sp package to plot the heat maps. Then we just call this function on our train_char and the two features of interest.

mapWORLD <- map('world', fill=TRUE, plot=FALSE)
nms <- sapply(strsplit(mapWORLD$names,  ':'),  function(x)x[1])
WORLDpolygons <- map2SpatialPolygons(mapWORLD,  IDs = nms,  CRS('+proj=longlat'))

mapCountries = function(df, feat){
  dat = data.frame(table(df[,feat]))
  names(dat) = c("country", "value")
  
  idx <- match(unique(nms),  dat$country)
  dat2 <- data.frame(value = dat$value[idx], country = unique(nms))
  row.names(dat2) <- unique(nms) 
  WORLDsp <- SpatialPolygonsDataFrame(WORLDpolygons,  data = dat2)
  spplot(WORLDsp['value'], main=paste(feat, "frequency"), col.regions=rev(heat.colors(21)))
}
mapCountries(data_char, "country_clean")

Here I wanted to take a look at the authors’ previous publications count. I thought this could be interesting if we could later relate this back to how much funding their project received. mutate() creates a new variable in our dataframe, and here I defined it to be the sum of the first author’s prev_pubs and the last author’s.

rawdata <- rawdata %>% mutate(prev_pubs = first_author_num_prev_pubs + last_author_num_prev_pubs)
pub_count <- data.frame(rawdata$prev_pubs, rawdata$found_by_googlescholar)
pub_count$rawdata.found_by_googlescholar <- as.factor(pub_count$rawdata.found_by_googlescholar)

Now I just create a histogram in ggplot() using the value calculated with the pub_count. There’s a fairly large range in the distribution of authors’ previous publication count.

ggplot(pub_count, aes(x = rawdata.prev_pubs, fill = rawdata.found_by_googlescholar)) +  
  geom_histogram() + 
  stat_bin(binwidth = 100) +
  scale_fill_discrete(name = "Shown in\nGoogle Scholar\nSearch") + 
  labs(title="Histogram of Authors' Previous Publications", size=24, face="bold") + 
  xlab("Number of Publications for First and Last Author") + ylab("Frequency")

Here I wanted to take a look at the funding, naturally we must follow the money. Specifically I wanted to create a histogram that showed how much funding each project was receiving while breaking each project up according to the type of funding they were receiving.

If you know that you want to select() multiple columns in a row, we may use a : to indicate the first column through the last column, i.e. has _R01_funding:has_U_funding. You use mutate_each_ with the extra underscore if you want to supply what I wrote as cols as a string/variable. factor(.) forces all of the columns to be factor variables. Typically in R we indicate all columns in a matrix with .

data_fund <- rawdata %>% select(sum_avg_dollars, has_R01_funding:has_U_funding)
cols <- c("has_R01_funding", "has_T32_funding", "has_P01_funding", 
          "has_R21_funding", "has_P30_funding", "has_P50_funding", 
          "has_U01_funding", "has_R37_funding", "has_K_funding", 
          "has_U_funding")
data_fund <- data_fund %>% mutate_each_(funs(factor(.)),cols)
str(data_fund)

## 'data.frame':	11603 obs. of  11 variables:
##  $ sum_avg_dollars: int  2992315 NA NA NA NA NA NA NA NA NA ...
##  $ has_R01_funding: Factor w/ 2 levels "0","1": 2 NA NA NA NA NA NA NA NA NA ...
##  $ has_T32_funding: Factor w/ 2 levels "0","1": 1 NA NA NA NA NA NA NA NA NA ...
##  $ has_P01_funding: Factor w/ 2 levels "0","1": 1 NA NA NA NA NA NA NA NA NA ...
##  $ has_R21_funding: Factor w/ 2 levels "0","1": 1 NA NA NA NA NA NA NA NA NA ...
##  $ has_P30_funding: Factor w/ 2 levels "0","1": 1 NA NA NA NA NA NA NA NA NA ...
##  $ has_P50_funding: Factor w/ 2 levels "0","1": 1 NA NA NA NA NA NA NA NA NA ...
##  $ has_U01_funding: Factor w/ 2 levels "0","1": 1 NA NA NA NA NA NA NA NA NA ...
##  $ has_R37_funding: Factor w/ 2 levels "0","1": 1 NA NA NA NA NA NA NA NA NA ...
##  $ has_K_funding  : Factor w/ 1 level "0": 1 NA NA NA NA NA NA NA NA NA ...
##  $ has_U_funding  : Factor w/ 1 level "0": 1 NA NA NA NA NA NA NA NA NA ...

Each funding variable is a 1 if it is that type of funding or a 0 if it’s not. So What we want is one column that has a factor level for each of the types of funding, arranged by the dollars funded. data_fund %>% gather(funding, yes, -sum_avg_dollars) we pipe in data_fund dataframe using our piping operator %>%, and then we use gather() which puts all of the columns selected into rows with new variables funding (the key) and yes which is whether or not the study had that funding type. Then we filter() for only the rows with a yes value of 1, which means they had that funding type and then arrange() each by the amount of funding.

data_fund <- data_fund %>% gather(funding, yes, -sum_avg_dollars) %>% 
  filter(yes == 1) %>% select(-yes) %>% arrange(sum_avg_dollars)
data_fund$funding <- as.factor(data_fund$funding)

Now we plot this with a ggplot() histogram.

ggplot(data_fund, aes(x = sum_avg_dollars, fill=funding)) +  
  geom_histogram(alpha=0.7) + 
  scale_x_log10(limits=c(100000,1500000000)) + 
  labs(title="Histogram of Funding Arranged by Type", size=24, face="bold") + 
  xlab("Funding") + ylab("Frequency")

Outside googling led me to find that the reward names refer to: Program and Cooperative Awards (P01, P20, P50, U01), Individual Research Awards (R01, R21, and R37), and Institutional Award (T32).

Now that I have procrastinated my actual homework enough I think it’s time to get back to it. Feel free to add some analysis and send it to me. I’m always intrigued.

Untitled was originally published by Mike Chaykowsky at annotatoR on September 25, 2016.

Hidden Markov Model Simulation

2016-07-12T00:00:00+00:00

HMM Simulation

Without having formally worked in Hidden Markov Models before, this is my attempt at reinterpreting a well known solution in the computational biology domain. I read an article in Nature magazine by Sean R Eddy, which will serve as a perfect problem for me to attempt an HMM simulation akin to the Eddy example. I encourage you to brief yourself on the article before continuing here. Don’t worry, it’s very short.

We simulate a string of length 26 (as in the Eddy study) and determine the probability of that string given the structure while inferring the hidden state path. The model is probably looking for an even number of A,C,G,T for the beginning and once there’s too many G’s it marks it as a “5SS”. This is because the “5SS” state has very high probability in G and “exon” has even probability throughout. That is why we see the change from green to red occur on a G observation (seen below).

require(HMM)
 nSim = 26
 States = c("S","exon", "5SS", "intron", "N")
 Symbols = LETTERS[c(1,3,7,20)]
 transitions = matrix(c(0,1, 0, 0, 0, 0, 0.9, 0.1, 0, 0,0,0,0,1,0,0,0,0,0.9,0.1,0,0,0,0,1), c(length(States), length(States)), byrow = TRUE)
 row0 <- c(0,0,0,0)
 row1 <- c(1/4, 1/4, 1/4, 1/4)
 row2 <- c(0.05, 0, 0.95, 0)
 row3 <- c(0.4,0.1,0.1,0.4)
 row4 <- c(0,0,0,0)
 set.seed(513)
 emissions = matrix(c(row0,row1,row2,row3,row4), nrow=5, ncol=4, byrow = TRUE)
 hmm = initHMM(States, Symbols, transProbs = transitions, emissionProbs = emissions)
 sim = simHMM(hmm, 26)
 vit = viterbi(hmm, sim$observation)
 f = forward(hmm, sim$observation)
 b = backward(hmm, sim$observation)
 i <- f[2, nSim]
 j <- f[3, nSim]
 probObservations = (i + log(1 + exp(j - i)))
 posterior = exp((f + b) - probObservations)
 x = list(hmm = hmm, sim = sim, vit = vit, posterior = posterior)
 
plot(as.numeric(factor(x$sim$observation)), ylim = c(-7.5, 6), pch=3, ylab = ylb, xlab = "", bty = "n", xaxt = "n", yaxt = "n"); axis(1, at=seq_along(x$sim$observation), labels=x$sim$observation)
axis(2, at = 1:4)

# Simulating (truth) #
 text(0.3, -1.2, adj = 0, cex = 0.8, col = "black", "True state path")
 for (i in 1:nSim) {
    if (x$sim$states[i] == "exon")
        rect(i, -1, i + 1, 0, col = "green", border = NA)
   else if (x$sim$states[i] == "5SS")
     rect(i, -1, i + 1, 0, col = "white")
    else rect(i, -1, i + 1, 0, col = "red", border = NA)
   }
# Inference and Viterbi algorithm: finding the most probable path #
text(0.3, -3.2, adj = 0, cex = 0.8, col = "black", "Viterbi's most probable path")
for (i in 1:nSim) {
    if (x$vit[i] == "exon")
        rect(i, -3, i + 1, -2, col = "green", border = NA)
  else if (x$sim$states[i] == "5SS")
    rect(i, -1, i + 1, 0, col = "white")
    else rect(i, -3, i + 1, -2, col = "red", border = NA)
}
# Differences:
text(0.3, -5.2, adj = 0, cex = 0.8, col = "black", "Difference")
differing = !(x$sim$states == x$vit)
for (i in 1:nSim) {
    if (differing[i])
        rect(i, -5, i + 1, -4, col = rgb(0.3, 0.3, 0.3),
            border = NA)
    else rect(i, -5, i + 1, -4, col = rgb(0.9, 0.9, 0.9),
        border = NA)
       }
 
 points(x$posterior[2, ] - 3, type = "l")
 # Difference with classification by posterior-probability:
 text(0.3, -7.2, adj = 0, cex = 0.8, col = "black", "Difference by posterior-probability")
 differing = !(x$sim$states == x$vit)
 for (i in 1:nSim) {
    if (posterior[2, i] > 0.5) {
        if (x$sim$states[i] == "exon")
            rect(i, -7, i + 1, -6, col = rgb(0.9, 0.9, 0.9),
              border = NA)
        else rect(i, -7, i + 1, -6, col = rgb(0.3, 0.3, 0.3),
            border = NA)
     }
     else {
         if (x$sim$states[i] == "intron")
             rect(i, -7, i + 1, -6, col = rgb(0.9, 0.9, 0.9),
               border = NA)
         else rect(i, -7, i + 1, -6, col = rgb(0.3, 0.3, 0.3),
            border = NA)
      }
    }

This code generates the same type of model as the Eddy article. The top portion indicates the 26 simulated observation sequence. The true state path is green when the state is “exon” and white when it becomes “5SS” and then red once it becomes “intron”. I guess Viterbi can’t pick up on the subtlety of the extra G that creates the “5SS” state, the algorithm believes we remained in “exon” for the entirety. The viterbi moving average line does seem to indicate a possibly change in state towards the end of the sequence, but it was not represented in the final output. We then observe the difference and the difference by posterior probability between Viterbi and the true state path. The difference is like a density of false positives and represents the errors in the model. The posterior difference uses forward - backward algorithm which is a Bayesian technique, which is why we call it the posterior difference.

With so few states and observations we could probably just enumerate all possible state sequences and find the one with the highest probability, but this is not scalable. We could also consider a more unsupervised approach to learning the parameters. We could use an iterative process like EM algorithm to find the MLE.

A Look at the Evaluation and Decoding Algorithms

Let’s suppose we have an HMM structure like model with N observations $(y = y_1:N)$, but there is a way we know the value of the hidden states $(x)$ in the chain as well as the observables. In this case we could easily calculate the likelihood

\[p(x,y) = p(x_1)\prod_{k=1}^{N-1} p(x_{k+1}|x_k)\prod_{k=1}^{N} p(y_k|x_k)\]

If we do not observe the hidden states, then,

\[p(y) = \sum_{y_1} ... \sum_{y_N} p(x_1)\prod_{k=1}^{N-1}p(x_{k+1}|x_k)\prod_{k=1}^{N} p(y_k|x_k)\]

Because we have structure we can exploit this with a dynamic programming algorithm for calculating the likelihood.

For evaluation, forward algorithm is used to calculate what the probability is of the observed sequence. The algorithm computes the probability, $p(x_k, y_{1:k})$. Using the Markov property, i.e. the conditional probability distribution of future states of the process depends only upon the present state, not on the sequence of events that preceded it, we can see that $p(x_k, y_{1:k}) = \sum_{x_{k-1}}p(x_k,x_{k-1},y_{1:k})$ when summing over all possibly values of $x_{k-1}$. This leads us to $\sum_{x_{k-1}}p(y_k|x_k,x_{k-1},y_{1:k-1})p(x_k|x_{k-1},y_{1:k-1})p(x_{k-1}|y_{1:k-1})p(y_{1:k-1})$, where $p(x_{k-1}|y_{1:k-1})p(y_{1:k-1})=p(x_{k-1},y_{1:k-1})$.

Now independence can be applied to the first term in the summation $p(y_k|x_k,x_{k-1},y_{1:k-1})$ since we can just say this equates to $p(y_k|x_k)$, and the second term $p(x_k|x_{k-1},y_{1:k-1})$ can be simplified to $p(x_k|x_{k-1})$.
Which leaves us with $p(x_k, y_{1:k}) = \sum_{x_{k-1}}p(y_k|x_k)p(x_k|x_{k-1})p(x_{k-1},y_{1:k-1}) = \alpha_k(x_k)$.

As we just saw, forward algorithm computes the probability $p(x_k,y_{1:k})$.
Backward algorithm instead computes the joint distributions of $p(y_{k+1:n}|x_k)$. Backward works recursively. While the methods are different, Forward and the Backward algorithm can be used to determine the probability of a sequence.

Viterbi algorithm deals with the decoding problem (given a sequence and a model, what is the most likely sequence of states that produced the sequence), while forward algorithm deals with the evaluation problem (what is the probability that a particular sequence is produced by a particular model).

Posterior decoding makes use of the forward and backward algorithms. The goal is to determine the path through the hidden markov model that corresponds to true labeling of the data. Instead of determining the most probable path (as in Viterbi), posterior decoding determines, independently, for every symbol $O_t$ the most probable state using,

\[\hat{\pi}_i = argmax_k P(\pi_i = k, X)\]

This method is based on the posterior probability of emitting $X$ from state $k$ when the emitted sequence is known. This is why it is called posterior decoding.

\[P(\pi_i = k,X) = P(x_1, x_2, ..., x_i, \pi_i = k) \cdot P(x_{i+1}, x_{i+2}, ..., x_N|\pi_i = k)\]

this is saying that the probability of being in state $k$ when $X$ is emitted, is equivalent to the emitting $x_1…x_{i-1}$ over any path, entering $k$, emitting $x_i$, and then emitting $x_{i+1}, x_{i+2}, …, x_N$ over any path. The first term is just $\alpha_i(k)$ and we calculate the second term with the backward algorithm, which is also used to calculate $P(x)$.

The difference between Viterbi and posterior decoding is that in position $i$, the Viterbi algorithm calculates,

\[\pi_i^* = i\text{-th position of } argmax_{\pi} P(X,\pi)\]

However, there is not one statement that says one is better than the other. Much of this depends on how likely the Viterbi optimal path is. If the optimal path is only marginally better than alternatives, posterior decoding may be the better choice. Posterior decoding is better in instances when you want to take into account all possible paths.

Learning in Graphical Models

The Expectation and Maximization (EM) algorithm is an efficient iterative procedure to compute the Maximum Likelihood Estimate (MLE) or in some cases a Maximum A-Posteriori estimate (MAP) in the case we have missing data. In an HMM, hidden variables are considered missing. So EM is used here for parameter estimation.

To handle the missing data, we kind of pretend that we have data and structure to calculate the maximum likelihood estimators for the $x$’s. Given a random vector $y = {y_1, y_2, …, y_n}$ of observed variables we also have some $x = {x_1, x_2, …, x_n}$ that we don’t know. So we have $y$ and $x$ and we calculate the density given the parameters and the distribution and parameters are associated to the concatenation of the observables and the non-observed. The first thing we try to do is estimate the non-observed. This is the E-algorithm and gives us the $\hat{x}_i$’s.

So the $(y,x)$ has a joint distribution whose density is indexed by an n-dimensional parameter $\theta$. We want to compute the MLE of $\theta$ based on $y$. And the parameters will be estimated from the $y$’s and the structure.

\[\theta^* = \theta_{MLE} \in argmax_{\theta} p(y;\theta)\]

So we want to maximize the log-likelihood funtion of $y$,

\[log L(\theta;y) = l(\theta;y) = log p(y;\theta)\]

But we can only compute the log-likelihood of the observed data and then we use this to iteratively maximize the log-likelihood of the hidden portion,

\[l_{obs}(\theta;y_{obs}) = l(\theta;y) - log p(x|y;\theta)\]

To iteratively maximize the log-likelihood of the hidden portion,

\[l(\theta;y) = E_{\theta} [l(\theta;y)|y_{obs}]\]

wher $y$ is the $y_{obs}$ and the $x$’s.

So we are using the observables to estimate the unobserved.

In the expectation, the E-step, the missing data are estimated given the observed data and current estimate of the model parameters. In the M-step we assume that we know the missing data.

Hidden Markov Model Simulation was originally published by Mike Chaykowsky at annotatoR on July 12, 2016.

Forest Fires [Update]

2016-05-15T00:00:00+00:00

library(dplyr)
library(ggplot2)
library(leaps)
library(knitr)
library(caret)
library(corrplot)
library(gmodels)
library(mosaic)
library(multcomp)
library(DescTools)
library(glmnet)

This data considers forest fire data from the Montesinho natural park in the Tr’as-os-Montes northeast region of Portugal. The data used in the experiments was collected from January 2000 to December 2003. The goal is to learn more about the variables involved with predicting forest fires and possibly classify new fires as big or small based on simple atmospheric indicators.

Recall the following variable descriptions,

X - x-axis spatial coordinate within the Montesinho park map: 1 to 9
Y - y-axis spatial coordinate within the Montesinho park map: 2 to 9
month - month of the year: “jan” to “dec”
day - day of the week: “mon” to “sun”
FFMC - Fine Fuel Moisture Code (FFMC) index from the Fire Weather Index (FWI) system: 18.7 to 96.20
DMC - Duff Moisture Code (DMC) index from the FWI system: 1.1 to 291.3
DC - Drought Code (DC) index from the FWI system: 7.9 to 860.6
ISI - Initial Spread Index (ISI) from the FWI system: 0.0 to 56.10
temp - temperature in Celsius degrees: 2.2 to 33.30
RH - relative humidity in %: 15.0 to 100
wind - wind speed in km/h: 0.40 to 9.40
rain2 - outside rain in mm/m2 : 0.0 to 6.4
area - the burned area of the forest (in ha): 0.00 to 1090.84

ff <- read.csv("forestfires.csv")
ff2 <- ff %>% mutate(rain2 = as.factor(rain > 0), logarea = log(area + 1), X = as.factor(X), Y = as.factor(Y)) %>% dplyr::select(-c(rain, area))
dim(ff2)
str(ff2)

We can see that our initial dataset contains 13 variables with 517 observations.

Also recall from the simple linear regression report that we will be using the log transform of area burnt (in hectares), and we will be using rain as a factor variable (i.e. whether or not it is raining at the time of the fire).

One-Way ANOVA

In the linear model, we found that there was sufficient reason to include 4 factor levels from the ‘month’ variable. These were, December, June, March, and September. But I wonder if the difference in the means between these factor levels is simply due to chance, or is there a true difference between the population means. We will now use ANOVA to test if there is a difference between the factor level means.

We want to test the hypothesis,

\[H_0: \mu_1 = \mu_2 = \mu_3 = \mu_4\] \[H_1: not H_0\]

To test this hypothesis we will look at a graph of individual fires and their log area burnt for the months in question. We also can look at a table of the means for each month and finally an ANOVA table.

month_1 <- factor(ff2$month, levels = c('dec', 'jun', 'mar', 'sep'))
xyplot(logarea ~ month_1, data = ff2, pch=19, xlab="month", ylab="log(area burnt)")

means <- aggregate(logarea ~ month_1, data = ff2, FUN=mean)
means

##   month_1   logarea
## 1     dec 2.5716700
## 2     jun 0.8430907
## 3     mar 0.7725645
## 4     sep 1.2745374

month.aov <- aov(logarea ~ month_1, data = ff2)
anova(month.aov)

## Analysis of Variance Table
## 
## Response: logarea
##            Df Sum Sq Mean Sq F value   Pr(>F)   
## month_1     3  29.86  9.9524  5.0762 0.001987 **
## Residuals 248 486.23  1.9606                    
## ---
## Signif. codes:  0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1

#qf(.95, 3, 248)

At the $\alpha = 0.05$ level of significance, there is sufficient reason to reject $H_0$ since our F statistic is greater than 2.641. Also, in the ANOVA table there is a p-value of 0.002, which leads us to believe there is a difference between these months, on average.

But what we have reject here is that all of the means are equal. It is possible that only one mean is different than the rest. Let’s look at a boxplot to get a better sense of the distributions.

boxplot(logarea ~ month_1, data = ff2, ylab = "log(area burnt)")

So based on this boxplot, it is likely that one month is the cause of the difference in means. But we are not certain yet. We want to check pairwise comparisons for this purpose.

TukeyHSD(month.aov)

##   Tukey multiple comparisons of means
##     95% family-wise confidence level
## 
## Fit: aov(formula = logarea ~ month_1, data = ff2)
## 
## $month_1
##                diff         lwr         upr     p adj
## jun-dec -1.72857927 -3.22155566 -0.23560288 0.0159040
## mar-dec -1.79910546 -3.10306502 -0.49514590 0.0024178
## sep-dec -1.29713261 -2.53554643 -0.05871879 0.0360751
## mar-jun -0.07052619 -1.07773570  0.93668331 0.9978862
## sep-jun  0.43144666 -0.48932979  1.35222310 0.6198340
## sep-mar  0.50197285 -0.06297076  1.06691646 0.1011988

R does most of the leg work here adjusting the p-values for multiple comparisons. So we can see that all of the significant differences between pairwise comparisons involve the month of December.

Let’s now perform a nested F-test to compare June, March, and September to December.

We want to test the hypothesis,

\[H_0: \mu_1 = \frac{\mu_2 + \mu_3 + \mu_4}{3}\] \[H_1: not H_0\]

ff3 <- ff2
levels(ff3$month) <- c("apr", "aug", "dec", "feb", "jan", "jul", "group", "group", "may", "nov", "oct", "group")
means2 <- aggregate(logarea ~ factor(month, levels = c("dec", "group")), data = ff3, FUN=mean)
means2

##   factor(month, levels = c("dec", "group"))  logarea
## 1                                       dec 2.571670
## 2                                     group 1.132804

month.aov2 <- aov(logarea ~ factor(month, levels = c("dec", "group")), data = ff3)
anova(month.aov2)

## Analysis of Variance Table
## 
## Response: logarea
##                                            Df Sum Sq Mean Sq F value
## factor(month, levels = c("dec", "group"))   1  17.97 17.9675  9.0177
## Residuals                                 250 498.12  1.9925        
##                                             Pr(>F)   
## factor(month, levels = c("dec", "group")) 0.002945 **
## Residuals                                            
## ---
## Signif. codes:  0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1

The ANOVA table shows that the nested F-test rejects $H_0$ and suggests that there is a difference between the grouped months on average compared with December. So now we want to know, does December have an affect on log(area burnt)? To figure this out we will utilize linear contrasts.

lm1 = lm(logarea ~ month_1, data = ff2); coef(lm1)

## (Intercept)  month_1jun  month_1mar  month_1sep 
##    2.571670   -1.728579   -1.799105   -1.297133

december = rbind('December' = c(-1, 1/3, 1/3, 1/3))
september = rbind('September' = c(1/3, 1/3, 1/3, -1))
cntrsts = rbind('December' = c(-1, 1/3, 1/3, 1/3), 
                 'September' = c(1/3, 1/3, 1/3, -1))
summary(glht(month.aov, linfct=mcp(month_1=cntrsts), 
             alternative="greater"), test=adjusted("none"))

## 
## 	 Simultaneous Tests for General Linear Hypotheses
## 
## Multiple Comparisons of Means: User-defined Contrasts
## 
## 
## Fit: aov(formula = logarea ~ month_1, data = ff2)
## 
## Linear Hypotheses:
##                Estimate Std. Error t value Pr(>t)
## December <= 0   -1.6083     0.4858  -3.311  0.999
## September <= 0   0.1212     0.2290   0.529  0.299
## (Adjusted p values reported -- none method)

ScheffeTest(month.aov, which="month_1", contrasts=t(cntrsts))

## 
##   Posthoc multiple comparisons of means : Scheffe Test 
##     95% family-wise confidence level
## 
## $month_1
##                       diff     lwr.ci     upr.ci   pval    
## jun,mar,sep-dec -1.6082724 -2.9755691 -0.2409758 0.0132 *  
## dec,jun,mar-sep  0.1212377 -0.5234158  0.7658912 0.9636    
## 
## ---
## Signif. codes:  0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1

We can be 95% confident that the population mean averaged from the factor level December is $e^{-2.976}$ to $e^{-0.241}$ lower than that of the other months.

We can be 95% confident that the population mean averaged from the factor level September is $e^{-0.523}$ to $e^{0.766}$ greater than that of the other months.

The Scheffe multiple comparisons procedure was employed here as we looked at the treatment means $\mu_{i.}$ in the linear contrasts.

I’m also interested to see if there is a significant difference between the mean areas burnt of the days of the week.

We want to test the hypothesis,

\[H_0: \mu_1 = \mu_2 = \mu_3 = \mu_4 = \mu_5 = \mu_6 = \mu_7\] \[H_1: not H_0\]

Again, to test this hypothesis we will look at a graph of individual fires and their log area burnt for the days in question. We will also look at a table of the means for each day and the ANOVA table.

xyplot(logarea ~ day, data = ff2, pch=19, xlab="day", ylab="log(area burnt)")

aggregate(logarea ~ day, data = ff2, FUN=mean)

##   day   logarea
## 1 fri 0.9697708
## 2 mon 1.0899676
## 3 sat 1.2263961
## 4 sun 1.1240928
## 5 thu 1.0262667
## 6 tue 1.2307187
## 7 wed 1.1136639

anova(aov(logarea ~ day, data = ff2))

## Analysis of Variance Table
## 
## Response: logarea
##            Df  Sum Sq Mean Sq F value Pr(>F)
## day         6    4.22  0.7031  0.3568 0.9059
## Residuals 510 1004.88  1.9704

#qf(.95, 6, 510)

Our F-statistic is not greater than the corresponding F-value at an $\alpha = 0.05$ level of significance, so there is not sufficient reason to reject the idea that there is a difference between the days of the week, on average.

Two-Way ANOVA

We can look at the additivity and interaction between two factor variables, month and vertical position (Y).

par(mfrow=c(1,3))
plot(logarea ~ month + Y, data = ff2)
with(ff2, interaction.plot(month, Y, logarea))

This shows slight evidence of nonadditivity and could be more than simple natrual variation. However, we will test the significance of the interaction to be sure,

monthday.aov <- aov(logarea ~ month*Y, data = ff2)
anova(monthday.aov)

## Analysis of Variance Table
## 
## Response: logarea
##            Df Sum Sq Mean Sq F value  Pr(>F)  
## month      11  37.37  3.3970  1.7887 0.05334 .
## Y           6  25.24  4.2073  2.2154 0.04052 *
## month:Y    30  55.81  1.8604  0.9796 0.49948  
## Residuals 469 890.68  1.8991                  
## ---
## Signif. codes:  0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1

plot(monthday.aov$fitted, rstudent(monthday.aov), xlab="Fitted Raw", ylab="Student Residuals", pch=19)

The ANOVA table indicated that the interaction term is not significant so we will only look at additive effects.

monthday2.aov <- aov(logarea ~ month + Y, data = ff2)
anova(monthday2.aov)

## Analysis of Variance Table
## 
## Response: logarea
##            Df Sum Sq Mean Sq F value  Pr(>F)  
## month      11  37.37  3.3970  1.7909 0.05277 .
## Y           6  25.24  4.2073  2.2181 0.04016 *
## Residuals 499 946.49  1.8968                  
## ---
## Signif. codes:  0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1

The data certainly seem more consistent with the additive model.

ff2$resid = predict(aov(logarea ~ month + Y, data = ff2))
par(mfrow=c(1,2))
plot(aov(logarea ~ month + Y, data = ff2), which=1)
plot(aov(logarea ~ month + Y, data = ff2), which=4)

histogram(~ resid, type='density', density=TRUE, data=ff2)

These figures indicate that the normality and linearity assumptions seems to be a problem. The equality of variance assumption seems to be broken as well, yielding a fatal error for my machine. The cook’s distance plot shows some very influential outliers with the additive model. Here they are below,

ff2[c(305, 470, 472),]

##     X Y month day FFMC  DMC    DC  ISI temp RH wind rain2  logarea
## 305 6 5   may sat 85.1 28.0 113.8  3.5 11.3 94  4.9 FALSE 0.000000
## 470 6 3   apr sun 91.0 14.6  25.6 12.3 13.7 33  9.4 FALSE 4.129229
## 472 4 3   may fri 89.6 25.4  73.7  5.7 18.0 40  4.0 FALSE 3.675794
##        resid
## 305 1.818040
## 470 1.137743
## 472 1.857754

Logistic Regression

The biggest problem throughout this study has been the problem of censored data. The researchers decided that if a fire was less than 0.1 hectares in area burnt, they would mark this down as a fire, but with area equal to zero. Now I will attempt to erase this difficulty in skewed response by changing the problem slightly to a classification problem. Now I will attempt to predict whether the fire is a ‘big’ fire. Big fires will be denoted by the log(area burnt) > 3.

For feature selection we will use a lasso with cross-validation.

ffclass <- ff2 %>% mutate(bigfire = logarea > 3) %>% dplyr::select(-logarea)
ffclass$bigfire <- as.factor(ffclass$bigfire)

X <- ffclass$X; X <- as.factor(X)
Y <- ffclass$Y; Y <- as.factor(Y)
month <- ffclass$month; month <- as.factor(month)
day <- ffclass$day; day <- as.factor(day)
FFMC <- ffclass$FFMC
DMC <- ffclass$DMC
DC <- ffclass$DC
ISI <- ffclass$ISI
temp <- ffclass$temp
RH <- ffclass$RH
wind <- ffclass$wind
rain2 <- ffclass$rain2; rain2 <- as.factor(rain2)
bigfire <- ffclass$bigfire

xfactors <- model.matrix(bigfire ~ X + Y + month + day + rain2)[,-1]
x <- as.matrix(data.frame(FFMC, DMC, DC, ISI, temp, RH, wind, xfactors))

glmmod <- glmnet(x, y=as.factor(bigfire), alpha=1, family='binomial')
plot(glmmod,xvar="lambda")
grid()

coef(glmmod)[,10]

##  (Intercept)         FFMC          DMC           DC          ISI 
## -2.137685872  0.000000000  0.000000000  0.000000000  0.000000000 
##         temp           RH         wind           X2           X3 
##  0.000000000 -0.001484071  0.033531851 -0.069033251 -0.375203944 
##           X4           X5           X6           X7           X8 
##  0.063193725 -0.205011497  0.000000000  0.000000000  0.000000000 
##           X9           Y3           Y4           Y5           Y6 
##  0.146788302  0.012437035  0.000000000  0.000000000  0.000000000 
##           Y8           Y9     monthaug     monthdec     monthfeb 
##  2.518580684  0.000000000  0.000000000  0.000000000  0.000000000 
##     monthjan     monthjul     monthjun     monthmar     monthmay 
##  0.000000000  0.000000000  0.000000000  0.000000000  0.838989996 
##     monthnov     monthoct     monthsep       daymon       daysat 
##  0.000000000  0.000000000  0.200451646  0.000000000  0.000000000 
##       daysun       daythu       daytue       daywed    rain2TRUE 
##  0.000000000 -0.063985812  0.000000000  0.000000000  0.000000000

cv.glmmod <- cv.glmnet(x, y=bigfire, alpha=1, family='binomial')
plot(cv.glmmod)

best_lambda <- cv.glmmod$lambda.min
cat("The best lambda value using cross validation is", best_lambda)

## The best lambda value using cross validation is 0.03891355

So cross validated lasso tells us that the optimal lambda value is the one that corresponds to the model with only the intercept term. So this is not very helpful. But I will instead use the variables with non-zero coefficients from the glmnet lasso.

set.seed(511)
glm.fit <- glm(bigfire ~ RH + wind + I(X=='2') + I(X=='3') + I(X=='4') + I(X=='5') + I(X=='9') + I(Y=='3') + I(month=='dec') + I(month=='may') + I(month=='sep') + I(day=='thu'), data = ffclass, family = binomial)
summary(glm.fit)

## 
## Call:
## glm(formula = bigfire ~ RH + wind + I(X == "2") + I(X == "3") + 
##     I(X == "4") + I(X == "5") + I(X == "9") + I(Y == "3") + I(month == 
##     "dec") + I(month == "may") + I(month == "sep") + I(day == 
##     "thu"), family = binomial, data = ffclass)
## 
## Deviance Residuals: 
##     Min       1Q   Median       3Q      Max  
## -0.9678  -0.5519  -0.4227  -0.2773   2.6343  
## 
## Coefficients:
##                        Estimate Std. Error z value Pr(>|z|)    
## (Intercept)           -2.054593   0.582963  -3.524 0.000424 ***
## RH                    -0.016172   0.009476  -1.707 0.087882 .  
## wind                   0.165166   0.084576   1.953 0.050835 .  
## I(X == "2")TRUE       -0.700534   0.509485  -1.375 0.169136    
## I(X == "3")TRUE       -1.476478   0.751438  -1.965 0.049429 *  
## I(X == "4")TRUE        0.150352   0.354701   0.424 0.671650    
## I(X == "5")TRUE       -1.563292   1.040311  -1.503 0.132912    
## I(X == "9")TRUE        1.026058   0.717094   1.431 0.152471    
## I(Y == "3")TRUE        0.155498   0.388511   0.400 0.688979    
## I(month == "dec")TRUE  0.177348   0.930324   0.191 0.848815    
## I(month == "may")TRUE  2.250212   1.503902   1.496 0.134589    
## I(month == "sep")TRUE  0.647498   0.303800   2.131 0.033062 *  
## I(day == "thu")TRUE   -0.895065   0.552355  -1.620 0.105135    
## ---
## Signif. codes:  0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1
## 
## (Dispersion parameter for binomial family taken to be 1)
## 
##     Null deviance: 371.19  on 516  degrees of freedom
## Residual deviance: 343.38  on 504  degrees of freedom
## AIC: 369.38
## 
## Number of Fisher Scoring iterations: 6

glm.probs = predict(glm.fit, type = "response")
glm.probs <- data.frame(glm.probs)

glm.pred=rep("FALSE", 517)
glm.pred[glm.probs > .15] = "TRUE"
table(glm.pred, ffclass$bigfire,dnn=c("Prediction","Truth"))

##           Truth
## Prediction FALSE TRUE
##      FALSE   338   27
##      TRUE    119   33

hist(predict(glm.fit, type = "response"), xlab = "Individual Probabilities of Big Fire", main = NULL)

cat("The training error rate is", 100 - 100*mean(glm.pred == ffclass$bigfire), "%")

## The training error rate is 28.23985 %

So we find significance in the month of September (a positive relationship with log area burnt) and with the horizontal map position of 3 (a negative relationship with log area burnt) and wind (a positive relationship with log area burnt).

We are willing to allow our model to predict there is a big fire when it’s actually a small fire because we really wouldn’t want the model to miss a big fire. In other words, we will allow some false positives in order to reduce the number of false negatives.

Summary

This model has confirmed our previous model’s intuition that September has a significant predictive relationship with area burnt in these firest fires. The logistic model seems to have a stronger positive relationship with wind and area burnt than the previous linear model. ANOVA told us that there is something intrinsically different about the month of December in relation to area burnt. This could be due to people on holiday starting fires, since most forest fires are started by humans (thanks Smokey the Bear). With the horizontal map position of 3 being a strong negitive predictor of area burnt, after some research I do not have a good explanation for why this might be.

While the linear model found a significant relationship between Duff Moisture Code (DMC), Drought Code (DC), temperature and area burnt, the logistic regression did not. And while the logistic regression found significance in wind speed, the linear model did not. In my opinion, the logistic regression is mroe reliable as it was not affected by the cencorship problem described previously.

Beyond the Model, Looking Into Logistic Regression

We will now reduce the problem down to two predictors and the classifier label (bigfire) so that we can take a closer look at what R is doing under the hood with logistic regression.

The big difference between the previous linear regression and now the logistic regression is the response variable is now binary. In other words, the y-variable (dependent variable) went from being continuous to just being either 0 or 1.

So if we set our 0 and 1 appropriately, 1 - big fire and 0 - small fire, we want to obtain probabilities that the response takes on a value of 1. The logistic function (or sigmoid function) is perfect for our purposes because its behavior allows us to set a hypothesis between 0 and 1. If we state our hypothesis, $h(x)$ as the probability that y takes a value of 1, $h(x)$ is a function of some paramater $\theta$ and our data $x$, where $h(x) = g(\theta^T x)$ and $g(z)$ is the sigmoid function $\frac{1}{1 + e^{-z}}$.

So when will our hypothesis make a prediction of 1 and when will it make a prediction of 0? The answer to this question has to do with the decision boundary.

We can say that the model will predict 1 if our hypothesis is greater than or equal to some probability, say 0.5. And when it is less than 0.5 the model predicts 0. So if our hypothesis is just the sigmoid function evaluated at $\theta^T x$ then we can say the model will predict 1 when $\theta^T x \geq 0$. But how do we estimate the parameter(s)? As you might expect, finding the parameters necessary for the model is an optimization problem.

\[J(\theta) = \dfrac{1}{m} \sum_{i=1}^m \text{Cost}(h_\theta(x^{(i)}),y^{(i)})\] \[\text{Cost}(h_\theta(x),y) = -\log(h_\theta(x)), \text{if y = 1}\] \[\text{Cost}(h_\theta(x),y) = -\log(1-h_\theta(x)), \text{if y = 0}\]

So this is very useful because the more the hypothesis is off from y, the larger the cost function output. And if the hypothesis is equal to y, the cost is 0. This guarantees the convexity of $J(\theta)$ and that we can obtain a proper minimization.

However, this cost function can be joined in the form,

\[\text{Cost}(h_\theta(x),y) = - y \log(h_\theta(x)) - (1 - y) \log(1 - h_\theta(x))\]

and $J(\theta)$ becomes

\[J(\theta) = - \frac{1}{m} \sum_{i=1}^m [y^{(i)}\log (h_\theta (x^{(i)})) + (1 - y^{(i)})\log (1 - h_\theta(x^{(i)}))]\]

or in vector format,

\[J\left(\theta\right) = -\frac{1}{m}\left(\log\left(g\left(X\theta\right)\right)^{T}y+\log\left(1-g\left(X\theta\right)\right)^{T}\left(1-y\right)\right)\]

Now we can implement gradient descent.

We can see this implemented with MATLAB and two of the continuous predictors Duff Moisture Code (DMC) and Drought Code (DC). Using these two predictors allows us to visualize the data and the decision boundary, as seen in the figures below.

%%MATLAB
%% Data
clear ; close all; clc

data = load('ffclass.txt');
X = data(:, [1, 2]); y = data(:, 3);

fprintf(['Plotting data with + indicating (y = 1) examples and o ' ...
         'indicating (y = 0) examples.\n']);

plotData(X, y);

% Put some labels 
hold on;
% Labels and Legend
xlabel('Duff Moisture Code (DMC)')
ylabel('Drought Code (DC)')

% Specified in plot order
legend('Big Fire', 'Small Fire')
hold off;

pause;

%% Cost and Gradient

%  Matrix for our data
[m, n] = size(X);

% Intercept term
X = [ones(m, 1) X];

% Fitting parameters
initial_theta = zeros(n + 1, 1);

% Initial cost and gradient
[cost, grad] = costFunction(initial_theta, X, y);

fprintf('Cost at initial theta (zeros): %f\n', cost);
fprintf('Gradient at initial theta (zeros): \n');
fprintf(' %f \n', grad);

pause;

##   Cost at initial theta (zeros): 0.693147
## Gradient at initial theta (zeros): 
##   0.383946 
##  42.411605 
##   208.871567 
##  Local minimum possible.

%% Optimization with fminunc

%  Set options for fminunc
options = optimset('GradObj', 'on', 'MaxIter', 400);

%  Run fminunc to obtain the optimal theta
%  This function will return theta and the cost 
[theta, cost] = ...
	fminunc(@(t)(costFunction(t, X, y)), initial_theta, options);

% Print theta to screen
fprintf('Cost at theta found by fminunc: %f\n', cost);
fprintf('theta: \n');
fprintf(' %f \n', theta);

% Plot Boundary
plotDecisionBoundary(theta, X, y);

% Put some labels 
hold on;
% Labels and Legend
xlabel('Duff Moisture Code (DMC)')
ylabel('Drought Code (DC)')

% Specified in plot order
legend('Big Fire', 'Small Fire')
hold off;

pause;

##   Cost at theta found by fminunc: 0.358790
## theta: 
##  -2.123344 
##  -0.000557 
##  0.000291 
##  For a day with scores DMC = 110 and DC = 540, we predict a big fire probability of 0.116324

%% Prediction

prob = sigmoid([1 110 540] * theta);
fprintf(['For a day with scores DMC = 110 and DC = 540, we predict a big fire ' ...
         'probability of %f\n\n'], prob);

% Accuracy on our training set
p = predict(theta, X);
%p = 0;

fprintf('Train Accuracy: %f\n', mean(double(p == y)) * 100);

pause;

##   Train Accuracy: 88.394584

Forest Fires [Update] was originally published by Mike Chaykowsky at annotatoR on May 15, 2016.

Eigenfaces with PCA

2016-05-01T00:00:00+00:00

My goal here was to look under the hood of principal component analysis (PCA) and get a better sense of how it functions, more specifically in the field of image compression. Using an implementation from scikit-learn, PCA and support vector machines (SVM) were utilized to reduce the dimensionality of and classify over 13,000 color images of famous figures’ faces and look at a rudimentary facial recognition process. PCA utilizes the eigenvectors of the covariance matrix to redescribe data points in the direction of highest variance. A metric developed using a weighted average of precision and recall yielded a score of 77% when 50 principal components were used for the study and out of 36 faces given to the model to recognize, 29 were predicted correctly. Improvements of the study could be developed using a cross-validation of the number of principal components.

Data

Our data are images set to 250 x 250 pixels containing faces of famous figures. There are 13,233 images in the whole set with 5749 different people and 1680 of them contain more than 1 image in their set of images. This is an important fact because the program learns from the images and the highest variance will be described in the direction of people with the most images. The dataset contains 5 errors, which are, Fold 1: Janica_Kostelic_0001, Janica_Kostelic_0002 Fold 1: Nora_Bendijo_0001, Nora_Bendijo_0002 Fold 5: Jim_OBrien_0001, Jim_OBrien_0002 Fold 5: Jim_OBrien_0001, Jim_OBrien_0003 Fold 5: Elisabeth_Schumacher_0001, Elisabeth_Schumacher_0002.

If we are representing our images as a vector of values. Each value corresponds to a pixel’s intensity on a scale measured from 0 to 255 inclusive, and a square $N$ by $N$ image can be expressed as an $N^2$-dimensional vector, $X = (x_1 x_2 x_3 ... x_{N^2})$ where the rows of pixels are just placed concurrently to form a one dimensional image. We are using color images so we need matrices for each of the three color channels in the RGB color space (red, green, blue). To describe how the data is processed, and a slight introduction into visualizing principal component analysis (PCA), we can take a brief view into one of the images, Aaron Eckhart.

Example

## Importance of components:
##                           PC1     PC2     PC3
## Standard deviation     1.6929 0.36422 0.03701
## Proportion of Variance 0.9553 0.04422 0.00046
## Cumulative Proportion  0.9553 0.99954 1.00000

Here we see our segmented image described graphically as a function of its first two principal components $u$ and $v$, respectively. So now that we have seen what PCA can do with one of our training images, lets take a look at how PCA actually works.

What is PCA?

PCA is a technique that identifies patterns in data, and then expresses the data in such a way that highlights these patterns. Some may recognize that identifying patterns in high-dimensionality is a difficult task. Why is this difficult? We cannot display our data visually and the higher we go in dimensions, the more uniformly distant each data point is from every other data point. PCA can be used to reduce this dimensionlity.

Math of PCA

So mathematically, what does PCA want? PCA wants to know if there is another basis that is a linear combination of the original basis, which reexpresses our data. PCA does carry some assumptions with it. One of which is linearity. Linearity makes the problem simpler by reducing the number of possible bases allowed. Linearity also is a benefit that allows us to assume continuity in a data set. If we let X and Y be $m$×$n$ matrices related by a linear transformation $P$, where X is the original data set and Y is a new representation of the data, then,

$PX=Y$,

$p_i$ are the rows of $P$

$x_i$ are the columns of $X$

$y_i$ are the columns of $Y$

represents a change of basis. The rows of P, ${p1, . . . , pm}$, are a set of new basis vectors for expressing the columns of $X$ and each coefficient of $y_i$ is a dot product of $x_i$ with the corresponding row in $P$. So the jth coefficient of $y_i$ is a projection on to the jth row of $P$, or $y_i$ is a projection on to the basis of ${p1, . . . , pm}$. So our conclusion here is that the rows of $P$ are a new set of basis vectors for the columns of $X$. So we must now ask ourselves, how do we find the correct change of basis? The row vectors ${p1, . . . , pm}$ become the principal components.

The first step in applying PCA on a dataset is to subtract the mean from each of the data dimensions. Where the mean is the average across each dimension. Essentially what this does is produces a data set whose mean is zero.

Our next step is calculating the covariance matrix. PCA is all about variance. Let’s take a look at the idea of variance for a moment.

The variance of A and B are individually defined as follows.

\[\sigma_A^2 = \langle a_i a_i \rangle_i , \sigma_B^2 = \langle b_i b_i \rangle_i\]

where the expectation is the average over $n$ variables.

Covariance is much like variance, except instead of seeing how much one variable varies it determines how much two variables ‘co-vary’.

covariance of A and B $\equiv \sigma_{AB}^2 = \langle a_i b_i \rangle_i$

But we don’t just want A and B. We want to be able to have a big matrix of $m$ row vectors. So say we make the sets of A and B into row vectors, $a = [a_1, a_2, . . . a_n], b = [b_1, b_2, . . . b_n]$. Now,

\[\sigma_{ab}^2 \equiv \frac{1}{n-1}ab^T\]

with the first term for normalization.

Now we can accomplish the expansion of our method from just two vectors to $m$ vectors. We can rename the row vectors $x_1 \equiv a, x_2 \equiv b$ and consider additional indexed row vectors $x3, . . . , xm$. Recall we want a covariance matrix, so we can define a new $m$×$n$ matrix X where each row of X corresponds to all measurements of a particular type ($x_i$). Each column of X corresponds to a set of measurements from one particular trial. And we can call this new matrix the covariance matrix $S_X$,

\[S_X \equiv \frac{1}{n-1}XX^T\]

the ijth element of the variance is the dot product between the vector of the ith measurement type with the vector of the jth measurement type.

Now our new matrix $S_X$ gives us correlation information for all possible pairs of values where zero covariance corresponds to entirely uncorrelated data. In a way, we can view our really high-dimensions data set as being extremely redundant, as in, we really don’t need all of those dimensions to describe most of the relationships within the data. So to reduce this redundancy, we can imagine changing the covariance matrix around until each variable co-varies as little as possible with the other variables. So with this new covariance matrix $S_Y$, what features would we want to optimize the most? If we are trying to make the covariances between different values to be zero, this would make all off-diagonal terms in $S_Y$ zero. Or in other words, this ‘diagnolizes’ $S_Y$. To do this, PCA assumes $P$ is an orthonormal matrix, i.e. PCA assumes that all basis vectors ${p1, . . . , pm}$ are orthonormal ($p_i p_j = \delta_{ij}$). The other assumption that PCA makes is that the most important directions are the ones with the largest variances.

So this choice of assuming the directions iwth the highest variances are the most important ones is another way of saying they are the ‘principal’ components. PCA finds the normalized direction that the variance in $X$ is maximized and this is $p_1$ or the first principal component. Then when it goes to select its next direction it must pick a direction that is perpendicular to all previous directions because of the orthonormality condition. We then have to specify how many times it does this. It could select directions up to $m$ times in $m$-dimensions.

So we have calculated the covariance matrix, which will be $p$x$p$, and since this is a square matrix we can calculate the eigenvectors and eigenvalues (note: these are unit eigenvectors). So this extraction of the eigenvectors of the covariance matrix is what gives us the lines that characterize the data. Then we transform the data to be expressed in terms of those directions. We can see that the eigenvector with the greatest eigenvalue is the first principal component. So naturally we want to order the eigenvectors by eigenvalue. Now we have all of the directions in order from most important to least important. So this is the important aspect to dimensionality reduction. We can leave out as many of these components as we want, and that will be the new dimensionality of our data set. Using matrices, this is equivalent to choosing the eigenvectors that we want to keep as our principal components and placing them in a matrix of vecotrs, then take the transpose of thise and multiply it by the original data set, transposed. This will give us the original data in terms of the vectors we chose. Now our data is expressed in terms of the similarities and differences of the data themselves.

Solving PCA. Let’s assume some data set is an $m$×$n$ matrix X, where $m$ is the number of measurement types and $n$ is the number of data trials. The goal is to find some orthonormal matrix P where $Y=PX$ such that $S_Y \equiv \frac{1}{n-1}YY^T$ is diagonalized. The rows of P are the principal components of X. We begin by rewriting $S_Y$ in terms of P.

\[S_Y = \frac{1}{n-1}YY^T\] \[= \frac{1}{n-1}(PX)(PX)^T\] \[= \frac{1}{n-1}P(XX^T)P^T\] \[S_Y = \frac{1}{n-1}PAP^T\]

$A \equiv XX^T$ where A is symmetric (A symmetric matrix is diagonalized by an orthogonal matrix of its eigenvectors)

\[A = EDE^T\]

where $D$ is a diagonal matrix and $E$ is a matrix of eigenvectors of $A$ arranged as columns. We select the matrix P to be a matrix where each row $p_i$ is an eigenvector of $XX^T$. By this selection, $P \equiv E^T$. Substituting, $A=P^TDP$ and then ($P^{-1} = P^T$),

\[S_Y = \frac{1}{n-1}PAP^T\] \[= \frac{1}{n-1}P(P^TDP)P^T\] \[= \frac{1}{n-1}(PP^T)D(PP^T)\] \[= \frac{1}{n-1}(PP^{-1})D(PP^{-1})\] \[S_Y = \frac{1}{n-1}D\]

The choice of P diagonalizes $S_Y$.

PCA for Image Compression

So when we use PCA for image compression, what we are doing is reducing the image to only the most important directions of variance, however we sometimes need to be able to reconstruct the image afterwards. For this we must take all $m$ components when performing PCA, since if we didn’t take all of the components we would have lost some information about the image. To get the original data back we just need to multiply the final data by the inverse of the matrix of vectors we created, then we have to add on the mean of the original data that we subtracted in the beginning.

In our experiment we have varying numbers of images for each famous figure, where each image is 250 pixels wide by 250 pixels high. For each image we create an image vector as described above, and then we put all of the images together in one matrix with each row as an image’s vector. So now assume we have a matrix for each famous person in our set, and then we have performed PCA so we have or original data in terms of the eigenvectors of the covariance matrix. Now we want to use this new information to perform facial recognition on an image or multiple images that the program has never seen before. The program checks for the difference between the new image and the original images, along the new axes determined by PCA eigenvectors directions. This allows the program to check for the most similarities and differences at once since these are the directions of highest variance.

Results

This example of PCA is exciting because we actually have a visual representation of what happened to our photos. The eigenfaces figure below shows how PCA applied to all ~13,000 images has created a kind of compilation photo for all of the famous people, where the most prevalent figures have the most impact on the first eigenface. The first eigenface contains 21.7% of the variance explained and the second component contains 13.6% of the variance explained.

Eigenfaces

Below, we can see a list of 19 figures used in the prediction process and the model’s precision and recall. There is also another metric, f1-score, which can be interpreted as a weighted average of the precision and recall, where an f1 score reaches its best value at 1 and worst score at 0. The relative contribution of precision and recall to the f1 score are equal. The formula for the f1 score is: $f1 = 2 \cdot (\text{precision} \cdot \text{recall}) / (\text{precision} + \text{recall})$. Support is the number of images used for each figure during the classification. The greatest f1-score came with Gloria Macapagal Arroyo and the most comical prediction was the model thought Former Governor of Missouri John Ashcroft was Former Governor of California Arnold Schwarzenegger.

                         precision    recall  f1-score   support

         Ariel Sharon       0.73      0.76      0.74        21
       Schwarzenegger       0.33      0.67      0.44         6
         Colin Powell       0.76      0.75      0.75        67
      Donald Rumsfeld       0.68      0.92      0.78        25
        George W Bush       0.83      0.85      0.84       138
    Gerhard Schroeder       0.86      0.74      0.79        34
            GM Arroyo       0.91      1.00      0.95        10
          Hugo Chavez       0.62      0.76      0.68        17
       Jacques Chirac       0.50      0.50      0.50        10
        Jean Chretien       0.89      0.57      0.70        14
    Jennifer Capriati       0.80      0.57      0.67        14
        John Ashcroft       0.70      0.64      0.67        11
    Junichiro Koizumi       0.92      0.71      0.80        17
           Laura Bush       1.00      0.71      0.83        14
       Lleyton Hewitt       0.44      0.67      0.53         6
         LIL da Silva       0.70      0.64      0.67        11
      Serena Williams       1.00      0.38      0.56        13
           Tony Blair       0.59      0.74      0.66        27
       Vladimir Putin       0.55      0.50      0.52        12
150comp's:avg / total       0.77      0.75      0.75       467
 50comp's:avg / total       0.78      0.77      0.77       467
250comp's:avg / total       0.76      0.75      0.75       467

What we can see from the results above is that when the number of principal components was reduced from 150 to 50, there was actually an improved f1-score. A possible reason for this is overfitting. When you allow too much training in the model we can see that the model will only be able to predict those images that it trained on (which is not helpful at all). When we reduce the number of components to 50 we actually see an improved prediction, precision, and recall. When 150 components were used, the model predicted 28 of the 36 images correctly and when 50 components were used the model predicted 29 of the 36 images correctly (see below for 150 components results). With 250 components the model makes 10 errors, only predicting 26 of the 36 correctly.

Predictions

Reference

http://setosa.io/ev/principal-component-analysis/

https://www.cs.princeton.edu/picasso/mats/PCA-Tutorial-Intuition_jp.pdf

Scikit-learn: Machine Learning in Python, Pedregosa et al., JMLR 12, pp. 2825-2830, 2011. http://scikit-learn.org/stable/auto_examples/applications/face_recognition.html

Eigenfaces with PCA was originally published by Mike Chaykowsky at annotatoR on May 01, 2016.

Verified Certificate

2016-04-15T00:00:00+00:00

Armed with 4 datasets on students enrolled in the Entrepreneurship 101 MOOC on edX, I attempt to answer some interesting questions about those students who succeed (and how to encourage more of them to succeed). So first things first, let’s do some data cleaning. We have 4 separate datasets, and all provide different information, so we will use only the data that is most relevant to our question. First, we will look at which groups of students tended to complete the assignments and earn verified certificates.

## Classes 'tbl_df', 'tbl' and 'data.frame':	35647 obs. of  13 variables:
##  $ id                   : int  8 27 99 254 408 409 411 737 848 876 ...
##  $ grade                : num  0 0 0 0 0 0 0 0 0 0 ...
##  $ HW.01                : num  0 0 0 0 0 0 0 0 0 0 ...
##  $ HW.02                : num  0 0 0 0 0 0 0 0 0 0 ...
##  $ HW.03                : num  0 0 0 0 0 0 0 0 0 0 ...
##  $ HW.Avg               : num  0 0 0 0 0 0 0 0 0 0 ...
##  $ Final                : num  0 0 0 0 0 0 0 0 0 0 ...
##  $ Enrollment.Track     : Factor w/ 2 levels "honor","verified": 1 1 1 1 1 1 1 1 1 1 ...
##  $ Certificate.Delivered: Factor w/ 2 levels "N","Y": 1 1 1 1 1 1 1 1 1 1 ...
##  $ Certificate.Type     : Factor w/ 2 levels "honor","verified": NA NA NA NA NA NA NA NA NA NA ...
##  $ gender               : Factor w/ 2 levels "f","m": 2 NA NA 2 NA NA NA NA NA NA ...
##  $ level_of_education   : Factor w/ 10 levels "Associates","Bachelors",..: 8 NA NA 6 NA NA NA NA NA NA ...
##  $ Age                  : num  57 NA NA 31 NA NA NA NA NA NA ...

So we’ve landed on a good dataframe that will provide us with much of the relevant information necessary to determine what groups of students do well. Let’s recap breifly what was done. We’ve sorted the rows by student id, created ‘factor’ variables for the enrollment track (either ‘honor’ or ‘verified’) and Certificate Delivered (yes or no) and gender (male or female) and level of education (10 levels inculding HighSchool, Bachelors, etc.). We have also transformed birthdate to age of student. So now we have an appropriate set of predictors to look at a model.

We are trying to predict ‘Certificate Delivered’. This is a binary factor variable (i.e. the student either received a certificate, or they didn’t). For this we will use logistic regression. Looking initially at the whole dataset, we use gender, level of education, and age as our predictors. We do not include 3 levels of education, “P_OTH”, “PSE”, and “other” due to small sample size and a resulting high standard error. We end up with 4 significant predictors in relation to Certificate Delivered. These are, “gender = male” (p-val = 0.0008) “level of education = HS” (p-val = 0.0188) “level of education = JHS”(p-val = 8.23e-05) and “Age”(p-val = 9.38e-09). All have positive relationships to predicting Certificate Delivered, except for Age which has a negative relationship. How do we interpret these results? An intuitive explanation is that as we decrease age of student they are more likely to receive a verified certificate. Students with a level of education of JHS or HS are more likely to receive a verified certificate. And male students are more likely to receive a verified certificate. Let’s check our results.

##           Truth
## Prediction     N     Y
##          N 25552   389
##          Y  2050   104

## The training error rate is 8.68126 %

We can see from the histogram that most of the probabilites given by the logistic model fall around 2%. These are the probabilities of each individual student receiving a verified certificate. So controlling for false postiives/false negatives, we will assign probabilities of over 0.03 a value of “yes” and check for our predictions. We have a training error rate of about 8.7%, which is pretty good. This means that assigning student’s with probabilities of over 3% a prediction of “yes” yields in a prediction accuracy of about 91.3%. Now we will test this model on some data it has never seen before.

##           Truth
## Prediction    N    Y
##          N 3369   45
##          Y  141    9

## The test error rate is 5.218855 %

So we actually end up with a better test error rate than our training error rate. This means that the model predicted the correct outcome of a student’s success about 94.8% of the time.

Now we will check how many hard workers we have. aka how many students attempted all of the assignments?

## The number of students who attempted all homeworks is 570

It may also be interesting to note that 672 students attempted at least 1 assignment. So a large portion of those students that attempted an assignment, attempted all of the assignments.

Now we will check how many students actually received a verified certificate.

## The number of students who received a verified certificate is 127

Other aspects of this data must be researched more thoroughly. I observed a sample of time separation data between assignment time submitted and assignment time graded, however, excluding a few outliers most grades were produced within 20mins. So this did not yield any results.

Using this information we want to know what can be done to encourage more learners to complete the course and earn a verified certificate. We see that older students do not tend to earn a certificate. This can use further research to observe what barriers to completion there are for older students (possibly scheduling issues, tech-friendliness, etc). Implementing techniques geared towards encouraging female students in the Entrepreneurship course could help with the predominantly male population. We also might want to look into why lower levels of education tend to increase odds of receiving a certificate.

One dataset I would be very intrigued to look at is the discussion board data. Observing whether or not students utilize the discussion board could be a very useful predictor for certificate delivered. Text mining techniques can also be employed to determine user interest and sentiment.

Verified Certificate was originally published by Mike Chaykowsky at annotatoR on April 15, 2016.

Forest Fires Linear Model Selection

2016-04-04T00:00:00+00:00

The primary goals of this report are to obtain the best linear model possible to predict area burnt during forest fires in Montesinho natural park in the Tr´as-os-Montes northeast region of Portugal and to understand the underlying relationships between our predictors and area burnt (i.e. how does area burnt change based on a 1 unit increase in some other variable). Our predicors range from meteorological to temporal to geographical. Predicting forest fires has long been considered a challenging task from statisticians, as so many factors go into its spread and capacity. However, we will always be desperate for simple predictors since the resources to put new technology in various parts of the world are sparce. In this paper, I employed subset selection techniques along with cross validation to build the best linear model possible. I conclude that the best model contains ten predictors. This model results in an RMSE value of about 1.39 and an MAE of 1.155, which is our preferred method of error diagnostics for this dataset (see explanation in section Subset Selection Cross Validates).

library(dplyr)
library(ggplot2)
library(leaps)
library(knitr)
library(caret)
library(corrplot)
set.seed(123)

Variable Descriptions:

X - x-axis spatial coordinate within the Montesinho park map: 1 to 9
Y - y-axis spatial coordinate within the Montesinho park map: 2 to 9
month - month of the year: “jan” to “dec”
day - day of the week: “mon” to “sun”
FFMC - Fine Fuel Moisture Code (FFMC) index from the Fire Weather Index (FWI) system: 18.7 to 96.20
DMC - Duff Moisture Code (DMC) index from the FWI system: 1.1 to 291.3
DC - Drought Code (DC) index from the FWI system: 7.9 to 860.6
ISI - Initial Spread Index (ISI) from the FWI system: 0.0 to 56.10
temp - temperature in Celsius degrees: 2.2 to 33.30
RH - relative humidity in %: 15.0 to 100
wind - wind speed in km/h: 0.40 to 9.40
rain2 - outside rain in mm/m2 : 0.0 to 6.4
area - the burned area of the forest (in ha): 0.00 to 1090.84

ff <- read.csv("forestfires.csv")
ff2 <- ff %>% mutate(rain2 = as.factor(rain > 0), logarea = log(area + 1)) %>% select(-c(rain, area))
dim(ff2)

## [1] 517  13

str(ff2)

## 'data.frame':	517 obs. of  13 variables:
##  $ X      : int  7 7 7 8 8 8 8 8 8 7 ...
##  $ Y      : int  5 4 4 6 6 6 6 6 6 5 ...
##  $ month  : Factor w/ 12 levels "apr","aug","dec",..: 8 11 11 8 8 2 2 2 12 12 ...
##  $ day    : Factor w/ 7 levels "fri","mon","sat",..: 1 6 3 1 4 4 2 2 6 3 ...
##  $ FFMC   : num  86.2 90.6 90.6 91.7 89.3 92.3 92.3 91.5 91 92.5 ...
##  $ DMC    : num  26.2 35.4 43.7 33.3 51.3 ...
##  $ DC     : num  94.3 669.1 686.9 77.5 102.2 ...
##  $ ISI    : num  5.1 6.7 6.7 9 9.6 14.7 8.5 10.7 7 7.1 ...
##  $ temp   : num  8.2 18 14.6 8.3 11.4 22.2 24.1 8 13.1 22.8 ...
##  $ RH     : int  51 33 33 97 99 29 27 86 63 40 ...
##  $ wind   : num  6.7 0.9 1.3 4 1.8 5.4 3.1 2.2 5.4 4 ...
##  $ rain2  : Factor w/ 2 levels "FALSE","TRUE": 1 1 1 2 1 1 1 1 1 1 ...
##  $ logarea: num  0 0 0 0 0 0 0 0 0 0 ...

We can see that our initial dataset contains 13 variables with 517 observations.

We also have some factor variables alongside of integer and numeric variables.

We will be using the log transform of area burnt (in hectares) due to its strong right skew, and we will be using rain as a factor variable (i.e. whether or not it is raining at the time of the fire).

pairs(ff2[,c(3,4,12,13)])

corpears.mat <- cor(ff2[,c(1,2,5,6,7,8,9,10,11,13)])
corspear.mat <- cor(ff2[,c(1,2,5,6,7,8,9,10,11,13)], method = "spearman")

par(mfrow=c(1,2))
corrplot(corpears.mat, order = 'hclust')
corrplot(corspear.mat, order = 'hclust')

The pairs plot is for the factor variables and the correlation plot is for the numeric variables. The pairs plot indicated no correlation within the factor variables. For the numeric variables, it’s always good practice to run both Pearson and Spearman because Pearson deals with linear relationships so it may falter in some non-linear scenarios where Spearman will not. So, if we have a situation where the Spearman is greater than the Pearson, this indicates that there is something non-linear going on and we may need a log transform on a variable or more. From the plots it seems that many of the meteorological indices are somewhat correlated.

Based on my intimate knowledge of the dataset and the predicor variables, I do not feel that it is necessary to include interaction terms for this model.

trainIndex <- createDataPartition(ff2$logarea, p=0.9, list = FALSE)
ff2Train <- ff2[trainIndex,]
ff2Test <- ff2[-trainIndex,]

full.model <- lm(logarea ~ ., data = ff2Train)
summary(full.model)$coef

##                 Estimate  Std. Error     t value    Pr(>|t|)
## (Intercept) -1.990699673 1.758678719 -1.13192913 0.258280735
## X            0.047602316 0.034087347  1.39648051 0.163273885
## Y           -0.013400449 0.063750072 -0.21020289 0.833606629
## monthaug     0.256022739 0.876126141  0.29222132 0.770255148
## monthdec     2.544425811 0.938927128  2.70992895 0.006992696
## monthfeb     0.374492686 0.609073788  0.61485602 0.538967644
## monthjan     0.082615617 1.256826937  0.06573349 0.947619867
## monthjul     0.014948095 0.757433399  0.01973519 0.984263562
## monthjun    -0.210677600 0.700882955 -0.30058885 0.763870013
## monthmar    -0.157124455 0.546126178 -0.28770724 0.773706308
## monthmay     0.746945499 1.132253722  0.65969798 0.509792806
## monthnov    -0.879837033 1.513250648 -0.58142188 0.561253884
## monthoct     0.770504879 1.039469099  0.74124847 0.458938222
## monthsep     0.909968775 0.977237349  0.93116455 0.352279073
## daymon       0.220184849 0.248289127  0.88680826 0.375666586
## daysat       0.314888837 0.235006770  1.33991390 0.180964902
## daysun       0.222382991 0.223447868  0.99523434 0.320169301
## daythu       0.094087455 0.252976471  0.37192176 0.710130149
## daytue       0.411475188 0.245248501  1.67778880 0.094098455
## daywed       0.191922597 0.263779937  0.72758603 0.467254008
## FFMC         0.014370026 0.017165485  0.83714653 0.402964663
## DMC          0.004051423 0.001958798  2.06832064 0.039193599
## DC          -0.001743149 0.001329022 -1.31160264 0.190338202
## ISI         -0.026935046 0.019017776 -1.41630896 0.157392603
## temp         0.061885533 0.024256997  2.55124456 0.011071236
## RH           0.006017405 0.007127721  0.84422564 0.399002094
## wind         0.079535843 0.041660192  1.90915688 0.056892046
## rain2TRUE   -0.971484397 0.622693231 -1.56013322 0.119447339

Fitting our full model, we can see the p-values indicate that monthdec, DMC, and temp are significant at the 0.05 level. The $R^2_a$ indicates that about 3% of the variance in the response is explained by a linear relationship with the predictors. This $R^2_a$ is very low, so we shouldn’t expect much from our predictions, but we have a p-value of 0.049 for the current full model so we may be able to see some relationships between the predictors and the response. The residual plot indicated the model needs tweaking.

Nested F-Tests, Forward Selection

add1(lm(logarea ~ temp, data = ff2Train), logarea ~ 
       X + Y + month + day + FFMC + DMC + DC + ISI + 
       temp + RH + wind + rain2, test = "F")

## Single term additions
## 
## Model:
## logarea ~ temp
##        Df Sum of Sq    RSS    AIC F value  Pr(>F)  
## <none>              936.77 328.78                  
## X       1     3.482 933.29 329.04  1.7347 0.18846  
## Y       1     1.228 935.54 330.16  0.6105 0.43501  
## month  11    35.773 901.00 332.56  1.6423 0.08417 .
## day     6     4.495 932.28 338.53  0.3696 0.89820  
## FFMC    1     0.539 936.23 330.51  0.2676 0.60517  
## DMC     1     3.268 933.50 329.14  1.6280 0.20262  
## DC      1     1.977 934.79 329.79  0.9834 0.32188  
## ISI     1     3.352 933.42 329.10  1.6696 0.19695  
## RH      1     0.001 936.77 330.78  0.0005 0.98276  
## wind    1     5.013 931.76 328.27  2.5018 0.11440  
## rain2   1     1.995 934.78 329.78  0.9922 0.31973  
## ---
## Signif. codes:  0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1

Nested F-tests with forward selection indicates the one-variable model with logarea ~ temp.

Nested F-Tests, Backward Selection

Nested F-tests with backward selection also indicates the one-variable model with logarea ~ temp. The order of removal was: Y, day, FFMC, RH, rain2, ISI, DC, X, wind, DMC, month, leaving us with,

drop1(lm(logarea ~ temp, data = ff2Train), test = "F")

## Single term deletions
## 
## Model:
## logarea ~ temp
##        Df Sum of Sq    RSS    AIC F value  Pr(>F)  
## <none>              936.77 328.78                  
## temp    1    9.0918 945.86 331.30  4.5228 0.03397 *
## ---
## Signif. codes:  0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1

Subset Selection Cross Validated (90% Train, 10% Test)

#best subset
ff2.bestsub <- regsubsets(logarea ~ ., data=ff2Train, nvmax = 20)
ff2.bestsub.summary <- summary(ff2.bestsub)
best.cp <- which.min(ff2.bestsub.summary$cp)
cat("The best number of variables to minimize Cp is", best.cp)
best.ar2 <- which.max(ff2.bestsub.summary$adjr2)
cat("The best number of variables to maximize adjusted R^2 is", best.ar2)
best.bic <- which.min(ff2.bestsub.summary$bic)
cat("The best number of variables to minimize BIC is", best.bic)

par(mfrow=c(2,2))
plot(ff2.bestsub, scale = 'r2')
plot(ff2.bestsub, scale = 'adjr2')
plot(ff2.bestsub, scale = 'Cp')
plot(ff2.bestsub, scale = 'bic')

ff2.bestsub.total = regsubsets(logarea ~ ., data = ff2, nvmax = 20)
cat("The coefficients to minimize Cp are\n", 
    names(coef(ff2.bestsub.total, 5)))

## The coefficients to minimize Cp are
##  (Intercept) X monthdec monthsep temp wind

cat("The coefficients to maximize adjusted R^2 are\n", 
    names(coef(ff2.bestsub.total, 12)))

## The coefficients to maximize adjusted R^2 are
##  (Intercept) X monthdec monthjun monthmar monthoct monthsep daytue DMC DC temp wind rain2TRUE

cat("The coefficients to minimize BIC are\n", 
    names(coef(ff2.bestsub.total, 2)))

## The coefficients to minimize BIC are
##  (Intercept) monthdec temp

Optimizing for $C_p$ (5 vars), $R^2_a$ (12), and $BIC$ (2) are all giving us different models. Let’s continue.

test.mat = model.matrix(logarea ~ ., data = ff2Test)
val.errors = rep(NA, 20)
for(i in 1:20){
  coefi = coef(ff2.bestsub, id=i)
  pred = test.mat[,names(coefi)]%*%coefi
  val.errors[i] = mean((ff2Test$logarea-pred)^2)
}

val.errors.mae = rep(NA, 20)
for(i in 1:20){
  coefi = coef(ff2.bestsub, id=i)
  pred.mae = test.mat[,names(coefi)]%*%coefi
  val.errors.mae[i] = mean(abs(ff2Test$logarea-pred.mae))
}

par(mfrow=c(1,2))
plot(val.errors, type = "b")
plot(val.errors.mae, type = "b")

coef(ff2.bestsub, 1)

## (Intercept)    monthdec 
##    1.109950    1.625311

coef(ff2.bestsub, 11)

##   (Intercept)             X      monthdec      monthfeb      monthsep 
## -0.3372121759  0.0458164419  2.1928116636  0.4398217503  0.4614473719 
##        daytue           DMC            DC           ISI          temp 
##  0.2189178855  0.0033051963 -0.0006118161 -0.0226146870  0.0478136280 
##          wind     rain2TRUE 
##  0.0729525694 -0.8450540019

Here we create matrices from our data to compute the test Mean Square Error (MSE) and Mean Absolute Error (MAE) for each optimal 1-,2-,3-,… variable models. Now I will argue that the MAE is better for our dataset than the MSE. Our response variable, area burnt, contains many 0-values and then occasional large values. The issue with using MSE for data such as this is that we are relying too heavily on the error terms for the very large fire instances. What we really want is the mean absolute error so that we do not square the errors and intensify our errors for large predictions. The goal is to minimize test MSE and MAE since if the model we fit on the training data has a low error for the test data, then our predictions should be pretty good. We see that the best model is the one that contains 1 variable according to the test MSE and MAE. In other words, the model that was fit on the training data with one variable had the lowest MSE and MAE when applied to the test data. However, after observing our plot of MAE values the 11 variable model has nearly the same MAE as the 1-variable model and it also increases our $R^2_a$ value. The range of our response variable is approximately 0 to 7 and our lowest root MSE is 1.082 and lowest MAEs are 0.9443508 (1-var model) and 0.9463533 (11-var model).

coef(ff2.bestsub.total, 1)

## (Intercept)    monthdec 
##    1.085148    1.486522

coef(ff2.bestsub.total, 11)

##  (Intercept)            X     monthdec     monthjun     monthmar 
##  0.211427831  0.050780523  1.951204985 -0.565328045 -0.446842902 
##     monthoct     monthsep          DMC           DC         temp 
##  0.519387856  0.613863479  0.004147180 -0.001598876  0.034617499 
##         wind    rain2TRUE 
##  0.062060539 -0.805144940

We look at the coefficients for the whole dataset to get highest accuracy. The 1-variable model has the same variables as our training set, but slightly different coefficients and the 11-variable model has different predictors and coefficients.

Cross Validated 10-Fold Subset Selection

set.seed(123)
k=10
folds = sample(1:k, nrow(ff2), replace = TRUE)
cvfold.errors = matrix(NA,k,20,dimnames=list(NULL, paste(1:20)))
cvfold.errors.mae = matrix(NA,k,20,dimnames=list(NULL, paste(1:20)))

predict.regsubsets = function(object ,newdata ,id ,...){
  form=as.formula (object$call[[2]])
  mat=model.matrix(form, newdata)
  coefi =coef(object ,id=id)
  xvars = names(coefi)
  mat[,xvars ]%*%coefi
}

for (j in 1:k){
  bestsub = regsubsets(logarea ~ ., data = ff2[folds != j,], nvmax = 20)
  for(i in 1:20){
    pred10=predict.regsubsets(bestsub, ff2[folds == j,], id=i)
    cvfold.errors[j,i]=mean((ff2$logarea[folds==j] - pred10)^2)
  }
}

## Reordering variables and trying again:

for (j in 1:k){
  bestsub = regsubsets(logarea ~ ., data = ff2[folds != j,], nvmax = 20)
  for(i in 1:20){
    pred10.mae=predict.regsubsets(bestsub, ff2[folds == j,], id=i)
    cvfold.errors.mae[j,i]=mean(abs(ff2$logarea[folds==j] - pred10.mae))
  }
}

## Reordering variables and trying again:

mean.cv.errors = apply(cvfold.errors, 2, mean)
mean.cv.errors.mae = apply(cvfold.errors.mae, 2, mean)
mean.cv.errors
mean.cv.errors.mae

par(mfrow=c(1,2))
plot(mean.cv.errors, type = 'b', xlab = "Number of Variables", ylab = "Test MSE")
plot(mean.cv.errors.mae, type = 'b', xlab = "Number of Variables", ylab = "Test MAE")

Cross-validated 10-fold subset selection produces the same answer for test MSE, but a different one for test MAE. The 10-fold CV tells us the minimum test MSE occurs with the 1-variable model. The 10-fold CV tells us the minimum test MAE occurs with the 2-variable model and has a large reduction in error with the 10-variable model. Recall, the range of our response variable is approximately 0 to 7 and our lowest root MSE is 1.396 (1-var model) and our lowest test MAE is 1.140 (2-var model) with the 10-variable model at 1.155 MAE.

coef(ff2.bestsub.total, 1)

## (Intercept)    monthdec 
##    1.085148    1.486522

coef(ff2.bestsub.total, 2)

## (Intercept)    monthdec        temp 
##  0.57120277  1.87906042  0.02684671

coef(ff2.bestsub.total, 10)

##  (Intercept)            X     monthdec     monthjun     monthmar 
##  0.211598289  0.053797867  1.860354192 -0.532651270 -0.403198781 
##     monthsep          DMC           DC         temp         wind 
##  0.506994774  0.003148472 -0.001212802  0.031520861  0.059630087 
##    rain2TRUE 
## -0.821049959

I use the coefficients for the whole dataset to get highest accuracy for the 1 and 10 variable models.

Ok so let’s recap what we have learned about our predictors.

Two types of cross validation were used here to determine the best predictors. The first was a simple 90-10 split between the training data and the test data. Here I performed optimization on $C_p$, $R^2_a$, and $BIC$, where all gave different solutions including the 5-variable, 12-variable, and 2-variable models respectively. I then performed cross-validation with our test set where I obtained a minimum MSE & MAE with the 1-variable model (i.e. logarea ~ monthdec), but the 11-variable model and nearly as low an MAE with 0.9463533, and optimizes other diagnostics more than the 1-variable model. Then I went through a 10-fold cross-validation subset selection, which also yielded the 1-variable model. However, the 10-variable model (logarea ~ X + monthdec + monthjun + monthmar + monthsep + DMC + DC + temp + wind + rain2) had a strongly decreased MAE compared to the previous models and optimizes other diagnostics more than the 1-variable model.

So I am kind of stuck between the 10 variable model or the 11 variable model, so I will run an anova F-test.

model10 <- lm(logarea ~ X + I(month=='dec') + I(month=='jun') + I(month=='mar') + I(month=='sep') + DMC + DC + temp + wind + rain2, data = ff2Train)
model11 <- lm(logarea ~ X + I(month=='dec') + I(month=='feb') + I(month=='sep') + I(day=='tue') + DMC + DC + ISI + temp + wind + rain2, data = ff2Train)
anova(model10, model11)

## Analysis of Variance Table
## 
## Model 1: logarea ~ X + I(month == "dec") + I(month == "jun") + I(month == 
##     "mar") + I(month == "sep") + DMC + DC + temp + wind + rain2
## Model 2: logarea ~ X + I(month == "dec") + I(month == "feb") + I(month == 
##     "sep") + I(day == "tue") + DMC + DC + ISI + temp + wind + 
##     rain2
##   Res.Df    RSS Df Sum of Sq      F Pr(>F)
## 1    457 884.30                           
## 2    456 879.35  1    4.9517 2.5678 0.1098

The ANOVA F-test indicates that there is no good reason to use the 11-variable model over the 10-variable model.

So after our diagnostics our best model is the 10-variable model: logarea ~ X + monthdec + monthjun + monthmar + monthsep + DMC + DC + temp + wind + rain2TRUE.

Just to make sure there isn’t anything odd going on with our month variables we should take a look at a visual,

plot(ff2$month, ff2$logarea)

So it does seem that the September month could be included due to an outlier or a multi-day fire that was very large in area burnt each day. However, these fires still must take part in the prediction process so they will not be removed. December does not seem to be due to an outlier at all; there just seem to be a lot of medium sized fires in December. A possible reason for this could be people travelling for the holidays and then starting a forest fire.

Let’s take a look at it along with the residuals.

final.model <- lm(logarea ~ X + I(month=='dec') + I(month=='jun') + I(month=='mar') + I(month=='sep') + DMC + DC + temp + wind + rain2, data = ff2Train)
summary(final.model)

## 
## Call:
## lm(formula = logarea ~ X + I(month == "dec") + I(month == "jun") + 
##     I(month == "mar") + I(month == "sep") + DMC + DC + temp + 
##     wind + rain2, data = ff2Train)
## 
## Residuals:
##     Min      1Q  Median      3Q     Max 
## -1.8524 -1.0288 -0.5327  0.8570  5.2954 
## 
## Coefficients:
##                         Estimate Std. Error t value Pr(>|t|)   
## (Intercept)            0.0206717  0.3872725   0.053  0.95745   
## X                      0.0468845  0.0280374   1.672  0.09517 . 
## I(month == "dec")TRUE  2.1240498  0.6736137   3.153  0.00172 **
## I(month == "jun")TRUE -0.4664052  0.3834046  -1.216  0.22443   
## I(month == "mar")TRUE -0.3444337  0.3019958  -1.141  0.25467   
## I(month == "sep")TRUE  0.5239788  0.1851031   2.831  0.00485 **
## DMC                    0.0033459  0.0015441   2.167  0.03076 * 
## DC                    -0.0011847  0.0005994  -1.976  0.04872 * 
## temp                   0.0406331  0.0144827   2.806  0.00524 **
## wind                   0.0620272  0.0390185   1.590  0.11260   
## rain2TRUE             -0.8036091  0.5885446  -1.365  0.17279   
## ---
## Signif. codes:  0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1
## 
## Residual standard error: 1.391 on 457 degrees of freedom
## Multiple R-squared:  0.06509,	Adjusted R-squared:  0.04463 
## F-statistic: 3.182 on 10 and 457 DF,  p-value: 0.0005814

We see that our $R^2_a$ hasn’t changed much, but the model p-value has decreased significantly down to about 0.0006. Our test MAE is 1.155, which hinders our predictive power.

xyplot(rstudent(final.model) ~ fitted(final.model),
  xlab = "Fitted Values",
  ylab = "Residuals",
  panel = function(x, y, ...)
  {
    panel.grid(h = -1, v = -1)
    panel.abline(h = 0)
    panel.xyplot(x, y, ...)
  }
)

The diagonal (almost) solid line in the studentized residual plot is from the large number of 0’s in the response variable. We seem to have an issue with variance, but we have transformed this to the best of our abilities within the linear framework. Possible future work can be done with censor models and zero-inflated models.

newdata = data.frame(X=5, month="dec", DMC = 150, DC = 550, temp=15, wind = 7, rain2 = "TRUE")
predict(final.model, newdata, interval = "predict")

##        fit        lwr      upr
## 1 2.469529 -0.7508781 5.689936

Here I have a 95% prediction interval for the case where a fire occurs on a rainy/windy Tuesday in December and it is 15 degrees celcius in the middle portion of Montesinho natural park. Our interval does contain 0, which means a fire would most likely burn a small - medium radius (recall these values are exponents since we took log transform of area).

error <- fitted(final.model) - ff2Train$logarea
RMSEtrain <- sqrt(mean((error)^2))
MAEtrain <- mean(abs(error))
cat("The train RMSE is", RMSEtrain)

## The train RMSE is 1.374602

cat("The train MAE is", MAEtrain)

## The train MAE is 1.122505

So what we see here is that the training RMSE is about 1.37 and the test RMSE was 1.39. This indicates that our model did not overfit the data, so there is still hope for our model’s predictive power.

Outliers Analysis

I obtain the studentizded deleted residuals and use the Bonferroni outlier test procedure with $\alpha$ = .01, and a Bonferroni critical value of $t(1 - \frac{\alpha}{2n}, n - p - 1)$ where $n=517$ and $p=10$. There are no outliers in the Y direction. Leverage values greater than $\frac{2p}{n}$ are considered outlying cases with regard to their X values. There are 41 outliers in the X direction.

rstu.fin <- rstudent(final.model)
rstu.fin.df <- data.frame(rstu.fin)

outy.fin <- rstu.fin > qt(1 - .01/1034, 517-11-1)
sum(outy.fin) # number of outliers in Y

hii <- hatvalues(final.model)
outx.fin <- hii > 20/517
sum(outx.fin) # number of outliers in X

cat("The cases of outliers in the X direction are", names(hii[sapply(20/517, function(x) hii > x)]))

## The cases of outliers in the X direction are 23 60 76 105 151 244 275 276 277 279 282 285 287 296 297 298 299 300 302 303 304 370 371 375 395 400 401 412 449 460 463 464 470 473 474 475 476 500 501 502 510

The largest influence comes from case #23.

inf.fin <- cbind(dffits(final.model), dfbetas(final.model), cooks.distance(final.model))
inf.fin23 <- data.frame(inf.fin[23,])
rownames(inf.fin23) <- c("DFFITS", "DBETAS Intercept", "DBETAS X", "DBETAS December", "DBETAS June", "DBETAS March", "DBETAS September", "DBETAS DMC", "DBETAS DC", "DBETAS temp", "DBETAS wind", "DBETAS Rain", "Cook's D")
inf.fin23

##                  inf.fin.23...
## DFFITS            -0.135341451
## DBETAS Intercept   0.044698669
## DBETAS X          -0.061124837
## DBETAS December    0.014030825
## DBETAS June        0.016267770
## DBETAS March       0.024003010
## DBETAS September  -0.080908361
## DBETAS DMC        -0.012632041
## DBETAS DC          0.025737627
## DBETAS temp       -0.013086998
## DBETAS wind       -0.072849752
## DBETAS Rain        0.016281335
## Cook's D           0.001663918

For this sized dataset the DBETAS and Cook’s Distance cutoff is 1, so we have no problems here.

I believe that the biggest take-away here can be seen in the estimated $\beta$ coefficients. For instance, in the variable temp we see that a 1 degree increase in temperature is associated with a multiplicative change of $e^{\beta_{temp}} = 1.03623$ in the median of area burnt. We’ve also found significance amongst the meteorological variables DMC - Duff Moisture Code (DMC), DC - Drought Code (DC), which could be useful to park rangers if they have constant access to these features. More research needs to be conducted on the occurence of forest fires in the month of December and September.

Forest Fires Linear Model Selection was originally published by Mike Chaykowsky at annotatoR on April 04, 2016.