Loading & Preparing Data
options(scipen=10)
pacman::p_load(latex2exp,Matrix,dplyr,tidyr,ggplot2,caTools,plotly)
rm(list=ls(all=TRUE))
load("data/tf4.rdata")


Predictions

par(mfrow=c(1,2), cex=0.8)
hist(B$Buy)
hist(log(B$Rev,10))

group_by(B,age) %>% 
  summarise(n=n(), Buy=mean(Buy), Rev=mean(Rev)) %>% 
  ggplot(aes(Buy,Rev,size=n,label=age)) + 
  geom_point(alpha=0.5,color='gold') + 
  geom_text(size=4) + 
  labs(title="Age Group Comparison (size: no. customers)") +
  xlab("Buying Probability") + ylab("Expected Revenue") +
  scale_size(range=c(4,20)) + theme_bw()  -> p
ggplotly(p)

Assumption


Parameterized Cost Effect Function

The \(Logistic\) function is handy in defining parameterized S-curves
\[\Delta P(x|m,b,a) = m \cdot Logis(\frac{10(x - b)}{a})\]

DP = function(x,m0,b0,a0) {m0*plogis((10/a0)*(x-b0))}
par(mar=c(4,4,2,1),cex=0.7)
curve(DP(x,m=0.20,b=30,a=40), 0, 60, lwd=2, ylim=c(0, 0.25),
      main="F( x | m=0.2, b=30, a=40 )", ylab="delta P")
abline(h=seq(0,0.2,0.05),v=seq(0,60,5),col='lightgrey',lty=2)

The instrument parameters represent:

  • m : height of the s-curve (the max. effect)
  • b : center of the rising slope
  • a : width of the rising slope

in one single program we can emulate all possible S-curves which specifies how the effect (\(\Delta P\)) varies the strategic variable (\(x\))


Estimating Expected Payoff

Now we can estimate the instrument’s expected return for every customer. Because probability is cap at 1, so we need a conditional equation as below.

\[\hat{R}(x) = \left\{\begin{matrix} \Delta P \cdot M \cdot margin - x & , & P + \Delta P \leq 1\\ (1-P) \cdot M \cdot margin - x & , & else \end{matrix}\right.\]

Combining …

  • Predictions (\(P, M\)) : the expected buying probability and amount for every customers and
  • Assumption (\(\Delta P(x|m,b,a)\)) : the increment in purchase probability

We can estimate

  • the Expected Incremental Profit (net of cost) for Every Customer (\(\hat{R}(x)\)).

Note that both \(\Delta P\) and \(\hat{R}\) are functions of \(x\) given \(m,b,a\)

  • \(m, b, a\) are the characteristics of the instrument
  • \(x\) is our strategic variable which implies the intensity of marketing in this case


Estimating (Assuming) Raw Margin

# load(data/tf0.rdata)
# group_by(Z0, age) %>% summarise(sum(price)/sum(cost) - 1)
margin = 0.17  # assume margin = 0.17

Estimating Expected Return

m=0.2; b=25; a=40; x=30
dp = pmin(1-B$Buy, DP(x,m,b,a))
eR = dp*B$Rev*margin - x
hist(eR,main="Dist. Expected Return",xlab="Expected Return",ylab="No. Customers")


Group Exercise

Use the analysis above to answer the following questions …

🚴 How many customers should we apply this instruments (eR > 0)?

sum(eR > 0)
## [1] 7228

🚴 What is the expected return if we apply this instrument to ALL customers?

sum(eR)
## [1] -203881

🚴 What is the expected return if we only apply it to those who have positive return?

sum(eR[eR>0])
## [1] 75883.81

Simulation

One Instrument

Assuming the instrument parameters (\(m,b,a\)), we can estimate how

  • eReturn : expected return when applying to all
  • N : No. profitable cases
  • eReturn2 : expected return when we only apply to the profitable

vary with the intensity of the instrument (eg. the face value of the coupon) in the simulation range of \(x \in [10, 45]\).

m=0.2; b=25; a=40; X = seq(10,45,1)

df = sapply(X, function(x) {
  dp = pmin(DP(x,m,b,a),1-B$Buy)
  eR = dp*B$Rev*margin - x
  c(x=x, eReturn=sum(eR), N=sum(eR > 0), eReturn2=sum(eR[eR > 0]))
  }) %>% t %>% data.frame %>% 
  gather('key','value',-x)

df %>% ggplot(aes(x=x, y=value, col=key)) + 
  geom_hline(yintercept=0,linetype='dashed') +
  geom_line(size=1.5,alpha=0.5) + 
  facet_wrap(~key,ncol=1,scales='free_y') + theme_bw()

Multiple Instruments

With some modification of the code, we can define multiple (4) instruments at once

mm=c(0.20, 0.25, 0.15, 0.25)
bb=c(  25,   30,   15,   30)
aa=c(  40,   40,   30,   60) 
X = seq(0,60,2) 
do.call(rbind, lapply(1:length(mm), function(i) data.frame(
  Inst=paste0('Inst',i), Cost=X, 
  Gain=DP(X,mm[i],bb[i],aa[i])
  ))) %>% data.frame %>% 
  ggplot(aes(x=Cost, y=Gain, col=Inst)) +
  geom_line(size=1.5,alpha=0.5) + theme_bw() +
  ggtitle("Prob. Function: f(x|m,b,a)")

and run simulation on multiple instrument to compare their cost effectiveness.

X = seq(10, 60, 1) 
df = do.call(rbind, lapply(1:length(mm), function(i) {
  sapply(X, function(x) {
    dp = pmin(1-B$Buy, DP(x,mm[i],bb[i],aa[i]))
    eR = dp*B$Rev*margin - x
    c(i=i, x=x, eR.ALL=sum(eR), N=sum(eR>0), eR.SEL=sum(eR[eR > 0]) )
    }) %>% t %>% data.frame
  })) 

df %>% 
  mutate_at(vars(eR.ALL, eR.SEL), function(y) round(y/1000)) %>% 
  gather('key','value',-i,-x) %>% 
  mutate(Instrument = paste0('I',i)) %>%
  ggplot(aes(x=x, y=value, col=Instrument)) + 
  geom_hline(yintercept=0, linetype='dashed', col='blue') +
  geom_line(size=1.5,alpha=0.5) + 
  xlab('Strength (x)') + ylab('Exp. Return($K)') + 
  ggtitle('Simulation: Cost Effectiveness of 4 Marketing Instruments') +
    facet_wrap(~key,ncol=1,scales='free_y') + theme_bw() -> p

plotly::ggplotly(p)

With in df we have the columns

  • i : instrument id
  • x : unit cost
  • eR.ALL : total expected payoff when apply to all customers
  • N : the number of customers with positive expected net payoff
  • eR.SEL : total expected payoff when only apply to the N customers

The Optimal Strength for each instruments can be extracted simply by …

group_by(df, i) %>% top_n(1,eR.SEL)
## # A tibble: 4 x 5
## # Groups:   i [4]
##       i     x   eR.ALL     N  eR.SEL
##   <dbl> <dbl>    <dbl> <dbl>   <dbl>
## 1     1    34 -217614.  7569  93549.
## 2     2    40 -196943.  8783 143043.
## 3     3    22  -50497. 10880 107149.
## 4     4    43 -307871.  6979 106687.

Discussion

Here is the number of customers in each age group.

par(cex=0.7, mar=c(2,2,1,2))
table(B$age) %>% barplot


🚴 Group Assignment：
If the 4 parameter combinations above each represents the effect of an instrument to an age group:
  ■ I1 : a24, a29
  ■ I2 : a34, a39
  ■ I3 : a44, a49
  ■ I4 : a54, a59, a64, a69
Please find the optimal strategy for each age group in terms of：
  ■ No. customers to apply (N)？
  ■ The strength of instrument (x)？
  ■ The expected return (eR.SEL)？




X = seq(10, 60, 1)

agrp =  list(
  c("a24","a29"),
  c("a34","a39"),
  c("a44","a49"),
  c("a54","a59","a64","a69")
  )

df = do.call(rbind, lapply(1:length(agrp), function(i) {
  ag = filter(B, age %in% agrp[[i]] )
  sapply(X, function(x) {
    dp = pmin(1- ag$Buy , DP(x,mm[i],bb[i],aa[i]))
    eR = dp* ag$Rev *margin - x
    c(i=i, x=x, eR.ALL=sum(eR), N=sum(eR>0), eR.SEL=sum(eR[eR > 0]) )
    }) %>% t %>% data.frame
  })) 

group_by(df, i) %>% top_n(1,eR.SEL)
## # A tibble: 4 x 5
## # Groups:   i [4]
##       i     x   eR.ALL     N eR.SEL
##   <dbl> <dbl>    <dbl> <dbl>  <dbl>
## 1     1    34 -52796.    626  5923.
## 2     2    40 -35113.   4175 70408.
## 3     3    22    -68.9  3472 36733.
## 4     4    42 -83643.    673  8012.