Please download and load data “Ad_Experiment.Rdata” from Canvas.
- Purchase: A dummy variable indicating whether the consumer eventually subscribed at Star Digital or not (= 0 if there was no purchase; = 1 if there was a purchase).
- Imp_1 - Imp_6: The number of impressions for each consumer at Website 1 to Website 6
- Test: a factor with 2 levels: “Control” and “Treatment”
load("Ad_Experiment.RData")
head(AdExp_Data)
## # A tibble: 6 x 9
## ID Purchase Test Imp_1 Imp_2 Imp_3 Imp_4 Imp_5 Imp_6
## <dbl> <dbl> <fct> <dbl> <dbl> <dbl> <dbl> <dbl> <dbl>
## 1 27 0 Treatment 0 0 0 0 0 1
## 2 126 0 Treatment 0 1 0 0 0 0
## 3 167 1 Treatment 0 0 0 1 0 0
## 4 195 1 Treatment 0 1 0 0 0 0
## 5 323 1 Control 0 10 0 0 0 0
## 6 365 0 Treatment 0 0 0 0 0 1
To get some variables for later use.
Get the no. of consumers in control vs. treatment group.
# N[1] - the no. of control cases;
# N[2] - the no. of treatment cases.
N <- table(AdExp_Data$Test)
N
##
## Control Treatment
## 2656 22647
Get two index vectors of consumers in treatment vs. control group.
# Consumers in the treatment group
Treatment <- which(AdExp_Data$Test == "Treatment")
# Consumers in the control group
Control <- which(AdExp_Data$Test == "Control")
Bootstrapping ATE (i.e., Expected Lift) and its CI’s
- Start bootstrapping with an “Unpooled” procedure. That is, we obtain two random samples for Treatment and Control group, respectively.
- Respectively for the treatment and control group, we obtain a random sample with the same sample size as the original data (\(N_{control}=N[1]=2656\) and \(N_{Treatment}=N[2]=22647\)) WITH replacement (! very important).
- This procedure will deal with the unequal group sizes and the sampling variations are taken into consideration.
- We will use a function at R \(sample(x, size, replace = T)\), where \(x\) is the vector to sample from, \(size\) is the number of elements to choose from \(x\) (for bootstrapping, this is set at \(length(x)\)), and \(replace=T\) points to sampling with replacement for bootstrapping.
#Start boostrapping with an "Unplooed" procedure
#set the seeds for replication; you may delete this line.
set.seed(123456789)
#the no. of bootstrapping samples; can be changed to other values
S <- 2000
# a vector to store boostrapped lift estimates
Lift <- rep(0,S)
for (i in 1:S) {
# To produce a bootstrappted data set:
# A random sample with the same sample size, sampled with replacement.
# Using the two indices variables "Treatment" and "Control".
# Sampling two vectors that are of same length as "Treatment" and "Control" with replacement.
Data.boot <- AdExp_Data[c(sample(Treatment,N[1],replace = T),
sample(Control,N[2],replace = T)),2:3]
# To calcualte the ATE for each bootstrapped sample: Data.boot
Lift[i] <- mean(Data.boot$Purchase[Data.boot$Test=="Treatment"]) -
mean(Data.boot$Purchase[Data.boot$Test=="Control"])
}
#Get the ATE and bootstrapped CIs
ATE <- mean(Lift)
# The 95% confidence interval
CI_95 <- quantile(Lift,c(.025,.975))
# The 90% confidence interval
CI_90 <- quantile(Lift,c(.05,.95))
#We can also plot "Lift" and the 90% and 95% CI's
hist(Lift,breaks = 100)
abline(v=c(CI_90,CI_95),
col=c("blue","blue","red","red"),
lty=rep(2,4),
lwd=rep(2,4))

Calcuating ROI of Online Display Ads
- If we believe that the ATE of \(0.0190\) is credible, we can then use the ATE (average Lift) to calcualte ROI for further reporting.
- The ROI calculation requires two values: 1) the profits from the conversions; and 2) the costs of online ads. As the costs are the payment for impressions (CPM), we use consumers in the treatment group (as the control group were served no Digital Star ads, we cannot calcuate the costs).
- The overall expected profits should be: \(Profits=ATE \times N_{Treatment} \times 60\), with €60 the CLV of one subscription (see page 3 of the case).
- The overall costs are from the CPM model or costs per thousand impressions. We use: \(Costs=\dfrac{Impressions_{1-5}}{1000} \times €25 + \dfrac{Impressions_{6}}{1000} \times €20\), as the CPM for Website 1-5 is €25 and Website 6 is €20 (see page 3 of the case).
# Sum up the impressions for treatment group consumers
Impressions <- colSums(AdExp_Data[Treatment,-c(1:3)])
# Different CPMs as shown above: Website 1-5 - 25 and Website 6 - 20
Costs <- sum(Impressions/1000*c(rep(25,5),20))
#The return is the number of people in treatment * the ATE (Lift) * 60 euros
Profits <- ATE*N[2]*60
# Calculate ROI: Return/Investment = (Profits-Costs)/Costs
ROI <- (Profits-Costs)/Costs
# Show final results
Results <- c(Costs,Profits,ROI)
names(Results) <- c("Costs","Profits","ROI")
Results
## Costs Profits ROI
## 4254.390000 25801.946657 5.064782
LS0tDQp0aXRsZTogJ0Nhc2UgSVY6IE1lYXN1cmluZyBPbmxpbmUgQWRzIEVmZmVjdGl2ZW5lc3MgYXQgU3RhciBEaWdpdGFsJw0Kb3V0cHV0Og0KICBodG1sX2RvY3VtZW50Og0KICAgIGRmX3ByaW50OiB0aWJibGUNCiAgICBjb2RlX2Rvd25sb2FkOiB5ZXMNCiAgICB0aGVtZTogY2VydWxlYW4NCiAgICB0b2M6IHllcw0KICAgIHRvY19mbG9hdDogeWVzDQogICAgbnVtYmVyX3NlY3Rpb25zOiBubw0KICBwZGZfZG9jdW1lbnQ6DQogICAgdG9jOiB5ZXMNCi0tLQ0KDQojIyMgKipQbGVhc2UgZG93bmxvYWQgYW5kIGxvYWQgZGF0YSAiQWRfRXhwZXJpbWVudC5SZGF0YSIgZnJvbSBDYW52YXMuKiogDQoqICoqUHVyY2hhc2UqKjogQSBkdW1teSB2YXJpYWJsZSBpbmRpY2F0aW5nIHdoZXRoZXIgdGhlIGNvbnN1bWVyIGV2ZW50dWFsbHkgc3Vic2NyaWJlZCBhdCBTdGFyDQpEaWdpdGFsIG9yIG5vdCAoPSAwIGlmIHRoZXJlIHdhcyBubyBwdXJjaGFzZTsgPSAxIGlmIHRoZXJlIHdhcyBhIHB1cmNoYXNlKS4NCiogKipJbXBfMSAtIEltcF82Kio6IFRoZSBudW1iZXIgb2YgaW1wcmVzc2lvbnMgZm9yIGVhY2ggY29uc3VtZXIgYXQgV2Vic2l0ZSAxIHRvIFdlYnNpdGUgNg0KKiAqKlRlc3QqKjogYSBmYWN0b3Igd2l0aCAyIGxldmVsczogIkNvbnRyb2wiIGFuZCAiVHJlYXRtZW50Ig0KDQpgYGB7cn0NCmxvYWQoIkFkX0V4cGVyaW1lbnQuUkRhdGEiKQ0KaGVhZChBZEV4cF9EYXRhKQ0KYGBgDQoNCiMjIyAqKlRvIGdldCBzb21lIHZhcmlhYmxlcyBmb3IgbGF0ZXIgdXNlLioqDQpHZXQgdGhlIG5vLiBvZiBjb25zdW1lcnMgaW4gY29udHJvbCB2cy4gdHJlYXRtZW50IGdyb3VwLiANClwNCmBgYHtyfQ0KIyBOWzFdIC0gdGhlIG5vLiBvZiBjb250cm9sIGNhc2VzOyANCiMgTlsyXSAtIHRoZSBuby4gb2YgdHJlYXRtZW50IGNhc2VzLg0KTiA8LSB0YWJsZShBZEV4cF9EYXRhJFRlc3QpIA0KTg0KYGBgDQpcDQpHZXQgdHdvIGluZGV4IHZlY3RvcnMgb2YgY29uc3VtZXJzIGluIHRyZWF0bWVudCB2cy4gY29udHJvbCBncm91cC4gDQpgYGB7cn0NCiMgQ29uc3VtZXJzIGluIHRoZSB0cmVhdG1lbnQgZ3JvdXANClRyZWF0bWVudCA8LSB3aGljaChBZEV4cF9EYXRhJFRlc3QgPT0gIlRyZWF0bWVudCIpDQoNCiMgQ29uc3VtZXJzIGluIHRoZSBjb250cm9sIGdyb3VwDQpDb250cm9sIDwtIHdoaWNoKEFkRXhwX0RhdGEkVGVzdCA9PSAiQ29udHJvbCIpDQpgYGANCg0KIyMjICoqQm9vdHN0cmFwcGluZyBBVEUgKGkuZS4sIEV4cGVjdGVkIExpZnQpIGFuZCBpdHMgQ0kncyoqDQoqICoqU3RhcnQgYm9vdHN0cmFwcGluZyB3aXRoIGFuICJVbnBvb2xlZCIgcHJvY2VkdXJlLiBUaGF0IGlzLCB3ZSBvYnRhaW4gdHdvIHJhbmRvbSBzYW1wbGVzIGZvciBUcmVhdG1lbnQgYW5kIENvbnRyb2wgZ3JvdXAsIHJlc3BlY3RpdmVseS4qKg0KKiBSZXNwZWN0aXZlbHkgZm9yIHRoZSB0cmVhdG1lbnQgYW5kIGNvbnRyb2wgZ3JvdXAsIHdlIG9idGFpbiBhIHJhbmRvbSBzYW1wbGUgd2l0aCB0aGUgc2FtZSBzYW1wbGUgc2l6ZSBhcyB0aGUgb3JpZ2luYWwgZGF0YSAoJE5fe2NvbnRyb2x9PU5bMV09MjY1NiQgYW5kICROX3tUcmVhdG1lbnR9PU5bMl09MjI2NDckKSBXSVRIIHJlcGxhY2VtZW50ICghIHZlcnkgaW1wb3J0YW50KS4gDQoqIFRoaXMgcHJvY2VkdXJlIHdpbGwgZGVhbCB3aXRoIHRoZSB1bmVxdWFsIGdyb3VwIHNpemVzIGFuZCB0aGUgc2FtcGxpbmcgdmFyaWF0aW9ucyBhcmUgdGFrZW4gaW50byBjb25zaWRlcmF0aW9uLiANCiogV2Ugd2lsbCB1c2UgYSBmdW5jdGlvbiBhdCBSICRzYW1wbGUoeCwgc2l6ZSwgcmVwbGFjZSA9IFQpJCwgd2hlcmUgJHgkIGlzIHRoZSB2ZWN0b3IgdG8gc2FtcGxlIGZyb20sICRzaXplJCBpcyB0aGUgbnVtYmVyIG9mIGVsZW1lbnRzIHRvIGNob29zZSBmcm9tICR4JCAoZm9yIGJvb3RzdHJhcHBpbmcsIHRoaXMgaXMgc2V0IGF0ICRsZW5ndGgoeCkkKSwgYW5kICRyZXBsYWNlPVQkIHBvaW50cyB0byBzYW1wbGluZyB3aXRoIHJlcGxhY2VtZW50IGZvciBib290c3RyYXBwaW5nLiANCg0KYGBge3J9DQojU3RhcnQgYm9vc3RyYXBwaW5nIHdpdGggYW4gIlVucGxvb2VkIiBwcm9jZWR1cmUNCg0KI3NldCB0aGUgc2VlZHMgZm9yIHJlcGxpY2F0aW9uOyB5b3UgbWF5IGRlbGV0ZSB0aGlzIGxpbmUuIA0Kc2V0LnNlZWQoMTIzNDU2Nzg5KSANCg0KI3RoZSBuby4gb2YgYm9vdHN0cmFwcGluZyBzYW1wbGVzOyBjYW4gYmUgY2hhbmdlZCB0byBvdGhlciB2YWx1ZXMNClMgPC0gMjAwMCANCg0KIyBhIHZlY3RvciB0byBzdG9yZSBib29zdHJhcHBlZCBsaWZ0IGVzdGltYXRlcw0KTGlmdCA8LSByZXAoMCxTKSANCg0KZm9yIChpIGluIDE6Uykgew0KICANCiAgIyBUbyBwcm9kdWNlIGEgYm9vdHN0cmFwcHRlZCBkYXRhIHNldDoNCiAgICAjIEEgcmFuZG9tIHNhbXBsZSB3aXRoIHRoZSBzYW1lIHNhbXBsZSBzaXplLCBzYW1wbGVkIHdpdGggcmVwbGFjZW1lbnQuDQogICAgIyBVc2luZyB0aGUgdHdvIGluZGljZXMgdmFyaWFibGVzICJUcmVhdG1lbnQiIGFuZCAiQ29udHJvbCIuDQogICAgIyBTYW1wbGluZyB0d28gdmVjdG9ycyB0aGF0IGFyZSBvZiBzYW1lIGxlbmd0aCBhcyAiVHJlYXRtZW50IiBhbmQgIkNvbnRyb2wiIHdpdGggcmVwbGFjZW1lbnQuDQogIERhdGEuYm9vdCA8LSBBZEV4cF9EYXRhW2Moc2FtcGxlKFRyZWF0bWVudCxOWzFdLHJlcGxhY2UgPSBUKSwNCiAgICAgICAgICAgICAgICAgICAgICBzYW1wbGUoQ29udHJvbCxOWzJdLHJlcGxhY2UgPSBUKSksMjozXQ0KICANCiAgIyBUbyBjYWxjdWFsdGUgdGhlIEFURSBmb3IgZWFjaCBib290c3RyYXBwZWQgc2FtcGxlOiBEYXRhLmJvb3QNCiAgTGlmdFtpXSA8LSBtZWFuKERhdGEuYm9vdCRQdXJjaGFzZVtEYXRhLmJvb3QkVGVzdD09IlRyZWF0bWVudCJdKSAtIA0KICAgIG1lYW4oRGF0YS5ib290JFB1cmNoYXNlW0RhdGEuYm9vdCRUZXN0PT0iQ29udHJvbCJdKSANCn0NCg0KI0dldCB0aGUgQVRFIGFuZCBib290c3RyYXBwZWQgQ0lzDQpBVEUgPC0gbWVhbihMaWZ0KQ0KDQojIFRoZSA5NSUgY29uZmlkZW5jZSBpbnRlcnZhbA0KQ0lfOTUgPC0gcXVhbnRpbGUoTGlmdCxjKC4wMjUsLjk3NSkpDQoNCiMgVGhlIDkwJSBjb25maWRlbmNlIGludGVydmFsDQpDSV85MCA8LSBxdWFudGlsZShMaWZ0LGMoLjA1LC45NSkpDQoNCiNXZSBjYW4gYWxzbyBwbG90ICJMaWZ0IiBhbmQgdGhlIDkwJSBhbmQgOTUlIENJJ3MNCmhpc3QoTGlmdCxicmVha3MgPSAxMDApDQphYmxpbmUodj1jKENJXzkwLENJXzk1KSwNCiAgICAgICBjb2w9YygiYmx1ZSIsImJsdWUiLCJyZWQiLCJyZWQiKSwNCiAgICAgICBsdHk9cmVwKDIsNCksDQogICAgICAgbHdkPXJlcCgyLDQpKQ0KYGBgDQoNCiMjIyAqKkNhbGN1YXRpbmcgUk9JIG9mIE9ubGluZSBEaXNwbGF5IEFkcyoqDQoNCiogSWYgd2UgYmVsaWV2ZSB0aGF0IHRoZSBBVEUgb2YgJDAuMDE5MCQgaXMgY3JlZGlibGUsIHdlIGNhbiB0aGVuIHVzZSB0aGUgQVRFIChhdmVyYWdlIExpZnQpIHRvIGNhbGN1YWx0ZSBST0kgZm9yIGZ1cnRoZXIgcmVwb3J0aW5nLg0KKiBUaGUgUk9JIGNhbGN1bGF0aW9uIHJlcXVpcmVzIHR3byB2YWx1ZXM6IDEpIHRoZSBwcm9maXRzIGZyb20gdGhlIGNvbnZlcnNpb25zOyBhbmQgMikgdGhlIGNvc3RzIG9mIG9ubGluZSBhZHMuIEFzIHRoZSBjb3N0cyBhcmUgdGhlIHBheW1lbnQgZm9yIGltcHJlc3Npb25zIChDUE0pLCB3ZSB1c2UgY29uc3VtZXJzIGluIHRoZSB0cmVhdG1lbnQgZ3JvdXAgKGFzIHRoZSBjb250cm9sIGdyb3VwIHdlcmUgc2VydmVkIG5vIERpZ2l0YWwgU3RhciBhZHMsIHdlIGNhbm5vdCBjYWxjdWF0ZSB0aGUgY29zdHMpLiANCiogVGhlIG92ZXJhbGwgZXhwZWN0ZWQgcHJvZml0cyBzaG91bGQgYmU6ICRQcm9maXRzPUFURSBcdGltZXMgTl97VHJlYXRtZW50fSBcdGltZXMgNjAkLCB3aXRoIOKCrDYwIHRoZSBDTFYgb2Ygb25lIHN1YnNjcmlwdGlvbiAoc2VlIHBhZ2UgMyBvZiB0aGUgY2FzZSkuIA0KKiBUaGUgb3ZlcmFsbCBjb3N0cyBhcmUgZnJvbSB0aGUgQ1BNIG1vZGVsIG9yIGNvc3RzIHBlciB0aG91c2FuZCBpbXByZXNzaW9ucy4gV2UgdXNlOiAkQ29zdHM9XGRmcmFje0ltcHJlc3Npb25zX3sxLTV9fXsxMDAwfSBcdGltZXMg4oKsMjUgKyBcZGZyYWN7SW1wcmVzc2lvbnNfezZ9fXsxMDAwfSBcdGltZXMg4oKsMjAkLCBhcyB0aGUgQ1BNIGZvciBXZWJzaXRlIDEtNSBpcyDigqwyNSBhbmQgV2Vic2l0ZSA2IGlzIOKCrDIwIChzZWUgcGFnZSAzIG9mIHRoZSBjYXNlKS4NCg0KYGBge3J9DQojIFN1bSB1cCB0aGUgaW1wcmVzc2lvbnMgZm9yIHRyZWF0bWVudCBncm91cCBjb25zdW1lcnMNCkltcHJlc3Npb25zIDwtIGNvbFN1bXMoQWRFeHBfRGF0YVtUcmVhdG1lbnQsLWMoMTozKV0pDQoNCiMgRGlmZmVyZW50IENQTXMgYXMgc2hvd24gYWJvdmU6IFdlYnNpdGUgMS01IC0gMjUgYW5kIFdlYnNpdGUgNiAtIDIwDQpDb3N0cyA8LSBzdW0oSW1wcmVzc2lvbnMvMTAwMCpjKHJlcCgyNSw1KSwyMCkpDQoNCiNUaGUgcmV0dXJuIGlzIHRoZSBudW1iZXIgb2YgcGVvcGxlIGluIHRyZWF0bWVudCAqIHRoZSBBVEUgKExpZnQpICogNjAgZXVyb3MNClByb2ZpdHMgPC0gQVRFKk5bMl0qNjANCg0KIyBDYWxjdWxhdGUgUk9JOiBSZXR1cm4vSW52ZXN0bWVudCA9IChQcm9maXRzLUNvc3RzKS9Db3N0cw0KUk9JIDwtIChQcm9maXRzLUNvc3RzKS9Db3N0cw0KDQojIFNob3cgZmluYWwgcmVzdWx0cw0KUmVzdWx0cyA8LSBjKENvc3RzLFByb2ZpdHMsUk9JKQ0KbmFtZXMoUmVzdWx0cykgPC0gYygiQ29zdHMiLCJQcm9maXRzIiwiUk9JIikNClJlc3VsdHMNCmBgYA0KDQoNCg0K