R | Chen Xing

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.")

How to use DT table in blogdown?

Fri, 08 Jul 2022 00:00:00 +0000

The DT::datatable object often does not work appropriately in the blogdown post. How to solve this issue?

It seems no good answers for this problem. DT + widgetframe 📦 is a potential solution. I will do some experiment in this post.

library(tidyverse)
library(DT)
# this is the package to solve above issue
library(widgetframe)

After loading the packages, let’s make some tables.

Knit File Format

Here I am using Rmarkdown rather than Rmd!

Tibble

iris %>%
  head(10) %>%
  as_tibble()

## # A tibble: 10 × 5
##    Sepal.Length Sepal.Width Petal.Length Petal.Width Species
##           <dbl>       <dbl>        <dbl>       <dbl> <fct>  
##  1          5.1         3.5          1.4         0.2 setosa 
##  2          4.9         3            1.4         0.2 setosa 
##  3          4.7         3.2          1.3         0.2 setosa 
##  4          4.6         3.1          1.5         0.2 setosa 
##  5          5           3.6          1.4         0.2 setosa 
##  6          5.4         3.9          1.7         0.4 setosa 
##  7          4.6         3.4          1.4         0.3 setosa 
##  8          5           3.4          1.5         0.2 setosa 
##  9          4.4         2.9          1.4         0.2 setosa 
## 10          4.9         3.1          1.5         0.1 setosa

kableExtra

iris %>%
  head(5) %>%
  # this is a wrapping function for kbl in kableExtra
  zetaEDA::print_kbl(
    cap = "Test kableExtra"
  )

Table 1: Test kableExtra
Sepal.Length	Sepal.Width	Petal.Length	Petal.Width	Species
5.1	3.5	1.4	0.2	setosa
4.9	3.0	1.4	0.2	setosa
4.7	3.2	1.3	0.2	setosa
4.6	3.1	1.5	0.2	setosa
5.0	3.6	1.4	0.2	setosa

gt

Note that gt table has some displaying problem in Rmarkdown, but it works fine in Rmd. Really drives me crazy…

iris %>%
  head(5) %>%
  gt::gt()

Sepal.Length	Sepal.Width	Petal.Length	Petal.Width	Species
5.1	3.5	1.4	0.2	setosa
4.9	3.0	1.4	0.2	setosa
4.7	3.2	1.3	0.2	setosa
4.6	3.1	1.5	0.2	setosa
5.0	3.6	1.4	0.2	setosa

DT

If you need to sort, search or add url link in the table, you will find the DT::datatable super helpful.

However, usually DT table cannot appropriately display in blogdown environment.

For example,

iris %>%
  head(5) %>%
  DT::datatable(caption = "DOES NOT WORK Table")

We have to use widgetframe package. See more details for this package here.

dt <- iris %>%
  head(20) %>%
  DT::datatable(
    caption = "It Works Table",
    rownames = FALSE,
    selection = "none",
    escape = FALSE,
    class = "cell-border hover compact stripe",
    fillContainer = T,
    options = list(
      dom = "frtip",
      pageLength = 10,
      scrollX = TRUE
    )
  )

widgetframe::frameWidget(dt, height = 300, width = "100%")

Now it works fine.

I am also curious about the bootstrap in DT::datatable .

dt2 <- iris %>%
  head(20) %>%
  DT::datatable(
    caption = "Bootstrap Table",
    style = "bootstrap",
    rownames = FALSE,
    selection = "none",
    escape = FALSE,
    class = "cell-border hover compact stripe",
    fillContainer = T,
    options = list(
      dom = "frtip",
      pageLength = 10,
      scrollX = TRUE
    )
  )

widgetframe::frameWidget(dt2, height = 300, width = "100%")

Well, DOES NOT WORK…

Summary

When using DT in blogdown post, do 2 step:

Save DT::datatable to an object.
Use widgetframe::frameWidget .

Tidy Evaluation in R

Mon, 16 May 2022 00:00:00 +0000

1 Motivation

为什么需要tidy evaluation?

很多时候，我们需要建立一些wrapping functions，这些函数是建立在dplyr或者ggplot2之上的，函数中的参数 function(data, xvar, yvar, ...) 往往是data 中的某个列。我们来举个例子吧，

library(zetaEDA)
enable_zeta_ggplot_theme()

The data is diamonds data set,

dat <- diamonds %>% head(1000)

print_kbl(head(dat))

carat	cut	color	clarity	depth	table	price	x	y	z
0.23	Ideal	E	SI2	61.5	55	326	3.95	3.98	2.43
0.21	Premium	E	SI1	59.8	61	326	3.89	3.84	2.31
0.23	Good	E	VS1	56.9	65	327	4.05	4.07	2.31
0.29	Premium	I	VS2	62.4	58	334	4.20	4.23	2.63
0.31	Good	J	SI2	63.3	58	335	4.34	4.35	2.75
0.24	Very Good	J	VVS2	62.8	57	336	3.94	3.96	2.48

The common task is to compute group mean,

dat %>%
  group_by(color) %>%
  summarise(mean_price = mean(price, na.rm = TRUE))

## # A tibble: 7 × 2
##   color mean_price
##   <ord>      <dbl>
## 1 D          2594.
## 2 E          2543.
## 3 F          2692.
## 4 G          2576.
## 5 H          2308.
## 6 I          1948.
## 7 J          1990.

How to build a function to compute the group mean?

Maybe you would like to try this:

# define the function
cal_group_mean <- function(data, group_var, mean_var) {
  data %>%
    group_by(group_var) %>%
    summarize(mean = mean(mean_var, na.rm = TRUE))
}

# first try
cal_group_mean(dat, group_var = color, mean_var = price)

## Error in `group_by()`:
## ! Must group by variables found in `.data`.
## ✖ Column `group_var` is not found.

NOT Work! OK, let’s try this,

# second try
cal_group_mean(dat, group_var = "color", mean_var = "price")

## Error in `group_by()`:
## ! Must group by variables found in `.data`.
## ✖ Column `group_var` is not found.

In order to make it work, what you need is the Tidy Evaluation!

# define the function again, use tidy evaluation
cal_group_mean <- function(data, group_var, mean_var) {
  group_var <- enquo(group_var)
  mean_var <- enquo(mean_var)

  data %>%
    group_by(!!group_var) %>%
    summarize(mean = mean(!!mean_var, na.rm = TRUE))
}

# the correct result
cal_group_mean(dat, group_var = color, mean_var = price)

## # A tibble: 7 × 2
##   color  mean
##   <ord> <dbl>
## 1 D     2594.
## 2 E     2543.
## 3 F     2692.
## 4 G     2576.
## 5 H     2308.
## 6 I     1948.
## 7 J     1990.

2 `quo()` function & “bang bang” `!!`

In the example below we use the quo function and the “bang-bang” !! operator to set color as our group by variable.

The “quo” function allows us to store the variable name in our “group_var” variable
“!!” extracts the stored variable name.

# store the variable name in 'group_var'
group_var <- quo(color)

class(group_var)

## [1] "quosure" "formula"

dat %>%
  # extract the stored variable name using 'bang bang'
  group_by(!!group_var) %>%
  summarize(mean = mean(price, na.rm = TRUE))

## # A tibble: 7 × 2
##   color  mean
##   <ord> <dbl>
## 1 D     2594.
## 2 E     2543.
## 3 F     2692.
## 4 G     2576.
## 5 H     2308.
## 6 I     1948.
## 7 J     1990.

注意：上面的代码并没有写在函数的内部，如果我们需要使用tidy evaluation的方式来写函数的话，不要用quo ，需要使用enquo !

3 `enquo()` function & “bang bang” `!!`

To use tidy evaluation in a function, we will still use the “!!” operator as we did above, but instead of “quo” we will use the enquo function.

cal_group_stats <- function(data, group_var, target_var) {
  # store the variable name using `enquo`
  group_var <- enquo(group_var)
  target_var <- enquo(target_var)

  data %>%
    # extract the stored variable using bang-bang !!
    group_by(!!group_var) %>%
    summarize(across(!!target_var, list(
      mean = ~ mean(.x, na.rm = TRUE),
      sd = ~ sd(.x, na.rm = TRUE)
    )))
}

# try
cal_group_stats(dat, group_var = clarity, target_var = price)

## # A tibble: 8 × 3
##   clarity price_mean price_sd
##   <ord>        <dbl>    <dbl>
## 1 I1           2674.    618. 
## 2 SI2          2489.    840. 
## 3 SI1          2440.    873. 
## 4 VS2          2616.    669. 
## 5 VS1          2383.    928. 
## 6 VVS2         2497.    828. 
## 7 VVS1         2159.   1051. 
## 8 IF           2829.     38.0

cal_group_stats(dat, group_var = NULL, target_var = price)

## # A tibble: 1 × 2
##   price_mean price_sd
##        <dbl>    <dbl>
## 1      2477.     840.

4 The “Curly-Curly” Shortcut `{{}}`

The “curly-curly” {{ }} operator directly extracts a stored variable name from “target_var” in the example below. In the prior example we needed both “enquo” and “!!” to evaluate a variable like this so the “curly-curly” operator is a convenient shortcut.

cal_group_stats2 <- function(data, group_var, target_var) {
  # store the variable name using `enquo`
  group_var <- enquo(group_var)

  data %>%
    group_by(!!group_var) %>%
    # using `{{}}` as shortcut
    summarize(across({{ target_var }}, list(
      mean = ~ mean(.x, na.rm = TRUE),
      sd = ~ sd(.x, na.rm = TRUE)
    )))
}

# check
cal_group_stats2(dat, group_var = clarity, target_var = price)

## # A tibble: 8 × 3
##   clarity price_mean price_sd
##   <ord>        <dbl>    <dbl>
## 1 I1           2674.    618. 
## 2 SI2          2489.    840. 
## 3 SI1          2440.    873. 
## 4 VS2          2616.    669. 
## 5 VS1          2383.    928. 
## 6 VVS2         2497.    828. 
## 7 VVS1         2159.   1051. 
## 8 IF           2829.     38.0

identical(
  cal_group_stats(dat, group_var = clarity, target_var = price),
  cal_group_stats2(dat, group_var = clarity, target_var = price)
)

## [1] TRUE

Remark: {{}} is the shortcut of enquo() and !! .

5 `as_label()` function and `:=` operator

How can I use the variable name? The answer is as_label() function.

print_class <- function(data, myvar) {
  myvar1 <- enquo(myvar)
  message("Understand the class of `enquo(myvar)`:")
  print(class(myvar1))

  myvar2 <- as_label(enquo(myvar))
  message("Understand the class of `as_label(enquo(myvar))`:")
  print(class(myvar2))
}

# check
print_class(dat, myvar = color)

## Understand the class of `enquo(myvar)`:

## [1] "quosure" "formula"

## Understand the class of `as_label(enquo(myvar))`:

## [1] "character"

We will illustrate the as_label() using the below example:

The as_label function extracts the string value of the target_var variable (price in this case). We use this to set the value of the target_var column.
If you want to extract the string variable name with the as_label function, you will still need to use enquo and !!. You CANNOT use the {{}} shortcut!

cal_group_stats3 <- function(data, group_var, target_var) {
  # store the variable name using `enquo`
  group_var <- enquo(group_var)
  target_var <- enquo(target_var)

  data %>%
    group_by(!!group_var) %>%
    summarize(across(!!target_var, list(
      mean = ~ mean(.x, na.rm = TRUE),
      sd = ~ sd(.x, na.rm = TRUE)
    ))) %>%
    mutate(varName = as_label(target_var))
}

# check
cal_group_stats3(dat, group_var = color, target_var = price)

## # A tibble: 7 × 4
##   color price_mean price_sd varName
##   <ord>      <dbl>    <dbl> <chr>  
## 1 D          2594.     712. price  
## 2 E          2543.     769. price  
## 3 F          2692.     553. price  
## 4 G          2576.     715. price  
## 5 H          2308.     974. price  
## 6 I          1948.    1141. price  
## 7 J          1990.    1181. price

Let’s see another example: using the variable name in ggplot title.

plotxy <- function(data, xvar, yvar) {
  xvar <- enquo(xvar)
  yvar <- enquo(yvar)
  data_name <- as_label(enquo(data))

  data %>%
    ggplot(aes(x = !!xvar, y = !!yvar)) +
    geom_point() +
    geom_smooth() +
    # using variable name in the title
    ggtitle(str_c(
      as_label(yvar), " vs. ", as_label(xvar),
      " in ", data_name, " data"
    ))
}

# check
plotxy(iris, xvar = Sepal.Length, yvar = Sepal.Width)

Remark: If you need to use/extract the variable name as a string, please use enquo() and as_label() functions.

5.1 `:=` 用于在 `summarize` 或 `mutate` 中声明新变量

In the following example:

The “walrus operator” := is used to create a column named after the variable name stored in the target_var argument (“price” in the example).
The := allows you to use strings and evaluated variables (such as target_name and target_var in our example) on the left hand side of an assignment operation (where there would normally be a “=” operator) in functions such as “mutate” and “summarize”.

cal_group_stats4 <- function(data, group_var, target_var) {
  target_name <- as_label(enquo(target_var))

  data %>%
    group_by({{ group_var }}) %>%
    summarize(
      # use := to declare new column
      !!paste0("mean_", target_name) := mean({{ target_var }}),
      !!paste0("sd_", target_name) := sd({{ target_var }})
    )
}

# check
cal_group_stats4(dat, group_var = color, target_var = price)

## # A tibble: 7 × 3
##   color mean_price sd_price
##   <ord>      <dbl>    <dbl>
## 1 D          2594.     712.
## 2 E          2543.     769.
## 3 F          2692.     553.
## 4 G          2576.     715.
## 5 H          2308.     974.
## 6 I          1948.    1141.
## 7 J          1990.    1181.

Remark: 在 summarize 或者 mutate 函数里声明新变量时，如果等号到左边包含 as_label(enquo(var)) ，需要使用 := ，而非传统的🟰

6 `sysms()` function and `!!!`

The syms function and the !!! operator are used for passing a list of variables as a function argument.

In prior examples !! was used to evaluate a single group-by variable. We now use !!! to evaluate a list of group-by variables. One quirk is that to use the syms function we will need to pass the variable names in quotes.

cal_group_stats5 <- function(data, group_vars, target_var) {
  group_vars <- syms(group_vars)
  target_name <- as_label(enquo(target_var))

  data %>%
    group_by(!!!group_vars) %>%
    summarize(
      !!paste0("minVal_", target_name) := min({{ target_var }}),
      !!paste0("maxVal_", target_name) := max({{ target_var }})
    )
}

# check
# single group-by variable
cal_group_stats5(
  data = dat,
  group_vars = "color",
  target_var = price
)

## # A tibble: 7 × 3
##   color minVal_price maxVal_price
##   <ord>        <int>        <int>
## 1 D              357         2897
## 2 E              326         2897
## 3 F              342         2897
## 4 G              354         2896
## 5 H              337         2893
## 6 I              334         2896
## 7 J              335         2898

# a list of group-by variables
cal_group_stats5(
  data = dat,
  group_vars = c("color", "clarity"),
  target_var = price
)

## # A tibble: 53 × 4
## # Groups:   color [7]
##    color clarity minVal_price maxVal_price
##    <ord> <ord>          <int>        <int>
##  1 D     I1              2869         2869
##  2 D     SI2             2762         2896
##  3 D     SI1              552         2896
##  4 D     VS2              357         2897
##  5 D     VS1              402         2861
##  6 D     VVS2             554         2897
##  7 D     VVS1             553         2866
##  8 E     I1               345         2862
##  9 E     SI2              326         2896
## 10 E     SI1              326         2897
## # … with 43 more rows

# a NULL group-by variable
cal_group_stats5(
  data = dat,
  group_vars = NULL,
  target_var = price
)

## # A tibble: 1 × 2
##   minVal_price maxVal_price
##          <int>        <int>
## 1          326         2898

Remark: 如果有多个group-by variables，那么需要使用 syms 和 !!! .

7 Summary

The variable I am referring here is the variable in the function argument:

{{}} operator is a shortcut for using enquo() and !! .
If you need to use the variable name string, eg. use it in the ggplot title, please use enquo() and as_label .
If you need to declare the new variable in summarize / mutate , DO NOT use = , please use := instead.
If you have multiple group-by variables, the tidy evaluation requires to use syms() and !!! operator.

Why TBATS?

Sat, 07 May 2022 00:00:00 +0000

I read Hyndman’s “Forecasting time series with complex seasonal patterns using exponential smoothing” paper again these days and provide some notes.

What is TBATS model?

TBATS: Trigonometric seasonality, Box-Cox transformation, ARMA errors, Trend and Seasonal components.

Motivation

For time series with Complex Seasonality, the common model like ETS, ARIMA, etc. CANNOT handle.

What do I mean Complex Seasonality?
- non-integer seasonality
  - eg. weekly time series w/ annual seasonal pattern 365.25/7 ≈ 52.18.
- multiple seasonality
  - eg. hourly time series.
What do I mean CANNOT handle?
- Too Many seasonal components lead to over-parameterization.

Idea behind TBATS

Idea: Modification of the state space models for exponential smoothing!

Box-Cox transformation enable “non-linearity”.
Use ARMA process to model error.
Trigonometric representation of seasonal components based on Fourier series.

BATS Model

\[ \begin{aligned}y_{t}^{(\omega)} &=\left\{\begin{array}{ll}\frac{y_{t}^{\omega}-1}{\omega} ; & \omega \neq 0 \\\log y_{t} & \omega=0\end{array}\right.\\y_{t}^{(\omega)} &=\ell_{t-1}+\phi b_{t-1}+\sum_{i=1}^{T} s_{t-m_{i}}^{(i)}+d_{t} \\\ell_{t} &=\ell_{t-1}+\phi b_{t-1}+\alpha d_{t} \\b_{t} &=(1-\phi) b+\phi b_{t-1}+\beta d_{t} \\s_{t}^{(i)} &=s_{t-m_{i}}^{(i)}+\gamma_{i} d_{t} \\d_{t} &=\sum_{i=1}^{p} \varphi_{i} d_{t-i}+\sum_{i=1}^{q} \theta_{i} \varepsilon_{t-i}+\varepsilon_{t}\end{aligned} \]

Note that:

The equations above do the following:
- Box-Cox transformation
- State Space Model framework
- level component
- trend component
- seasonal component
- ARMA process modeling error
$\alpha, \beta, \gamma$ are smoothing parameters.
$\phi$ is damping parameter for damping trend.
$\epsilon_t \sim \text{Gaussian-WN}(0, \sigma^2)$

REMARK:

BATS treats seasonal component as same as ETS model. This implies that BATS can only model integer period lengths. Approach taken in BATS requires m_i seed states for season i, if this season is long the model may become intractable.

Therefore BATS DOES NOT solve the complex seasonality problem!

TBATS Model

The difference between BATS and TBATS is the first letter “T”. Specifically, TBATS use the trigonometric representation of seasonal components based on Fourier series. Therefore, the first letter “T” is for “Trigonometric”.

BATS differs from TBATS only in the way it models seasonal effects.For TBATS, we use:

\[ \begin{aligned}s_{t}^{(i)} &=\sum_{j=1}^{k_{i}} s_{j, t}^{(i)} \\s_{j, t}^{(i)} &=s_{j, t-1}^{(i)} \cos \lambda_{j}^{(i)}+s_{j, t-1}^{*(i)} \sin \lambda_{j}^{(i)}+\gamma_{1}^{(i)} d_{t} \\s_{j, t}^{*(i)} &=-s_{j, t-1} \sin \lambda_{j}^{(i)}+s_{j, t-1}^{*(i)} \cos \lambda_{j}^{(i)}+\gamma_{2}^{(i)} d_{t}\end{aligned} \]

Note:

We describe the stochastic level of the $i$th seasonal component by $s_{j, t}^{(i)}$.
The stochastic growth in the level of the $i$th seasonal component that is needed to describe the change in the seasonal component over time by $s_{j, t}^{*(i)}$
The number of harmonics required for the $i$th seasonal component is denoted by $k_i$. When $k_i = m_i/2$ for even values of $m_i$, and $k_i = (m_i - 1)/2$ for odd values of $m_i$.
Why using Fourier terms (Harmonics)?
- It is anticipated that most seasonal components will require fewer harmonics, thus reducing the number of parameters to be estimated.
KEY Advantage:
- Use harmonics to reduce number of parameters to be estimated, solve over-parameterization.
- Based on trigonometric functions, it can be used to model non-integer seasonal frequencies.

How Does TBATS Choose The Final Model

Under the hood TBATS will consider various alternatives and fit quite a few models. It will consider models:

with Box-Cox transformation and without it.
with and without Trend
with and without Trend Damping
with and without ARMA(p,q) process used to model residuals
non-seasonal model
various amounts of harmonics used to model seasonal effects

The final model will be chosen using Akaike information criterion (AIC).

In particular auto ARMA is used to decide if residuals need modeling and what p and q values are suitable.

R Code

Loading package:

library(zetaEDA)
library(zeta.forecast)
library(forecast)
enable_zeta_ggplot_theme()

Check data:

autoplot(weeksale)

splits <- ts_split(weeksale, 8)
train <- splits$train
test <- splits$test

BATS/TBATS

For BATS Model,

$\operatorname{BATS}\left(\omega, \phi, p, q, m_{1}, m_{2}, \ldots, m_{T}\right)$

# bats model
bats_m <- bats(train)
bats_m

## BATS(0.354, {1,0}, -, {52})
## 
## Call: bats(y = train)
## 
## Parameters
##   Lambda: 0.353777
##   Alpha: 0.06931721
##   Gamma Values: -0.2472086
##   AR coefficients: 0.353693
## 
## Seed States:
##              [,1]
##  [1,] 236.2172862
##  [2,]  48.6153298
##  [3,]  25.6318979
##  [4,]  65.9402978
##  [5,]  48.5353739
##  [6,]  34.5740092
##  [7,]  32.2362991
##  [8,]  17.0571974
##  [9,]  18.2687693
## [10,]  12.1147339
## [11,]  17.6131427
## [12,]  -0.8316901
## [13,]  -1.5229147
## [14,]  12.8711144
## [15,] -14.7505548
## [16,] -19.1669848
## [17,] -19.8997841
## [18,] -21.1926193
## [19,] -23.4601100
## [20,] -20.8589143
## [21,] -22.8231038
## [22,] -28.4857736
## [23,] -28.1033726
## [24,] -32.0859166
## [25,] -26.6846780
## [26,] -22.8513308
## [27,] -35.7280360
## [28,] -42.0967584
## [29,] -13.6621107
## [30,]  18.7225542
## [31,]   3.6108027
## [32,] -18.6830362
## [33,]  -9.1773408
## [34,]  -1.2862120
## [35,]  -0.1671799
## [36,]  20.2180037
## [37,]   5.0885815
## [38,] -11.7724907
## [39,] -41.3620492
## [40,] -46.7859929
## [41,] -49.6365415
## [42,] -57.6488590
## [43,] -24.3202110
## [44,] -37.3709292
## [45,] -28.7887699
## [46,] -25.1689822
## [47,]   5.6126602
## [48,]   5.6972456
## [49,]  48.6994849
## [50,]  93.1440007
## [51,]  77.8410675
## [52,]  60.1611764
## [53,]  59.6051217
## [54,]   0.0000000
## attr(,"lambda")
## [1] 0.3537771
## 
## Sigma: 30.79541
## AIC: 8780.338

For TBATS Model,

$\operatorname{TBATS}\left(\omega, \phi, p, q,\left\{m_{1}, k_{1}\right\},\left\{m_{2}, k_{2}\right\}, \ldots,\left\{m_{T}, k_{T}\right\}\right)$

# tbats model
tbats_m <- tbats(train)
tbats_m

## TBATS(0.346, {0,1}, -, {<52.19,5>})
## 
## Call: tbats(y = train)
## 
## Parameters
##   Lambda: 0.345914
##   Alpha: 0.01716498
##   Gamma-1 Values: -0.009315079
##   Gamma-2 Values: 0.005982234
##   MA coefficients: 0.343452
## 
## Seed States:
##              [,1]
##  [1,] 177.5373756
##  [2,]  29.6240539
##  [3,]  17.7008739
##  [4,]  16.6389904
##  [5,]   0.5296389
##  [6,]  -0.3902185
##  [7,] -11.3794443
##  [8,] -17.1882094
##  [9,]   7.1278290
## [10,]   8.5281331
## [11,]   2.5042501
## [12,]   0.0000000
## attr(,"lambda")
## [1] 0.3459141
## 
## Sigma: 31.59406
## AIC: 8771.571

Check the KEY Difference!

Note that:

TBATS: The seed state for seasonal is $2 \cdot k_1 = 2 \cdot 5 = 10$.
BATS: The seed state for seasonal is $52$! Much larger than TBATS

Performance

Compare Accuracy:

bats_fc <- forecast(bats_m, h = length(test))
tbats_fc <- forecast(tbats_m, h = length(test))

accuracy(bats_fc, test)

##                    ME      RMSE      MAE          MPE        MAPE      MASE
## Training set 1199.837  89752.11 46368.39 -28256.17129 28276.14207 0.6546733
## Test set     5425.741 151518.01 92546.58    -41.36154    58.91754 1.3066612
##                    ACF1 Theil's U
## Training set -0.1925466        NA
## Test set     -0.2937480  1.204268

accuracy(tbats_fc, test)

##                     ME      RMSE      MAE          MPE        MAPE      MASE
## Training set  6471.137  99574.55 51738.22 -50245.07151 50265.01625 0.7304897
## Test set     36719.289 136648.52 68088.57    -15.87087    36.99544 0.9613396
##                     ACF1 Theil's U
## Training set -0.09246037        NA
## Test set      0.03653672  1.050218

plots:

bats_cv <- tssv_direct(weeksale, test_horizon = 8, forecast_model = bats_forecast)

tbats_cv <- tssv_direct(weeksale, test_horizon = 8, forecast_model = tbats_forecast)

plot_tssv(bats_cv, max_hist = 52) +
  labs(title = "BSTS 8-step Forecast for weeksale data")

plot_tssv(tbats_cv, max_hist = 52) +
  labs(title = "TBSTS 8-step Forecast for weeksale data")

Here, the tbats model does a better job in terms of RMSE criteria.

Translate Column Names back and forth

Fri, 11 Mar 2022 00:00:00 +0000

在处理中文数据中，第一步就是翻译列名到英语。当我们分析完数据后，可能还需要将结果与之前的中文列名对应回去，这样比较麻烦。今天来总结一个小技巧。

# loading package
library(zetaEDA)

# raw data
dat <- tibble(姓名 = c("张三", "李四"), 年龄 = c(20, 30))

# check
dat %>% 
  print_kbl()

姓名	年龄
张三	20
李四	30

首先，建立一个数据集储存中英文对照表。

# build a column name translation data set
column_names_translation <- tibble(
  "姓名" = "name",
  "年龄" = "age"
) %>% 
  pivot_longer(1:2, names_to = "chinese", values_to = "english") 
  
# check
column_names_translation %>% 
  print_kbl()

chinese	english
姓名	name
年龄	age

接下来就是trick啦：

using deframe(), make a named vector
using rename(!!! your_variable)

# translate to English
tmp <- column_names_translation %>% 
  select(english, chinese) %>% 
  deframe()

tmp

##   name    age 
## "姓名" "年龄"

# `!!!` in rename is important
dat %>% 
  rename(!!!tmp) %>% 
  print_kbl()

name	age
张三	20
李四	30

# translate back to Chinese
tmp2 <- column_names_translation %>% 
  select(chinese, english) %>% 
  deframe()

dat %>% 
  rename(!!!tmp) %>% 
  rename(!!!tmp2) %>% 
  print_kbl()

姓名	年龄
张三	20
李四	30

R Plotly Tutorial

Fri, 07 Jan 2022 00:00:00 +0000

Loading Package

library(tidyverse)
library(plotly)
library(zetaEDA)
enable_zeta_ggplot_theme()

ggplotly

If you are very familiar with ggplot, then you can easily convert the ggplot object to plotly object, which is able to interactively communicate the plots with the end-user.

set.seed(123)

dat <- tibble(
  date = seq.Date(from = as.Date("2010-01-01"), length.out = 48, by = "month"),
  actual = rnorm(48, mean = 10, sd = 3),
  fc = rnorm(48, mean = 9.8, sd = 2.4)
)

dat <- dat %>%
  mutate(
    diff = actual - fc,
    RMSE = sqrt(mean((diff)^2)),
    MAE = mean(abs(diff))
  )

Take a look at our data:

dat %>%
  head() %>%
  knitr::kable()

date	actual	fc	diff	RMSE	MAE
2010-01-01	8.318573	11.671916	-3.3533432	3.462068	2.836012
2010-02-01	9.309468	9.599914	-0.2904467	3.462068	2.836012
2010-03-01	14.676125	10.407964	4.2681605	3.462068	2.836012
2010-04-01	10.211525	9.731488	0.4800374	3.462068	2.836012
2010-05-01	10.387863	9.697111	0.6907523	3.462068	2.836012
2010-06-01	15.145195	13.084646	2.0605495	3.462068	2.836012

ggplot code

plt_dat <- dat %>%
  select(actual, fc, date) %>%
  pivot_longer(cols = -date, names_to = "type", values_to = "value") %>%
  mutate(type = factor(type, levels = c("actual", "fc"))) %>%
  filter(date <= as.Date("2012-06-01"))

p <- plt_dat %>%
  ggplot(aes(x = date, y = value, fill = type)) +
  geom_col(position = "dodge", alpha = .8) +
  scale_fill_manual(values = c("steelblue", "orange")) +
  scale_x_date(
    date_breaks = "6 month",
    date_labels = "%Y-%m"
  ) +
  labs(x = "month", y = "value", title = "Compare Actual with Forecast Value")

p

Convert to plotly object using `ggplotly`

When you have a ggplot object, you can apply ggplotly function directly to get the result.

Note that:

This approach is the easiest way to do conversion!
However, this approach lacks some customization for plotly object.

# ?ggplotly

ggplotly(p)

Plotly

For advanced usage, please use plotly package function directly!

Reference: plotly r official website

Quickly learn use cheat sheet for plotly.

# step 1: make a plotly object
p2 <- plot_ly()

# step 2: add trace
p2 <- p2 %>%
  plotly::add_trace(
    data = plt_dat,
    x = ~date,
    y = ~value,
    color = ~type,
    type = "bar",
    colors = c("steelblue", "orange"),
    text = ~date,
    hovertemplate = "%{text}<br>%{y:.2f}"
  )

# step 3: set layout, i.e. x-axis, y-axis, title, etc.
p2 <- p2 %>%
  plotly::layout(
    title = "Compare Actual with Forecast Value",
    xaxis = list(
      tickformat = "%m\n%Y\n",
      title = "month",
      showline = TRUE,
      mirror = TRUE
    ),
    yaxis = list(
      showline = TRUE,
      mirror = TRUE,
      title = "value"
    )
  )

print your plotly object :)

p2

Plotly Reference

Shell Tutorial For R User

Fri, 05 Feb 2021 00:00:00 +0000

Let’s go over some basic shell commands.

Get started

Command	Description	In R
whoami	Who is the user?	Sys.info() / whoami::whoami()
date	Get date & time	Sys.date() / Sys.time()
cal	Display Calendar
clear	Clear the screen	Ctrl + L

whoami # who is the user

date # get data & time

cal # display canlendar

clear # clear the screen, crtl + l

Help/Documentation

Command	Description	In R
whatis	Single line description of a command	? / ?? / help()
man	Display manual pages for a command	? / ?? / help()
help	Display manual pages for a command	? / ?? / help()
/?	Display manual pages for a command	? / ?? / help()

man ls # help & documentation

whatis ls # single line description of a command

# help命令是bash内建命令，用于显示bash内建命令的帮助信息

Navigating file system

Command	Description	In R
pwd	Print working directory	getwd() / here::here()
ls	List directory contents	dir() / list.files() / list.dirs() / dir_info() / fs::dir_ls()
cd	Change current working directory	setwd()
mkdir	Create directory	dir.create() / fs::dir_create()
rmdir	Remove/delete directory	fs::dir_delete()

pwd # print working directory

ls # list files & folders

mkdir test # create directory called test

change working directory

Command	Description
cd	Navigate into directory
cd ..	Go up one level
cd -	Go to previous working directory
cd ~	Change directory to home directory
cd /	Change directory to root directory

cd test # navigate into test directory

cd .. # go up to one level

cd - # go to previous working directory
  
cd ~ # change directory to home directory

cd / # change directory to root directory
  
rmdir test # remove empty directory, note that the folder must be empty

list the file and folders

Command	Description
ls	List directory contents
ls -l	List files one per line
ls -a	List all files, including hidden files
ls - la	Display permission, ownership, size & modification date
ls -lh	Long format with size displayed in human readable units
ls -lS	Long format list sorted by size
ls -ltr	Long format list sorted by modification date

R | Chen Xing

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.)

How to use DT table in blogdown?

Knit File Format

Tibble

kableExtra

gt

DT

Summary

Tidy Evaluation in R

1 Motivation

2 quo() function & “bang bang” !!

3 enquo() function & “bang bang” !!

4 The “Curly-Curly” Shortcut {{}}

5 as_label() function and := operator

5.1 := 用于在 summarize 或 mutate 中声明新变量

6 sysms() function and !!!

7 Summary

Why TBATS?

What is TBATS model?

Motivation

Idea behind TBATS

BATS Model

TBATS Model

How Does TBATS Choose The Final Model

R Code

BATS/TBATS

Check the KEY Difference!

Performance

Translate Column Names back and forth

R Plotly Tutorial

Loading Package

ggplotly

ggplot code

Convert to plotly object using ggplotly

Plotly

Plotly Reference

Shell Tutorial For R User

Get started

Help/Documentation

Navigating file system

change working directory

list the file and folders

Build `cbs` data

2 `quo()` function & “bang bang” `!!`

3 `enquo()` function & “bang bang” `!!`

4 The “Curly-Curly” Shortcut `{{}}`

5 `as_label()` function and `:=` operator

5.1 `:=` 用于在 `summarize` 或 `mutate` 中声明新变量

6 `sysms()` function and `!!!`

Convert to plotly object using `ggplotly`