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


年齡與地理區隔的關聯性

使用馬賽克圖檢視列連表的關聯性(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)) +
  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()
g1

g2 = arrange(cats, desc(totalGross)) %>% 
  mutate(pc=100*totalGross/sum(totalGross), cum.pc=cumsum(pc)) %>% 
  head(40) %>% ggplot(aes(x=1:40)) +
  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)