Machine Learning on rdata.lu Blog | Data science with R

Teaching Luxembourgish to my computer

Wed, 14 Feb 2018 00:00:00 +0000

How we taught a computer to understand Luxembourguish

Today we reveal a project that Kevin and myself have been working on for the past 2 months, Liss. Liss is a sentiment analysis artificial intelligence; you can let Liss read single words or whole sentences, and Liss will tell you if the overall sentiment is either positive or negative. Such tools are used in marketing, to determine how people perceive a certain brand or new products for instance. The originality of Liss, is that it works on Luxembourguish texts.

How to develop a basic sentiment analysis AI

Machine learning algorithms need data in order to get trained. Training a machine means showing it hundreds, thousands, or even more examples in order for the machine to learn patterns, and then, once the machine learned the patterns, we can use to machine for predictions. For example, we can train a machine learning algorithm to determine if a given picture is a picture of a cat or of a dog. For this, we show the machine thousands of pictures of cats and dogs, until the machine has learned some patterns. For example, the machine will learn that cats are on average smaller than dogs, and have eyes that look more like almonds unlike dogs. It is not always (albeit possible) to know which patterns, or features, the machine is using to learn the difference between cats and dogs. Then, once we show the machine a new picture, it will be able to predict, with a certain confidence, that the picture is of a dog, or a cat.

For sentiment analysis, you proceed in a similar manner; you show the algorithm thousands of texts that are either labeled as being positive or negative, and then, once you show the machine new texts, it will predict the sentiment. However, where can you find such example data, also called the training set to train your AI with? One solution is to scrape movie reviews. Movie reviews are texts written by humans, with a final score attached to it. A reviewer might write the following review about Interstellar:

“One of the best movies I have ever seen. The actors were great and the soundtrack amazing! 9/10”

Here, the AI will learn to associate the score of 9, very positive, to words such as best and amazing.

Another possible review, for, say, The Room could be:

“Wiseau put a lot of time and effort into this movie and it was utter crap. 2/10”

Here, the AI will learn to associate words such as crap with a low score, 2.

This is the gist of it, but of course feeding all this training examples to the AI requires a lot of thought and data pre-processing. This blog post will not deal with the technicalities, but more with how we tackled a serious problem: where do we find movies reviews written in Luxembourguish?

Your browser does not support the video tag.

Where we found Luxembourguish comments

Luxembourg is a small country with a small population. As such, the size of the internet in Luxembourguish is quite small. Add to that the fact that most people only speak Luxembourguish, and don’t know how to write it, and you got a big problem: as far as we are aware, it is not possible to find, say, movie reviews to train a machine on. So how did we tackle this problem? Because there were no comments in Luxembourguish laying around for us to work with, we scraped German comments. Linguistically, Luxembourg is very close to West German dialects, but with some French influences too. However, putting German and Luxembourguish sentences side by side clearly shows the similarities:

Luxembourguish:

“Hallo, wéi geet et dir?” (Hello, how are you?)
“Ganz gudd, merci!” (Very well, thank you!)

German:

“Wie geht es dir?”
“Ganz gut, danke!”

The only word in the Luxembourguish sentences that comes from French is merci, meaning thank you. Of course, this is a simple example, but if we look at more complicated sentences, for example from the Bible, we still see a lot of similarities between Luxembourguish and German:

Wéi d’Elisabeth am sechste Mount war, ass den Engel Gabriel vum Herrgott an eng Stad a Galiläa geschéckt ginn, déi Nazareth heescht,

bei eng Jongfra, déi engem Mann versprach war, dee Jouseph geheescht huet an aus dem Haus vum David war. Dës Jongfra huet Maria geheescht.

Den Engel ass bei si eragaang a sot: “Free dech, [Maria], ganz an der Gnod! Den Här ass mat dir.”

Und im sechsten Monat ward der Engel Gabriel gesandt von Gott in eine Stadt in Galiläa, die heißt Nazareth,

zu einer Jungfrau, die vertraut war einem Manne mit Namen Joseph, vom Hause David; und die Jungfrau hieß Maria.

Und der Engel kam zu ihr hinein und sprach: Gegrüßet seist du, Hochbegnadete! Der Herr ist mit dir!

-Lk 1,26-38

In these sentences, most differences come from the use of different tenses or different choices in what to include in the translation. For instance the first sentence in Luxembourguish starts with Wéi d’Elisabeth am sechste Mount war (As Elisabeth six months pregnant was) while in the German translation starts with Und im sechsten Monat (And in the sixth month). Same meaning, but the reference to Elisabeth is implicit.

So German and Luxembourguish are very close, but what good does that do us? Training a model on German movie reviews and trying to predict sentiments of texts in Luxembourguish will not work. So the solution was to translate the comments we scraped from German to Luxembourguish. We scraped 50000 comments; obviously we could not translate them ourselves, so we use Google’s translate api to do it. There’s a nice R package that makes it easy to work with this api, called {translate}.

The translation quality is not bad, but the longer and more complicated the comments, the more spotty is the translation; but overall the quality seems to be good enough. Let’s translate the German sentences from above back to Luxembourguish using Google Translate:

An am sechsten Mount huet de Engel Gabriel vu Gott geschéckt an eng Stad an Galiläa geschéckt, déi Nazareth genannt gëtt

zu engem Kiischte, dee vum Josephsjäreger bekannt gouf, aus dem Haus vum David; an den Numm vun der Jungfra Maria war .

De Engel ass si komm an huet gesot: “A Blann, geeschteg bass! Den Här ass mat iech!

The translation here is really not that great, but Bible verses are written in a pretty unusual way. What about a more standard text? Let’s try with the first paragraph on Luxembourg from the German version of Wikipedia:

German:

Das Großherzogtum Luxemburg ist ein Staat und eine Demokratie in Form einer parlamentarischen Monarchie im Westen Mitteleuropas. Es ist das letzte Großherzog- bzw. Großfürstentum (von einst zwölf) in Europa. Das Land gehört zum mitteldeutschen Sprachraum. Landessprache ist Luxemburgisch, Verwaltungs- und Amtssprachen sind Französisch, Deutsch und Luxemburgisch. Gemeinsam mit seinem Nachbarn Belgien und mit den Niederlanden bildet Luxemburg die Beneluxstaaten.

Luxembourguish (from Google Translate):

D’Groussherzogtum Lëtzebuerg ass e Staat an eng Demokratie an der Form vun enger parlamentarescher Monarchie an der Westeuropa. Et ass de leschte Grand-Duché oder Grand-Duché (e puer Joeren) an Europa.Dëst Land gehéiert zu der zentrale germanescher Sprooch. D’Nationalsprooch ass Lëtzebuergesch, administrativ an offizielle Sproochen sinn franséisch, däitsch a lëtzebuergesch. Zesumme mat sengem Noper Belgien an Holland ass Lëtzebuerg de Benelux.

English (from Google Translate):

The Grand Duchy of Luxembourg is a state and a democracy in the form of a parliamentary monarchy in western Central Europe. It is the last Grand Duchy or Grand Duchy (once twelve) in Europe. The country belongs to the central German language area. The national language is Luxembourgish, administrative and official languages are French, German and Luxembourgish. Together with its neighbor Belgium and the Netherlands, Luxembourg is the Benelux.

Knowing both German and Luxembourguish, I can tell that the translation is pretty good, and would require minimal human editing to make it perfect.

So we were pretty confident that this was a strategy that would be worth to try, so that’s what we did. We translated the comments using Google Translate api with the following R code:

Once we had translated everything, we started training a model.

The sentiment analysis tool we built

To train the model, we use the R programming language and Keras, a deep learning library. The comments had to be preprocessed, which is what took the most time. Then, building a model with Keras is quite simple, and we did not do anything special to it; actually, we did not spend much time tuning the model and to our astonishment, it worked quite well! To share the results with anyone, we also created a web app that you can access by clicking here.
Try to write, words, sentences, and most importantly give us feedback! See you for the next post.

Don’t hesitate to follow us on twitter @rdata_lu and to subscribe to our youtube channel.
You can also contact us if you have any comments or suggestions. See you for the next post!

Churn Analysis - Part 2: Indicators

Fri, 12 Jan 2018 00:00:00 +0000

Hello everyone,

In the last post we have decided to continue our study with the logistic regression. We have obtained the following ROC curve with an area under the curve (AUC) of 0.843.

Now we imagine 2 scenarios. In the first one, we suppose we have a large budget and we want to target many customers. In the second one, we have a restricted budget. Hence, we want to contact just 25% of the customers in our database.
For the first scenario, we will focus on the threshold value. We want to optimize the number of good classifications.
Then, in the second scenario, we will focus on the probability that each customer has to churn. We will sort our database by their probability to churn, we also call this probability, the score. Then we will select the top 25% customers of our database based on their probability to churn by using a lift curve.

Scenario 1: Threshold Optimization

Each customer has a score that corresponds to his probability to churn. Let’s see the score of the five first customers of our database.

head(pred_logistic,5)

##          1          2          3          4          5 
## 0.62513394 0.32512336 0.52812027 0.31273422 0.01264661

Originally, the threshold is 0.5. We predict a positive answer if the score is higher than 0.5 and a negative answer if the score is lower than 0.5.
It means for the 5 customers above that the model predicts a positive answer for customer 1 and customer 3 and a negative answer for the 3 other customers.

To optimize the threshold, we want to compute different statistical indicators (accuracy, precision, sensitivity, f1 and kappa) for different threshold values from 0.05 to 0.847 with a step value of 0.001. We don’t go above 0.847 because after this value, we just have negative answers.

if (!require("tidyverse")) install.packages("tidyverse")
library("tidyverse")
if (!require("caret")) install.packages("caret")
library("caret")
if (!require("e1071")) install.packages("e1071")
library("e1071")
comp = cbind.data.frame(answer = db_test$ChurnNum, 
                        pred=pred_logistic) %>%
        arrange(desc(pred))

indic_perf = function(x){
        compare = comp %>%
                mutate(pred = ifelse(pred>x,1,0))
         
        if(ncol(table(compare))>1){
        
        mat = confusionMatrix(table(compare), positive = "1")

        #acuracy 
        acc = mat$overall["Accuracy"]
        
        #Kappa
        kap = mat$overall["Kappa"]
        
        #sensitivity
        sen = mat$byClass["Sensitivity"]
        
        #F1
        f1_stat = mat$byClass["F1"]
        
        #Precision
        prec = mat$byClass["Precision"]
        

        }else{
                acc = NA
                prec = NA
                sen = NA 
                kap = NA
                f1_stat = NA
        }
        return(data.frame(threshold = x, accuracy = acc, 
                          precision = prec, sensitivity = sen, 
                          kappa = kap, f1= f1_stat))
}
indics = do.call(rbind, lapply(seq(0.05,0.95, by=0.001), 
                               indic_perf)) %>%
        filter(!is.na(accuracy))


if (!require("plotly")) install.packages("plotly")
library("plotly")
if (!require("IRdisplay")) install.packages("IRdisplay")
library("IRdisplay")

gather_indics = tidyr::gather(indics, variable, 
                      value, -threshold) %>%
  group_by(variable) %>%
  mutate(color =  (max(value) == value), 
         threshold = as.numeric(threshold) )
        
q=ggplot(gather_indics , aes(x= threshold, y=value)) +
        ggtitle("Indicator values by thresholds")+
        geom_point(aes(color = color), size=0.5) +
        facet_wrap(~variable, scales = 'free_x') +
        scale_color_manual(values = c(NA, "tomato")) +
        labs(x="thresholds", y=" ") +
        geom_line(color="navy") + theme_bw()+ 
        theme( legend.position="none")
offline(ggplotly(q),  width = '100%')

We draw a table where we show the maximum value for each indicator.

max_indics = indics %>%
        filter(accuracy == max(accuracy, na.rm=TRUE) | precision == max(precision, na.rm = TRUE) | sensitivity == max(sensitivity, na.rm = TRUE) | kappa == max(kappa, na.rm = TRUE) | f1 == max(f1, na.rm = TRUE) )

max_indics

##    threshold  accuracy   precision sensitivity       kappa          f1
## 1      0.050 0.5071157 0.978571429   0.3479365 0.199653582 0.513348946
## 2      0.051 0.5099620 0.978571429   0.3492670 0.202547963 0.514795679
## 3      0.052 0.5118596 0.978571429   0.3501597 0.204484542 0.515764706
## 4      0.053 0.5132827 0.978571429   0.3508323 0.205940664 0.516493874
## 5      0.054 0.5166034 0.978571429   0.3524116 0.209350638 0.518203310
## 6      0.055 0.5208729 0.978571429   0.3544631 0.213760484 0.520417854
## 7      0.056 0.5232448 0.978571429   0.3556132 0.216222936 0.521656354
## 8      0.057 0.5237192 0.978571429   0.3558442 0.216716506 0.521904762
## 9      0.339 0.7718216 0.751785714   0.5517693 0.475812739 0.636432351
## 10     0.584 0.8026565 0.471428571   0.6875000 0.437820539 0.559322034
## 11     0.585 0.8026565 0.469642857   0.6884817 0.437107483 0.558386412
## 12     0.799 0.7405123 0.023214286   1.0000000 0.033727638 0.045375218
## 13     0.800 0.7400380 0.021428571   1.0000000 0.031159002 0.041958042
## 14     0.801 0.7400380 0.021428571   1.0000000 0.031159002 0.041958042
## 15     0.802 0.7400380 0.021428571   1.0000000 0.031159002 0.041958042
## 16     0.803 0.7390892 0.017857143   1.0000000 0.026008938 0.035087719
## 17     0.804 0.7390892 0.017857143   1.0000000 0.026008938 0.035087719
## 18     0.805 0.7390892 0.017857143   1.0000000 0.026008938 0.035087719
## 19     0.806 0.7390892 0.017857143   1.0000000 0.026008938 0.035087719
## 20     0.807 0.7390892 0.017857143   1.0000000 0.026008938 0.035087719
## 21     0.808 0.7390892 0.017857143   1.0000000 0.026008938 0.035087719
## 22     0.809 0.7381404 0.014285714   1.0000000 0.020841748 0.028169014
## 23     0.810 0.7381404 0.014285714   1.0000000 0.020841748 0.028169014
## 24     0.811 0.7381404 0.014285714   1.0000000 0.020841748 0.028169014
## 25     0.812 0.7376660 0.012500000   1.0000000 0.018251704 0.024691358
## 26     0.813 0.7376660 0.012500000   1.0000000 0.018251704 0.024691358
## 27     0.814 0.7376660 0.012500000   1.0000000 0.018251704 0.024691358
## 28     0.815 0.7376660 0.012500000   1.0000000 0.018251704 0.024691358
## 29     0.816 0.7376660 0.012500000   1.0000000 0.018251704 0.024691358
## 30     0.817 0.7376660 0.012500000   1.0000000 0.018251704 0.024691358
## 31     0.818 0.7376660 0.012500000   1.0000000 0.018251704 0.024691358
## 32     0.819 0.7371917 0.010714286   1.0000000 0.015657346 0.021201413
## 33     0.820 0.7371917 0.010714286   1.0000000 0.015657346 0.021201413
## 34     0.821 0.7371917 0.010714286   1.0000000 0.015657346 0.021201413
## 35     0.822 0.7371917 0.010714286   1.0000000 0.015657346 0.021201413
## 36     0.823 0.7367173 0.008928571   1.0000000 0.013058663 0.017699115
## 37     0.824 0.7367173 0.008928571   1.0000000 0.013058663 0.017699115
## 38     0.825 0.7362429 0.007142857   1.0000000 0.010455645 0.014184397
## 39     0.826 0.7362429 0.007142857   1.0000000 0.010455645 0.014184397
## 40     0.827 0.7362429 0.007142857   1.0000000 0.010455645 0.014184397
## 41     0.828 0.7362429 0.007142857   1.0000000 0.010455645 0.014184397
## 42     0.829 0.7362429 0.007142857   1.0000000 0.010455645 0.014184397
## 43     0.830 0.7362429 0.007142857   1.0000000 0.010455645 0.014184397
## 44     0.831 0.7362429 0.007142857   1.0000000 0.010455645 0.014184397
## 45     0.832 0.7362429 0.007142857   1.0000000 0.010455645 0.014184397
## 46     0.833 0.7362429 0.007142857   1.0000000 0.010455645 0.014184397
## 47     0.834 0.7362429 0.007142857   1.0000000 0.010455645 0.014184397
## 48     0.835 0.7362429 0.007142857   1.0000000 0.010455645 0.014184397
## 49     0.836 0.7357685 0.005357143   1.0000000 0.007848280 0.010657194
## 50     0.837 0.7352941 0.003571429   1.0000000 0.005236558 0.007117438
## 51     0.838 0.7352941 0.003571429   1.0000000 0.005236558 0.007117438
## 52     0.839 0.7348197 0.001785714   1.0000000 0.002620469 0.003565062
## 53     0.840 0.7348197 0.001785714   1.0000000 0.002620469 0.003565062
## 54     0.841 0.7348197 0.001785714   1.0000000 0.002620469 0.003565062
## 55     0.842 0.7348197 0.001785714   1.0000000 0.002620469 0.003565062
## 56     0.843 0.7348197 0.001785714   1.0000000 0.002620469 0.003565062
## 57     0.844 0.7348197 0.001785714   1.0000000 0.002620469 0.003565062
## 58     0.845 0.7348197 0.001785714   1.0000000 0.002620469 0.003565062
## 59     0.846 0.7348197 0.001785714   1.0000000 0.002620469 0.003565062
## 60     0.847 0.7348197 0.001785714   1.0000000 0.002620469 0.003565062

We still have a lot of values so we decide to remove some rows. We keep the five most relevant thresholds : 0.057, 0.339, 0.584, 0.585 and 0.799.

max_indics %>%
        filter( threshold %in% c("0.057", "0.339", "0.584", "0.585", "0.799"))

##   threshold  accuracy  precision sensitivity      kappa         f1
## 1     0.057 0.5237192 0.97857143   0.3558442 0.21671651 0.52190476
## 2     0.339 0.7718216 0.75178571   0.5517693 0.47581274 0.63643235
## 3     0.584 0.8026565 0.47142857   0.6875000 0.43782054 0.55932203
## 4     0.585 0.8026565 0.46964286   0.6884817 0.43710748 0.55838641
## 5     0.799 0.7405123 0.02321429   1.0000000 0.03372764 0.04537522

At this stage, we can choose a threshold based on what we think is the most important. I suggest to continue with 0.339. Hence we have the following confusion matrix.

compare = comp %>%
                mutate(pred = ifelse(pred>0.339,1,0))
confusionMatrix(table(compare), positive = "1")

## Confusion Matrix and Statistics
## 
##       pred
## answer    0    1
##      0 1206  342
##      1  139  421
##                                           
##                Accuracy : 0.7718          
##                  95% CI : (0.7533, 0.7896)
##     No Information Rate : 0.638           
##     P-Value [Acc > NIR] : < 2.2e-16       
##                                           
##                   Kappa : 0.4758          
##  Mcnemar's Test P-Value : < 2.2e-16       
##                                           
##             Sensitivity : 0.5518          
##             Specificity : 0.8967          
##          Pos Pred Value : 0.7518          
##          Neg Pred Value : 0.7791          
##              Prevalence : 0.3620          
##          Detection Rate : 0.1997          
##    Detection Prevalence : 0.2657          
##       Balanced Accuracy : 0.7242          
##                                           
##        'Positive' Class : 1               
##

With a threshold of 0.339, we have the best f1 value and we have an acceptable level of accuracy, presicion and sensitivity (recall). Now let’s focus on the second scenario.

Scenario 2: Lift curve

Now we want to target a percentage of customers in our database. Let’s sort customers by their score. Then, we observe the churn rate in different percentile of our database. The best way to visualize the churn rate by percentile is to make a lift curve. It consists of sorting customers by their probability to leave and then separate them in percentiles. The higher their probability to leave, the higher will be their rank. It means that the 5th percentile represents the top 5% of our customers database that have the highest probability to leave following our model.

By the way, we know there is 26.54% of churn in our database. So if we have a random model, it is expected to have 26.54% of churn in each percentile. Hence we can compare the churn rate in our model and the random one.

fivtile = nrow(comp)/20
step = floor(fivtile * 1:20)
pct = sapply(step, function(x){
        return(mean(comp[1:x,1]))})

#paste(seq(from = 5, to = 100, by=5), "%",sep=" ")
lift = data.frame(label= seq(from = 5, to = 100, by=5), score = pct*100)
q = ggplot(lift, aes(x=label, y=score))+
        
        geom_bar(stat="identity",position="stack",color="navy", fill="navy")+ 
        ggtitle("Churn rate per cumulative percentile of \n customers  with the highest probability to leave")+
        coord_cartesian(xlim = c(5,100), ylim = c(0,100))+
        scale_y_continuous(breaks = seq(from = 0, to = 100, by=25), labels = function(x) paste0(x,"%", sep = ""))+
        scale_x_continuous(breaks = c(5, 25, 50, 75, 100), labels = function(x) paste0(x,"%", sep = ""))+
        labs(x="cumulative percentile ", y="churn rate") + 
        geom_line(aes(y=score[20]),linetype=2, size=1, color="tomato")+ 
        theme_minimal()+
        theme( 
                panel.grid.major.x = element_blank(),
                panel.grid.minor.x = element_blank(),
                plot.title = element_text(size=17,face="bold", hjust=0.5),
                axis.text.x = element_text(vjust=1),
                axis.ticks.x = element_blank(),
                axis.title.x = element_text(size=13, face="bold", vjust=-0.4),
                axis.title.y = element_text(size=13,face="bold")#,
                #strip.text.x = element_text(face="italic", size=11)
                )

print(q)

Our model is really efficient compared to the random model. We detect at least 2 times more churn using our model up to the 40th percentile. If we target 25% of our database, we observe that the churn rate is 61,67%.

Conclusion

In the first part we have cleaned the database, made an exploratory data analysis and then we have tested different models to finally choose the one with the biggest area under the curve (AUC), the logistic regression.
Then in the second part, we have imagined two different scenarios. In the first one, we focused on the threshold value and in the second one, we wanted to target just 25% of the database. Hence, in the first part, we found the optimized threshold value: 0.339. Then in the second part we have seen that our model is efficient on the top 25% customers of our database. The churn rate expected without model is 26.54% while the churn rate is 61.67% for our model.

I hope you enjoy reading this study. See you soon for the next post!
Don’t hesitate to contact me if you have any comments or suggestions.

Churn Analysis - Part 1: Model Selection

Thu, 04 Jan 2018 00:00:00 +0000

Hello everyone,

Today we will make a churn analysis with a dataset provided by IBM.
You can find the dataset here.

What is a churn?

We can shortly define customer churn (most commonly called “churn”) as customers that stop doing business with a company or a service. There are customer churns in different business area. In this post, we will focus on the telecom area. Here, we want to predict which customers will leave their current telecom provider. This type of studies are called churn analysis. It’s a trendy topic in customer relationship management (CRM) departments because it costs more money to find new customers than keeping the existing ones. So companies want to prevent them to leave.

How could we identify customers who are likely to leave?

To identify the customers, we need to have a database with data about the previous customers that churned. Using this data, we develop a model which identifies customers that have a profile close to the ones that already left.
To simulate an experiment where we want to predict if our customers will churn, we need to work with a partitioned database. The database has 2 parts, one part will be the training set. This will be used to create the model. The second part will be the testing set which will be used to evaluate our model.
In this case we know customer answers from the testing dataset so we can compare the model prediction with the true answers. Nevertheless in reality, we don’t know what will be the true answers. So we have to target mainly customers with high probability to churn. This probability is given by our model.

Let’s start

We import data and look at quick insight results. We encode the SeniorCitizen variable as a factor variable.

#to manipulate data
if (!require("tidyverse")) install.packages("tidyverse")
library("tidyverse")
path = "https://community.watsonanalytics.com/wp-content/uploads/2015/03/WA_Fn-UseC_-Telco-Customer-Churn.csv?cm_mc_uid=58920755505115141495567&cm_mc_sid_50200000=1514149556&cm_mc_sid_52640000=1514149556"
db_churn = read_csv(path)

#To see variables structure 
#str(db_churn)

db_churn$SeniorCitizen = as.factor(db_churn$SeniorCitizen)
summary(db_churn)

##   customerID           gender          SeniorCitizen   Partner         
##  Length:7043        Length:7043        0:5901        Length:7043       
##  Class :character   Class :character   1:1142        Class :character  
##  Mode  :character   Mode  :character                 Mode  :character  
##                                                                        
##                                                                        
##                                                                        
##                                                                        
##   Dependents            tenure      PhoneService       MultipleLines     
##  Length:7043        Min.   : 0.00   Length:7043        Length:7043       
##  Class :character   1st Qu.: 9.00   Class :character   Class :character  
##  Mode  :character   Median :29.00   Mode  :character   Mode  :character  
##                     Mean   :32.37                                        
##                     3rd Qu.:55.00                                        
##                     Max.   :72.00                                        
##                                                                          
##  InternetService    OnlineSecurity     OnlineBackup      
##  Length:7043        Length:7043        Length:7043       
##  Class :character   Class :character   Class :character  
##  Mode  :character   Mode  :character   Mode  :character  
##                                                          
##                                                          
##                                                          
##                                                          
##  DeviceProtection   TechSupport        StreamingTV       
##  Length:7043        Length:7043        Length:7043       
##  Class :character   Class :character   Class :character  
##  Mode  :character   Mode  :character   Mode  :character  
##                                                          
##                                                          
##                                                          
##                                                          
##  StreamingMovies      Contract         PaperlessBilling  
##  Length:7043        Length:7043        Length:7043       
##  Class :character   Class :character   Class :character  
##  Mode  :character   Mode  :character   Mode  :character  
##                                                          
##                                                          
##                                                          
##                                                          
##  PaymentMethod      MonthlyCharges    TotalCharges       Churn          
##  Length:7043        Min.   : 18.25   Min.   :  18.8   Length:7043       
##  Class :character   1st Qu.: 35.50   1st Qu.: 401.4   Class :character  
##  Mode  :character   Median : 70.35   Median :1397.5   Mode  :character  
##                     Mean   : 64.76   Mean   :2283.3                     
##                     3rd Qu.: 89.85   3rd Qu.:3794.7                     
##                     Max.   :118.75   Max.   :8684.8                     
##                                      NA's   :11

There are 3 numerical variables and 18 categorical variables. Then we observe the churn rate.

if (!require("janitor")) install.packages("janitor")
library("janitor")
prop = tabyl(db_churn$Churn)
prop

##   db_churn$Churn    n   percent
## 1             No 5174 0.7346301
## 2            Yes 1869 0.2653699

We realize that we have only 11 missing values in our dataset and they are all linked to the variable TotalCharges and none of them are churning. They represent only 0,16 % of our total observations. So we decide to remove them.

n_NA = db_churn %>%
        filter(is.na(TotalCharges)) %>%
        select(Churn)
#The next line give the percentage of missing values in our dataset
#100*nrow(n_NA)/nrow(db_churn)

#11 NA, that 0.16% of our database and none of them decode to churn
db_churn = db_churn %>%
        filter(!is.na(TotalCharges))

Now we can split our database in 2 parts. The training part and the testing part.

if (!require("caret")) install.packages("caret")
library("caret")
set.seed(7)
trainId = createDataPartition(db_churn$Churn, 
                       p=0.7, list=FALSE,times=1)
 
db_train = db_churn[trainId,]
db_test = db_churn[-trainId,]

As we have seen in summary(df), there are 3 numerical variables and they don’t have the same scale. Hence, we need to use a method to rescale them. First, we want to see their distribution.

gather_train =gather(db_train %>% 
               select(customerID, MonthlyCharges,TotalCharges, tenure),
               variable, value,
       -customerID)
ggplot(gather_train , aes(value)) + facet_wrap(~variable, scales = 'free_x') +
        geom_histogram() + theme_bw()

None of the variables on the graph above has a gaussian distribution, so we rescale them without standardization.

normalize = function(x) {
        result = (x - min(x, na.rm = TRUE)
                  ) / (max(x, na.rm = TRUE) - min(x, na.rm = TRUE))
        return(result)
}
norm.train = lapply(db_train %>% 
                    select(MonthlyCharges, TotalCharges, tenure),
                    normalize)
norm.train = do.call(cbind, norm.train) %>%
             as.data.frame()

Then we see in summary(df) that some variables have the following factors:

“Yes”
“No”
“No internet service” (or “No phone service”).

The third factor doesn’t give anymore no more informations so we recode the third factor in “No”.

factor.train = lapply(db_train %>% 
                      select(-customerID,-MonthlyCharges, 
                      -TotalCharges, -tenure), 
                      function(x){
        x = gsub("No internet service", "No", x)
        x = gsub("No phone service", "No", x)
        return(x)
})

factor.train = do.call(cbind, factor.train) %>% 
               as.data.frame()

db_train = cbind( customerID = db_train[,1], 
                  factor.train, norm.train)

Now that our training set is clean, we can estimate our train with 3 different models.

Decision tree
Random Forest
Logistic Regression

Decision tree

First, we make a decision tree with library("rpart"). We keep the original options.

if (!require("rpart")) install.packages("rpart")
library("rpart")
if (!require("rpart.plot")) install.packages("rpart.plot")
library("rpart.plot")

tree = rpart(Churn ~., data = db_train %>% 
                     select(-customerID), method="class")
rpart.plot(tree)

In the graphic above, we see the decision tree that groups observations by their variable values. A decision tree has 2 mains components, leaves and nodes.

Leaves represent a group of observation. For each leaf, an answer is given, “Yes” or “No”. Below these answers, figures represent the percentage of churn in a leaf and finally we see the percentage of total observations in the leaf.
Nodes show which varible where used to seperate a leaf in two sub-leaves

Contract is the main variable in the churn decision. It makes sense because it is harder to change telecom providers if customers have a long term contract than a month-to-month contract.

Random forest

Imagine that you want to buy Kendrick Lamar’s new album. You ask a friend if you should buy it. Your friend tells you: “Buy it”. But you are not sure that your friend and you share the same musical taste so you decide to ask the same question to 29 other friends. At the end you have 20 pros and 10 cons. By the majority you decide to buy it. Random forest works the same way!
Instead of using one tree, we will use many trees with different variable options to draw our model. Then for each observation, we choose their category by taking the majority vote of our different trees.

Here we use a 5-fold cross-validation method. We don’t have so many variables so we choose 5 different values to optimize the number of variables via tuneLenght.

if (!require("randomForest")) install.packages("randomForest")
library("randomForest")

ctrl = trainControl(method = "cv", number=5, 
                classProbs = TRUE, summaryFunction = twoClassSummary)

model.rf = train(Churn ~., data = db_train %>% select(-customerID),
                         method = "rf",
                         ntree = 75,
                         tuneLength = 5,
                         metric = "ROC",
                         trControl = ctrl)
        
model.rf

## Random Forest 
## 
## 4924 samples
##   19 predictor
##    2 classes: 'No', 'Yes' 
## 
## No pre-processing
## Resampling: Cross-Validated (5 fold) 
## Summary of sample sizes: 3939, 3939, 3939, 3940, 3939 
## Resampling results across tuning parameters:
## 
##   mtry  ROC        Sens       Spec     
##    2    0.8293918  0.9244813  0.4560674
##    7    0.8180692  0.8946058  0.4988535
##   12    0.8150772  0.8940526  0.4996227
##   17    0.8129159  0.8882434  0.4934924
##   23    0.8066348  0.8882434  0.4980843
## 
## ROC was used to select the optimal model using the largest value.
## The final value used for the model was mtry = 2.

Logistic regression

The logistic regression fits perfectly for a model that explains a binomial variable. We need to do 2 things. First, recode the churn variable as 0 for “No” and 1 for “Yes”. Second, we have to choose which variable combinations will the best explain the churn decision.

db_train$ChurnNum = ifelse(db_train$Churn == "Yes",1,0)
good_model = step(glm(ChurnNum ~.,data = db_train %>% 
                  select(-customerID, -Churn ), 
                  family=binomial(link='logit')), 
                  direction="both")

## Start:  AIC=4115.6
## ChurnNum ~ gender + SeniorCitizen + Partner + Dependents + PhoneService + 
##     MultipleLines + InternetService + OnlineSecurity + OnlineBackup + 
##     DeviceProtection + TechSupport + StreamingTV + StreamingMovies + 
##     Contract + PaperlessBilling + PaymentMethod + MonthlyCharges + 
##     TotalCharges + tenure
## 
##                    Df Deviance    AIC
## - Partner           1   4067.6 4113.6
## - TechSupport       1   4067.7 4113.7
## - Dependents        1   4067.9 4113.9
## - gender            1   4068.0 4114.0
## - OnlineSecurity    1   4068.1 4114.1
## - OnlineBackup      1   4068.2 4114.2
## - PhoneService      1   4068.3 4114.3
## <none>                  4067.6 4115.6
## - DeviceProtection  1   4069.8 4115.8
## - MonthlyCharges    1   4070.1 4116.1
## - SeniorCitizen     1   4070.5 4116.5
## - StreamingMovies   1   4071.0 4117.0
## - StreamingTV       1   4071.1 4117.1
## - InternetService   2   4073.7 4117.7
## - MultipleLines     1   4075.5 4121.5
## - PaperlessBilling  1   4076.3 4122.3
## - TotalCharges      1   4081.4 4127.4
## - PaymentMethod     3   4088.7 4130.7
## - Contract          2   4120.3 4164.3
## - tenure            1   4144.6 4190.6
## 
## Step:  AIC=4113.62
## ChurnNum ~ gender + SeniorCitizen + Dependents + PhoneService + 
##     MultipleLines + InternetService + OnlineSecurity + OnlineBackup + 
##     DeviceProtection + TechSupport + StreamingTV + StreamingMovies + 
##     Contract + PaperlessBilling + PaymentMethod + MonthlyCharges + 
##     TotalCharges + tenure
## 
##                    Df Deviance    AIC
## - TechSupport       1   4067.8 4111.8
## - gender            1   4068.0 4112.0
## - Dependents        1   4068.1 4112.1
## - OnlineSecurity    1   4068.2 4112.2
## - OnlineBackup      1   4068.2 4112.2
## - PhoneService      1   4068.3 4112.3
## <none>                  4067.6 4113.6
## - DeviceProtection  1   4069.8 4113.8
## - MonthlyCharges    1   4070.1 4114.1
## - SeniorCitizen     1   4070.5 4114.5
## - StreamingMovies   1   4071.1 4115.1
## - StreamingTV       1   4071.1 4115.1
## + Partner           1   4067.6 4115.6
## - InternetService   2   4073.8 4115.8
## - MultipleLines     1   4075.5 4119.5
## - PaperlessBilling  1   4076.4 4120.4
## - TotalCharges      1   4081.4 4125.4
## - PaymentMethod     3   4088.7 4128.7
## - Contract          2   4120.3 4162.3
## - tenure            1   4145.4 4189.4
## 
## Step:  AIC=4111.75
## ChurnNum ~ gender + SeniorCitizen + Dependents + PhoneService + 
##     MultipleLines + InternetService + OnlineSecurity + OnlineBackup + 
##     DeviceProtection + StreamingTV + StreamingMovies + Contract + 
##     PaperlessBilling + PaymentMethod + MonthlyCharges + TotalCharges + 
##     tenure
## 
##                    Df Deviance    AIC
## - gender            1   4068.2 4110.2
## - Dependents        1   4068.2 4110.2
## - OnlineSecurity    1   4068.3 4110.3
## <none>                  4067.8 4111.8
## - OnlineBackup      1   4070.6 4112.6
## - SeniorCitizen     1   4070.7 4112.7
## + TechSupport       1   4067.6 4113.6
## + Partner           1   4067.7 4113.7
## - PhoneService      1   4072.8 4114.8
## - DeviceProtection  1   4075.6 4117.6
## - PaperlessBilling  1   4076.5 4118.5
## - TotalCharges      1   4081.4 4123.4
## - MonthlyCharges    1   4083.9 4125.9
## - StreamingTV       1   4084.4 4126.4
## - StreamingMovies   1   4084.8 4126.8
## - PaymentMethod     3   4088.9 4126.9
## - MultipleLines     1   4093.8 4135.8
## - InternetService   2   4102.4 4142.4
## - Contract          2   4121.1 4161.1
## - tenure            1   4145.5 4187.5
## 
## Step:  AIC=4110.16
## ChurnNum ~ SeniorCitizen + Dependents + PhoneService + MultipleLines + 
##     InternetService + OnlineSecurity + OnlineBackup + DeviceProtection + 
##     StreamingTV + StreamingMovies + Contract + PaperlessBilling + 
##     PaymentMethod + MonthlyCharges + TotalCharges + tenure
## 
##                    Df Deviance    AIC
## - Dependents        1   4068.6 4108.6
## - OnlineSecurity    1   4068.7 4108.7
## <none>                  4068.2 4110.2
## - OnlineBackup      1   4071.0 4111.0
## - SeniorCitizen     1   4071.1 4111.1
## + gender            1   4067.8 4111.8
## + TechSupport       1   4068.0 4112.0
## + Partner           1   4068.1 4112.1
## - PhoneService      1   4073.2 4113.2
## - DeviceProtection  1   4075.9 4115.9
## - PaperlessBilling  1   4077.0 4117.0
## - TotalCharges      1   4081.8 4121.8
## - MonthlyCharges    1   4084.3 4124.3
## - StreamingTV       1   4084.8 4124.8
## - StreamingMovies   1   4085.2 4125.2
## - PaymentMethod     3   4089.3 4125.3
## - MultipleLines     1   4094.2 4134.2
## - InternetService   2   4102.8 4140.8
## - Contract          2   4121.4 4159.4
## - tenure            1   4145.9 4185.9
## 
## Step:  AIC=4108.63
## ChurnNum ~ SeniorCitizen + PhoneService + MultipleLines + InternetService + 
##     OnlineSecurity + OnlineBackup + DeviceProtection + StreamingTV + 
##     StreamingMovies + Contract + PaperlessBilling + PaymentMethod + 
##     MonthlyCharges + TotalCharges + tenure
## 
##                    Df Deviance    AIC
## - OnlineSecurity    1   4069.1 4107.1
## <none>                  4068.6 4108.6
## - OnlineBackup      1   4071.5 4109.5
## - SeniorCitizen     1   4072.1 4110.1
## + Dependents        1   4068.2 4110.2
## + gender            1   4068.2 4110.2
## + Partner           1   4068.4 4110.4
## + TechSupport       1   4068.5 4110.5
## - PhoneService      1   4073.7 4111.7
## - DeviceProtection  1   4076.4 4114.4
## - PaperlessBilling  1   4077.4 4115.4
## - TotalCharges      1   4082.5 4120.5
## - MonthlyCharges    1   4084.8 4122.8
## - StreamingTV       1   4085.3 4123.3
## - StreamingMovies   1   4085.8 4123.8
## - PaymentMethod     3   4090.0 4124.0
## - MultipleLines     1   4094.8 4132.8
## - InternetService   2   4103.5 4139.5
## - Contract          2   4123.1 4159.1
## - tenure            1   4147.3 4185.3
## 
## Step:  AIC=4107.13
## ChurnNum ~ SeniorCitizen + PhoneService + MultipleLines + InternetService + 
##     OnlineBackup + DeviceProtection + StreamingTV + StreamingMovies + 
##     Contract + PaperlessBilling + PaymentMethod + MonthlyCharges + 
##     TotalCharges + tenure
## 
##                    Df Deviance    AIC
## <none>                  4069.1 4107.1
## - SeniorCitizen     1   4072.5 4108.5
## + OnlineSecurity    1   4068.6 4108.6
## + Dependents        1   4068.7 4108.7
## + gender            1   4068.7 4108.7
## + Partner           1   4068.9 4108.9
## + TechSupport       1   4069.0 4109.0
## - OnlineBackup      1   4074.4 4110.4
## - PaperlessBilling  1   4078.1 4114.1
## - PhoneService      1   4080.8 4116.8
## - DeviceProtection  1   4081.9 4117.9
## - TotalCharges      1   4083.0 4119.0
## - PaymentMethod     3   4090.4 4122.4
## - StreamingTV       1   4101.9 4137.9
## - StreamingMovies   1   4102.5 4138.5
## - MultipleLines     1   4106.8 4142.8
## - MonthlyCharges    1   4106.9 4142.9
## - Contract          2   4123.4 4157.4
## - InternetService   2   4146.5 4180.5
## - tenure            1   4148.1 4184.1

It seems that 13 variables are enough for our model. Now let’s see coefficient estimates.

summary(good_model)

## 
## Call:
## glm(formula = ChurnNum ~ SeniorCitizen + PhoneService + MultipleLines + 
##     InternetService + OnlineBackup + DeviceProtection + StreamingTV + 
##     StreamingMovies + Contract + PaperlessBilling + PaymentMethod + 
##     MonthlyCharges + TotalCharges + tenure, family = binomial(link = "logit"), 
##     data = db_train %>% select(-customerID, -Churn))
## 
## Deviance Residuals: 
##     Min       1Q   Median       3Q      Max  
## -1.9012  -0.6731  -0.2923   0.7290   3.3888  
## 
## Coefficients:
##                                      Estimate Std. Error z value Pr(>|z|)
## (Intercept)                           0.60150    0.22743   2.645 0.008174
## SeniorCitizen1                        0.18366    0.09965   1.843 0.065337
## PhoneServiceYes                       1.04493    0.30762   3.397 0.000682
## MultipleLinesYes                      0.69549    0.11417   6.092 1.12e-09
## InternetServiceFiber optic            2.82341    0.32796   8.609  < 2e-16
## InternetServiceNo                    -2.87861    0.40080  -7.182 6.86e-13
## OnlineBackupYes                       0.25915    0.11367   2.280 0.022619
## DeviceProtectionYes                   0.41179    0.11563   3.561 0.000369
## StreamingTVYes                        0.92831    0.16380   5.667 1.45e-08
## StreamingMoviesYes                    0.92595    0.16194   5.718 1.08e-08
## ContractOne year                     -0.66307    0.12800  -5.180 2.22e-07
## ContractTwo year                     -1.24824    0.20212  -6.176 6.59e-10
## PaperlessBillingYes                   0.26399    0.08847   2.984 0.002847
## PaymentMethodCredit card (automatic) -0.18326    0.13747  -1.333 0.182523
## PaymentMethodElectronic check         0.30024    0.11163   2.690 0.007152
## PaymentMethodMailed check            -0.02901    0.13531  -0.214 0.830262
## MonthlyCharges                       -8.02745    1.32045  -6.079 1.21e-09
## TotalCharges                          2.63684    0.72491   3.637 0.000275
## tenure                               -4.24828    0.52098  -8.154 3.51e-16
##                                         
## (Intercept)                          ** 
## SeniorCitizen1                       .  
## PhoneServiceYes                      ***
## MultipleLinesYes                     ***
## InternetServiceFiber optic           ***
## InternetServiceNo                    ***
## OnlineBackupYes                      *  
## DeviceProtectionYes                  ***
## StreamingTVYes                       ***
## StreamingMoviesYes                   ***
## ContractOne year                     ***
## ContractTwo year                     ***
## PaperlessBillingYes                  ** 
## PaymentMethodCredit card (automatic)    
## PaymentMethodElectronic check        ** 
## PaymentMethodMailed check               
## MonthlyCharges                       ***
## TotalCharges                         ***
## tenure                               ***
## ---
## Signif. codes:  0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1
## 
## (Dispersion parameter for binomial family taken to be 1)
## 
##     Null deviance: 5702.8  on 4923  degrees of freedom
## Residual deviance: 4069.1  on 4905  degrees of freedom
## AIC: 4107.1
## 
## Number of Fisher Scoring iterations: 6

Most of them are significants they have a p-value lower than 0.05. As we could expect, ContractOne year, ContractTwo year or a high value for the variable tenure reduce the probability to churn.

Now that we have our 3 models, we decide to test them on our testing dataset. But first, we need to apply the same transformations that we appliedd to the training set.

norm.test = lapply(db_test %>% select(MonthlyCharges,TotalCharges, tenure), normalize)
norm.test = do.call(cbind, norm.test) %>%
        as.data.frame()

factor.test = lapply(db_test %>% 
                     select(-customerID,-MonthlyCharges, 
                            -TotalCharges, -tenure), 
                     function(x){
        x = gsub("No internet service", "No", x)
        x = gsub("No phone service", "No", x)
        return(x)
})
factor.test = do.call(cbind, factor.test) %>% as.data.frame()


db_test = cbind( customerID = db_test[,1], factor.test , norm.test)
db_test$ChurnNum  = ifelse(db_test$Churn == "Yes", 1, 0)

if (!require("ROSE")) install.packages("ROSE")
library("ROSE")
pred_tree = predict(tree, db_test %>% 
                    select(-customerID), type = c("prob"))[,2]
pred_rf = predict(object=model.rf, db_test %>% 
                          select(-customerID), type='prob')[,2]
pred_logistic = predict(good_model, db_test, type="response")

roc_tree = roc.curve(response = db_test$ChurnNum, pred_tree, 
                   col = "#0d84da")
roc_rf = roc.curve(response = db_test$ChurnNum, pred_rf, 
                   col = "#ef0a30", add.roc=TRUE)
roc_logistic = roc.curve(response = db_test$ChurnNum, pred_logistic, 
                   col = "#45a163", add.roc=TRUE)

legend("bottomright", legend=c("Decision Tree", "Random Forest", 
                               "Logistic Regression"), 
       lwd = 2, col = c("#0d84da", "#ef0a30", "#45a163"))

The logistic regression gives the best model: a better true positive rate for less false positive observations.

In the next post we will focus on the different way to analyse results from the logistic regression.

Don’t hesitate to contact me if you have any comments or suggestions. See you for the next post.