Pareto-NBD | Chen Xing

Incorporating Time-Invariant Covariates into PNBD II

Fri, 26 Aug 2022 00:00:00 +0000

Introduction

In this post, we’ll continue discover the difference between the Cohort Modeling and the Extended PNBD Model with time-invariant covariates. Check here to see the previous post.

Data Prepare

First let’s import the transactional data, and select the customers who first purchase happened in 2017-2018.

trans_dat <- read_rds("~/Desktop/trans_dat.rds")

# select the customers who first purchase happened in 2017-2018
trans_dat <- trans_dat %>%
  filter(date <= as.Date("2019-12-31")) %>%
  filter(fp_yr <= 2018)

# glimpse
head(trans_dat)

## # A tibble: 6 × 4
##   cust  date        sales fp_yr
##   <chr> <date>      <dbl> <dbl>
## 1 10017 2018-03-08   674.  2018
## 2 10021 2017-08-27   495.  2017
## 3 10040 2017-05-13  2781   2017
## 4 10041 2018-07-21    72   2018
## 5 10048 2018-10-10  4472.  2018
## 6 10049 2017-02-05 18780   2017

summary(trans_dat)

##      cust                date                sales              fp_yr     
##  Length:14943       Min.   :2017-01-01   Min.   :     0.5   Min.   :2017  
##  Class :character   1st Qu.:2017-06-11   1st Qu.:   414.2   1st Qu.:2017  
##  Mode  :character   Median :2018-02-16   Median :  1003.8   Median :2017  
##                     Mean   :2018-04-08   Mean   :  2147.1   Mean   :2017  
##                     3rd Qu.:2018-12-28   3rd Qu.:  2168.5   3rd Qu.:2018  
##                     Max.   :2019-12-31   Max.   :476659.0   Max.   :2018

How many new customers joined the enterprise in 2017 and 2018?

trans_dat %>%
  group_by(fp_yr) %>%
  summarize(new_cust = n_distinct(cust))

## # A tibble: 2 × 2
##   fp_yr new_cust
##   <dbl>    <int>
## 1  2017     5114
## 2  2018     2767

Train/Test

Training: Two years, 2017-2018, transactional data.
Testing: One year, 2019, transactional data.

The Cohort Models

Cohort 2017

Prepare CLV data,

ch17_dat <- trans_dat %>%
  filter(fp_yr == 2017)

# build clv type of data
dclv_17 <- generate_clvdata(
  data = ch17_dat,
  splitDate = "2018-12-31"
)

## Note that: time unit is in < week >

Build PNBD Model,

m17 <- standard_PNBD_model(dclv_17)

# check
summary(m17)

## Pareto NBD Standard  Model 
## 
## Call:
## pnbd(clv.data = clvData, optimx.args = optimx.args)
## 
## Fitting period:                                
## Estimation start  2017-01-01    
## Estimation end    2018-12-31    
## Estimation length 104.1429 Weeks
## 
## Coefficients:
##       Estimate Std. Error  z-val Pr(>|z|)    
## r      0.84155    0.08460  9.947  < 2e-16 ***
## alpha 54.31617    4.38954 12.374  < 2e-16 ***
## s      0.32609    0.03272  9.967  < 2e-16 ***
## beta   3.20325    1.06076  3.020  0.00253 ** 
## ---
## Signif. codes:  0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1
## 
## Optimization info:                  
## LL     -16587.4554
## AIC    33182.9107 
## BIC    33209.0697 
## KKT 1  TRUE       
## KKT 2  TRUE       
## fevals 409.0000   
## Method Nelder-Mead
## 
## Used Options:                 
## Correlation FALSE

Check the tracking plots,

plot(m17)

plot(m17, cumulative = TRUE)

On the testing period, the model curve is under the actual number of repeat transactions curve.

Cohort 2018

Similarly, we’ll get,

dclv_18 <- trans_dat %>%
  filter(fp_yr == 2018) %>%
  generate_clvdata(splitDate = "2018-12-31")

## Note that: time unit is in < week >

# model
m18 <- standard_PNBD_model(dclv_18)

# check model coef
summary(m18)

## Pareto NBD Standard  Model 
## 
## Call:
## pnbd(clv.data = clvData, optimx.args = optimx.args)
## 
## Fitting period:                               
## Estimation start  2018-01-01   
## Estimation end    2018-12-31   
## Estimation length 52.0000 Weeks
## 
## Coefficients:
##       Estimate Std. Error z-val Pr(>|z|)    
## r      1.05005    0.30318 3.463 0.000533 ***
## alpha 40.98040   10.09464 4.060 4.92e-05 ***
## s      0.31008    0.04534 6.839 7.95e-12 ***
## beta   0.42186    0.22740 1.855 0.063572 .  
## ---
## Signif. codes:  0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1
## 
## Optimization info:                  
## LL     -2529.2006 
## AIC    5066.4012  
## BIC    5090.1032  
## KKT 1  TRUE       
## KKT 2  TRUE       
## fevals 285.0000   
## Method Nelder-Mead
## 
## Used Options:                 
## Correlation FALSE

Again, checking the tracking plots

plot(m18)

plot(m18, cumulative = TRUE)

On the testing period, the model curve is under the actual number of repeat transactions curve.

Interpret Model Coef

The 2017 cohort has lower transaction rate and lower dropout rate comparing with the 2018-cohort.

Table 1: cohort model coefs
cohort	r	alpha	s	beta	lambda	mu
2017	0.842	54.316	0.326	3.203	0.015	0.102
2018	1.050	40.980	0.310	0.422	0.026	0.735

Accuracy of Predictions

Let’s find the MAE and RMSE of the conditional expected transactions (CET) on the testing set.

Table 2: Cohort Model Error Measure on cohort 2017, 2018 and all together
cohort	MAE	RMSE	Corr
2017	0.431	0.924	0.517
2018	0.615	1.089	0.424
All	0.496	0.985	0.484

Let’s check the error distribution for cohort 2017,

Why the customers purchased more in 2019, i.e. the actual transactions are larger than the model predictions?

After we talked with the company’s manager, we knew that the company started to perform a new membership service plan in 2019. The new service mode worked pretty well and led to the increasing number of repeat transactions.

The Extended PNBD Model

# set the fp_yr as a factor variable
trans_dat <- trans_dat %>%
  mutate(fp_yr = factor(fp_yr))

# check the factor level
levels(trans_dat$fp_yr)

## [1] "2017" "2018"

Note that, the model will use 2017 cohort as baseline or reference group.

# prepare static covariates data
static_cov_dat <- trans_dat %>%
  distinct(cust, fp_yr)

# clv data
dclv_all <- generate_clvdata(trans_dat, splitDate = "2018-12-31")

## Note that: time unit is in < week >

# make static covariates data as clv type of data
dclv_stat <- SetStaticCovariates(
  clv.data = dclv_all,
  data.cov.life = static_cov_dat,
  data.cov.trans = static_cov_dat,
  names.cov.life = "fp_yr",
  names.cov.trans = "fp_yr",
  name.id = "cust"
)

Now, we build the extended PNBD model with time-invariant covariates, which are fp_yr in this case.

ext_m <- standard_PNBD_model(
  dclv_stat,
  start.params.model = c(r = .88, alpha = 56.16, s = .29, beta = 2.25),
  start.params.life = c(fp_yr2018 = 2.01),
  start.params.trans = c(fp_yr2018 = .55)
)

# check the model
summary(ext_m)

## Pareto NBD with Static Covariates  Model 
## 
## Call:
## pnbd(clv.data = clvData, optimx.args = optimx.args, start.params.life = ..1, 
##     start.params.trans = ..2)
## 
## Fitting period:                                
## Estimation start  2017-01-01    
## Estimation end    2018-12-31    
## Estimation length 104.1429 Weeks
## 
## Coefficients:
##                 Estimate Std. Error  z-val Pr(>|z|)    
## r                0.86825    0.08145 10.660  < 2e-16 ***
## alpha           55.50864    4.28397 12.957  < 2e-16 ***
## s                0.31854    0.02583 12.332  < 2e-16 ***
## beta             2.90289    0.80920  3.587 0.000334 ***
## life.fp_yr2018   1.67367    0.29780  5.620 1.91e-08 ***
## trans.fp_yr2018  0.45153    0.10167  4.441 8.95e-06 ***
## ---
## Signif. codes:  0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1
## 
## Optimization info:                  
## LL     -19116.9873
## AIC    38245.9746 
## BIC    38287.8079 
## KKT 1  TRUE       
## KKT 2  TRUE       
## fevals 581.0000   
## Method Nelder-Mead
## 
## Used Options:                     
## Correlation     FALSE
## Regularization  FALSE
## Constraint covs FALSE

After checking the summary of the model, we know that the fp_yr affects both purchase process and attrition process (P-values are significant).

Now let’s check the tracking plot,

plot(ext_m)

plot(ext_m, cumulative = TRUE)

Interpret Model Coef

Since the 2017 cohort as the reference group, we already know its corresponding r, alpha, s, beta. However, we still need to calculate the alpha and beta for the 2018 cohort.

Plug into the formula: alpha = alpha0 * exp(-gamma1 * z1) and beta = beta0 * exp(-gamma2 * z2)

Table 3: Extended PNBD with time-invariate covariates model coefficients
cohort	r	alpha	s	beta	lambda	mu
2017	0.868	55.509	0.319	2.903	0.016	0.110
2018	0.868	35.340	0.319	0.544	0.025	0.585

If we compare this model’s coefficients with the cohort models’, we’ll find the purchase/dropout rate estimates are quite similar for both models.

Accuracy of Predictions

Again, calculate the MAE and RMSE on CET.

ext_m_pred <- predict(ext_m) %>%
  select(cust = Id, actual.x, CET) %>%
  left_join(static_cov_dat)

ext_m_17_acc <- ext_m_pred %>%
  filter(fp_yr == 2017) %>%
  cal_err()

ext_m_18_acc <- ext_m_pred %>%
  filter(fp_yr == 2018) %>%
  cal_err()

ext_m_all_acc <- ext_m_pred %>%
  cal_err()

# result
bind_rows(ext_m_17_acc, ext_m_18_acc, ext_m_all_acc) %>%
  mutate(cohort = c(2017:2018, "All"), .before = 1) %>%
  mutate(across(where(is.numeric), round, digits = 3)) %>%
  print_kbl(
    cap = "Extended PNBD Model Error Measure on cohort 2017, 2018 and all together"
  )

Table 4: Extended PNBD Model Error Measure on cohort 2017, 2018 and all together
cohort	MAE	RMSE	Corr
2017	0.432	0.924	0.517
2018	0.615	1.085	0.429
All	0.496	0.983	0.486

Conclusion

Comparing the prediction error of two models, we find that two models prediction behaviors are very close. I prefer the extended PNBD model for this data.

Incorporating Time-Invariant Covariates into PNBD

Tue, 23 Aug 2022 00:00:00 +0000

Introduction

The original Pareto-NBD Model is awesome, but it does not allow us to add any covariates. In some cases, the covariates may affect the purchase, or the attrition process, or both. In this post, we will learn the simple case, adding the time-invariant covariates using CLVTools R package📦 and my own zetaclv package.

Next, we will predict customer’s future transactions using two approaches:

Divide the customers into different cohort groups, which is defined by the first purchase year, then build the models for each cohort.
Without “cohorting” the customer, we’ll build a model using the first purchase year as time-invariant covariates.

After that, let’s compare and understand the difference between two models/approaches, and choose the better one.

Add Time-Invariant Covariates in PNBD

If you familiar with the original Pareto-NBD Model (here to review), then this new model is not complicated at all!

Recall that, in PNBD Model, we assume that the transactional rate, $\lambda$, and the dropout rate, $\mu$, have the following distribution $$\lambda \sim \text{Gamma}(r, \alpha), \ \ \mu \sim \text{Gamma}(s, \beta)$$

We keep the shape parameters (i.e. $r, s$) unchanged, but replace the following scale parameters:

From Fader PS, Hardie BGS (2007)

For more details, see Fader PS, Hardie BGS (2007). “Incorporating time-invariant covariates into the Pareto/NBD and BG/NBD models.”

Why we set $\alpha, \beta$ in this form?

The idea is from proportional hazard model (check my previous post if needed).

$\alpha_0, \beta_0$ refer baseline hazard.
The $\gamma$ part refers the log of hazard ratio.

Data Prepare

The transactional data has cust, date and sales information.

# add first purchase year column
dat <- eg_trans_data %>%
  with_groups(
    .groups = cust,
    .f = mutate,
    # first purchase year
    fp_yr = min(lubridate::year(date))
  ) %>%
  filter(fp_yr < 2020) %>%
  arrange(cust, date)

# have a look
head(dat, 5) %>% print_kbl(cap = "dat")

Table 1: dat
cust	date	sales	fp_yr
uid0001	2019-12-02	3470	2019
uid0001	2020-04-20	1050	2019
uid0001	2020-04-20	124	2019
uid0003	2018-12-11	1948	2018
uid0003	2019-02-22	828	2018

summary(dat)

##       cust            date                sales           fp_yr     
##  uid3414:  248   Min.   :2018-01-11   Min.   :    0   Min.   :2018  
##  uid0384:  239   1st Qu.:2019-01-26   1st Qu.:  182   1st Qu.:2018  
##  uid1156:  191   Median :2019-08-01   Median :  560   Median :2018  
##  uid1149:  173   Mean   :2019-09-22   Mean   : 1431   Mean   :2018  
##  uid0018:  155   3rd Qu.:2020-05-14   3rd Qu.: 1465   3rd Qu.:2019  
##  uid3466:  152   Max.   :2021-06-07   Max.   :79270   Max.   :2019  
##  (Other):21307

We will use the fp_yr variable to define the cohort group. How many customers in each cohort?

dat %>%
  group_by(fp_yr) %>%
  summarize(n_cust = n_distinct(cust))

## # A tibble: 2 × 2
##   fp_yr n_cust
##   <dbl>  <int>
## 1  2018   1097
## 2  2019   2314

Cohort Models

Cohort data:

# cohort data
dat18 <- filter(dat, fp_yr == 2018)
dat19 <- filter(dat, fp_yr == 2019)

Build the clv type of data:

dclv_18 <- generate_clvdata(
  data = dat18,
  splitDate = "2019-12-31"
)

## Note that: time unit is in < week >

dclv_18

## CLV Transaction Data 
## 
## Call:
## clvdata(data.transactions = data, date.format = "ymd", time.unit = timeUnit, 
##     estimation.split = splitDate, name.id = "cust", name.date = "date", 
##     name.price = "sales")
##                          
## Total # customers    1097
## Total # transactions 4968
## Spending information TRUE
## 
##                                 
## Time unit         Weeks         
##                                 
## Estimation start  2018-01-11    
## Estimation end    2019-12-31    
## Estimation length 102.7143 Weeks
##                                 
## Holdout start     2020-01-01    
## Holdout end       2021-06-07    
## Holdout length    74.71429 Weeks

dclv_19 <- generate_clvdata(
  data = dat19,
  splitDate = "2019-12-31"
)

## Note that: time unit is in < week >

dclv_19

## CLV Transaction Data 
## 
## Call:
## clvdata(data.transactions = data, date.format = "ymd", time.unit = timeUnit, 
##     estimation.split = splitDate, name.id = "cust", name.date = "date", 
##     name.price = "sales")
##                          
## Total # customers    2314
## Total # transactions 5108
## Spending information TRUE
## 
##                                 
## Time unit         Weeks         
##                                 
## Estimation start  2019-01-01    
## Estimation end    2019-12-31    
## Estimation length 52.0000 Weeks 
##                                 
## Holdout start     2020-01-01    
## Holdout end       2021-06-07    
## Holdout length    74.71429 Weeks

Now, let’s model the cohort group data:

m18 <- standard_PNBD_model(dclv_18)

summary(m18)

## Pareto NBD Standard  Model 
## 
## Call:
## pnbd(clv.data = clvData, optimx.args = optimx.args)
## 
## Fitting period:                                
## Estimation start  2018-01-11    
## Estimation end    2019-12-31    
## Estimation length 102.7143 Weeks
## 
## Coefficients:
##       Estimate Std. Error  z-val Pr(>|z|)    
## r      0.39734    0.04020  9.884  < 2e-16 ***
## alpha 10.74518    1.01108 10.627  < 2e-16 ***
## s      0.12227    0.03574  3.421 0.000623 ***
## beta   2.79356    2.84873  0.981 0.326774    
## ---
## Signif. codes:  0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1
## 
## Optimization info:                  
## LL     -8303.6317 
## AIC    16615.2633 
## BIC    16635.2647 
## KKT 1  TRUE       
## KKT 2  TRUE       
## fevals 195.0000   
## Method Nelder-Mead
## 
## Used Options:                 
## Correlation FALSE

plot(m18)

plot(m18, cumulative = TRUE)

m19 <- standard_PNBD_model(dclv_19)

summary(m19)

## Pareto NBD Standard  Model 
## 
## Call:
## pnbd(clv.data = clvData, optimx.args = optimx.args)
## 
## Fitting period:                               
## Estimation start  2019-01-01   
## Estimation end    2019-12-31   
## Estimation length 52.0000 Weeks
## 
## Coefficients:
##       Estimate Std. Error z-val Pr(>|z|)    
## r      0.44721    0.06257 7.148 8.82e-13 ***
## alpha 15.02084    1.76408 8.515  < 2e-16 ***
## s      0.26878    0.04008 6.706 1.99e-11 ***
## beta   1.08620    0.56096 1.936   0.0528 .  
## ---
## Signif. codes:  0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1
## 
## Optimization info:                  
## LL     -4778.1858 
## AIC    9564.3715  
## BIC    9587.3584  
## KKT 1  TRUE       
## KKT 2  TRUE       
## fevals 489.0000   
## Method Nelder-Mead
## 
## Used Options:                 
## Correlation FALSE

plot(m19)

plot(m19, cumulative = TRUE)

compare the model coefficients:

cohort_model_coefs <- rbind(`2018` = coef(m18), `2019` = coef(m19))

cohort_model_coefs %>%
  as_tibble(rownames = "cohort") %>%
  print_kbl("compare the model's coef from different cohort")

Table 2: compare the model's coef from different cohort
cohort	r	alpha	s	beta
2018	0.3973431	10.74518	0.1222724	2.793557
2019	0.4472133	15.02084	0.2687787	1.086205

Interpret Coef

The expected value of transaction rate lambda is r/alpha, and the expected value of dropout rate mu is s/beta.

cohort_model_coefs %>%
  as_tibble(rownames = "cohort") %>%
  mutate(lambda = r / alpha, mu = s / beta) %>%
  mutate(across(c(r:mu), round, digits = 3)) %>%
  print_kbl("compare transaction/dropout rate")

Table 3: compare transaction/dropout rate
cohort	r	alpha	s	beta	lambda	mu
2018	0.397	10.745	0.122	2.794	0.037	0.044
2019	0.447	15.021	0.269	1.086	0.030	0.247

We can conclude that the 2018-cohort has higher purchase rate and lower dropout rate.

Extended PNBD Model

The clv type of data:

dclv_all <- generate_clvdata(
  data = dat,
  splitDate = "2019-12-31"
)

## Note that: time unit is in < week >

dclv_all

## CLV Transaction Data 
## 
## Call:
## clvdata(data.transactions = data, date.format = "ymd", time.unit = timeUnit, 
##     estimation.split = splitDate, name.id = "cust", name.date = "date", 
##     name.price = "sales")
##                           
## Total # customers    3411 
## Total # transactions 10076
## Spending information TRUE 
## 
##                                 
## Time unit         Weeks         
##                                 
## Estimation start  2018-01-11    
## Estimation end    2019-12-31    
## Estimation length 102.7143 Weeks
##                                 
## Holdout start     2020-01-01    
## Holdout end       2021-06-07    
## Holdout length    74.71429 Weeks

The static covariate data:

stat_cov <- dat %>%
  distinct(cust, fp_yr) %>%
  mutate(fp_yr = factor(fp_yr, levels = c(2018, 2019)))

summary(stat_cov)

##       cust       fp_yr     
##  uid0001:   1   2018:1097  
##  uid0003:   1   2019:2314  
##  uid0004:   1              
##  uid0005:   1              
##  uid0006:   1              
##  uid0008:   1              
##  (Other):3405

The clv type of covariate data:

dclv_stat <- SetStaticCovariates(
  clv.data = dclv_all,
  data.cov.life = stat_cov,
  data.cov.trans = stat_cov,
  names.cov.life = "fp_yr",
  names.cov.trans = "fp_yr",
  name.id = "cust"
)

dclv_stat

## CLV Transaction Data with Static Covariates 
## 
## Call:
## clvdata(data.transactions = data, date.format = "ymd", time.unit = timeUnit, 
##     estimation.split = splitDate, name.id = "cust", name.date = "date", 
##     name.price = "sales")
##                           
## Total # customers    3411 
## Total # transactions 10076
## Spending information TRUE 
## 
##                                 
## Time unit         Weeks         
##                                 
## Estimation start  2018-01-11    
## Estimation end    2019-12-31    
## Estimation length 102.7143 Weeks
##                                 
## Holdout start     2020-01-01    
## Holdout end       2021-06-07    
## Holdout length    74.71429 Weeks
## 
## Covariates                              
## Trans. Covariates    fp_yr2019
##        # covs        1        
## Life.  Covariates    fp_yr2019
##        # covs        1

The PNBD Model with time-invariant covariates:

ext_m <- standard_PNBD_model(dclv_stat)

summary(ext_m)

## Pareto NBD with Static Covariates  Model 
## 
## Call:
## pnbd(clv.data = clvData, optimx.args = optimx.args)
## 
## Fitting period:                                
## Estimation start  2018-01-11    
## Estimation end    2019-12-31    
## Estimation length 102.7143 Weeks
## 
## Coefficients:
##                 Estimate Std. Error  z-val Pr(>|z|)    
## r                0.38211    0.02952 12.945  < 2e-16 ***
## alpha            9.36586    0.84549 11.077  < 2e-16 ***
## s                0.16033    0.03288  4.877 1.08e-06 ***
## beta             2.87077    2.27740  1.261   0.2075    
## life.fp_yr2019   1.19338    0.58044  2.056   0.0398 *  
## trans.fp_yr2019 -0.52757    0.11754 -4.489 7.17e-06 ***
## ---
## Signif. codes:  0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1
## 
## Optimization info:                  
## LL     -13095.4075
## AIC    26202.8149 
## BIC    26239.6235 
## KKT 1  TRUE       
## KKT 2  TRUE       
## fevals 607.0000   
## Method Nelder-Mead
## 
## Used Options:                     
## Correlation     FALSE
## Regularization  FALSE
## Constraint covs FALSE

plot(ext_m, cumulative = TRUE)

Interpret Coef

coef(ext_m) %>%
  enframe(name = "coef")

## # A tibble: 6 × 2
##   coef             value
##   <chr>            <dbl>
## 1 r                0.382
## 2 alpha            9.37 
## 3 s                0.160
## 4 beta             2.87 
## 5 life.fp_yr2019   1.19 
## 6 trans.fp_yr2019 -0.528

Note that, the baseline or “reference group” is cohort-2018, and we already know its 4 parameters.

For cohort-2019,

The cohort-2018 and cohort-2019 share the same values of r and s.
We only need to find its alpha and beta.

Plug into the formula: alpha = alpha0 * exp(-gamma1 * z1) and beta = beta0 * exp(-gamma2 * z2)

coefs <- unname(coef(ext_m))

# for cohort-2018, as reference group
r <- coefs[1]
s <- coefs[3]
alpha0 <- coefs[2]
beta0 <- coefs[4]

# here, the covariates are indicator variables (0/1; 0 refers baseline)
z1 <- 1
z2 <- 1

# gamma
gamma1 <- coefs[6]
gamma2 <- coefs[5]

# for cohort-2019
alpha <- alpha0 * exp(-gamma1 * z1)
beta <- beta0 * exp(-gamma2 * z2)

# put all together
coef_tbl <- tibble(
  r = c(r, r),
  alpha = c(alpha0, alpha),
  s = c(s, s),
  beta = c(beta0, beta)
) %>%
  mutate(cohort = c(2018, 2019), .before = 1) %>%
  mutate(
    lambda = r / alpha,
    mu = s / beta
  )

coef_tbl %>%
  mutate(across(r:mu, round, digits = 3)) %>%
  print_kbl(
    highlight_cols = c("lambda", "mu"),
    cap = "compare transaction/dropout rate"
  )

Table 4: compare transaction/dropout rate
cohort	r	alpha	s	beta	lambda	mu
2018	0.382	9.366	0.16	2.871	0.041	0.056
2019	0.382	15.873	0.16	0.870	0.024	0.184

Compare Two Models

The following tables show the values of coefficients from two models:

Table 5: **Cohort Model**
cohort	r	alpha	s	beta	lambda	mu
2018	0.397	10.745	0.122	2.794	0.037	0.044
2019	0.447	15.021	0.269	1.086	0.030	0.247

Table 6: **Extend PNBD: Time-Invariant Covariate Model**
cohort	r	alpha	s	beta	lambda	mu
2018	0.382	9.366	0.16	2.871	0.041	0.056
2019	0.382	15.873	0.16	0.870	0.024	0.184

According to above results, both Cohort Model and Extended PNBD Model have the same conclusion that cohort-2018 is better, which has the higher purchase rate and lower dropout rate.

The time unit used in the models is week. Now let’s change the time unit to year and try to get more intuitive result (i.e. compare the average number of transactions in a year, lambda, etc.).

Table 7: **Cohort Model**
(time unit: year)
cohort	lambda	mu
2018	1.92	2.28
2019	1.55	12.87

Table 8: **Extend PNBD: Time-Invariant Covariate Model**
(time unit: year)
cohort	lambda	mu
2018	2.12	2.90
2019	1.25	9.58

Compare Prediction Accuracy

Now let’s compare two models’ prediction error for CET (conditional expected transactions).

CET = PAlive * updated mean of Pareto/NBD
The value of CET has already involved the probability of alive (PAlive)!

ext_pred <- predict(ext_m)

ext_err <- ext_pred %>%
  summarize(
    MAE = mean(abs(actual.x - CET)),
    RMSE = sqrt(mean((actual.x - CET)^2))
  )

ch18_pred <- predict(m18) %>%
  select(actual.x, CET)

ch19_pred <- predict(m19) %>%
  select(actual.x, CET)

ch_err <- bind_rows(ch18_pred, ch19_pred) %>%
  summarize(
    MAE = mean(abs(actual.x - CET)),
    RMSE = sqrt(mean((actual.x - CET)^2))
  )

bind_rows(
  ch_err,
  ext_err
) %>%
  mutate(type = c("cohort model", "ext PNBD"), .before = 1) %>%
  print_kbl(cap = "Compare Model Prediction Error")

Table 9: Compare Model Prediction Error
type	MAE	RMSE
cohort model	1.031840	2.585261
ext PNBD	1.070709	2.623130

In this case, the cohort model is slightly more accurate in terms of MAE and RMSE.

However, in practice we may deal with many cohort groups and thus have to build many models. At that time, the extended PNBD with time-invariant covariate may save you a lot of time.

For example, in the above story, we used the first purchase year as time-invariant covariates to build ONLY ONE model instead of building m18 and m19, 2 separate models for 2018/2019 cohort groups.

Of course, there is no free lunch. We always need to balance the degree of “convenience” and the prediction accuracy.

Reference

Fader PS, Hardie BGS (2007). “Incorporating time-invariant covariates into the Pareto/NBD and BG/NBD models.” URL http://www.brucehardie.com/notes/019/time_invariant_covariates.pdf.
CLVTools R package Walkthrough pages

CLV Prediction in R

Sun, 10 Jul 2022 00:00:00 +0000

Introduction

In the previous posts, we talked about the theoretical part of Pareto/NBD model. This time, we will go over the CLV prediction in R.

Customer lifetime value (CLV) is a huge topic and CLV prediction is super important for the retailers. The decision maker could use CLV to determine “who” is the best customer and get ready to target them.

Roughly speaking,

$$ CLV \approx \text{future num of transactions} \cdot \text{future average spending} $$

apply the Pareto/NBD model to predict the future # of transactions
apply the Gamma-Gamma model to predict the future average spending

This approach is a more probabilistic approach. Of course, we can use machine learning (tree based models) to predict the future total spending, say during next year, using tidymodels workflow, but personally I prefer the simple but powerful probability models.

R package

I mainly use the following 3 R package to fulfill the CLV task:

CLVTools is pretty comprehensive and powerful over all 3. BTYDPlus provides lots of extensions for BTYD, for example its MBG/NBD model fixed the limitation of the BG/BD. BTYD is the oldest one but good for learning propose.

library(zetaEDA)
library(zetaclv)
library(BTYD)
library(BTYDplus)
enable_zeta_ggplot_theme()

Import the fake transactional data for this tutorial,

cohort19 <- eg_trans_data %>% 
  # add column first purchase year
  with_groups(cust, mutate, fp_yr = min(lubridate::year(date))) %>% 
  filter(fp_yr == 2019) %>% 
  select(-fp_yr)

# have a look
cohort19 %>% 
  head() %>% 
  arrange(cust, date) %>%
  print_kbl(cap = "Cohort 2019 transaction data")

Table 1: Cohort 2019 transaction data
cust	date	sales
uid0001	2019-12-02	3470
uid0001	2020-04-20	1050
uid0001	2020-04-20	124
uid0005	2019-08-08	1169
uid0006	2019-04-20	508
uid0006	2020-04-09	922

Build the Pareto/NBD Model using CLVTools 📦.

# build clv class of data
dclv <- generate_clvdata(
  data = cohort19,
  timeUnit = "week", 
  splitDate = NULL
)

## Note that: time unit is in < week >

# model object
pareto_nbd <- pnbd(dclv)

summary(pareto_nbd)

## Pareto NBD Standard  Model 
## 
## Call:
## pnbd(clv.data = dclv)
## 
## Fitting period:                                
## Estimation start  2019-01-01    
## Estimation end    2021-06-07    
## Estimation length 126.8571 Weeks
## 
## Coefficients:
##       Estimate Std. Error  z-val Pr(>|z|)    
## r      0.45945    0.04783  9.606   <2e-16 ***
## alpha 20.06906    1.71733 11.686   <2e-16 ***
## s      0.18148    0.01842  9.853   <2e-16 ***
## beta   1.01572    0.44456  2.285   0.0223 *  
## ---
## Signif. codes:  0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1
## 
## Optimization info:                  
## LL     -12872.0449
## AIC    25752.0898 
## BIC    25775.0767 
## KKT 1  TRUE       
## KKT 2  TRUE       
## fevals 24.0000    
## Method L-BFGS-B   
## 
## Used Options:                 
## Correlation FALSE

All these packages have common modeling steps, which will be showed in the next section.

Build `cbs` data

(C)ustomer-(B)y-(S)ufficient data includes:

x : number of repeat transactions.
- Usually, multiple transactions on the same day just count once; in other words, count the how many purchase days.
- 同一天多次购买，算一次。一般来说，是计数多少个不同的购买日期。
t.x : Time between first and last transactions.
- 首次购买至最后一次购买相隔的时间。
T.cal: Time between first transaction and end of calibration period.
- 首次购买至当前观测日相隔的时间。

More details for the cbs data, check this:

# the help doc explains all above variables
?BTYDplus::elog2cbs()

We have many ways to get cbs data from transactional data, here I use my own function.

cbs_dat <- generate_cbs(
  data = cohort19,
  timeUnit = "week", 
  splitDate = NULL
) %>% 
  select(cust, x, t.x, T.cal)

## Note that: time unit is in < week >

# check
cbs_dat %>% 
  head() %>% 
  print_kbl(cap = "example: CBS data")

Table 2: example: CBS data
cust	x	t.x	T.cal
uid0001	1	20.00000	79.00000
uid0005	0	0.00000	95.57143
uid0006	1	50.71429	111.28571
uid0010	0	0.00000	120.42857
uid0011	0	0.00000	124.85714
uid0012	0	0.00000	87.00000

Predict PAlive

This is the most tough part w.r.t computation in Pareto/NBD modeling. If you forget the story, please check my previous post here.

Result from “A Note on Deriving the Pareto/NBD Model and Related Expressions” shows that:

Checking source code

If we check the source code of the following functions, we’ll find they apply the above formula to get the probability of alive.

# check the source code:

# BTYD::pnbd.PAlive()

# BTYD::pnbd.generalParams

After checking, you will find that BTYD::pnbd.PAlive() internally called BTYD::pnbd.generalParams .

Insight

The probability of alive (PALive) for a given customer is a function of:

The 4 model parameters $ (r, \alpha, s, \beta) $.
The customer’s own CBS info, $ (x, t_x, T) $.

To sum up,

PAlive is a function of 4 parameters and individual’s CBS data.

$$ \text{PAlive} = \text{function}(r, \alpha, s, \beta, x, t_x, T) $$

PAlive DOES NOT depend on the prediction horizon $t $ ! This is a common mistake when someone explains this prediction result.

Interpretation

Let’s find the PAlive for cust:uid0001 who had x=1 repeat transactions (or 2 transactions in total),

# his own cbs
cbs_dat %>% 
  filter(cust == "uid0001")

##      cust x t.x T.cal
## 1 uid0001 1  20    79

# palive is a function of 4 model params and his own cbs
palive_val <- BTYD::pnbd.PAlive(
  params = unname(coef(pareto_nbd)),
  x = 1,
  t.x = 20, 
  T.cal = 79
)

palive_val

## [1] 0.6198724

For customer uid0001, the probability that he is still “alive” at present (i.e. $ \tau > T $ ) is 62.0%. In other words, there is 38.0% chance that the customer uid0001 had already leaved the company.

What about the customers with single purchase?

single_cbs_dat <- cbs_dat %>% 
  filter(x == 0) %>% 
  arrange(T.cal)

single_cbs_dat %>% 
  head() %>% 
  print_kbl(cap = "Example of the single purchase cbs data")

Table 3: Example of the single purchase cbs data
cust	x	t.x	T.cal
uid2509	0	0	74.85714
uid3443	0	0	74.85714
uid4183	0	0	74.85714
uid0301	0	0	75.00000
uid0727	0	0	75.00000
uid0799	0	0	75.00000

single_ids <- single_cbs_dat$cust

# use predict in clvtools to get all prediction results
all_preds <- predict(pareto_nbd, prediction.end = 52)

# discover the ones with single purchase
plotdata <- all_preds %>%
  filter(Id %in% single_ids) %>% 
  select(Id, PAlive) %>% 
  left_join(single_cbs_dat, by = c("Id" = "cust")) %>% 
  arrange(T.cal)

# have a look
plotdata %>% 
  head() %>% 
  print_kbl(cap = "Example of palive for the one with single purchase")

Table 4: Example of palive for the one with single purchase
Id	PAlive	T.cal
uid2509	0.3266206	74.85714
uid3443	0.3266206	74.85714
uid4183	0.3266206	74.85714
uid0301	0.3263572	75.00000
uid0727	0.3263572	75.00000
uid0799	0.3263572	75.00000

plotdata %>% 
  ggplot(aes(x = T.cal, y = PAlive)) +
  geom_jitter(alpha = .2, size = 2.5, width = .42) +
  geom_line(color = "tomato", size = 1.4) +
  labs(
    x = "T.cal (unit: week)",
    title = "PAlive (of single purchase customers) as a function of T.cal"
  )

If the customer had only 1 purchase, the earlier the purchase made, the more likely he will drop out. Fits our intuition.

Predict Conditional Expected Transaction

Insight

From last post, we have showed the Conditional Expected Transaction, CET, is the product of PAlive and the updated mean of Pareto/NBD:

CET = PAlive * updated mean of Pareto/NBD
The value of CET has already involved the probability of alive (PAlive)!

Example

Let’s check it by manually calculate the CET for the future 52 weeks.

params <- unname(coef(pareto_nbd))

# model parameters
r = params[1]
a = params[2]
s = params[3]
b = params[4]

# the customers cbs
cbs_dat %>% 
  filter(cust == "uid0001")

##      cust x t.x T.cal
## 1 uid0001 1  20    79

Setting inputs,

# note that from above formula 't.x' is not needed for the updated mean
x = 1
Tcal = 79

# prediction time horizon
t = 52

# follow the formula to compute updated mean of pnbd
part1 <- (r+x)*(b+Tcal)
part2 <- (a+Tcal)*(s-1)
part3 <- 1 - ((b+Tcal)/(b+Tcal+t))^(s-1)

updated_mean <- part1/part2*part3

updated_mean

## [1] 0.7295102

The “updated” mean of Pareto/NBD DOES NOT involve the individual’s t.x, only involves x and Tcal of the individual.

The individual’s t.x has nothing to do with “updated” mean of Pareto/NBD. This is a interesting point!
However, individual’s t.x definitely affects the PAlive.

# CET calculated manually
updated_mean * palive_val

## [1] 0.4522032

# CET calculated using BTYD
BTYD::pnbd.ConditionalExpectedTransactions(
  params = params,
  T.star = 52, 
  x = 1, 
  t.x = 20, 
  T.cal = 79
)

## [1] 0.4522032

# CET calculated using CLVTools
all_preds %>% 
  select(Id, CET) %>% 
  filter(Id == "uid0001") %>% 
  pull(CET)

## [1] 0.4522032

Oh yeah, all the above results are the same 🙂.

What happened on “updated” mean of Pareto/NBD?

# mean of Pareto/NBD
# without the individual level information
mean_pnbd <- BTYD::pnbd.Expectation(params = params, t = 52)
mean_pnbd

## [1] 0.6949746

# updated mean of Pareto/NBD
# for customer uid0001
updated_mean

## [1] 0.7295102

After updating the parameter with the individual’s behavior, we can see the “new mean” increase a little bit from 0.695 to 0.73.

Interpretation

Under customer uid0001’s past behavior, i.e. given his cbs data, the model expects he will make 0.45 number of transactions in the future 52 weeks.

Predict Average Spending

Insight

We will predict the customer’s future average spending using Gamma-Gamma-Model (if you don’t remember the story, click it). We have showed that ,

The moral of the story is that:

If the customer has many transactions, then his own average spending “will say more”, and the population mean “will say less”.
On the other hand, if the customer has a small number of transactions, then the population mean “will say more” on his future average spending.

Parameter Estimation (including the 1st trans.)

spend_cbs_data <- generate_cbs(
  data = cohort19,
  timeUnit = "week",
  splitDate = NULL
) %>% 
  # total number of tran
  mutate(num_trans = x + 1) %>% 
  # average spending
  mutate(avg_spend = sales/num_trans) %>% 
  mutate(is_single = x == 0) %>%
  as_tibble()

## Note that: time unit is in < week >

Same results obtained from two packages:

# check the function in BTYD
?BTYD::spend.EstimateParameters

params <- BTYD::spend.EstimateParameters(
  m.x.vector = spend_cbs_data$avg_spend,
  x.vector = spend_cbs_data$num_trans
)

names(params) <- c("p", "q", "r")

params

##           p           q           r 
##    1.749611    2.686046 2939.254721

# check the gg function in CLVTools
?CLVTools::gg

ggamma <- CLVTools::gg(clv.data = dclv, remove.first.transaction = FALSE)

ggamma

## Gamma-Gamma Model
## 
## Call:
## CLVTools::gg(clv.data = dclv, remove.first.transaction = FALSE)
## 
## Coefficients:
##        p         q     gamma  
##    1.750     2.686  2939.255  
## KKT1: TRUE 
## KKT2: TRUE

Understand weighted average

Calculate the weight for the given individual’s observed average,

# calculate the weight for the given individual's observed average
cal_ind_wt <- function(param_vec, num_trans) {
  p = param_vec[1]
  q = param_vec[2]
  r = param_vec[3]
  x = num_trans
  
  unname(
    (p*x) / (p*x + q - 1)
  )
}

Calculate the population mean,

cal_pop_mean <- function(param_vec) {
  p <- param_vec[1]
  q <- param_vec[2]
  r <- param_vec[3]

  if (q < 1) {
    stop("q must be greater than 1!")
  }

  # return
  res <- (p * r) / (q - 1)
  
  unname(res)
}

# what is the pop mean
pop_mean_spend <- cal_pop_mean(params)

pop_mean_spend

## [1] 3050.065

Now let’s compute the weight for each customer,

plotdata <- spend_cbs_data %>% 
  select(cust, is_single, num_trans, avg_spend) %>%
  mutate(ind_wt = cal_ind_wt(params, num_trans)) %>%
  mutate(pop_wt = 1 - ind_wt)

set.seed(123)

plotdata %>% 
  slice_sample(n = 10) %>% 
  mutate(across(ends_with("wt"), fmt_pct)) %>% 
  mutate(avg_spend = fmt_comma(avg_spend)) %>%
  print_kbl(cap = "weight for individual vs. weight for pop")

Table 5: weight for individual vs. weight for pop
cust	is_single	num_trans	avg_spend	ind_wt	pop_wt
uid4895	FALSE	3	1,574	76%	24%
uid1199	TRUE	1	6,809	51%	49%
uid0433	FALSE	4	1,971	81%	19%
uid4051	FALSE	12	2,022	93%	7%
uid2552	TRUE	1	3,132	51%	49%
uid2792	TRUE	1	280	51%	49%
uid2829	TRUE	1	4,485	51%	49%
uid2348	TRUE	1	1,730	51%	49%
uid1525	FALSE	4	2,005	81%	19%
uid3588	TRUE	1	1,706	51%	49%

plotdata %>% 
  distinct(num_trans, .keep_all = TRUE) %>% 
  select(num_trans, ind_wt) %>% 
  ggplot(aes(x = num_trans, y = ind_wt)) +
  geom_point() +
  geom_line() + 
  scale_y_continuous(labels = fmt_pct) +
  labs(title = "Individual Weight as a function of Num. of Trans.")

Parameter Estimation (without the 1st trans.)

params2 <- CLVTools::gg(clv.data = dclv, remove.first.transaction = TRUE) %>% coef

params2

##           p           q       gamma 
##    1.309883    2.542147 3975.335041

plotdata <- spend_cbs_data %>% 
  select(cust, is_single, num_trans, avg_spend) %>%
  mutate(ind_wt = cal_ind_wt(params2, num_trans)) %>%
  mutate(pop_wt = 1 - ind_wt)

plotdata %>% 
  distinct(num_trans, .keep_all = TRUE) %>% 
  select(num_trans, ind_wt) %>% 
  ggplot(aes(x = num_trans, y = ind_wt)) +
  geom_point() +
  geom_line() + 
  scale_y_continuous(labels = fmt_pct) +
  labs(title = "Individual Weight as a function of Num. of Trans.")

Theory Behind Pareto/NBD Part 1

Sun, 31 Jan 2021 00:00:00 +0000

1 Introduction

The Pareto/NBD model was developed by Schmittlein et al. (1987) to describe repeat-buying behavior in a noncontractual setting.

There are 4 key questions:

How many “alive” customers does the firm now have?
How has this customer base grown over the past year?
Which individuals on this list most likely represent active customers? Inactive customers?
What level of transactions should be expected next year by those on the list, both individually and collectively?

In order to answer these questions, we need to build up the model(s) to estimate:

What is the $\mathbb{P}(alive|\text{her trans infor})$?
What is the $\mathbb{E}(\text{# of trans}|\text{her trans infor})$?

2 PNBD Model Assumptions

2.1 Two stages in the lifetime

Customers go through 2 stages in their “lifetime”: they are “alive” for some period of time, then become permanently inactive.

2.2 Poisson Purchase

Given a customer while alive, the number of transactions follows Poisson distribution with parameter $\lambda$, called transaction rate. The probability of observing $x$ transactions in the time interval $(0,t]$ is given by:

\[P(X(t) = x | \lambda ) = e^{-\lambda t}\frac{(\lambda t)^x}{x!}, \ x = 0,1,2,...\]

This is equivalent to assuming that the time between transactions is $Exp(\lambda)$,

\[f(t_j - t_{j-1} | \lambda ) = \lambda e^{(t_j - t_{j-1})}, \ t_j > t_{j-1}> 0, \]

where $t_j$ is the time of the jth purchase.

2.3 Exponential Lifetime

A customer’s unobserved “lifetime” of length $\tau$, \[\tau \sim Exp(\mu), \ \ f(\tau | \mu) = \mu e^{-\mu\tau},\] where $\mu$ is called dropout rate.

2.4 Gamma transaction rate

Heterogeneity in transaction rates across customers follows a gamma distribution with shape parameter $r$ and scale parameter $\alpha$:

\[ \lambda \sim Gamma(r, \alpha ), \ \ g(\lambda|r, \alpha ) = \frac{\alpha ^r \lambda^{r-1}e^{-\lambda \alpha }}{\Gamma (r)}. \]

2.5 Gamma dropout rate

Heterogeneity in dropout rates across customers follows a gamma distribution with shape parameter $s$ and scale parameter $\beta$:

\[ \mu \sim Gamma(s, \beta), \ \ g(\mu | s, \beta ) = \frac{\beta^s\mu^{s-1}e^{-\mu\beta}}{\Gamma(s)}. \]

2.6 Two processes are Independent

The transaction rate $\lambda$ and the dropout rate $\mu$ vary independently across customers,

\[ \lambda \perp \mu. \]

3 Why named Pareto/NBD?

Short answer:

\[ \text{Poisson Purchase} + \text{Gamma transaction rate} \implies \text{NegBin} \]

\[ \text{Exponential lifetime} + \text{Gamma dropout rate} \implies \text{Pareto} \]

3.1 Poisson Gamma Mixture

Theorem 3.1 If we assume the Poisson purchase and the Gamma transaction rate, then the distribution of the number of transactions while the customer is alive is Negative Binomial (NBD).

Proof. \[\begin{align} P(X(t) = x | r, \alpha ) &= \int_{0}^{\infty}P(X(t) = x | \lambda )g(\lambda |r, \alpha ) d\lambda \\ & = \int_{0}^{\infty} e^{-\lambda t}\frac{(\lambda t)^x}{x!}\frac{\lambda^{r-1}\alpha^re^{-\lambda \alpha }}{\Gamma(r)} d\lambda\\ & = \frac{\alpha ^r}{\Gamma(r)}\frac{t^x}{x!}\int_{0}^{\infty }\lambda ^{x+r-1}e^{-\lambda (t+\alpha )} d\lambda, \text{ let } u = (t+\alpha )\lambda ,\\ & = \frac{\alpha ^r}{\Gamma(r)}\frac{t^x}{x!}\frac{1}{(t+\alpha)^{x+r} }\int_{0}^{\infty }u^{x+r-1}e^{-u}du, \text{ note the form of } \Gamma(.),\\ & = \frac{\alpha ^r}{\Gamma(r)}\frac{t^x}{x!}\frac{1}{(t+\alpha)^{x+r} }\Gamma(x+r) \\ & = \frac{\Gamma(r+x)}{\Gamma(r)x!}\left ( \frac{\alpha }{\alpha +t} \right )^{r}\left ( \frac{t}{\alpha +t} \right )^x \end{align}\]

Note that the last line is the density of negative binomial. It looks a little bit different from our familiar version of NegBin, and the parameter $r$ extends to the $\mathbb{R}^{+}$. In this case, it is called Polya distribution which is a special case of negative binomial.

3.2 Exponential Gamma Mixture

Theorem 3.2 If we assume the Exponential lifetime and the Gamma dropout rate, then the distribution of the “lifetime” is “Pareto distribution of the second kind”.

Proof. \[\begin{align} f(\tau|s, \beta ) &= \int_{0}^{\infty }f(\tau|\mu)g(\mu|s, \beta)d\mu \\ &= \int_{0}^{\infty }\mu e^{-\mu\tau}\frac{\beta e^{-\beta\mu}(\beta\mu)^{s-1}}{\Gamma(s)}d\mu\\ &= \frac{\beta^s}{\Gamma(s)} \int_{0}^{\infty }\mu^{s} e^{-\mu(\tau+\beta)}d\mu, \text{ let } \ \ u = \mu(\tau+\beta) \\ &= \frac{\beta^s}{\Gamma(s)} \int_{0}^{\infty }\frac{1}{(\tau+\beta)^s}u^s e^{-u}\frac{1}{\tau+\beta}du\\ &= \frac{\beta^s}{\Gamma(s)}\frac{1}{(\tau+\beta)^{s+1}}\int_{0}^{\infty }u^s e^{-u}du\\ &= \frac{\beta^s}{\Gamma(s)}\frac{1}{(\tau+\beta)^{s+1}}\Gamma(s+1)\\ &= \frac{\beta^s}{\Gamma(s)}\frac{1}{(\tau+\beta)^{s+1}}s\Gamma(s)\\ &= \frac{s}{\beta}\left ( \frac{\beta}{\tau+\beta} \right )^{s+1} \end{align}\]

Note that

\[ \begin{align} F(\tau|s, \beta ) &= \int_{0}^{\infty }F(\tau|\mu)g(\mu|s, \beta)d\mu \\ &= 1 - \left ( \frac{\beta}{\beta + \tau} \right ) ^{s} \end{align} \]

Therefore, if we assume Exponential lifetime and Gamma dropout rate, we have ended with Pareto Type II distribution, or more specifically, Lomax distribution.

In conclusion, the NBD and Pareto labels for each of the sub-models naturally leads to the name of the integrated model.

In the next post we will talk about the likelihood, the mean of the Pareto/NBD model, and other related derivations, eg. probability of the customer being alive.

4 Reference

Schmittlein DC, Morrison DG, Colombo R (1987). “Counting Your Customers: Who-Are They and What Will They Do Next?” Management Science, 33(1), 1-24.
Fader PS, Hardie BGS (2005). “A Note on Deriving the Pareto/NBD Model and Related Expressions.” URL
Fader PS, Hardie BGS (2007). “Incorporating time-invariant covariates into the Pareto/NBD and BG/NBD models.” URL.
Fader PS, Hardie BGS (2020). “Deriving an Expression for P(X(t)=x) Under the Pareto/NBD Model.” URL

Theory Behind Pareto/NBD Part 2

Sun, 31 Jan 2021 00:00:00 +0000

1 Deriving the Likelihood Function

Last time we talked about the ParetoNBD Model. Today we’ll derive the model likelihood function.

1.1 Some notation

For an customer,

Define:

\[ x = \text{the number of purchase,} \]

\[ t_i = \text{the time of ith purchase}, \ \text{ where } 1 \le t_i \le t_x, \]

\[ t_x = \text{the time of last purchase in the history,} \]

\[ T = \text{total time being observed} \]

Next, we’ll show that it is sufficient to use individual’s $(x, t_x, T)$ to describe his/her purchase behavior in Pareto/NBD model.

1.2 Conditional on $\lambda$ and $\mu$

Assume a customer’s $x$ transactions occurred during the period $(0,T]$; we denote these times by $t_1, t_2, t_3, \cdots, t_x$.

There are two possible ways this pattern of transactions could arise:

The customer is still alive at the end of the observation period (i.e., $\tau > T$ ), the individual-level likelihood function is simply the product of the (inter-transaction-time) exponential pdf and the associated survivor function:

\[\begin{aligned} L\left(\lambda \mid t_{1}, \ldots, t_{x}, T, \tau>T\right) &= \lambda e^{-\lambda t_{1}} \lambda e^{-\lambda\left(t_{2}-t_{1}\right)} \cdots \lambda e^{-\lambda\left(t_{x}-t_{x-1}\right)} e^{-\lambda\left(T-t_{x}\right)} \\ &=\lambda^{x} e^{-\lambda T} \end{aligned}\]

The customer became inactive at some time $\tau$ in the interval $(t_x, T]$ (i.e. $\tau \in (t_x, T]$), in which case the individual-level likelihood function is

\[\begin{aligned} & L\left(\lambda \mid t_{1}, \ldots, t_{x}, T, \text { inactive at } \tau \in\left(t_{x}, T\right]\right) \\ &=\lambda e^{-\lambda t_{1}} \lambda e^{-\lambda\left(t_{2}-t_{1}\right)} \cdots \lambda e^{-\lambda\left(t_{x}-t_{x-1}\right)} e^{-\lambda\left(\tau-t_{x}\right)} \\ &=\lambda^{x} e^{-\lambda \tau} \end{aligned}\]

Note that in both cases, information on when each of the x transactions occurred is not required.

We can replace $t_1, ...t_x$ , $T$ with $(x, t_x , T)$ where, by definition, $t_x = 0$ when $x = 0$. In other words, $t_x$, $x$ and $T$ are sufficient summaries of a customer’s transaction history. Using direct marketing terminology, $t_x$ is recency and $x$ is frequency.

由以上两个事实可知，无需知晓客户每次的购买时间，第一次消费时间、最后一次消费时间、消费频次 作为充分统计量，已经足够我们导出似然函数了！

Removing the conditioning on $\tau$ gives us the following expression for the individual-level likelihood function:

\[\begin{aligned} L\left(\lambda, \mu \mid x, t_{x}, T\right)=& L(\lambda \mid x, T, \tau>T) P(\tau>T \mid \mu) + \\ &\int_{t_{x}}^{T} L\left(\lambda \mid x, T, \text { inactive at } \tau \in\left(t_{x}, T\right]\right) f(\tau \mid \mu) d \tau \\ &=\lambda^{x} e^{-\lambda T} e^{-\mu T}+\lambda^{x} \int_{t_{x}}^{T} e^{-\lambda \tau} \mu e^{-\mu \tau} d \tau \\ &=\lambda^{x} e^{-(\lambda+\mu) T}+\frac{\lambda^{x} \mu}{\lambda+\mu} e^{-(\lambda+\mu) t_{x}}-\frac{\lambda^{x} \mu}{\lambda+\mu} e^{-(\lambda+\mu) T} \\ &=\frac{\lambda^{x} \mu}{\lambda+\mu} e^{-(\lambda+\mu) t_{x}}+\frac{\lambda^{x+1}}{\lambda+\mu} e^{-(\lambda+\mu) T} \end{aligned}\]

1.3 Removing the Conditioning on $\lambda$ and $\mu$

We remove the conditioning on $\lambda$ and $\mu$ by taking the expectation of $L(\lambda, \mu | x, t_x , T)$ over the distributions of $\lambda$ and $\mu$ :

\[ L\left(r, \alpha, s, \beta \mid x, t_{x}, T\right)=\int_{0}^{\infty} \int_{0}^{\infty} L\left(\lambda, \mu \mid x, t_{x}, T\right) g(\lambda \mid r, \alpha) g(\mu \mid s, \beta) d \lambda d \mu \]

The computation is tedious, check the paper “A Note on Deriving the Pareto/NBD Model and Related Expressions” to know the details.

1.4 MLE for $r, \alpha, s, \beta$

Since we have derived the likelihood function $L\left(r, \alpha, s, \beta \mid x, t_{x}, T\right)$, the 4 Pareto/NBD model parameters $(r, \alpha, s, \beta)$ can be estimated via the method of MLE. Specifically, suppose we have a sample of $N$ customers, where customer $i$ had $x_i$ transactions in the period $(0, T_i ]$, with the last transaction occurring at $t_{x_i}$ . The sample log-likelihood function is given by

\[ L L(r, \alpha, s, \beta)=\sum_{i=1}^{N} \ln \left[L\left(r, \alpha, s, \beta \mid x_{i}, t_{x_{i}}, T_{i}\right)\right]. \]

This can be maximized using standard numerical optimization routines. Therefore, we will obtain 4 maximum likelihood estimators $(\widehat{r} \ , \ \widehat{\alpha} \ , \ \widehat{s} \ , \ \widehat{\beta})$

2 Derivations

2.1 Mean of the Pareto/NBD Model

Given that the number of transactions follows a Poisson process while the customer is alive,

if $\tau > t$, the expected number of transactions is simply $\lambda t$.
if $\tau \le t$, the expected number of transactions in the interval (0, τ] is $\lambda \tau$.

Removing the conditioning on the time at which the customer becomes inactive, it follows that the expected number of transactions in the time interval $(0, t]$, conditional on $\lambda$ and $\mu$, is

\[ \begin{aligned} E[X(t) \mid \lambda, \mu] &=\lambda t P(\tau>t \mid \mu)+\int_{0}^{t} \lambda \tau f(\tau \mid \mu) d \tau \\ &=\lambda t e^{-\mu t}+\lambda \int_{0}^{t} \mu \tau e^{-\mu \tau} d \tau \\ &=\lambda t e^{-\mu t}+\frac{\lambda}{\mu} \int_{0}^{t} \mu^{2} \tau e^{-\mu \tau} d \tau, \text{where integrand is an Erlang-2} \\ &=\lambda t e^{-\mu t}+\frac{\lambda}{\mu}\left\{1-e^{-\mu t}-\mu t e^{-\mu t}\right\} \\ &=\frac{\lambda}{\mu}-\frac{\lambda}{\mu} e^{-\mu t} \end{aligned} \]

Now removing the Conditioning on $\lambda$ and $\mu$,

\[\begin{align} E[X(t) \mid r, \alpha, s, \beta] &=\int_{0}^{\infty} \int_{0}^{\infty} E[X(t) \mid \lambda, \mu] g(\lambda \mid r, \alpha) g(\mu \mid s, \beta) d \lambda d \mu \\ &=\frac{r \beta}{\alpha(s-1)}-\frac{r \beta^{s}}{\alpha(s-1)(\beta+t)^{s-1}} \\ &=\frac{r \beta}{\alpha(s-1)}\left[1-\left(\frac{\beta}{\beta+t}\right)^{s-1}\right] \tag{2.1} \end{align}\]

2.2 Derivation of PAlive

The probability that a customer with purchase history $(x, t_x , T)$ is “alive” at time $T$ is $P(\tau > T)$.

\[\begin{aligned} P\left(\tau>T \mid \lambda, \mu, x, t_{x}, T\right) &=\frac{L(\lambda \mid x, T, \tau>T) P(\tau>T \mid \mu)}{L\left(\lambda, \mu \mid x, t_{x}, T\right)} \\ &=\frac{\lambda^{x} e^{-(\lambda+\mu) T}}{L\left(\lambda, \mu \mid x, t_{x}, T\right)} \end{aligned}\]

As the $\lambda$ and $\mu$ are unobserved, we compute $P(alive | x, t_x , T)$ for a randomly-chosen individual by taking the expectation of the above result over the distribution of $\lambda$ and $\mu$ , updated to take account of the information $(x, t_x , T)$:

\[\begin{array}{l} P\left(\text { alive } \mid r, \alpha, s, \beta, x, t_{x}, T\right) \\ \qquad=\int_{0}^{\infty} \int_{0}^{\infty} P\left(\tau>T \mid \lambda, \mu, x, t_{x}, T\right) g\left(\lambda, \mu \mid r, \alpha, s, \beta, x, t_{x}, T\right) d \lambda d \mu \end{array}\]

By Bayes’ theorem, the joint posterior distribution of $\lambda$ and $\mu$ is

\[ g\left(\lambda, \mu \mid r, \alpha, s, \beta, x, t_{x}, T\right)=\frac{L\left(\lambda, \mu \mid x, t_{x}, T\right) g(\lambda \mid r, \alpha) g(\mu \mid s, \beta)}{L\left(r, \alpha, s, \beta \mid x, t_{x}, T\right)} \]

Thus,

\[\begin{array}{l} P\left(\text { alive } \mid r, \alpha, s, \beta, x, t_{x}, T\right) \\ \quad=\int_{0}^{\infty} \int_{0}^{\infty} \lambda^{x} e^{-(\lambda+\mu) T} g(\lambda \mid r, \alpha) g(\mu \mid s, \beta) d \lambda d \mu / L\left(r, \alpha, s, \beta \mid x, t_{x}, T\right) \\ \quad=\frac{\Gamma(r+x) \alpha^{r} \beta^{s}}{\Gamma(r)(\alpha+T)^{r+x}(\beta+T)^{s}} / L\left(r, \alpha, s, \beta \mid x, t_{x}, T\right)\\ \quad=\left\{1+\left(\frac{s}{r+s+x}\right)(\alpha+T)^{r+x}(\beta+T)^{s} \mathrm{~A}_{0}\right\}^{-1} \end{array}\]

For details check the reference paper. Note that, the above result is the formula to calculate PAlive used in BTYD 📦 implemented in R.

2.3 Conditional Expectation of Transactions

Let random variable $Y(t) = \text{num of purchase made in } (T, T+t]$. We are interested in computing $E(Y(t)|x, t_x, T)$, the expected number of purchase in the period $(T, T+t]$ for a customer with purchase history $(x, t_x, T)$.

If the customer is active at $T$,

\[ \begin{array}{l} &E[Y(t) \mid \lambda, \mu, \text { alive at } T]\\ &=\lambda t P(\tau>T+t \mid \mu, \tau>T)+\int_{T}^{T+t} \lambda \tau f(\tau \mid \mu, \tau>T) d \tau\\ &=\lambda t e^{-\mu t}+\lambda \int_{0}^{t} \mu \tau e^{-\mu \tau} d \tau \\ &=\frac{\lambda}{\mu}-\frac{\lambda}{\mu} e^{-\mu t} \end{array} \]

Of course we don’t know whether a customer is alive at $T$; therefore

\[ E\left[Y(t) \mid \lambda, \mu, x, t_{x}, T\right]=E[Y(t) \mid \lambda, \mu, \text { alive at } T] P\left(\tau>T \mid \lambda, \mu, x, t_{x}, T\right) \]

Also, since $\lambda$ and $\mu$ are unobserved, we need to integrate them out:

\[ \begin{array}{c} E\left[Y(t) \mid r, \alpha, s, \beta, x, t_{x}, T\right]=\int_{0}^{\infty} \int_{0}^{\infty}\left\{E[Y(t) \mid \lambda, \mu, \text { alive at } T] P\left(\tau>T \mid \lambda, \mu, x, t_{x}, T\right)\right. \\ \left.g\left(\lambda, \mu \mid r, \alpha, s, \beta, x, t_{x}, T\right)\right\} d \lambda d \mu \end{array} \]

After the tedious computation, we will get

\[\begin{aligned} &E\left[Y(t) \mid r, \alpha, s, \beta, x, t_{x}, T\right]\\ &=\{\frac{\Gamma(r+x) \alpha^{r} \beta^{s}}{\Gamma(r)(\alpha+T)^{r+x}(\beta+T)^{s}} / L\left(r, \alpha, s, \beta \mid x, t_{x}, T\right)\} \\ &\times \frac{(r+x)(\beta+T)}{(\alpha+T)(s-1)}\left[1-\left(\frac{\beta+T}{\beta+T+t}\right)^{s-1}\right]\\ &= \{P(\text{alive}|x, t_x, T)\} \times \text{updated mean of Pareto/NBD} \end{aligned}\]

Note that:

The first part, the bracketed term, is out expression for $P(\text{alive}|x, t_x, T)$.
The rest part is mean of the Pareto/NBD (2.1), with “updated” parameters that reflect the individual’s behavior up to time $T$ (assuming no “death” in $(0,T])$).

Next time, we’ll finally take about the prediction of CLV.

3 Reference

Schmittlein DC, Morrison DG, Colombo R (1987). “Counting Your Customers: Who-Are They and What Will They Do Next?” Management Science, 33(1), 1-24.
Fader PS, Hardie BGS (2005). “A Note on Deriving the Pareto/NBD Model and Related Expressions.” URL
Fader PS, Hardie BGS (2007). “Incorporating time-invariant covariates into the Pareto/NBD and BG/NBD models.” URL.
Fader PS, Hardie BGS (2020). “Deriving an Expression for P(X(t)=x) Under the Pareto/NBD Model.” URL

Pareto-NBD | Chen Xing

Incorporating Time-Invariant Covariates into PNBD II

Introduction

Data Prepare

Train/Test

The Cohort Models

Cohort 2017

Cohort 2018

Interpret Model Coef

Accuracy of Predictions

The Extended PNBD Model

Interpret Model Coef

Accuracy of Predictions

Conclusion

Incorporating Time-Invariant Covariates into PNBD

Introduction

Add Time-Invariant Covariates in PNBD

Why we set $\alpha, \beta$ in this form?

Data Prepare

Cohort Models

Interpret Coef

Extended PNBD Model

Interpret Coef

Compare Two Models

Compare Prediction Accuracy

Reference

CLV Prediction in R

Introduction

R package

Build cbs data

Predict PAlive

Checking source code

Insight

Interpretation

What about the customers with single purchase?

Predict Conditional Expected Transaction

Insight

Example

What happened on “updated” mean of Pareto/NBD?

Interpretation

Predict Average Spending

Insight

Parameter Estimation (including the 1st trans.)

Understand weighted average

Parameter Estimation (without the 1st trans.)

Theory Behind Pareto/NBD Part 1

1 Introduction

2 PNBD Model Assumptions

2.1 Two stages in the lifetime

2.2 Poisson Purchase

2.3 Exponential Lifetime

2.4 Gamma transaction rate

2.5 Gamma dropout rate

2.6 Two processes are Independent

3 Why named Pareto/NBD?

3.1 Poisson Gamma Mixture

3.2 Exponential Gamma Mixture

4 Reference

Theory Behind Pareto/NBD Part 2

1 Deriving the Likelihood Function

1.1 Some notation

1.2 Conditional on \(\lambda\) and \(\mu\)

1.3 Removing the Conditioning on \(\lambda\) and \(\mu\)

1.4 MLE for \(r, \alpha, s, \beta\)

2 Derivations

2.1 Mean of the Pareto/NBD Model

2.2 Derivation of PAlive

2.3 Conditional Expectation of Transactions

3 Reference

Build `cbs` data