rm(list=ls(all=TRUE))
pacman::p_load(vcd, magrittr, readr, caTools, ggplot2, dplyr, plotly)
load("data/tf0.rdata")
sapply(list(cust=A0,tid=X0,items=Z0), nrow)
##   cust    tid  items 
##  32241 119328 817182


年齡與地理區隔

par(mfrow=c(1,2),cex=0.7)
table(A0$age) %>% barplot(las=2,main="Age Groups")
table(A0$area) %>% barplot(las=2,main="Areas")

Fig-2: Zip Codes
Fig-2: Zip Codes
hist( log(A0$m, 10) )

Z0 %>% group_by(cat) %>% summarise(total=sum(price)) %>% arrange(desc(total))
## # A tibble: 2,007 × 2
##       cat   total
##     <dbl>   <dbl>
##  1 560201 4329366
##  2 560402 3634174
##  3 500201 2204325
##  4 110217 2201258
##  5 320402 1481172
##  6 100205 1222044
##  7 100401 1197920
##  8 530110 1192350
##  9 530101 1161968
## 10 500210  979403
## # ℹ 1,997 more rows
count(Z0, cat, wt=price, sort=T) %>% head(40)
##       cat       n
## 1  560201 4329366
## 2  560402 3634174
## 3  500201 2204325
## 4  110217 2201258
## 5  320402 1481172
## 6  100205 1222044
## 7  100401 1197920
## 8  530110 1192350
## 9  530101 1161968
## 10 500210  979403
## 11 130204  950573
## 12 130206  911146
## 13 530105  862488
## 14 530114  821197
## 15 100102  820440
## 16 520457  808004
## 17 110401  801041
## 18 470105  783751
## 19 530404  749396
## 20 530403  728067
## 21 100516  687805
## 22 120103  667070
## 23 470103  659723
## 24 500202  651402
## 25 500804  650290
## 26 110117  594221
## 27 100505  573466
## 28 110333  567365
## 29 110507  553278
## 30 100311  550610
## 31 100201  545784
## 32 100414  532424
## 33 110411  522463
## 34 320501  514550
## 35 715001  488710
## 36 560204  486962
## 37 100403  486522
## 38 110109  483314
## 39 120101  440492
## 40 100301  436311


年齡與地理區隔的關聯性

使用馬賽克圖檢視列連表的關聯性(Association between Categorial Variables)

  • 方塊大小代表該類別組合的數量
  • 紅(藍)色代表該類別組合的數量顯著小(大)於期望值
  • 期望值就是邊際機率(如上方的直條圖所示)的乘積
  • 卡方檢定(類別變數的關聯性檢定)的p值顯示在圖示最下方
  • p-value < 2.22e-16 : age 與 area 之間有顯著的關聯性
MOSA = function(formula, data) mosaic(formula, data, shade=T, 
  margins=c(0,1,0,0), labeling_args = list(rot_labels=c(90,0,0,0)),
  gp_labels=gpar(fontsize=9), legend_args=list(fontsize=9),
  gp_text=gpar(fontsize=7),labeling=labeling_residuals)

MOSA(~age+area, A0)

簡單泡泡圖

年齡區隔特徵
A0 %>% group_by(age) %>% summarise(
  Group.Size = n(),              # 族群人數
  avg.Freq = mean(f),            # 平均購買次數
  avg.Revenue = sum(f*m)/sum(f)  # 平均客單價
  ) %>% 
  ggplot(aes(y=avg.Freq, x=avg.Revenue)) +
  geom_point(aes(col=age, size=Group.Size), alpha=0.5) +
  geom_text(aes(label=age)) +
  scale_size(range=c(5,25)) +
  theme_bw() + theme(legend.position="none") +
  ggtitle("年齡區隔特徵 (泡泡大小:族群人數)") + 
  ylab("平均購買次數") + xlab("平均客單價")

mean(A0$age == "a99")
## [1] 0.01941627

由於a99(沒有年齡資料的顧客)人數不多，而且特徵很獨特，探索時我們可以考慮濾掉這群顧客

A0 %>% filter(age!="a99") %>%    # 濾掉沒有年齡資料的顧客('a99')
  group_by(age) %>% summarise(
  Group.Size = n(),              # 族群人數
  avg.Freq = mean(f),            # 平均購買次數
  avg.Revenue = sum(f*m)/sum(f)  # 平均客單價
  ) %>% 
  ggplot(aes(y=avg.Freq, x=avg.Revenue)) +
  geom_point(aes(col=age, size=Group.Size), alpha=0.5) +
  geom_text(aes(label=age)) +
  scale_size(range=c(5,25)) +
  theme_bw() + theme(legend.position="none") +
  ggtitle("年齡區隔特徵 (泡泡大小:族群人數)") + 
  ylab("平均購買次數") + xlab("平均客單價")

地理區隔特徵
A0 %>% filter(age!="a99") %>%    # 濾掉沒有年齡資料的顧客('a99')
  group_by(area) %>% summarise(
  Group.Size = n(),              # 族群人數
  avg.Freq = mean(f),            # 平均購買次數
  avg.Revenue = sum(f*m)/sum(f)  # 平均客單價
  ) %>% 
  ggplot(aes(y=avg.Freq, x=avg.Revenue)) +
  geom_point(aes(col=area, size=Group.Size), alpha=0.5) +
  geom_text(aes(label=area)) +
  scale_size(range=c(5,25)) +
  theme_bw() + theme(legend.position="none") +
  ggtitle("地理區隔特徵 (泡泡大小:族群人數)") + 
  ylab("平均購買次數") + xlab("平均客單價")

💡 主要發現：
※ 「年齡」與「地區」之間有很高的關聯性
    § 南港(z115)30~40歲的顧客比率比較低
    § 汐止(z221)、內湖(z114)和其他(zOthers)30~40歲的顧客比率比較高
※ 「平均購買次數」和「平均客單價」之間有明顯的負相關
    § 住的遠(近)的人比較少(常)來買、但每一次買的比較多(少)
    § 30~40歲(年輕和年長)的人比較少(常)來買、但每一次買的比較多(少)


產品資訊

cats = Z0 %>% group_by(cat) %>% summarise(
  noProd = n_distinct(prod),
  totalQty = sum(qty),
  totalRev = sum(price),
  totalGross = sum(price) - sum(cost),
  grossMargin = totalGross/totalRev,
  avgPrice = totalRev/totalQty
  )
品類的營收和毛利貢獻
g1 = arrange(cats, desc(totalRev)) %>% 
  mutate(pc=100*totalRev/sum(totalRev), cum.pc=cumsum(pc)) %>% 
  head(40) %>% ggplot(aes(x=1:40, label=cat)) +
  geom_col(aes(y=cum.pc),fill='cyan',alpha=0.5) +
  geom_col(aes(y=pc), fill='darkcyan',alpha=0.5) +
  labs(title="前40大品類(累計)營收", y="(累計)營收貢獻(%)") +
  theme_bw()
ggplotly(g1)
g2 = arrange(cats, desc(totalGross)) %>% 
  mutate(pc=100*totalGross/sum(totalGross), cum.pc=cumsum(pc)) %>% 
  head(40) %>% ggplot(aes(x=1:40,label=cat)) +
  geom_col(aes(y=cum.pc),fill='pink',alpha=0.5) +
  geom_col(aes(y=pc), fill='magenta',alpha=0.5) +
  labs(title="前40大品類(累計)獲利", y="(累計)獲利貢獻(%)") +
  theme_bw()
g2

plotly::subplot(g1, g2)

品類的營收和毛利貢獻相當分散

  • 營收最大的10個品類只貢獻~20%的營收
  • 毛利最大的10個品類只貢獻~12%的毛利


品類和年齡、地區的關聯性
top20 = tapply(Z0$qty,Z0$cat,sum) %>% sort %>% tail(20) %>% names
MOSA(~age+cat, Z0[Z0$cat %in% top20,])

MOSA(~cat+area, Z0[Z0$cat %in% top20,])

不同年齡、地區的顧客喜歡買的品類看來也不太一樣

周末與周間

X0$wday = format(X0$date, "%u")
par(cex=0.7, mar=c(2,3,2,1))
table(X0$wday) %>% barplot(main="No. Transactions in Week Days")

年齡與購物日的關聯性
MOSA(~age+wday, X0)

df = Z0 %>% filter(cat %in% top20) %>% mutate(wday = format(date, '%u'))
MOSA(~cat+wday, df)