Graph Set 1

# plotting graph 1
p1 <- model_data %>% 
  group_by(is_canceled, distribution_channel) %>% 
  summarise(
    num = n()
  ) %>% 
  group_by(distribution_channel) %>%
  mutate(
    prop = num/sum(num)
  ) %>% 
  ggplot()+
  geom_bar(aes(x=factor(distribution_channel,levels= rev(levels(distribution_channel))), y= prop, fill= is_canceled), stat= "identity")+
  theme(
  axis.text.x = element_blank(),
  axis.ticks = element_blank())+
  guides(fill=FALSE)+
  ylab("")+
  xlab("")+
  ggtitle("Distribution Channel")+
  coord_flip()+
  geom_hline(yintercept=0.6296, color = "black", size = 0.75)

# plotting graph 2
p2 <- model_data %>% 
  group_by(is_canceled, reserved_room_type) %>% 
  summarise(
    num = n()
  ) %>% 
  group_by(reserved_room_type) %>%
  mutate(
    prop = num/sum(num)
  ) %>% 
  ggplot()+
  geom_bar(aes(x=factor(reserved_room_type,levels= rev(levels(reserved_room_type))), y= prop, fill= is_canceled), stat= "identity")+ 
  theme(
  axis.text.x = element_blank(),
  axis.ticks = element_blank())+
  guides(fill=FALSE)+
  ylab("")+
  xlab("")+
  ggtitle("Room Type")+
  coord_flip()+
  geom_hline(yintercept=0.6296, color = "black", size= 0.75)

# plotting graph 3
p3 <- model_data %>% 
  group_by(is_canceled, customer_type) %>% 
  summarise(
    num = n()
  ) %>% 
  group_by(customer_type) %>%
  mutate(
    prop = num/sum(num)
  ) %>% 
  ggplot()+
  geom_bar(aes(x=factor(customer_type,levels= rev(levels(customer_type))), y= prop, fill= is_canceled), stat= "identity")+
  theme(
  axis.text.x = element_blank(),
  axis.ticks = element_blank())+
  ylab("")+
  xlab("")+
  ggtitle("Customer Type")+
  coord_flip()+
  theme(legend.position="bottom", legend.box = "horizontal",
        legend.background = element_rect(fill="lightgrey",
                                  size=0.5, linetype="solid", 
                                  colour ="black"))+
  geom_hline(yintercept=0.6296, color = "black", show.legend = TRUE, size=0.75)

# releveling, plotting graph 4
l.o <- c("Und", "SC", "FB", "HB", "BB")
p4 <- model_data %>% 
  group_by(is_canceled, meal) %>% 
  summarise(
    num = n()
  ) %>% 
  group_by(meal) %>%
  mutate(
    prop = num/sum(num)
  ) %>% 
  ungroup() %>% 
  mutate(
    meal = ifelse(meal == "Undefined", "Und", as.character(meal))
  ) %>% 
  ggplot()+
  geom_bar(aes(x= factor(meal, levels= l.o), y= prop, fill= is_canceled), stat= "identity")+
  theme(
  axis.text.x = element_blank(),
  axis.ticks = element_blank())+
  guides(fill=FALSE)+
  ylab("")+
  xlab("")+
  ggtitle("Meal Type")+
  coord_flip()+
  geom_hline(yintercept=0.6296, color = "black", size= 0.75)


## arrange plots
p <- ggarrange(p2, p1, p4, p3, 
          ncol=2,
          nrow=2)

p

The line in the graphs above represents the true split of customers that have not canceled (62.96%), in the modeling data.

These graphs show the proportion of features for the room type and meal type, as well as the distribution channel and the customer type. There are a few things that stand out:

• The room types all seem to hover around the true split of cancellations, however the room type “P” is always canceled.
  • This could be due to an extremely low number of bookings for this room type.
• Bookings made through Corporate, Direct, or GDS channels are typically kept, while TA/TO channels have roughly the usual proportion of cancelations.
  • However, the Undefined distribution channel is never canceled, again this could be due to an extremely low number of bookings through an undefined channel.
• Meal types all hover around the expected cancelation proportion, except for the “FB” or Full-Board type. Bookings made that have designated a Full-Board meal are typically canceled.
  • Also not that bookings with an Undefined meal type have the highest proportion of retained bookings.
• While Contract and Transient bookings hover around the estimated cancelation proportions, it is apparant that bookings made for groups are usually retained!
  • This could be a good marketing avenue, targeting or pushing ads for group bookings to help retain bookings.
  • The Transient-Party customer type also tends to retain their bookings significantly more than expected.

Graph Set 2

## p1 and p2
# market_segment, arrival_date_month
# plotting graph 2
p1 <- model_data %>% 
  group_by(is_canceled, market_segment) %>% 
  summarise(
    num = n()
  ) %>% 
  group_by(market_segment) %>%
  mutate(
    prop = num/sum(num)
  ) %>% 
  ggplot()+
  geom_bar(aes(x=market_segment, y= prop, fill= is_canceled), stat= "identity")+ 
  theme(
  axis.text.x = element_blank(),
  axis.ticks = element_blank())+
  guides(fill=FALSE)+
  ylab("")+
  xlab("")+
  ggtitle("Market Segment")+
  coord_flip()+
  geom_hline(yintercept=0.6296, color = "black", size= 0.75)
  
p2 <- model_data %>% 
  group_by(is_canceled, arrival_date_month) %>% 
  summarise(
    num = n()
  ) %>% 
  group_by(arrival_date_month) %>%
  mutate(
    prop = num/sum(num)
  ) %>% 
  ggplot()+
  geom_bar(aes(x=arrival_date_month, y= prop, fill= is_canceled), stat= "identity")+ 
  theme(
  axis.text.x = element_blank(),
  axis.ticks = element_blank())+
  guides(fill=FALSE)+
  ylab("")+
  xlab("")+
  ggtitle("Month of Arrival")+
  coord_flip()+
  geom_hline(yintercept=0.6296, color = "black", size= 0.75)

# getting mu for plot 3
## plotting plot 3
mu<- model_data %>% 
  subset(days_in_waiting_list> 0) %>% 
  group_by(is_canceled) %>% 
  summarise(
    mean = mean(days_in_waiting_list)
  )
p3 <- model_data %>% 
  subset(days_in_waiting_list> 0) %>% 
  ggplot(aes(days_in_waiting_list, color= is_canceled, fill= is_canceled)) +
  geom_density(alpha=0.6, show.legend = FALSE) + 
  geom_vline(xintercept=mu$mean[2], color= "blue", size= 0.75)+ 
  geom_vline(xintercept=mu$mean[1], color= "red", size= 0.75)+
  ylab("")+
  xlab("")+
  ggtitle("Days in Waiting List")


p4 <- model_data %>% 
  mutate(
    is_repeated_guest = ifelse(is_repeated_guest==1, "yes", "no")
  ) %>% 
  group_by(is_canceled, is_repeated_guest) %>% 
  summarise(
    num = n()
  ) %>% 
  group_by(is_repeated_guest) %>%
  mutate(
    prop = num/sum(num)
  ) %>% 
  ggplot()+
  geom_bar(aes(x=is_repeated_guest, y= prop, fill= is_canceled), stat= "identity")+
  theme(
  axis.text.x = element_blank(),
  axis.ticks = element_blank())+
  ylab("")+
  xlab("")+
  ggtitle("Repeated Guest")+
  coord_flip()+
  theme(legend.position="bottom", legend.box = "horizontal",
        legend.background = element_rect(fill="lightgrey",
                                  size=0.5, linetype="solid", 
                                  colour ="black"))+
  geom_hline(yintercept=0.6296, color = "black", show.legend = TRUE, size=0.75)


## arrange plots
p <- ggarrange(p2, p1, p3, p4,
          ncol=2,
          nrow=2)

p

The black line represents the true split of is_canceled in the model data (62.96%). While the blue and red line in the graph of ‘Days in Waiting List’ respresents the respective means.

It is also important to note that outliers or the distributions were changed, in order to get better insights.

From these graphs there is a good amount of information we can extract:

• The proportion of retained and canceled bookings seems to be relatively stable throughout the months.
  • However January has the highest proportion of retained bookins,
    • while June has the highest number of cancellations.
• The market segment of bookings has some clear differences in the proportion of retained and canceled bookings.
  • The Groups seems to be the only group far below the usualy 67% of reained bookings.
  • The Direct, Corporate, Complementary, and Aviation bookings tend to have the highest amount of retained bookings.
  • The TA/TO markets are right around the average proportion.
• The number of days a customer spends in a waiting list generally has better effects.
  • This graph was heavily modified, as shown before at least 75% of bookings spend 0 days in a waiting list, so this is looking at all number of days greater than 0 to get a better insight.
• It is clearly shown that if a booking was made by a repeated guest, they are much more likely to retain the current booking.
  • However, if they are not a repeated guest the proportion of retained bookings is as expected.

Graph Set 3

# getting mu for plot 1
## plotting plot 1
mu<- model_data %>% 
  group_by(is_canceled) %>% 
  summarise(
    mean = mean(adr)
  )
p1 <- model_data %>% 
  subset(adr >0 & adr < 320) %>% 
  ggplot(aes(adr, color= is_canceled, fill= is_canceled)) +
  geom_density(alpha=0.6, show.legend = FALSE) + 
  geom_vline(xintercept=mu$mean[2], color= "blue", size= 0.75)+ 
  geom_vline(xintercept=mu$mean[1], color= "red", size= 0.75)+
  ylab("")+
  xlab("")+
  ggtitle("Average Daily Rate")

# getting mu for plot 2
## plotting plot 2
mu<- model_data %>% 
  group_by(is_canceled) %>% 
  summarise(
    mean = mean(lead_time)
  )
p2 <- model_data %>% 
  subset(lead_time< 500) %>% 
  ggplot(aes(lead_time, color= is_canceled, fill= is_canceled)) +
  geom_density(alpha=0.6, show.legend = FALSE) + 
  geom_vline(xintercept=mu$mean[2], color= "blue", size= 0.75)+ 
  geom_vline(xintercept=mu$mean[1], color= "red", size= 0.75)+
  ylab("")+
  xlab("")+
  ggtitle("Lead Time")

p3 <- model_data %>%
  subset(total_of_special_requests < 5) %>% 
  ggplot(aes(total_of_special_requests, color= is_canceled, fill= is_canceled))+
  geom_density(alpha=0.6, show.legend = FALSE)+
  ylab("")+
  xlab("")+
  ggtitle("Total # of Special Requests")

p4 <- model_data %>%
  subset(required_car_parking_spaces <= 3) %>% 
  ggplot(aes(required_car_parking_spaces, color= is_canceled, fill= is_canceled))+
  geom_density(alpha=0.6)+
  ylab("")+
  xlab("")+
  ggtitle("Total # of Cars")+
  theme(legend.position="bottom", legend.box = "horizontal",
        legend.background = element_rect(fill="lightgrey",
                                  size=0.5, linetype="solid", 
                                  colour ="black"))



## arrange plots
p <- ggarrange(p1, p2, p3, p4,
          ncol=2,
          nrow=2)

p

The blue and red line in the above graphs respresent the respective means.

• The Average Daily Rate is nearly identical between canceled bookings, and retained bookings.
  • The extreme outliers were removed for this distribtuion, looking at ADRs’ above 0, and below 500.
• Lead times are typically lower for retained bookings, this could suggest that the sooner the booking, the more likely the customer is to retain that booking.
  • The outliers were removed for this distribution, looking at the Lead Times less than 500 days.
• Generally, bookings that require a special request are more likely to be retained, while if they do not require a special request, they are more likely to be canceled.
  • Outliers of requests more than 4 were excluded.
• The total numbers of cars dont really tend to lead towards any valuable information.
  • Outliers with cars more than 3 were removed.

Graph Set 4

p1 <- model_data %>%
  subset(stays_in_weekend_nights<=5) %>% 
  ggplot(aes(stays_in_weekend_nights, color= is_canceled, fill= is_canceled))+
  geom_density(alpha=0.6, show.legend = FALSE)+
  ylab("")+
  xlab("")+
  ggtitle("Total # of Weekend Nights")

p2 <- model_data %>%
  subset(stays_in_week_nights<=11) %>% 
  ggplot(aes(stays_in_week_nights, color= is_canceled, fill= is_canceled))+
  geom_density(alpha=0.6, show.legend = FALSE)+
  ylab("")+
  xlab("")+
  ggtitle("Total # of Week Nights")

p3 <- model_data %>%
  subset(booking_changes < 5) %>% 
  ggplot(aes(booking_changes, color= is_canceled, fill= is_canceled))+
  geom_density(alpha=0.6)+
  ylab("")+
  xlab("")+
  ggtitle("Total # of Booking Changes")+
  theme(legend.position="bottom", legend.box = "horizontal",
        legend.background = element_rect(fill="lightgrey",
                                  size=0.5, linetype="solid", 
                                  colour ="black"))


# getting plot 4
p4 <- model_data %>% 
  mutate(
    tp = adults + children + babies
  ) %>% 
  subset(tp < 6) %>% 
  ggplot(aes(tp, color= is_canceled, fill= is_canceled))+
  geom_density(alpha=0.6, show.legend = FALSE)+
  ylab("")+
  xlab("")+
  ggtitle("Total Party")

## arrange plots
p <- ggarrange(p2, p1, p4, p3,
          ncol=2,
          nrow=2)

p

We can notice that generally customers that booked on the weekends did not cancel their bookings. It is also apparent that bookings made with only two week nights were more often canceled than retained.

• This could suggest that it would be better to market towards weekend bookings, or bookings for more than 2 days, or bookings made for 1 day.

• The total number of party members has little effect on cancellations,

  • however, bookings made for 1 party member are less likely to be canceled, while parties of 2 are more likely to be canceled.
  • Outliers of parties greater than 5 were removed.

• If a booking is changed, there is a much higher chance that the booking will be retained, while if there are no changes, there seems to be more cancelations.

  • Outliers of bookings greater than 4 were removed.

Base Model || Data Distribution

base <- model_data[sample(nrow(model_data)),]

base <- model_data %>% 
  distinct()

# getting train and test data
train <- base %>% 
  tt.split(percent = 0.8)

test <- base %>% 
  tt.split(train, dups=FALSE)

# checking distribution of data
print.ttDist(train, test, "is_canceled", base)

## Checking distribution of prediction variable 
## 
## in the training data... 
## 
##         total samples : 66744 
##      is_canceled == y : 18942    % : 28.38   dups : 0 
##      is_canceled == n : 47802    % : 71.62   dups : 0 
## 
## in the test data... 
## 
##         total samples : 16685 
##      is_canceled == y : 4674     % : 28.01   dups : 0 
##      is_canceled == n : 12011    % : 71.99   dups : 0 
## 
## in train + test data... 
## 
##         total samples : 83429 
##          dups between : 0 
## 
## in base data... 
## 
##         total samples : 83429 
##      is_canceled == y : 23616    % : 28.31   dups : 0 
##      is_canceled == n : 59813    % : 71.69   dups : 0

With typical models you do not want duplicates in the training data or the testing data, as this can lead to overfitting or lopsided weighting of Type 1 and Type 2 errors.

However because of the nature of the problem at hand, many bookings are going to be very similar to each other, and bookings might have the exact same features but also have different outcomes. In other words, two bookings that are exactly the same can just as easily be canceled, as it can be retained. This is why the final model will be ran using duplicates in the data.

For this first Base Model, the duplicates will be left out of the model, this will serve as a purpose to test how sensitive the model is to having duplicates in the training and testing data.

Base Model || Random Forest Call

This first model will be created with 501 trees. Typically an odd number of trees is used to break ties, as this current model will look for a majority vote of a 50% threshold.

# calling and getting random forest model
rf <- randomForest(is_canceled ~ ., data = train,
                   importance = TRUE,
                   ntree = 501)

print(rf)

## 
## Call:
##  randomForest(formula = is_canceled ~ ., data = train, importance = TRUE,      ntree = 501) 
##                Type of random forest: classification
##                      Number of trees: 501
## No. of variables tried at each split: 4
## 
##         OOB estimate of  error rate: 19.87%
## Confusion matrix:
##      y     n class.error
## y 9511  9431  0.49788829
## n 3830 43972  0.08012217

From the above summary we can gather some good information:

• The Out of Bag error rate is 19.87%
  • ie, the accuracy is 0.8013.
  • This means that the data the model validated itself on had a general accuracy of 78.7%.
• The False Negative rate is very high.
  • \(FNR=\frac{9431}{9431+43972}\approx0.1766\)
    • ie, the algorithm incorrectly guessed 17.6% of the bookings that did not cancel.
  • Also to note, out of the 18,942 samples the algorithm classified as being canceled, close to half of those were wrong!
• The TPR is also very high.
  • \(TPR=\frac{9511}{9511+3830}\approx0.71292\)
    • ie, the model correctly guessed 71.3% of bookings that did cancel.

A lower False Negative Rate is the ideal goal, in this model there were a total of 9,431 retained bookings that would have been missed due to misclassification! This could translate into less profits.

Base Model || Confusion Matrix

Lets run the testing data from before through this current model.

# getting predictions for test data
test$pred <- predict(rf, newdata = test)

# taking a look at the confusion matrix
confusionMatrix(test$pred, test$is_canceled)

## Confusion Matrix and Statistics
## 
##           Reference
## Prediction     y     n
##          y  2356   947
##          n  2318 11064
##                                           
##                Accuracy : 0.8043          
##                  95% CI : (0.7982, 0.8103)
##     No Information Rate : 0.7199          
##     P-Value [Acc > NIR] : < 2.2e-16       
##                                           
##                   Kappa : 0.4671          
##                                           
##  Mcnemar's Test P-Value : < 2.2e-16       
##                                           
##             Sensitivity : 0.5041          
##             Specificity : 0.9212          
##          Pos Pred Value : 0.7133          
##          Neg Pred Value : 0.8268          
##              Prevalence : 0.2801          
##          Detection Rate : 0.1412          
##    Detection Prevalence : 0.1980          
##       Balanced Accuracy : 0.7126          
##                                           
##        'Positive' Class : y               
## 

To note:

• The accuracy of the model, ran with this training data, is 0.8043,
  • which is better than the Out of Bag estimate from the model!
  • The FNR is:
    • \(FNR=\frac{947}{947+11064}\approx0.07884\)
    • This is much better than the OOB estimate!
  • The TPR is:
    • \(TPR=\frac{2356}{2356+2318}\approx0.50407\)

While this model seems to be preforming better with the testing data, as far as a lower FNR goes, the TPR also dropped much more than the initial findings! This could be indicitive of overfitting the model, meaning the algorithm is using too many trees.

Base Model || Hyperparameter Analysis

Lets take a look at the error graph to see if there is a more optimal number of trees.

plot(rf, main="Base Model, 80% Train w/ no Duplicates")
abline(v=51,col="black")
rf.legend <- if (is.null(rf$test$err.rate)){
  colnames(rf$err.rate)
  }else {colnames(rf$test$err.rate)}

legend("top", cex =0.5, legend=rf.legend, lty=c(1,2,3), col=c(1,2,3), horiz=T)

This graph shows a clear indication of what is happening with the tree size and the model. The goal is to choose a number of trees that is roughly right before the curves start to even out. This model was ran with 501 trees, which is shown at the far right of the graph, where the error rates are already stabilized.

The next model will be ran with 51 trees. This was partially done through pre-testing, however it can be seen that it lines up nicely with the graph above, the vertical line in the graph above is the point where 51 trees land on the graph.

Next lets take a look into the features of the model.

Base Model || Feature Importance

# explains feature impact on model
varImpPlot(rf,
           main = "Variable Importance for Base Model")

# actual values of importance
#importance(rf)

This charts explains two things, the Mean Decrease Accuracy, and the Mean Decrease Gini.

The Mean Decrease Accuracy describes the suitability of a variable being a parent node, or the main predictor. This means that the higher the Mean Decrease Accuracy, the more likely it is to be a parent node in a given Random Forest Tree.

The Mean Decrease Gini describes the purity of a variable, these variables tend to be a child node to a given tree in the Random Forest model. This means the higher the Mean Decrease Gini, the more likely this node is to be used after the Parent node.

Both of these metrics combined can give insight into how the variables, are effecting the models ability to correctly classify the predictor.

For example, the total_of_special_requests, lead_time, required_car_parking_spaces, and the previous_cancellations are the four most likely features to be the first split in a tree. While, lead_time and adr are the most likely variables to be used as a child node.

Conversley, the number of babies is almost never the first split in a given tree, while the number of days in the waiting list, number of babies, or the repeated guests are almost never child nodes in a given tree.

# number of occurances for each variable
used = varUsed(rf)

used.df <- model_data %>% 
  lapply(function(x){
    return (NA)
  })

used.df <- data.frame("feature"= names(used.df), "value"=NA)

for (i in 2:nrow(used.df)){
  used.df[i,2] = used[i-1]
}


used.df %>% 
  arrange(-value) %>% 
  hchart("bar", hcaes(feature, value)) %>% 
  hc_title(text= "Number of times the variable was split") %>% 
  hc_xAxis(title= list(text= "")) %>% 
  hc_yAxis(title = list(text = "Total Number of Splits"))

This graph shows the number of times a given feature was split, for all trees. As shown, adr and lead time have the highest frequency of splits utilized by the Random Forest Model. This could be due to these two variables being the only true continuous variables. Conversley, it can be notes that the deposit_type was, comparitavely, almost never split. This could mean that it has the least correlation to the prediction of a booking being canceled or retained.

Random Forest does a good job of not utilizing features, unless the algorithm feels that it will add value to the tree. Given this, I believe all the current features are fine to use for future modeling.

Model Two || Data Distribution

m.d <- model_data[sample(nrow(model_data)),]

m.d <- model_data

# getting train and test data
train <- m.d %>% 
  tt.split(percent = 0.6)

test <- m.d %>% 
  tt.split(train, dups=TRUE)

# checking distribution of data
print.ttDist(train, test, "is_canceled", model_data)

## Checking distribution of prediction variable 
## 
## in the training data... 
## 
##         total samples : 71632 
##      is_canceled == y : 26397    % : 36.85   dups : 11252 
##      is_canceled == n : 45235    % : 63.15   dups : 7500 
## 
## in the test data... 
## 
##         total samples : 31673 
##      is_canceled == y : 8839     % : 27.91   dups : 368 
##      is_canceled == n : 22834    % : 72.09   dups : 756 
## 
## in train + test data... 
## 
##         total samples : 103305 
##          dups between : 0 
## 
## in model_data data... 
## 
##         total samples : 119386 
##      is_canceled == y : 44220    % : 37.04   dups : 20604 
##      is_canceled == n : 75166    % : 62.96   dups : 15353

Here I took the original modeling data, again this is the raw data with dropped features and dropped NA values. There are a few new things to note about this data:

• This data will be a modest 60% Training amd 40% Testing Split.
  • The lower training data will be as a guide to test how sensitive the model is to a lower amount of training data, and a higher amount of testing data.
  • As shown, there are also duplicates in this training data, as well as minimal duplicates in the testing data
  • There are still no duplicates between the Training and Testing data.
    • This is important, as we want to know how the model will run with a brand new data points.

As for the Algorithm, it will also be ran with a few different hyperparameters:

• A 5 Fold Cross Validation will be implemented, to make up for the lower number of Training Samples.
  • This will mean that the algorithm will trained with five sets of 14,326 samples. Then it will take the average of these 5 sets to make a decision.
    • This is good because it enables the algorithm to self validate itself.
    • This can also be bad because it lowers the varience of unknown errors, which is an important factor when there are many unknowns playing into a decision.
• A threshold of 0.63 will be set.
  • This means that it will take a majority vote of 63% of the trees to be classified as yes.
    • This pushed the model to say that a booking will cancel less often, which should help keep the False Negative Rate and the True Positive Rate Lower.

Lets run the Algorithm

Second Model || Random Forest Call

# cross validation declaration
ctrl <- trainControl(method="cv",
                     number = 5,
                     summaryFunction=twoClassSummary,
                     classProbs=TRUE,
                     savePredictions = "final"
                     #summaryFunction = fourStats
                     )

# training model
rf <- train(is_canceled ~ .,
               data=train,
               method="rf",
               metric= "ROC",
               maximize= TRUE,
               ntree = 51,
               cutoff = c(.63, .37),
               trControl=ctrl)

print(rf)

## Random Forest 
## 
## 71632 samples
##    20 predictor
##     2 classes: 'y', 'n' 
## 
## No pre-processing
## Resampling: Cross-Validated (5 fold) 
## Summary of sample sizes: 57306, 57306, 57305, 57305, 57306 
## Resampling results across tuning parameters:
## 
##   mtry  ROC        Sens       Spec     
##    2    0.8131252  0.2474903  1.0000000
##   33    0.9118937  0.6599609  0.9553885
##   65    0.9091044  0.6635222  0.9520283
## 
## ROC was used to select the optimal model using the largest value.
## The final value used for the model was mtry = 33.

This summary output is a bit different than the previous, this is because we had to switch to using a different function from the “caret” package, as this will allow the implementation of Cross Validation.

This Algorithm was actually set to use the ROC parameter as a basis of preformance, as well as an attempt to choose a mtry value based off the optimal ROC.

It is shown that the best mtry value was 33, as the ROC had the highest value at this hyperparameter, landing at a ROC of 0.9119, which is very high!

Second Model || Confusion Matrix

# getting predictions for test data
test$pred <- predict(rf, newdata = test)

# taking a look at the confusion matrix
confusionMatrix(test$pred, test$is_canceled)

## Confusion Matrix and Statistics
## 
##           Reference
## Prediction     y     n
##          y  3214  1198
##          n  5625 21636
##                                         
##                Accuracy : 0.7846        
##                  95% CI : (0.78, 0.7891)
##     No Information Rate : 0.7209        
##     P-Value [Acc > NIR] : < 2.2e-16     
##                                         
##                   Kappa : 0.3676        
##                                         
##  Mcnemar's Test P-Value : < 2.2e-16     
##                                         
##             Sensitivity : 0.3636        
##             Specificity : 0.9475        
##          Pos Pred Value : 0.7285        
##          Neg Pred Value : 0.7937        
##              Prevalence : 0.2791        
##          Detection Rate : 0.1015        
##    Detection Prevalence : 0.1393        
##       Balanced Accuracy : 0.6556        
##                                         
##        'Positive' Class : y             
## 

Above shows the Confusion Matrix for the Second Model, as shown:

• The general accuracy of the model is 0.7846,
  • this is a drop in accuracy of 0.0197,
    • something that is expected, as we are attempting to skew the errors.
• The False Negative Rate is:
  • \(FNR=\frac{1198}{1198+21636}\approx0.05247\)
  • Which is a drop of 0.02637, from the Base Model,
    • this is a good sign, it means the error of classifying a booking as canceled is decreasing!
• The True Positive Rate is:
  • \(TPR=\frac{3214}{3214+5625}\approx0.36362\)
  • Which is a drop of 0.14045, from the Base Model
    • this is a steeper drop than the FNR

Overall a drop in accuracy of approximately 1.97%, however a loss of 0.0256 in the FNR. This is great as it means the models False Negative Rate is approaching 0!

Third Model || Data Distribution

For the split of training and testing data, I will implement a more aggressive approach. The train data will be 90% of the modeling data, while the test data will only be 10% of the modeling data.

m.d <- model_data[sample(nrow(model_data)),]

m.d <- model_data

# getting train and test data
train <- m.d %>% 
  tt.split(percent = 0.9)

test <- m.d %>% 
  tt.split(train, dups=TRUE)

# checking distribution of data
print.ttDist(train, test, "is_canceled", model_data)

## Checking distribution of prediction variable 
## 
## in the training data... 
## 
##         total samples : 107448 
##      is_canceled == y : 39803    % : 37.04   dups : 18234 
##      is_canceled == n : 67645    % : 62.96   dups : 13258 
## 
## in the test data... 
## 
##         total samples : 7540 
##      is_canceled == y : 2072     % : 27.48   dups : 25 
##      is_canceled == n : 5468     % : 72.52   dups : 42 
## 
## in train + test data... 
## 
##         total samples : 114988 
##          dups between : 0 
## 
## in model_data data... 
## 
##         total samples : 119386 
##      is_canceled == y : 44220    % : 37.04   dups : 20604 
##      is_canceled == n : 75166    % : 62.96   dups : 15353

As we can see, it is roughly the same distribution from before, however, the samples for the training data is much higher, and the samples for the testing data is conversely, much lower.

This will also serve as a purpose to see how the sensitivity of the model to more training data as a whole.

Third Model || Random Forest Call

For this Third Model the Folds for the Cross Validation technique will stay at 5, however the threshold will be adjusted to 0.8. This means that the model will classify a booking as being canceled if an 80% majority is reached, otherwise it will be classified as not canceled.

This will be done to get an idea of an extreme threshold, to get a basis of where the final thershold should be.

# cross validation declaration
ctrl <- trainControl(method="cv",
                     number = 5,
                     summaryFunction=twoClassSummary,
                     classProbs=TRUE,
                     savePredictions = "final"
                     )

# training model
rf <- train(is_canceled ~ .,
               data=train,
               method="rf",
               metric= "ROC",
               maximize= TRUE,
               ntree = 51,
               cutoff = c(.8, .2),
               trControl=ctrl)

print(rf)

## Random Forest 
## 
## 107448 samples
##     20 predictor
##      2 classes: 'y', 'n' 
## 
## No pre-processing
## Resampling: Cross-Validated (5 fold) 
## Summary of sample sizes: 85959, 85959, 85958, 85958, 85958 
## Resampling results across tuning parameters:
## 
##   mtry  ROC        Sens        Spec     
##    2    0.8085244  0.08464105  1.0000000
##   33    0.9210869  0.57123844  0.9842856
##   65    0.9185169  0.57603706  0.9830143
## 
## ROC was used to select the optimal model using the largest value.
## The final value used for the model was mtry = 33.

Again, the best chosen mtry value is 33, with a ROC of 0.92109. Which is the highest ROC out of all the models, however, lets check to more specific statistics.

Third Model || Confusion Matrix

Lets take the testing data, and run it through the model and take a look at the confusion matrix.

# getting predictions for test data
test$pred <- predict(rf, newdata = test)

# taking a look at the confusion matrix
confusionMatrix(test$pred, test$is_canceled)

## Confusion Matrix and Statistics
## 
##           Reference
## Prediction    y    n
##          y  414   89
##          n 1658 5379
##                                           
##                Accuracy : 0.7683          
##                  95% CI : (0.7586, 0.7778)
##     No Information Rate : 0.7252          
##     P-Value [Acc > NIR] : < 2.2e-16       
##                                           
##                   Kappa : 0.24            
##                                           
##  Mcnemar's Test P-Value : < 2.2e-16       
##                                           
##             Sensitivity : 0.19981         
##             Specificity : 0.98372         
##          Pos Pred Value : 0.82306         
##          Neg Pred Value : 0.76439         
##              Prevalence : 0.27480         
##          Detection Rate : 0.05491         
##    Detection Prevalence : 0.06671         
##       Balanced Accuracy : 0.59177         
##                                           
##        'Positive' Class : y               
## 

Above shows the Confusion Matrix for the Second Model, as shown:

• The general accuracy of the model is 0.7683,
  • this is a drop in accuracy of 0.036, from the Base Model,
    • something that is expected, as we are attempting to skew the errors.
• The False Negative Rate is:
  • \(FNR=\frac{89}{89+5379}\approx0.01628\)
  • Which is a drop of 0.06256, from the Base Model,
    • this is a good sign, it means the error of classifying a booking as canceled is decreasing!
• The True Positive Rate is:
  • \(TPR=\frac{414}{414+1658}\approx0.19981\)
  • Which is a drop of 0.30426, from the Base Model,
    • this is a much steeper drop than the FNR

Overall a drop in accuracy of approximately 3.6%, however a loss of 0.06256 in the FNR. This is great as it means the models False Negative Rate is approaching 0, however there is a big loss in the True Positive Rate, meaning the model is underestimating the number of canceled booking. This could translate to more money wasted, for little gain.

Fourth Model || Data Distribtuion

For this Fourth Model, the split of training and testing data will be the normal the typical 80% training and 20% testing.

m.d <- model_data[sample(nrow(model_data)),]

m.d <- model_data

# getting train and test data
train <- m.d %>% 
  tt.split(percent = 0.8)

test <- m.d %>% 
  tt.split(train, dups=TRUE)

# checking distribution of data
print.ttDist(train, test, "is_canceled", model_data)

## Checking distribution of prediction variable 
## 
## in the training data... 
## 
##         total samples : 95509 
##      is_canceled == y : 35271    % : 36.93   dups : 15865 
##      is_canceled == n : 60238    % : 63.07   dups : 11268 
## 
## in the test data... 
## 
##         total samples : 15332 
##      is_canceled == y : 4293     % : 28   dups : 83 
##      is_canceled == n : 11039    % : 72   dups : 196 
## 
## in train + test data... 
## 
##         total samples : 110841 
##          dups between : 0 
## 
## in model_data data... 
## 
##         total samples : 119386 
##      is_canceled == y : 44220    % : 37.04   dups : 20604 
##      is_canceled == n : 75166    % : 62.96   dups : 15353

As shown, there are duplicates in the training data, as well as the testing data. This is due to the nature of the problem at hand. One thing to note is that there are no duplicated between the two data sets. This means that every sample that gets ran through the confusion matrix, will be a sample not seen by the initial algorithm.

Fourth Model || Random Forest Call

As the previous threshold showed an extreme case, the idea goal is to find a happy medium. For this,

The model will also be ran with a 5 Fold Cross Validation, this is to directly see the impact of the new threshold.

# cross validation declaration
ctrl <- trainControl(method="cv",
                     number = 5,
                     summaryFunction=twoClassSummary,
                     classProbs=TRUE,
                     savePredictions = "final"
                     )

# training model
rf <- train(is_canceled ~ .,
               data=train,
               method="rf",
               metric= "ROC",
               maximize= TRUE,
               ntree = 51,
               cutoff = c(.7, .3),
               trControl=ctrl)

print(rf)

## Random Forest 
## 
## 95509 samples
##    20 predictor
##     2 classes: 'y', 'n' 
## 
## No pre-processing
## Resampling: Cross-Validated (5 fold) 
## Summary of sample sizes: 76408, 76408, 76407, 76406, 76407 
## Resampling results across tuning parameters:
## 
##   mtry  ROC        Sens       Spec     
##    2    0.8207087  0.1995978  1.0000000
##   33    0.9180675  0.6363869  0.9677114
##   65    0.9156848  0.6400727  0.9657525
## 
## ROC was used to select the optimal model using the largest value.
## The final value used for the model was mtry = 33.

Again, we see the optimal mtry value being 33, with a ROC of 0.91772. Showing a decrease of only 0.00583 from the Second Model!

This suggests that the overall accuracy should be roughly the same!

Fourth Model || Confusion Matrix

Lets take a look at the Confusion Matrix.

# getting predictions for test data
test$pred <- predict(rf, newdata = test)

# taking a look at the confusion matrix
confusionMatrix(test$pred, test$is_canceled)

## Confusion Matrix and Statistics
## 
##           Reference
## Prediction     y     n
##          y  1323   400
##          n  2970 10639
##                                           
##                Accuracy : 0.7802          
##                  95% CI : (0.7736, 0.7867)
##     No Information Rate : 0.72            
##     P-Value [Acc > NIR] : < 2.2e-16       
##                                           
##                   Kappa : 0.3328          
##                                           
##  Mcnemar's Test P-Value : < 2.2e-16       
##                                           
##             Sensitivity : 0.30818         
##             Specificity : 0.96376         
##          Pos Pred Value : 0.76785         
##          Neg Pred Value : 0.78176         
##              Prevalence : 0.28000         
##          Detection Rate : 0.08629         
##    Detection Prevalence : 0.11238         
##       Balanced Accuracy : 0.63597         
##                                           
##        'Positive' Class : y               
## 

Above shows the Confusion Matrix for the Fourth Model, as shown:

• The general accuracy of the model is 0.7828,
  • this is a drop in accuracy of 0.0215, from the Base Model,
  • however, only a drop of 0.0018 from the Second Model!
    • This is something that is expected, as we are attempting to skew the errors.
• The False Negative Rate is:
  • \(FNR=\frac{407}{407+10633}\approx0.03687\)
  • Which is a drop of 0.04197, from the Base Model,
  • however, a drop of 0.0156 from the Second Model!
    • This is a good sign, it means the error of classifying a booking as canceled is decreasing!
• The True Positive Rate is:
  • \(TPR=\frac{1293}{1293+2903}\approx0.30815\)
  • Which is a drop of 0.19592, from the Base Model.

this tells us that to get a decrease of 4.2%, for the number of incorrectly classified canceled bookings, we lost an overall accuracy of correctly classifying the canceled bookings by 19.6%.

• ie, to reduce the number of bookings that are incorrectly classified as being canceled, we gained a much bigger error of incorrectly classifying a booking as not canceled.
  • This could translate to spending more money on advertising to target the correct bookings, with the downfall of wasting money on bookings that are incorrectly classified.