Uplift – Generalized Lai’s Approach

Data Preparation

Loading the required packages.

library(Information)        # Package that contains the dataset.
library(splitstackshape)    # Package for stratified splitting.
library(caret)              # For some standard predictive analytics techniques.
library(uplift)             # For the evaluation measures.

The data is located in the package “Information”. We first load it in and remove the unwanted columns.

# Getting the data
data("train", package = "Information")
df <- train

# Removing unwanted columns
unwantedColumns <- c("UNIQUE_ID")
df <- df[ , -which(names(df) %in% unwantedColumns)]

We set up some extra variables to make it more readable in the next steps.

# Extra variables:
treatmentVariable <- "TREATMENT"
targetVariable = "PURCHASE"
targetNegativeClass <- "NO"     # Needed later on for factoring the target variable (only needed for certain techniques)
targetPositiveClass <- "YES"    # Needed later on for factoring the target variable (only needed for certain techniques)
predictors <- names(df)[(names(df) != targetVariable) & (names(df) != treatmentVariable)]

We check the distribution of both treatment/control and purchase/non-purchase.

prop.table(table(df[,targetVariable], df[,treatmentVariable]))
         0      1
  0 0.4045 0.3959
  1 0.0983 0.1013

We split the dataset into a training and testing set. We have to do a stratified split on both the treatment and target variables because we want to keep the same ratios of treatment/control and purchase/non-purchase.

# Splitting into train & test set
splitted <- stratified(df, c(treatmentVariable, targetVariable), 0.66, bothSets=TRUE)
df.train <- as.data.frame(splitted[[1]])
df.test <- as.data.frame(splitted[[2]])

Checking if the ratios are indeed more or less the same.

# Check to see if the ratio's treatment/control and responder/non-responder remain correct. 
prop.table(table(df.train[,targetVariable], df.train[,treatmentVariable]))
prop.table(table(df.test[,targetVariable], df.test[,treatmentVariable]))
   
             0          1
  0 0.40448417 0.39584911
  1 0.09831844 0.10134828
   
            0         1
  0 0.4045307 0.3959988
  1 0.0982642 0.1012062

Modeling Techniques

In total there will be three example techniques. These are:

  • The Two Model Approach (also known as the Naive Approach)
  • The Dummy Treatment Approach
  • Generalized Lai’s Approach

On this page we present Generalized Lai’s Approach.

Generalized Lai’s Approach

The idea of this technique is that we try to estimate the four classes: ‘persuadables’, ‘sure things’, ‘do-not-disturbs’ and ‘lost causes’ by using information from the four groups we know: ‘control responders’, ‘control non-responders’, ‘treatment responders’ and ‘treatment non-responders’.

Reference where this approach was used:

  • K. Kane, V. S. Y. Lo, and J. Zheng. “True-lift modeling: Comparison of methods”. In: J Market Analytics 2.4 (Dec. 2014), pp. 218–238.

Training the model

For this technique we focus on the four classes we know: ‘control responders’, ‘control non-responders’, ‘treatment responders’ and ‘treatment non-responders’. Therefore we make a new target variable.

# Specifying new target variable.
targetVariable.Multi <- "PURCHASE.Multi"
targetCR <- "CR"
targetCN <- "CN"
targetTR <- "TR"
targetTN <- "TN"

We factor the original and the new target factor for the next step.

## Factoring Target variable ##
df.train[,targetVariable] <- factor(df.train[,targetVariable])
levels(df.train[,targetVariable]) <- c(targetNegativeClass, targetPositiveClass)

## Factoring Target variable Multinominal ##
df.train[,targetVariable.Multi] <- NA
levels(df.train[,targetVariable.Multi]) <- c(targetTN, targetTR, targetCN, targetCR)

We fill in the new target variable for each observation in our dataset.

df.train[,targetVariable.Multi][df.train[,targetVariable] == "YES" & df.train[,treatmentVariable] == 1] <- targetTR # Treated responders
df.train[,targetVariable.Multi][df.train[,targetVariable] == "NO"  & df.train[,treatmentVariable] == 1] <- targetTN # Treated non-responders
df.train[,targetVariable.Multi][df.train[,targetVariable] == "YES" & df.train[,treatmentVariable] == 0] <- targetCR # Control responders
df.train[,targetVariable.Multi][df.train[,targetVariable] == "NO"  & df.train[,treatmentVariable] == 0] <- targetCN # Control non-responders

We can take a look at the probabilities for each class.

prop.table(table(df.train[,targetVariable.Multi]))
        CN         CR         TN         TR 
0.40448417 0.09831844 0.39584911 0.10134828

The actual training of the model. The implementation of the technique can be found in the R “Caret”-package.

gbmGrid <-  expand.grid(interaction.depth = c(1, 5, 9),
                      n.trees = (1:30)*50,
                      shrinkage = 0.1,
                      n.minobsinnode = 20)

## setting up training schema ##
ctrl <- trainControl(method = "cv",
                   number = 5,
                   classProbs = TRUE,
                   summaryFunction=multiClassSummary)

## Training the model
model <- train(df.train[,predictors],
             df.train[,targetVariable.Multi],
             method="gbm",
             trControl=ctrl)
Iter   TrainDeviance   ValidDeviance   StepSize   Improve
     1        1.3863             nan     0.1000    0.0941
     2        1.3296             nan     0.1000    0.0697
     3        1.2863             nan     0.1000    0.0499
     4        1.2536             nan     0.1000    0.0426
     5        1.2276             nan     0.1000    0.0312
     6        1.2071             nan     0.1000    0.0271
     7        1.1902             nan     0.1000    0.0215
     8        1.1768             nan     0.1000    0.0160
     9        1.1658             nan     0.1000    0.0129
    10        1.1562             nan     0.1000    0.0104
    20        1.1120             nan     0.1000    0.0024
    40        1.0859             nan     0.1000   -0.0007
    60        1.0710             nan     0.1000   -0.0014
    80        1.0608             nan     0.1000   -0.0005
   100        1.0515             nan     0.1000   -0.0009
   120        1.0435             nan     0.1000   -0.0009
   140        1.0361             nan     0.1000   -0.0007
   150        1.0330             nan     0.1000   -0.0010

Iter   TrainDeviance   ValidDeviance   StepSize   Improve
     1        1.3863             nan     0.1000    0.0951
     2        1.3284             nan     0.1000    0.0733
     3        1.2824             nan     0.1000    0.0543
     4        1.2463             nan     0.1000    0.0413
     5        1.2197             nan     0.1000    0.0339
     6        1.1981             nan     0.1000    0.0273
     7        1.1804             nan     0.1000    0.0218
     8        1.1649             nan     0.1000    0.0179
     9        1.1515             nan     0.1000    0.0127
    10        1.1414             nan     0.1000    0.0119
    20        1.0889             nan     0.1000    0.0013
    40        1.0526             nan     0.1000   -0.0005
    60        1.0313             nan     0.1000   -0.0003
    80        1.0135             nan     0.1000   -0.0019
   100        0.9973             nan     0.1000   -0.0013
   120        0.9848             nan     0.1000   -0.0015
   140        0.9731             nan     0.1000   -0.0021
   150        0.9671             nan     0.1000   -0.0017

Iter   TrainDeviance   ValidDeviance   StepSize   Improve
     1        1.3863             nan     0.1000    0.0961
     2        1.3258             nan     0.1000    0.0727
     3        1.2795             nan     0.1000    0.0540
     4        1.2440             nan     0.1000    0.0442
     5        1.2145             nan     0.1000    0.0334
     6        1.1915             nan     0.1000    0.0280
     7        1.1720             nan     0.1000    0.0219
     8        1.1558             nan     0.1000    0.0158
     9        1.1426             nan     0.1000    0.0143
    10        1.1306             nan     0.1000    0.0101
    20        1.0734             nan     0.1000   -0.0004
    40        1.0259             nan     0.1000   -0.0023
    60        0.9959             nan     0.1000   -0.0014
    80        0.9707             nan     0.1000   -0.0012
   100        0.9498             nan     0.1000   -0.0015
   120        0.9313             nan     0.1000   -0.0021
   140        0.9125             nan     0.1000   -0.0027
   150        0.9043             nan     0.1000   -0.0012

Iter   TrainDeviance   ValidDeviance   StepSize   Improve
     1        1.3863             nan     0.1000    0.0907
     2        1.3296             nan     0.1000    0.0713
     3        1.2875             nan     0.1000    0.0536
     4        1.2531             nan     0.1000    0.0413
     5        1.2264             nan     0.1000    0.0330
     6        1.2050             nan     0.1000    0.0255
     7        1.1880             nan     0.1000    0.0192
     8        1.1752             nan     0.1000    0.0174
     9        1.1638             nan     0.1000    0.0136
    10        1.1547             nan     0.1000    0.0108
    20        1.1113             nan     0.1000    0.0016
    40        1.0856             nan     0.1000    0.0000
    60        1.0708             nan     0.1000   -0.0003
    80        1.0602             nan     0.1000   -0.0012
   100        1.0500             nan     0.1000   -0.0014
   120        1.0429             nan     0.1000   -0.0008
   140        1.0363             nan     0.1000   -0.0010
   150        1.0325             nan     0.1000   -0.0014

Iter   TrainDeviance   ValidDeviance   StepSize   Improve
     1        1.3863             nan     0.1000    0.0965
     2        1.3280             nan     0.1000    0.0728
     3        1.2835             nan     0.1000    0.0554
     4        1.2477             nan     0.1000    0.0439
     5        1.2199             nan     0.1000    0.0344
     6        1.1967             nan     0.1000    0.0272
     7        1.1783             nan     0.1000    0.0220
     8        1.1634             nan     0.1000    0.0168
     9        1.1515             nan     0.1000    0.0126
    10        1.1409             nan     0.1000    0.0108
    20        1.0905             nan     0.1000    0.0010
    40        1.0530             nan     0.1000   -0.0008
    60        1.0301             nan     0.1000   -0.0004
    80        1.0113             nan     0.1000   -0.0015
   100        0.9957             nan     0.1000   -0.0019
   120        0.9820             nan     0.1000   -0.0013
   140        0.9701             nan     0.1000   -0.0022
   150        0.9647             nan     0.1000   -0.0013

Iter   TrainDeviance   ValidDeviance   StepSize   Improve
     1        1.3863             nan     0.1000    0.0950
     2        1.3265             nan     0.1000    0.0752
     3        1.2801             nan     0.1000    0.0571
     4        1.2423             nan     0.1000    0.0445
     5        1.2133             nan     0.1000    0.0337
     6        1.1892             nan     0.1000    0.0287
     7        1.1691             nan     0.1000    0.0210
     8        1.1526             nan     0.1000    0.0142
     9        1.1403             nan     0.1000    0.0142
    10        1.1293             nan     0.1000    0.0093
    20        1.0723             nan     0.1000   -0.0011
    40        1.0262             nan     0.1000   -0.0015
    60        0.9968             nan     0.1000   -0.0020
    80        0.9725             nan     0.1000   -0.0014
   100        0.9502             nan     0.1000   -0.0019
   120        0.9296             nan     0.1000   -0.0019
   140        0.9107             nan     0.1000   -0.0027
   150        0.9020             nan     0.1000   -0.0027

Iter   TrainDeviance   ValidDeviance   StepSize   Improve
     1        1.3863             nan     0.1000    0.0907
     2        1.3305             nan     0.1000    0.0694
     3        1.2887             nan     0.1000    0.0536
     4        1.2552             nan     0.1000    0.0419
     5        1.2302             nan     0.1000    0.0334
     6        1.2095             nan     0.1000    0.0231
     7        1.1934             nan     0.1000    0.0221
     8        1.1793             nan     0.1000    0.0161
     9        1.1687             nan     0.1000    0.0132
    10        1.1597             nan     0.1000    0.0111
    20        1.1146             nan     0.1000    0.0010
    40        1.0892             nan     0.1000   -0.0009
    60        1.0741             nan     0.1000   -0.0016
    80        1.0628             nan     0.1000   -0.0008
   100        1.0528             nan     0.1000   -0.0009
   120        1.0449             nan     0.1000   -0.0002
   140        1.0383             nan     0.1000   -0.0010
   150        1.0356             nan     0.1000   -0.0013

Iter   TrainDeviance   ValidDeviance   StepSize   Improve
     1        1.3863             nan     0.1000    0.0911
     2        1.3281             nan     0.1000    0.0705
     3        1.2842             nan     0.1000    0.0552
     4        1.2505             nan     0.1000    0.0417
     5        1.2232             nan     0.1000    0.0337
     6        1.2004             nan     0.1000    0.0258
     7        1.1826             nan     0.1000    0.0235
     8        1.1667             nan     0.1000    0.0166
     9        1.1548             nan     0.1000    0.0141
    10        1.1437             nan     0.1000    0.0086
    20        1.0933             nan     0.1000    0.0005
    40        1.0583             nan     0.1000    0.0002
    60        1.0347             nan     0.1000   -0.0004
    80        1.0175             nan     0.1000   -0.0015
   100        1.0019             nan     0.1000   -0.0017
   120        0.9878             nan     0.1000   -0.0022
   140        0.9749             nan     0.1000   -0.0017
   150        0.9691             nan     0.1000   -0.0023

Iter   TrainDeviance   ValidDeviance   StepSize   Improve
     1        1.3863             nan     0.1000    0.0934
     2        1.3259             nan     0.1000    0.0709
     3        1.2798             nan     0.1000    0.0540
     4        1.2439             nan     0.1000    0.0424
     5        1.2159             nan     0.1000    0.0339
     6        1.1923             nan     0.1000    0.0241
     7        1.1735             nan     0.1000    0.0224
     8        1.1570             nan     0.1000    0.0179
     9        1.1431             nan     0.1000    0.0130
    10        1.1320             nan     0.1000    0.0111
    20        1.0765             nan     0.1000   -0.0011
    40        1.0315             nan     0.1000   -0.0010
    60        1.0014             nan     0.1000   -0.0021
    80        0.9761             nan     0.1000   -0.0022
   100        0.9542             nan     0.1000   -0.0028
   120        0.9358             nan     0.1000   -0.0021
   140        0.9181             nan     0.1000   -0.0020
   150        0.9094             nan     0.1000   -0.0028

Iter   TrainDeviance   ValidDeviance   StepSize   Improve
     1        1.3863             nan     0.1000    0.0931
     2        1.3295             nan     0.1000    0.0699
     3        1.2870             nan     0.1000    0.0531
     4        1.2534             nan     0.1000    0.0417
     5        1.2278             nan     0.1000    0.0330
     6        1.2071             nan     0.1000    0.0261
     7        1.1896             nan     0.1000    0.0196
     8        1.1768             nan     0.1000    0.0163
     9        1.1650             nan     0.1000    0.0122
    10        1.1553             nan     0.1000    0.0091
    20        1.1127             nan     0.1000    0.0008
    40        1.0880             nan     0.1000    0.0002
    60        1.0732             nan     0.1000   -0.0008
    80        1.0612             nan     0.1000   -0.0014
   100        1.0521             nan     0.1000   -0.0009
   120        1.0436             nan     0.1000   -0.0007
   140        1.0364             nan     0.1000   -0.0015
   150        1.0332             nan     0.1000   -0.0013

Iter   TrainDeviance   ValidDeviance   StepSize   Improve
     1        1.3863             nan     0.1000    0.0927
     2        1.3278             nan     0.1000    0.0722
     3        1.2834             nan     0.1000    0.0553
     4        1.2486             nan     0.1000    0.0423
     5        1.2205             nan     0.1000    0.0311
     6        1.1987             nan     0.1000    0.0255
     7        1.1812             nan     0.1000    0.0218
     8        1.1657             nan     0.1000    0.0148
     9        1.1547             nan     0.1000    0.0142
    10        1.1440             nan     0.1000    0.0117
    20        1.0923             nan     0.1000    0.0005
    40        1.0557             nan     0.1000   -0.0015
    60        1.0337             nan     0.1000   -0.0022
    80        1.0159             nan     0.1000   -0.0015
   100        0.9992             nan     0.1000   -0.0013
   120        0.9863             nan     0.1000   -0.0020
   140        0.9724             nan     0.1000   -0.0015
   150        0.9659             nan     0.1000   -0.0012

Iter   TrainDeviance   ValidDeviance   StepSize   Improve
     1        1.3863             nan     0.1000    0.0939
     2        1.3259             nan     0.1000    0.0723
     3        1.2796             nan     0.1000    0.0545
     4        1.2440             nan     0.1000    0.0441
     5        1.2156             nan     0.1000    0.0357
     6        1.1915             nan     0.1000    0.0261
     7        1.1723             nan     0.1000    0.0198
     8        1.1565             nan     0.1000    0.0183
     9        1.1430             nan     0.1000    0.0145
    10        1.1316             nan     0.1000    0.0089
    20        1.0757             nan     0.1000   -0.0003
    40        1.0328             nan     0.1000    0.0006
    60        1.0012             nan     0.1000   -0.0017
    80        0.9771             nan     0.1000   -0.0026
   100        0.9552             nan     0.1000   -0.0019
   120        0.9357             nan     0.1000   -0.0027
   140        0.9184             nan     0.1000   -0.0027
   150        0.9102             nan     0.1000   -0.0024

Iter   TrainDeviance   ValidDeviance   StepSize   Improve
     1        1.3863             nan     0.1000    0.0914
     2        1.3299             nan     0.1000    0.0701
     3        1.2872             nan     0.1000    0.0535
     4        1.2539             nan     0.1000    0.0415
     5        1.2277             nan     0.1000    0.0335
     6        1.2062             nan     0.1000    0.0244
     7        1.1900             nan     0.1000    0.0197
     8        1.1763             nan     0.1000    0.0172
     9        1.1646             nan     0.1000    0.0130
    10        1.1552             nan     0.1000    0.0106
    20        1.1136             nan     0.1000    0.0024
    40        1.0886             nan     0.1000   -0.0004
    60        1.0724             nan     0.1000    0.0000
    80        1.0602             nan     0.1000   -0.0016
   100        1.0499             nan     0.1000   -0.0013
   120        1.0415             nan     0.1000   -0.0011
   140        1.0347             nan     0.1000   -0.0007
   150        1.0315             nan     0.1000   -0.0011

Iter   TrainDeviance   ValidDeviance   StepSize   Improve
     1        1.3863             nan     0.1000    0.0957
     2        1.3283             nan     0.1000    0.0706
     3        1.2844             nan     0.1000    0.0534
     4        1.2500             nan     0.1000    0.0446
     5        1.2216             nan     0.1000    0.0351
     6        1.1983             nan     0.1000    0.0262
     7        1.1799             nan     0.1000    0.0209
     8        1.1646             nan     0.1000    0.0170
     9        1.1519             nan     0.1000    0.0137
    10        1.1410             nan     0.1000    0.0103
    20        1.0911             nan     0.1000    0.0016
    40        1.0536             nan     0.1000   -0.0010
    60        1.0304             nan     0.1000   -0.0018
    80        1.0127             nan     0.1000   -0.0007
   100        0.9976             nan     0.1000   -0.0018
   120        0.9844             nan     0.1000   -0.0024
   140        0.9712             nan     0.1000   -0.0016
   150        0.9658             nan     0.1000   -0.0016

Iter   TrainDeviance   ValidDeviance   StepSize   Improve
     1        1.3863             nan     0.1000    0.0958
     2        1.3257             nan     0.1000    0.0737
     3        1.2798             nan     0.1000    0.0542
     4        1.2429             nan     0.1000    0.0452
     5        1.2135             nan     0.1000    0.0335
     6        1.1901             nan     0.1000    0.0259
     7        1.1707             nan     0.1000    0.0215
     8        1.1549             nan     0.1000    0.0183
     9        1.1407             nan     0.1000    0.0133
    10        1.1302             nan     0.1000    0.0100
    20        1.0738             nan     0.1000    0.0019
    40        1.0252             nan     0.1000   -0.0024
    60        0.9966             nan     0.1000   -0.0027
    80        0.9718             nan     0.1000   -0.0016
   100        0.9501             nan     0.1000   -0.0020
   120        0.9308             nan     0.1000   -0.0016
   140        0.9124             nan     0.1000   -0.0023
   150        0.9032             nan     0.1000   -0.0021

Iter   TrainDeviance   ValidDeviance   StepSize   Improve
     1        1.3863             nan     0.1000    0.0946
     2        1.3260             nan     0.1000    0.0725
     3        1.2803             nan     0.1000    0.0549
     4        1.2441             nan     0.1000    0.0427
     5        1.2149             nan     0.1000    0.0349
     6        1.1918             nan     0.1000    0.0265
     7        1.1733             nan     0.1000    0.0211
     8        1.1584             nan     0.1000    0.0192
     9        1.1453             nan     0.1000    0.0119
    10        1.1352             nan     0.1000    0.0116
    20        1.0783             nan     0.1000    0.0012
    40        1.0387             nan     0.1000   -0.0008
    60        1.0128             nan     0.1000   -0.0015
    80        0.9926             nan     0.1000   -0.0012
   100        0.9740             nan     0.1000   -0.0014
   120        0.9565             nan     0.1000   -0.0027
   140        0.9412             nan     0.1000   -0.0012
   150        0.9336             nan     0.1000   -0.0012

Testing the model

For the test-set we will also have to factor the new and original target variables.

## Factoring Target variable ##
df.test$targetVariableFactor <- factor(df.test[,targetVariable])
levels(df.test[,"targetVariableFactor"]) <- c(targetNegativeClass, targetPositiveClass)

## Factoring Target variable Multinominal ##
df.test[,targetVariable.Multi] <- NA
levels(df.test[,targetVariable.Multi]) <- c(targetTN, targetTR, targetCN, targetCR)

 

We fill in the new targetVariable for the test set.

df.test[,targetVariable.Multi][df.test[,targetVariable] == "YES" & df.test[,treatmentVariable] == 1] <- targetTR # Treated responders
df.test[,targetVariable.Multi][df.test[,targetVariable] == "NO"  & df.test[,treatmentVariable] == 1] <- targetTN # Treated non-responders
df.test[,targetVariable.Multi][df.test[,targetVariable] == "YES" & df.test[,treatmentVariable] == 0] <- targetCR # Control responders
df.test[,targetVariable.Multi][df.test[,targetVariable] == "NO"  & df.test[,treatmentVariable] == 0] <- targetCN # Control non-responders

We look at the percentages for each class.

print(prop.table(table(df.test[,targetVariable.Multi])))
numeric(0)

We use the model to get the probabilities of the observations for the test set.

modelProbs.GLAI <- extractProb(list(model),
                        testX = df.test[,predictors],
                        testY = df.test[,targetVariable.Multi])

modelProbs.GLAI.Results <- modelProbs.GLAI[modelProbs.GLAI$dataType == "Test",]

 

We then group together the predictions in a dataframe. The final uplift prediction is the probability of a person purchasing when receiving a treatment minus the probability of a person purchasing when not receiving a treatment.

predictions.GLAI = data.frame(TR=numeric(nrow(modelProbs.GLAI.Results)),
                       TN=numeric(nrow(modelProbs.GLAI.Results)),
                       CR=numeric(nrow(modelProbs.GLAI.Results)),
                       CN=numeric(nrow(modelProbs.GLAI.Results)))

predictions.GLAI$TR <- modelProbs.GLAI.Results[,targetTR]
predictions.GLAI$TN <- modelProbs.GLAI.Results[,targetTN]
predictions.GLAI$CR <- modelProbs.GLAI.Results[,targetCR]
predictions.GLAI$CN <- modelProbs.GLAI.Results[,targetCN]

To calculate the uplift we work as followed:

prob.C <- prop.table(table(df.test[,treatmentVariable]))[1]
prob.T <- prop.table(table(df.test[,treatmentVariable]))[2]
 
predictions.GLAI$Uplift <- ((predictions.GLAI$TR / prob.T) + (predictions.GLAI$CN / prob.C)) - 
                           ((predictions.GLAI$TN / prob.T) + (predictions.GLAI$CR / prob.C))

We can take a sneak peak at the predictions.

head(predictions.GLAI, n = 10)
TR TN CR CN Uplift
0.01739837 0.5549081 0.01937161 0.4083219 -0.3074860
0.02733136 0.3742628 0.02735325 0.5710526 0.3835909
0.01457331 0.3579958 0.01792322 0.6095077 0.4858861
0.01405517 0.2543534 0.01686263 0.7147288 0.9046757
0.01761401 0.5480271 0.01913139 0.4152275 -0.2790007
0.16454106 0.2700424 0.09628684 0.4691297 0.5293520
0.01906595 0.5908612 0.01857155 0.3715013 -0.4480833
0.08062222 0.2974049 0.04908996 0.5728829 0.6057601
0.04442787 0.5114788 0.15680909 0.2872842 -0.6798531
0.10852538 0.3950889 0.28665632 0.2097294 -0.7293475

Evaluating the model

Evaluation in uplift modeling is difficult as we cannot both test a person how he would react when receving the campaign or treatment and how he would react when not receiving the campaign or treatment. Therefore we have to look at it on a more aggregated basis.

NOTE: From hereon the code is adopted from the ‘Uplift’-package. Because we made a modification to the code we could not use the package directly. The package can be found here: https://cran.r-project.org/web/packages/uplift/index.html

We rank the uplift scores from high to low and add this information to a dataframe.

set.seed(123) # As there is a randomness is involved we set a seed to be able to reproduce results while testing.

mm <- cbind(uplift = predictions.GLAI[,5],
            target = df.test[,targetVariable], 
            treatment = df.test[,treatmentVariable],
            uplift_rank = rank(-predictions.GLAI[,5], ties.method = "random"))

Afterwards we divide the observation into 10 equal groups. The first group will contain the highest uplift scores, the second group the second highest-scores and so on.

There is a possibility of having observations with the same uplift score and there is a chance that these will not be part of the same group. If this is the case, the observations are assigned randomly.

groups <- 10
bk <- unique(quantile(mm[, 4], probs = seq(0, 1, 1 / groups)))
if ((length(bk)-1) != groups){
    warning("uplift: due to many ties in uplift predictions, the ties will be dealt with randomly ", groups)
}
mm <- cbind(mm, decile = cut(mm[, 4], breaks = bk, labels = NULL, include.lowest = TRUE))

# Previewing the dataframe
head(mm)
uplift target treatment uplift_rank decile
-0.3074860 0 0 2749 9
0.3835909 0 0 629 2
0.4858861 0 0 446 2
0.9046757 0 0 56 1
-0.2790007 0 0 2668 8
0.5293520 0 0 365 2

We have now ranked all the observations in the test according to uplift score and assigned them into a group (according to their ranking). The next step is to test the actual values like per group:

  • How many belonged to the treatment group?
  • How many to the control group?
  • How many of those have purchased?
n.y1_ct0 <- tapply(mm[mm[, 3] == 0, ][, 2], mm[mm[, 3] == 0, ][, 5], sum)  # Sum of people responding and not having received the treatment
n.y1_ct1 <- tapply(mm[mm[, 3] == 1, ][, 2], mm[mm[, 3] == 1, ][, 5], sum)  # Sum of people responding and having received the treatment
r.y1_ct0 <- tapply(mm[mm[, 3] == 0, ][, 2], mm[mm[, 3] == 0, ][, 5], mean) # Ratio of people responding and not having received the treatment
r.y1_ct1 <- tapply(mm[mm[, 3] == 1, ][, 2], mm[mm[, 3] == 1, ][, 5], mean) # Ratio of people responding and having received the treatment
n.ct0 <- tapply(mm[mm[, 3] == 0, ][, 2], mm[mm[, 3] == 0, ][, 5], length)  # Sum of people not having received the treatment
n.ct1 <- tapply(mm[mm[, 3] == 1, ][, 2], mm[mm[, 3] == 1, ][, 5], length)  # Sum of people having received the treatment

# In rare situations the ratio of a group can be non-existing because there are nog people in the treatment or control group.
# We set these to 0.
r.y1_ct0 <- ifelse(is.na(r.y1_ct0), 0, r.y1_ct0)
r.y1_ct1 <- ifelse(is.na(r.y1_ct1), 0, r.y1_ct1)

We group these statistics into a new dataframe and call it a performance-class.

df <- merge(cbind(n.y1_ct0, r.y1_ct0, n.ct0), cbind(n.y1_ct1, r.y1_ct1, n.ct1), by= "row.names", all = TRUE)             
    
df$Row.names <- as.numeric(df$Row.names)
df[, c(2, 4, 5, 7)][is.na(df[, c(2, 4, 5, 7)])] <- 0 # missing implies 0 counts

df$uplift = df$r.y1_ct1 - df$r.y1_ct0

df <- df[order(df$Row.names), ] # Ordering according to row-names.

perf <- cbind(group   = df$Row.names,
             n.ct1    = df$n.ct1,
             n.ct0    = df$n.ct0, 
             n.y1_ct1 = df$n.y1_ct1,
             n.y1_ct0 = df$n.y1_ct0,
             r.y1_ct1 = df$r.y1_ct1, 
             r.y1_ct0 = df$r.y1_ct0,
             uplift   = df$uplift)

class(perf) <- "performance"

perf
      group n.ct1 n.ct0 n.y1_ct1 n.y1_ct0  r.y1_ct1  r.y1_ct0       uplift
 [1,]     1   171   169       56       36 0.3274854 0.2130178  0.114467629
 [2,]     2   180   160       51       38 0.2833333 0.2375000  0.045833333
 [3,]     3   163   177       32       36 0.1963190 0.2033898 -0.007070812
 [4,]     4   170   170       33       28 0.1941176 0.1647059  0.029411765
 [5,]     5   176   164       26       22 0.1477273 0.1341463  0.013580931
 [6,]     6   158   181       21       27 0.1329114 0.1491713 -0.016259878
 [7,]     7   173   167       30       24 0.1734104 0.1437126  0.029697830
 [8,]     8   165   175       28       23 0.1696970 0.1314286  0.038268398
 [9,]     9   161   179       30       35 0.1863354 0.1955307 -0.009195323
[10,]    10   173   167       37       65 0.2138728 0.3892216 -0.175348725
attr(,"class")
[1] "performance"

Now that we have the new performance-class we can use it to produce some graphs.

Response Rate per Decile

The Response Rate Per Decile plot is a direct visualisation of the performance block. In theory the ideal plot is to have high response rates for the treatment group and low response rates in the control group in the first deciles and vice versa in the last deciles.

temp.df.treatment <- data.frame(Decile = seq(1:10), responseRate = perf[,6], Group = "treatment")
  temp.df.control <- data.frame(Decile = seq(1:10), responseRate = perf[,7], Group = "control")
  temp.df <- rbind(temp.df.treatment, temp.df.control)

require(ggplot2)
  require(scales)
  ggplot(temp.df, aes(x=Decile)) +
    geom_bar(stat="identity", aes(y=responseRate, fill = Group), position = "dodge") + 
    scale_y_continuous(labels=percent, limits=c(0,0.7), name="Response Rate (%)") +
    scale_x_discrete(name ="Deciles", limits=rep(1:10)) +
    theme(panel.grid.major = element_blank(),
          panel.grid.minor = element_blank(),
          panel.background = element_blank()) +
    theme(axis.line.x = element_blank(),
          axis.line.y = element_blank(),
          # axis.ticks.y = element_blank(), axis.text.y = element_blank(),
          axis.ticks.x = element_blank(), axis.text.x = element_text(size=15)) +
    ggtitle("Response Rate Per Decile - Two Model Approach") + theme(plot.title = element_text(face="bold",hjust = 0.5))
Response Rate per Decile - Two Model Approach
Uplift per Decile

By subtracting the response rates of the treatment groups with the response rates of the control groups we achieve the uplift per decile as seen in the next plot.

In [98]:

temp.df.uplift <- data.frame(Deciles = seq(1:10), Uplift = perf[,6] - perf[,7])
require(ggplot2)
require(scales)
ggplot(temp.df.uplift, aes(x=Deciles)) +
geom_bar(stat="identity", aes(y =Uplift, fill="red")) + 
scale_y_continuous(labels=percent, limits=c(-0.3,0.3), name="Uplift (Treatment - Control)") +
scale_x_discrete(name ="Deciles", limits=rep(1:10)) +
theme(panel.grid.major = element_blank(),
      panel.grid.minor = element_blank(),
      panel.background = element_blank()) +
theme(axis.line.x = element_blank(),
      axis.ticks.x = element_blank(), axis.text.x = element_text(size=20), axis.text.y = element_text(size=20)) +
ggtitle("Uplift Per Decile - Two Model Approach") + theme(plot.title = element_text(face="bold", size=20)) +
guides(fill=FALSE)

Uplift per Decile - GLAI

Qini Plot

One way of representing the performance of an uplift technique as a single number is through the Qini Qoefficient and the accompaning Qini Curve.

The idea is to calculate the incremental gains:

  • First the cumulitative sum of the treated and the control groups are calculated with respect to the total population in each group at the specified decile.
  • Afterwards we calculate the percentage of the total amount of people (both treatment and control) present in each decile.
r.cumul.y1_ct1 <- cumsum(perf[,"n.y1_ct1"]) / cumsum(perf[,"n.ct1"])
r.cumul.y1_ct0 <- cumsum(perf[,"n.y1_ct0"]) / cumsum(perf[,"n.ct0"])
deciles <- seq(1 / groups, 1, 1 / groups)

r.cumul.y1_ct1[is.na(r.cumul.y1_ct1)] <- 0
r.cumul.y1_ct0[is.na(r.cumul.y1_ct0)] <- 0

Per decile we can calculate the incremental gains for the model performance.

### Model Incremental gains 
inc.gains <- c(0.0, (r.cumul.y1_ct1 - r.cumul.y1_ct0) * deciles)

The overall incremental gains is basically the overal uplift. The random incremental gains is then the overall incremental gains divided by the amount of groups used.

In [101]:

### Overall incremental gains
overall.inc.gains <- sum(perf[, "n.y1_ct1"]) / sum(perf[, "n.ct1"]) - sum(perf[, "n.y1_ct0"]) / sum(perf[, "n.ct0"])

### Random incremental gains
random.inc.gains <- c(0, cumsum(rep(overall.inc.gains / groups, groups)))

Next up we compute the area underneath the incremental curve.

### Compute area under the model incremental gains (uplift) curve 
x <- c(0.0, seq(1 / groups, 1, 1 / groups))
y <- inc.gains

auuc <- 0
auuc.rand <- 0

for (i in 2:length(x)) {
auuc <- auuc + 0.5 * (x[i] - x[i-1]) * (y[i] + y[i-1])
}

We do the same for the area underneath the random incremental curve.

### Compute area under the random incremental gains curve
y.rand <- random.inc.gains

for (i in 2:length(x)) {
auuc.rand <- auuc.rand + 0.5 * (x[i] - x[i-1]) * (y.rand[i] + y.rand[i-1])
}

We then compute the difference between those two areas.

### Compute the difference between the areas (Qini coefficient)
Qini <- auuc - auuc.rand
miny <- 100 * min(c(random.inc.gains, inc.gains))
maxy <- 100 * max(c(random.inc.gains, inc.gains))

The last step is to plot the Qini-curve.

plot(inc.gains * 100 ~ c(0, seq(100 / groups, 100, 100 / groups)), type ="b",
   col = "blue", lty = 2, xlab = "Proportion of population targeted (%)", 
   ylab = "Cumulative incremental gains (pc pt)", ylim = c(miny, maxy))
lines(random.inc.gains * 100 ~ c(0, seq(100 / groups, 100, 100 / groups)), type = "l", col = "red", lty = 1)
legend("topright", c("Model", "Random"), 
     col=c("blue", "red"), lty=c(2,1))

Qini Curve - GLAI

Disclaimer

Sources used:

 

Prepared by Floris Devriendt