Final_PROJECT

資料彙整流程

1.顧客分群
2.依據顧客族群價值屬性:設定行銷目標
3.製作模型:估計顧客的回購率、預期營收獲利、終身價值
4.根據特徵設計行銷方案
5.對方案的成本、效益進行假設

1. 交易項目計錄：`Z`

rm(list=ls(all=T))
pacman::p_load(magrittr, readr, caTools, ggplot2, dplyr, vcd,d3heatmap,Matrix, vcd )

1.1 讀進資料

Z = read_csv("C:/BAR_group6/final/data/ta_feng_all_months_merged.csv") %>% 
   data.frame %>% setNames(c(
    "date","cust","age","area","cat","prod","qty","cost","price"))

## Parsed with column specification:
## cols(
##   TRANSACTION_DT = col_character(),
##   CUSTOMER_ID = col_character(),
##   AGE_GROUP = col_character(),
##   PIN_CODE = col_character(),
##   PRODUCT_SUBCLASS = col_double(),
##   PRODUCT_ID = col_character(),
##   AMOUNT = col_double(),
##   ASSET = col_double(),
##   SALES_PRICE = col_double()
## )

nrow(Z)

## [1] 817741

#項目比數

日期格式轉換

Z$date = as.Date(Z$date, format="%m/%d/%Y")
par(cex=0.8)
hist(Z$date,'weeks',freq=T,las=2)

年齡層級、郵遞區號

age.group = c("<25","25-29","30-34","35-39","40-44",
              "45-49","50-54","55-59","60-64",">65")
Z$age = c(paste0("a",seq(24,69,5)),"a99")[match(Z$age,age.group,11)]
Z$area = paste0("z",Z$area)

#年齡級層和郵遞區號
par(mfrow=c(1,2),cex=0.7)
table(Z$age, useNA='ifany') %>% barplot(main="Age Groups", las=2)
table(Z$area,useNA='ifany') %>% barplot(main="Areas", las=2)

處理離群值

# Quantile of Variables
sapply(Z[,7:9], quantile, prob=c(.99, .999, .9995))

##        qty   cost   price
## 99%      6  858.0 1014.00
## 99.9%   14 2722.0 3135.82
## 99.95%  24 3799.3 3999.00

# Remove Outliers
Z = subset(Z, qty<=24 & cost<=3800 & price<=4000) 
nrow(Z)

## [1] 817182

彙總訂單 Assign Transaction ID

Z$tid = group_indices(Z, date, cust) # same customer same day

資料總覽

# No. cust, cat, prod, tid
#把項目彙總成訂單
#顧客人數 品類 產品數 訂單數(有重複購買)
#平均購買週期(一個月一次)
sapply(Z[c("cust","cat","prod","tid")], n_distinct)

##   cust    cat   prod    tid 
##  32256   2007  23789 119422

2. 交易計錄：`X`

交易資料彙整

X = Z %>% group_by(tid) %>% summarise(
  date = min(date),          # 交易日期  
  cust = min(cust),          # 顧客 ID
  age = min(age),            # 顧客 年齡級別
  area = min(area),          # 顧客 居住區別
  items = n(),               # 交易項目(總)數
  pieces = sum(qty),         # 產品(總)件數
  total = sum(price),        # 交易(總)金額
  gross = sum(price - cost)  # 毛利
) %>% data.frame
nrow(X) # 119422

## [1] 119422

處理離群值

# Check Quantile & Remove Outliers
sapply(X[,6:9], quantile, prob=c(.999, .9995, .9999))

##        items   pieces     total    gross
## 99.9%     54  81.0000  9009.579 1824.737
## 99.95%    62  94.2895 10611.579 2179.817
## 99.99%    82 133.0000 16044.401 3226.548

# Remove Outliers
X = subset(X, items<=62 & pieces<95 & total<16000) # 119328

交易摘要

summary(X)

##       tid              date                cust          
##  Min.   :     1   Min.   :2000-11-01   Length:119328     
##  1st Qu.: 29855   1st Qu.:2000-11-29   Class :character  
##  Median : 59705   Median :2001-01-01   Mode  :character  
##  Mean   : 59712   Mean   :2000-12-31                     
##  3rd Qu.: 89581   3rd Qu.:2001-02-02                     
##  Max.   :119422   Max.   :2001-02-28                     
##      age                area               items            pieces      
##  Length:119328      Length:119328      Min.   : 1.000   Min.   : 1.000  
##  Class :character   Class :character   1st Qu.: 2.000   1st Qu.: 3.000  
##  Mode  :character   Mode  :character   Median : 5.000   Median : 6.000  
##                                        Mean   : 6.802   Mean   : 9.222  
##                                        3rd Qu.: 9.000   3rd Qu.:12.000  
##                                        Max.   :62.000   Max.   :94.000  
##      total             gross        
##  Min.   :    5.0   Min.   :-1645.0  
##  1st Qu.:  227.0   1st Qu.:   21.0  
##  Median :  510.0   Median :   68.0  
##  Mean   :  851.6   Mean   :  130.9  
##  3rd Qu.: 1080.0   3rd Qu.:  168.0  
##  Max.   :15345.0   Max.   : 3389.0

每周交易次數

par(cex=0.8)
hist(X$date, "weeks", freq=T, las=2, main="No. Transaction per Week")

3. 顧客資料：`A`

顧客資料彙整

d0 = max(X$date) + 1
A = X %>% mutate(
  days = as.integer(difftime(d0, date, units="days"))
  ) %>% group_by(cust) %>% summarise(
    r = min(days),      # recency
    s = max(days),      # seniority
    f = n(),            # frquency
    m = mean(total),    # monetary
    rev = sum(total),   # total revenue contribution
    raw = sum(gross),   # total gross profit contribution
    age = min(age),     # age group
    area = min(area),   # area code
  ) %>% data.frame      
nrow(A) # 32241

## [1] 32241

glimpse(X)

## Observations: 119,328
## Variables: 9
## $ tid    <int> 1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12, 13, 14, 15, 16, ...
## $ date   <date> 2000-11-01, 2000-11-01, 2000-11-01, 2000-11-01, 2000-1...
## $ cust   <chr> "00038317", "00045902", "00045957", "00046855", "000586...
## $ age    <chr> "a69", "a59", "a54", "a39", "a39", "a44", "a49", "a64",...
## $ area   <chr> "z115", "z115", "z115", "z115", "z115", "z115", "z115",...
## $ items  <int> 2, 4, 1, 3, 6, 14, 1, 5, 5, 18, 11, 8, 17, 1, 6, 6, 1, ...
## $ pieces <dbl> 3, 9, 1, 5, 6, 14, 8, 5, 12, 31, 11, 10, 22, 1, 11, 8, ...
## $ total  <dbl> 76, 555, 133, 185, 306, 623, 365, 257, 242, 1514, 432, ...
## $ gross  <dbl> -8, 95, -47, 14, 52, 88, -3, 55, 2, 193, -20, 101, 407,...

table(X$age, format(X$date, "%u"))

##      
##          1    2    3    4    5    6    7
##   a24  811  750  793  739  719  843 1005
##   a29 1544 1383 1276 1389 1186 1671 2058
##   a34 2757 2410 2341 2335 2222 3297 4294
##   a39 3256 2871 2721 2930 2842 3999 5129
##   a44 2623 2463 2392 2445 2323 3352 3976
##   a49 1904 1810 1660 1682 1745 2343 2835
##   a54 1188 1114 1031 1095 1059 1424 1579
##   a59  557  541  504  520  496  649  700
##   a64  463  475  429  542  467  570  609
##   a69  788  783  788  901  815  875  868
##   a99  638  712  509  649  574  611  681

X %>% mutate(wdate=factor(format(date, "%u"))) %>% 
  count(age, wdate) %>%
  ggplot(aes(x=wdate, y=n, fill=age)) +
    geom_bar(stat="Identity") +
    facet_wrap(~age)

#年齡r級距

加入週(平日或假日)的屬性將訂單或顧客分類

X %>% mutate(wdate=format(date, "%u")) %>% 
  group_by(cust) %>% summarise(
    weekday = mean(wdate <= 5)
  ) %>% right_join(A) -> A

## Joining, by = "cust"

A = A %>% mutate(
  wday = ifelse(weekday == 0, "WEND", 
         ifelse(weekday == 1, "WDAY", "MIXED")) %>% factor  )

觀察每群的人數分布

table(A$wday , cut(A$f, c(0, 4, 8, 12, 20, 30, Inf)) ) %>% 
  prop.table(2) %>% round(3)

##        
##         (0,4] (4,8] (8,12] (12,20] (20,30] (30,Inf]
##   MIXED 0.273 0.847  0.943   0.977   0.990    1.000
##   WDAY  0.437 0.129  0.053   0.022   0.010    0.000
##   WEND  0.290 0.024  0.005   0.001   0.000    0.000

set.seed(2030)
A$km = A[,c(2,5,6)] %>% scale %>% {kmeans(.,5)$cluster} 
#table(A$km)

library(tidyr)

## 
## Attaching package: 'tidyr'

## The following objects are masked from 'package:Matrix':
## 
##     expand, pack, unpack

## The following object is masked from 'package:magrittr':
## 
##     extract

A %>% group_by(km) %>% summarise_at(vars(r,f,m,weekday), mean) %>% 
  mutate_at(vars(r:weekday), scale)  -> df 

mx = df[,-1] %>% as.matrix.data.frame() %>% t 
colnames(mx) = paste0("G", 1:5)
par(cex=0.75)
barplot(mx, beside=T, col=rainbow(4), ylim=c(-2,3))
legend('topright', legend=rownames(mx), fill=rainbow(4))

🗿
【G1】不常來/購買金額低/平日
【G2】不常/平日/錢少
【G3】近期有來/常來/購買金額低/平日
【G4】不常來/購買金額高/假日
【G5】不常來/假日/錢少

#各族群的年齡分布(人數/比率)
par(mfrow=c(2,1),cex=0.75)
table(A$age,A$km) %>% barplot(beside=T,main="分群後各年齡人數")
table(A$age,A$km) %>% prop.table(2)  %>% barplot(beside=T,main="分群後各年齡比率")

#各族群的主要分布地區
library(d3heatmap)
H=table(A$km,A$area) %>% as.data.frame.matrix 
E = (rowSums(H) %o% colSums(H))/sum(H)   # cells' expected value 
r = (H - E)/sqrt(E)    # standerdized residuals
r[r > 100] = 100       # adjust the outlier

r %>% d3heatmap(col=colorRamp(c('seagreen','lightyellow','red')))

< ##### 我們選定三個終身價值較高且族群特徵較為明顯的族群作為我們的目標客群

1)【G2:狗】強力潛在客群
- 因為G2人數眾多（10057人），但我們在全體顧客的消費頻率表看不到明顯突起，以及造訪頻率不是五群最低的，所以排除「新顧客」的可能。
- G2地理位置在大豐園附近，造訪頻率比同在附近的G3低但最近有來過，所以推測這群顧客認為大豐非他們心中的購物首選地點，只是作為首選店家的替代，例如只有在大豐做促銷或是首選店家沒開，才會來大豐消費。
- G2對於大豐的特定商品的喜好與其他族群有顯著差異，有可能是因為大豐有首選店家無法沒有的產品，所以我們可以加強潛在優勢產品來增加G2的黏著度，行銷目標是增加與鞏固該族群的消費習慣。(比對了G2對產品的偏好以及對該產品價格的敏感度，可以發現G2對特定產品的偏好與其他族群有顯著不同，且G2與非洲大豐園買的產品通常價格敏感度高，不常買的產品價格敏感度低，我們認為是因為產品的「獨特性」導致此結果，造成G2族群只會在我們有特價時才來消費。(所以之行銷策略會以增加消費者黏著度，也就是產品獨特性為目標。以產品類別500201為例，我們發現其主要的消費客群是中年人，並從單價和購買平率來看可能是酒類等娛樂性飲品品項，因此我們在酒類品項上和其他製酒公司聯名製作獨有品牌，並於週五partyday讓忠心狗狗購買指定酒類或是飲料搭配特定食物(像是下酒菜等)即可享有紅利加倍的優惠。
- 而將產品偏好與敏感度交叉比對後，我們發現在前銷量前二十名的產品裡，發現G2價格敏感度最高，也有顯著偏好購買的130106產品，很適合推出促銷策略，也可以作為日後的策略方向。
2)【G2:狗】強力潛在客群
- G3地理位置在大豐園附近，且最近剛來過，造訪頻率極高，但消費金額偏低。我們將這群顧客歸類在「常來買東西的鄰居」，他們的預估購買機率與購買金額都是五群最高，所以是大豐最重要的核心顧客。
- 我們的行銷目標就是提高此族群的課單價，所以推出集點抽獎制，希望可以讓這群顧客為了換獎品而提高每次的購買金額以得到點數。
3)【G4:獅子】工作年齡人口
- G3位置不在附近，且最近沒有來，造訪頻率也不高，但平均客單價極高。我們將這群顧客歸類在「上班族」，消費模式可能是久久到大豐補齊家用品，平常沒時間造訪。
- 我們的行銷目標就是提高此族群的購買頻率，比對G4的造訪頻率可以看到在發薪日前有明顯頻率低谷，所以推出上班族有感的「17吃土週」滿額兑現金折價券以及免運活動，增加他們的購買慾望，也提高平日購買率。

######開始做預測 ##### The Demarcation Date Remove data after the demarcation date

#切三個月下來再做資料彙整
feb01 = as.Date("2001-02-01")#要切斷的日期
Z_new = subset(Z, date < feb01)    # 618212

Aggregate for the Transaction Records

#項目會總程訂單
X_new = group_by(Z_new, tid) %>% summarise(
  date = first(date),  # 交易日期
  cust = first(cust),  # 顧客 ID
  age = first(age),    # 顧客 年齡級別
  area = first(area),  # 顧客 居住區別
  items = n(),                # 交易項目(總)數
  pieces = sum(qty),          # 產品(總)件數
  total = sum(price),         # 交易(總)金額(已經*過件數了)
  gross = sum(price - cost)   # 毛利
  ) %>% data.frame  # 88387

#最大化營收還是最大化獲利
#營收最大的保整獲利最大的

summary(X_new)

##       tid             date                cust          
##  Min.   :    1   Min.   :2000-11-01   Length:88387      
##  1st Qu.:22098   1st Qu.:2000-11-23   Class :character  
##  Median :44194   Median :2000-12-12   Mode  :character  
##  Mean   :44194   Mean   :2000-12-15                     
##  3rd Qu.:66291   3rd Qu.:2001-01-12                     
##  Max.   :88387   Max.   :2001-01-31                     
##      age                area               items             pieces       
##  Length:88387       Length:88387       Min.   :  1.000   Min.   :  1.000  
##  Class :character   Class :character   1st Qu.:  2.000   1st Qu.:  3.000  
##  Mode  :character   Mode  :character   Median :  5.000   Median :  6.000  
##                                        Mean   :  6.994   Mean   :  9.453  
##                                        3rd Qu.:  9.000   3rd Qu.: 12.000  
##                                        Max.   :112.000   Max.   :339.000  
##      total             gross        
##  Min.   :    5.0   Min.   :-1645.0  
##  1st Qu.:  230.0   1st Qu.:   23.0  
##  Median :  522.0   Median :   72.0  
##  Mean   :  888.7   Mean   :  138.3  
##  3rd Qu.: 1120.0   3rd Qu.:  174.0  
##  Max.   :30171.0   Max.   : 8069.0

table(X_new$age, format(X_new$date, "%u"))

##      
##          1    2    3    4    5    6    7
##   a24  603  563  531  529  492  635  754
##   a29 1180 1023  879 1055  886 1249 1545
##   a34 2094 1820 1628 1757 1660 2424 3241
##   a39 2499 2118 1855 2159 2104 2953 3853
##   a44 2015 1812 1636 1816 1726 2501 3072
##   a49 1489 1343 1146 1218 1264 1731 2163
##   a54  910  813  715  793  785 1081 1211
##   a59  429  396  335  396  361  497  535
##   a64  347  340  284  400  351  422  470
##   a69  588  549  530  670  607  665  679
##   a99  476  522  367  462  420  450  510

X_new %>% mutate(wdate=factor(format(date, "%u"))) %>% 
  count(age, wdate) %>%
  ggplot(aes(x=wdate, y=n, fill=age)) +
    geom_bar(stat="Identity") +
    facet_wrap(~age)

#年齡r級距

Check Quantile and Remove Outlier

sapply(X_new[,6:9], quantile, prob=c(.999, .9995, .9999))

##          items   pieces     total    gross
## 99.9%  56.0000  84.0000  9378.684 1883.228
## 99.95% 64.0000  98.0000 11261.751 2317.087
## 99.99% 85.6456 137.6456 17699.325 3389.646

#切除離群值
#前漢數量的OUTLIER不會小於0
#quantile百分位

X_new = subset(X_new, items<=64 & pieces<=98 & total<=11260) 
#REGRATION對OUTLIER非常敏感

Aggregate for Customer Records

#訂單彙總成顧客
d0 = max(X_new$date) + 1
A_new = X_new %>% mutate(
  days = as.integer(difftime(d0, date, units="days"))
  ) %>% 
  group_by(cust) %>% summarise(
    r = min(days),      # recency
    s = max(days),      # seniority
    f = n(),            # frquency
    m = mean(total),    # monetary
    rev = sum(total),   # total revenue contribution
    raw = sum(gross),   # total gross profit contribution
    age = age[1],       # age group
    area = area[1],     # area code
  ) %>% data.frame      # 28584
nrow(A_new)

## [1] 28584

#切了三個月準備X(項目>>>訂單>>>顧客)

X_new %>% mutate(wdate=format(date, "%u")) %>% 
  group_by(cust) %>% summarise(
    weekday = mean(wdate <= 5)
  ) %>% right_join(A_new) -> A_new

## Joining, by = "cust"

A_new  = A_new  %>% mutate(
  wday = ifelse(weekday == 0, "WEND", 
         ifelse(weekday == 1, "WDAY", "MIXED")) %>% factor  )

table(A_new $wday , cut(A_new $f, c(0, 4, 8, 12, 20, 30, Inf)) ) %>% 
  prop.table(2) %>% round(3)

##        
##         (0,4] (4,8] (8,12] (12,20] (20,30] (30,Inf]
##   MIXED 0.264 0.853  0.957   0.980   1.000    1.000
##   WDAY  0.440 0.128  0.040   0.020   0.000    0.000
##   WEND  0.296 0.019  0.002   0.000   0.000    0.000

Classification Model

#做類別模(邏輯式回歸)
#10:AMOUNT是Y(做GLM模型的準確度會變100%)
glm1 = glm(buy ~ ., TR[,c(2:11, 13)],family=binomial()) 
summary(glm1)#看係數(每個X對Y的效果)>>>商務數據不關心,是要拿X來預測Y(不用理會共線性的問題>>不影響對Y估計值的準確度)

## 
## Call:
## glm(formula = buy ~ ., family = binomial(), data = TR[, c(2:11, 
##     13)])
## 
## Deviance Residuals: 
##     Min       1Q   Median       3Q      Max  
## -3.7551  -0.8705  -0.6950   1.0314   1.8769  
## 
## Coefficients:
##                Estimate Std. Error z value Pr(>|z|)    
## (Intercept)  -1.042e+00  1.576e-01  -6.611 3.82e-11 ***
## weekday      -2.230e-01  1.723e-01  -1.294  0.19577    
## r            -1.165e-02  9.199e-04 -12.664  < 2e-16 ***
## s             8.964e-03  9.331e-04   9.606  < 2e-16 ***
## f             2.864e-01  1.670e-02  17.152  < 2e-16 ***
## m            -2.494e-05  2.784e-05  -0.896  0.37035    
## rev           3.774e-05  1.937e-05   1.948  0.05143 .  
## raw          -2.284e-04  8.551e-05  -2.672  0.00755 ** 
## agea29       -4.177e-02  8.669e-02  -0.482  0.62991    
## agea34        1.775e-02  7.997e-02   0.222  0.82437    
## agea39        7.861e-02  7.926e-02   0.992  0.32131    
## agea44        8.773e-02  8.135e-02   1.078  0.28082    
## agea49        1.935e-02  8.460e-02   0.229  0.81912    
## agea54        1.964e-02  9.326e-02   0.211  0.83318    
## agea59        1.770e-01  1.094e-01   1.618  0.10574    
## agea64        6.038e-02  1.175e-01   0.514  0.60734    
## agea69        2.663e-01  1.048e-01   2.543  0.01101 *  
## agea99       -1.415e-01  1.499e-01  -0.944  0.34536    
## areaz106     -4.420e-02  1.322e-01  -0.334  0.73813    
## areaz110     -2.103e-01  1.046e-01  -2.011  0.04428 *  
## areaz114      3.331e-02  1.112e-01   0.300  0.76452    
## areaz115      2.543e-01  9.698e-02   2.622  0.00874 ** 
## areaz221      1.761e-01  9.769e-02   1.803  0.07141 .  
## areazOthers  -4.861e-02  1.046e-01  -0.465  0.64203    
## areazUnknown -1.700e-01  1.233e-01  -1.378  0.16818    
## wdayWDAY      1.040e-02  9.307e-02   0.112  0.91103    
## wdayWEND     -2.405e-01  1.025e-01  -2.347  0.01894 *  
## ---
## Signif. codes:  0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1
## 
## (Dispersion parameter for binomial family taken to be 1)
## 
##     Null deviance: 27629  on 20007  degrees of freedom
## Residual deviance: 23287  on 19981  degrees of freedom
## AIC: 23341
## 
## Number of Fisher Scoring iterations: 5

#重要的是拿來做預測
#PRED模型預測會買不會買
#製作混淆矩陣
#pred > 0.5利用臨界值切開來
pred =  predict(glm1, TS, type="response")
cm = table(actual = TS$buy, predict = pred > 0.5)
cm

##        predict
## actual  FALSE TRUE
##   FALSE  3724  879
##   TRUE   1684 2289

#依據狀況調整

acc.ts = cm %>% {sum(diag(.))/sum(.)}
#sum(diag(.))/sum(.)>>>>>分子:對角線(DIAG)相加;分母:整個矩陣相加
c(1-mean(TS$buy) , acc.ts)  # 0.69998

## [1] 0.5367304 0.7011427

# acc.tS測試的準確率是0.7
#1-mean(TS$buy)>>>>非(在原始資料筐會買的比率)


#NULL MODEL :猜比較大的比率>>>只能猜對五成三
#用模型可以猜對七成

colAUC(pred, TS$buy)

##                     [,1]
## FALSE vs. TRUE 0.7555224

# 0.7556(不是很好>>因為資料太短)
#選擇行銷對象未必會切在0.5(報償成本矩陣不同CUTOFF就會不同)

進行預測

Aggregate data 2000-12-01 ~ 2001~02-28.

#資料再重新切割一次
#把三個月的資料再加起來
#重新開始分析

d0 = max(X$date) + 1
B = X %>%
  filter(date >= as.Date("2000-12-01")) %>% 
  mutate(days = as.integer(difftime(d0, date, units="days"))) %>% 
  group_by(cust) %>% summarise(
    r = min(days),      # recency
    s = max(days),      # seniority
    f = n(),            # frquency
    m = mean(total),    # monetary
    rev = sum(total),   # total revenue contribution
    raw = sum(gross),   # total gross profit contribution
    age = age[1],       # age group
    area = area[1],     # area code
  ) %>% data.frame      # 28584
nrow(B)

## [1] 28531

X %>% mutate(wdate=format(date, "%u")) %>% 
  group_by(cust) %>% summarise(
    weekday = mean(wdate <= 5)
  ) %>% right_join(B) -> B

## Joining, by = "cust"

B  = B  %>% mutate(
  wday = ifelse(weekday == 0, "WEND", 
         ifelse(weekday == 1, "WDAY", "MIXED")) %>% factor  )

table(B$wday , cut(B $f, c(0, 4, 8, 12, 20, 30, Inf)) ) %>% 
  prop.table(2) %>% round(3)

##        
##         (0,4] (4,8] (8,12] (12,20] (20,30] (30,Inf]
##   MIXED 0.363 0.893  0.969   0.986   0.993    1.000
##   WDAY  0.392 0.094  0.026   0.014   0.007    0.000
##   WEND  0.245 0.012  0.004   0.000   0.000    0.000

In B, there is a record for each customer. B$Buy is the probability of buying in March.

B$Buy = predict(glm1, B, type="response")

💡：預測購買金額時要記得做指數、對數轉換！

B2 = B %>% mutate_at(c("m","rev"), log10)
B$Rev = 10^predict(lm1, B2) #指數再轉回來
#如果這個人來買會買多少錢
#三月份會來買的機率已集會買多少錢

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

B=left_join(B,A[,c(1,12)])

## Joining, by = "cust"

summary(B)

##      cust              weekday             r               s        
##  Length:28531       Min.   :0.0000   Min.   : 1.00   Min.   : 1.00  
##  Class :character   1st Qu.:0.3333   1st Qu.: 8.00   1st Qu.:39.00  
##  Mode  :character   Median :0.6667   Median :21.00   Median :62.00  
##                     Mean   :0.6015   Mean   :28.84   Mean   :57.84  
##                     3rd Qu.:1.0000   3rd Qu.:43.00   3rd Qu.:82.00  
##                     Max.   :1.0000   Max.   :90.00   Max.   :90.00  
##        f                m                rev             raw         
##  Min.   : 1.000   Min.   :    8.0   Min.   :    8   Min.   : -686.0  
##  1st Qu.: 1.000   1st Qu.:  354.0   1st Qu.:  638   1st Qu.:   66.0  
##  Median : 2.000   Median :  691.4   Median : 1516   Median :  213.0  
##  Mean   : 3.068   Mean   :  986.9   Mean   : 2600   Mean   :  407.7  
##  3rd Qu.: 4.000   3rd Qu.: 1271.6   3rd Qu.: 3304   3rd Qu.:  524.0  
##  Max.   :70.000   Max.   :13017.0   Max.   :95153   Max.   :16146.0  
##      age                area              wday            Buy        
##  Length:28531       Length:28531       MIXED:13221   Min.   :0.1177  
##  Class :character   Class :character   WDAY : 9531   1st Qu.:0.2835  
##  Mode  :character   Mode  :character   WEND : 5779   Median :0.4027  
##                                                      Mean   :0.4656  
##                                                      3rd Qu.:0.6165  
##                                                      Max.   :1.0000  
##       Rev                  km       
##  Min.   :    80.18   Min.   :1.000  
##  1st Qu.:   557.31   1st Qu.:1.000  
##  Median :   822.78   Median :2.000  
##  Mean   :   972.60   Mean   :2.601  
##  3rd Qu.:  1174.36   3rd Qu.:4.000  
##  Max.   :127567.23   Max.   :5.000

從馬賽克圖中我們觀察到G2(潛在客群)的消費習慣在某些產品上和其他族群不同因此我們繼續深入分析這些產品的屬性並推測這些產品編號可能代表哪些產品

購物籃分析

利用購物籃分析，找出會帶來高獲利品項銷售的關聯規則。

options(scipen=10, digits=3)
pacman::p_load(arules, arulesViz)
load("C:/BAR_group6/final/data/tf0.rdata")

依總毛利對產品名稱作排列

tapply((Z0$price-Z0$cost), Z0$prod, sum) %>% sort(dec=T) %>% names -> TOP

create a transaction object `tr`

做購物籃分析之前，需要將訂單裡面的品項製作成一個transactions物件(tr)

tr = as(split(Z[,"prod"], Z[,"tid"]), "transactions")
tr

## transactions in sparse format with
##  119422 transactions (rows) and
##  23789 items (columns)

找出關連規則

使用arules::apriori()這個方法找出品項間的關聯法則(Association Rules)；通常我們會先放寬限制條件，先找一組可能用到的法則。

R <- apriori(tr, parameter=list(supp=0.0001, conf=0.25))

## Apriori
## 
## Parameter specification:
##  confidence minval smax arem  aval originalSupport maxtime support minlen
##        0.25    0.1    1 none FALSE            TRUE       5  0.0001      1
##  maxlen target   ext
##      10  rules FALSE
## 
## Algorithmic control:
##  filter tree heap memopt load sort verbose
##     0.1 TRUE TRUE  FALSE TRUE    2    TRUE
## 
## Absolute minimum support count: 11 
## 
## set item appearances ...[0 item(s)] done [0.00s].
## set transactions ...[23789 item(s), 119422 transaction(s)] done [0.47s].
## sorting and recoding items ... [10166 item(s)] done [0.01s].
## creating transaction tree ... done [0.05s].
## checking subsets of size 1 2 3 4 5 6 7 8 9 done [0.61s].
## writing ... [9795 rule(s)] done [0.14s].
## creating S4 object  ... done [0.04s].

summary(R)

## set of 9795 rules
## 
## rule length distribution (lhs + rhs):sizes
##    2    3    4    5    6    7    8    9 
## 1143 3362 2429 1385  874  448  136   18 
## 
##    Min. 1st Qu.  Median    Mean 3rd Qu.    Max. 
##    2.00    3.00    4.00    3.95    5.00    9.00 
## 
## summary of quality measures:
##     support          confidence         lift          count    
##  Min.   :0.00010   Min.   :0.250   Min.   :   4   Min.   : 12  
##  1st Qu.:0.00012   1st Qu.:0.433   1st Qu.:  75   1st Qu.: 14  
##  Median :0.00017   Median :0.632   Median : 264   Median : 20  
##  Mean   :0.00023   Mean   :0.638   Mean   : 560   Mean   : 28  
##  3rd Qu.:0.00023   3rd Qu.:0.857   3rd Qu.:1106   3rd Qu.: 27  
##  Max.   :0.00586   Max.   :1.000   Max.   :5331   Max.   :700  
## 
## mining info:
##  data ntransactions support confidence
##    tr        119422  0.0001       0.25

行銷目標與方法

然後我們可以設定條件，找到會帶來高營收品項(rhs)的關聯規則(lhs => rhs)：

support : lhs品項被購買的基礎機率
confidence : lhs品項被購買時rhs被購買的機率
lift : lhs品項被購買時，rhs被購買所增加機率的倍數
count : 交易筆數(交易筆數如果太少，分析就沒有實質意義)

rx = subset(R, rhs %in% TOP[1:200] & lift >= 50 & count > 100 )
df = inspect(rx)

##      lhs                rhs              support confidence  lift count
## [1]  {4716114000312} => {4716114000329} 0.001273      0.553 231.6   152
## [2]  {4716114000329} => {4716114000312} 0.001273      0.533 231.6   152
## [3]  {4710154015138} => {4710154015206} 0.000996      0.374  52.1   119
## [4]  {4713754987614} => {4713754987607} 0.001139      0.304  78.5   136
## [5]  {4713754987607} => {4713754987614} 0.001139      0.294  78.5   136
## [6]  {4710011402026} => {4710011402019} 0.002822      0.674  90.2   337
## [7]  {4710088414328} => {4710088414311} 0.001792      0.466  86.2   214
## [8]  {4710011401142} => {4710011406123} 0.001532      0.413  50.3   183
## [9]  {4710085172702} => {4710085172696} 0.002428      0.540  62.0   290
## [10] {4710254049323} => {4710254049521} 0.002010      0.431  55.6   240
## [11] {4710011409056} => {4710011406123} 0.002629      0.414  50.4   314
## [12] {4710011409056} => {4710011401128} 0.004446      0.700  51.0   531
## [13] {4710085120093} => {4710085172696} 0.003743      0.498  57.2   447
## [14] {4710011401135} => {4710011401128} 0.005862      0.753  54.9   700
## [15] {4710011401142,                                                   
##       4710011409056} => {4710011401128} 0.001197      0.745  54.3   143
## [16] {4710011401135,                                                   
##       4710011401142} => {4710011406123} 0.000888      0.484  59.0   106
## [17] {4710011401135,                                                   
##       4710011401142} => {4710011401128} 0.001390      0.758  55.3   166
## [18] {4710011401142,                                                   
##       4710011405133} => {4710011401128} 0.001248      0.687  50.1   149
## [19] {4710011401128,                                                   
##       4710011401142} => {4710011406123} 0.001013      0.457  55.6   121
## [20] {4710085120093,                                                   
##       4710085172702} => {4710085172696} 0.001348      0.654  75.2   161
## [21] {4710085120093,                                                   
##       4710085172702} => {4710085120628} 0.001281      0.622  54.7   153
## [22] {4710085172696,                                                   
##       4710085172702} => {4710085120628} 0.001491      0.614  54.0   178
## [23] {4710085120628,                                                   
##       4710085172702} => {4710085172696} 0.001491      0.605  69.5   178
## [24] {4710011401135,                                                   
##       4710011409056} => {4710011406123} 0.001599      0.472  57.5   191
## [25] {4710011401135,                                                   
##       4710011409056} => {4710011401128} 0.002721      0.802  58.5   325
## [26] {4710011405133,                                                   
##       4710011409056} => {4710011406123} 0.001474      0.493  60.1   176
## [27] {4710011405133,                                                   
##       4710011409056} => {4710011401128} 0.002278      0.762  55.6   272
## [28] {4710011406123,                                                   
##       4710011409056} => {4710011401128} 0.001993      0.758  55.3   238
## [29] {4710011401128,                                                   
##       4710011409056} => {4710011406123} 0.001993      0.448  54.6   238
## [30] {4710085120093,                                                   
##       4710085172696} => {4710085120628} 0.002135      0.570  50.2   255
## [31] {4710085120093,                                                   
##       4710085120628} => {4710085172696} 0.002135      0.539  61.9   255
## [32] {4710011401135,                                                   
##       4710011405133} => {4710011406123} 0.001633      0.444  54.1   195
## [33] {4710011401135,                                                   
##       4710011405133} => {4710011401128} 0.002839      0.772  56.3   339
## [34] {4710011401135,                                                   
##       4710011406123} => {4710011401128} 0.002453      0.803  58.6   293
## [35] {4710011401128,                                                   
##       4710011401135} => {4710011406123} 0.002453      0.419  51.0   293
## [36] {4710011405133,                                                   
##       4710011406123} => {4710011401128} 0.002227      0.702  51.2   266
## [37] {4710011401128,                                                   
##       4710011405133} => {4710011406123} 0.002227      0.429  52.3   266
## [38] {4710011401135,                                                   
##       4710011401142,                                                   
##       4710011409056} => {4710011401128} 0.000946      0.856  62.5   113
## [39] {4710085120093,                                                   
##       4710085172696,                                                   
##       4710085172702} => {4710085120628} 0.000879      0.652  57.4   105
## [40] {4710085120093,                                                   
##       4710085120628,                                                   
##       4710085172702} => {4710085172696} 0.000879      0.686  78.8   105
## [41] {4710011401135,                                                   
##       4710011405133,                                                   
##       4710011409056} => {4710011406123} 0.000996      0.527  64.2   119
## [42] {4710011401135,                                                   
##       4710011405133,                                                   
##       4710011409056} => {4710011401128} 0.001574      0.832  60.7   188
## [43] {4710011401135,                                                   
##       4710011406123,                                                   
##       4710011409056} => {4710011401128} 0.001340      0.838  61.1   160
## [44] {4710011401128,                                                   
##       4710011401135,                                                   
##       4710011409056} => {4710011406123} 0.001340      0.492  60.0   160
## [45] {4710011405133,                                                   
##       4710011406123,                                                   
##       4710011409056} => {4710011401128} 0.001164      0.790  57.6   139
## [46] {4710011401128,                                                   
##       4710011405133,                                                   
##       4710011409056} => {4710011406123} 0.001164      0.511  62.3   139
## [47] {4710011401135,                                                   
##       4710011405133,                                                   
##       4710011406123} => {4710011401128} 0.001357      0.831  60.6   162
## [48] {4710011401128,                                                   
##       4710011401135,                                                   
##       4710011405133} => {4710011406123} 0.001357      0.478  58.2   162
## [49] {4710011401135,                                                   
##       4710011405133,                                                   
##       4710011406123,                                                   
##       4710011409056} => {4710011401128} 0.000862      0.866  63.1   103
## [50] {4710011401128,                                                   
##       4710011401135,                                                   
##       4710011405133,                                                   
##       4710011409056} => {4710011406123} 0.000862      0.548  66.8   103

topp10 = c("4716114000312","4716114000329","4710011402026","4710088414328","4713754987607","4713754987614","4710085172702","4710011401135","4710011401142","4710085120093")

table(Z$prod) %>% sort %>% tail(200) %>% names -> top20_new

test=left_join(Z[,c(2,6,7)],A[,c(1,12)])

## Joining, by = "cust"

MOSA(~prod+km, test[test$prod %in% topp10,])

以族群3為例,相較其他族群來說最常購買前三個,在購買其他產品時,也會推薦相對應關聯性高的其他產品,以達到精準個人化的購物體驗

Final_PROJECT

第六組 龔雪燕 郭培羽 郭律磊 沈佳蒨 吳紫瑜

2020-01-07 23:13:04

資料彙整流程

1. 交易項目計錄：Z

1.1 讀進資料

日期格式轉換

年齡層級、郵遞區號

處理離群值

彙總訂單 Assign Transaction ID

資料總覽

2. 交易計錄：X

交易資料彙整

處理離群值

交易摘要

每周交易次數

3. 顧客資料：A

顧客資料彙整

加入週(平日或假日)的屬性將訂單或顧客分類

觀察每群的人數分布

Aggregate for the Transaction Records

Check Quantile and Remove Outlier

Aggregate for Customer Records

Preparing the Target Variables (Y)

Aggregate Feb’s Transaction by Customer

The Target for Regression - A$amount

The Target for Classification - A$buy

Summary of the Dataset

Train & Test Dataset

Spliting for Classification

Classification Model

Regression Model

進行預測

計算顧客終身價值

FOR G2(潛在客戶/邊際顧客)

族群的價格敏感度

FOR G3(鄰居/老人)

FOR G4(上班族)

購買機率與預期營收的分布

市場模擬：不同的參數組合的比較

行銷推薦系統

購物籃分析

依總毛利對產品名稱作排列

create a transaction object tr

找出關連規則

行銷目標與方法

第六組龔雪燕郭培羽郭律磊沈佳蒨吳紫瑜

1. 交易項目計錄：`Z`

2. 交易計錄：`X`

3. 顧客資料：`A`

The Target for Regression - `A$amount`

The Target for Classification - `A$buy`

create a transaction object `tr`