Rで移動平均を計算してみた
会員の購買データから、直近3ヶ月の購買頻度をブランド(今回はABC）へのロイヤルティとみなして、計算しまして、その時使用したパッケージ、zooが便利だったのでメモ。
やりたいこと
こんなデータから
| ID | Weeks | Brand | purchase flg |
|---|---|---|---|
| A | 1 | ABC | 1 |
| A | 2 | ABC | 1 |
| A | 3 | DEF | 0 |
| A | 4 | ABC | 1 |
| B | 1 | DEF | 0 |
| B | 2 | DEF | 0 |
| B | 3 | DEF | 0 |
| B | 4 | ABC | 1 |
直近2週間のABC購入率をloyaltyとした場合、こんなカラムをつくこと
| ID | Weeks | Brand | purchase flg | loyalty |
|---|---|---|---|---|
| A | 1 | ABC | 1 | - |
| A | 2 | ABC | 1 | - |
| A | 3 | DEF | 0 | 1.00 |
| A | 4 | ABC | 1 | 0.50 |
| B | 1 | DEF | 0 | - |
| B | 2 | DEF | 0 | - |
| B | 3 | DEF | 0 | 0.00 |
| B | 4 | ABC | 1 | 0.00 |
前の週と、その前の週の購買のうち、ABCブランドの購入回数比率がここではloyaltyです。
移動平均
移動平均、英語ではmoving meanやrolling meanなんて呼ばれまして、いろいろパッケージなり、自作で関数を作られてる方も見受けられますが、いざ自分で作ろうとするとちょっと面倒。。そんなときこの関数を見つけました。
Rccpが便利！
大きく2ステップで求めます。
①当該週を含んだ、2週間で計算
②1周分ずらす
とりあえず、データを準備する。
rm(list = ls())
install.packages("zoo")
install.packages("data.table")
install.packages("dplyr")
library(zoo)
library(dplyr)
library(data.table)
#make data frame
table <- as.data.frame(matrix(rep(0, 3),nrow = 8))
table$ID <- rep(c("A", "B"), each = 4)
table$Weeks <- rep(1:4, 2)
table$Brand <- c("ABC", "ABC", "DEF", "ABC", "DEF", "DEF", "DEF", "ABC")
table <- table[,-1]
これで、下記のデータフレームができたので。
| ID | Weeks | Brand |
|---|---|---|
| A | 1 | ABC |
| A | 2 | ABC |
| A | 3 | DEF |
| A | 4 | ABC |
| B | 1 | DEF |
| B | 2 | DEF |
| B | 3 | DEF |
| B | 4 | ABC |
FLGを追加する。
#make FLG column
table$purchase_flg <- 0
table[table$Brand == c("ABC"), "purchase_flg"] <- 1
これで最初に載せたデータフレームが完成。やっと本番の移動平均へ。
| ID | Weeks | Brand | purchase flg |
|---|---|---|---|
| A | 1 | ABC | 1 |
| A | 2 | ABC | 1 |
| A | 3 | DEF | 0 |
| A | 4 | ABC | 1 |
| B | 1 | DEF | 0 |
| B | 2 | DEF | 0 |
| B | 3 | DEF | 0 |
| B | 4 | ABC | 1 |
で、ここからが本題の移動平均
①当該週を含んだ、2週間で計算
group_byを使って、ID別に移動平均を計算。
(一応、パッケージのインストールから再掲）
install.packages("zoo")
install.packages("data.table")
install.packages("dplyr")
library(zoo)
library(dplyr)
library(data.table)
#calculate rolling mean
table <- table %>%
dplyr::group_by(ID) %>%
mutate(loyalty = rollmean(purchase_flg, 2, align = "right", fill = 0))
これで、下記のデータフレームができる。
| ID | Weeks | Brand | purchase flg | loyalty |
|---|---|---|---|---|
| A | 1 | ABC | 1 | 0.00 |
| A | 2 | ABC | 1 | 1.00 |
| A | 3 | DEF | 0 | 0.50 |
| A | 4 | ABC | 1 | 0.50 |
| B | 1 | DEF | 0 | 0.00 |
| B | 2 | DEF | 0 | 0.00 |
| B | 3 | DEF | 0 | 0.00 |
| B | 4 | ABC | 1 | 0.50 |
補足をすると、
align = "right" 今週とその前の週の平均(1週目は前の週がないので、NAとなり、それ以降は当該週とその前の週の平均）
align = "left" で、当該週とその翌週の平均(1週目が計算できるようになり（1週目と2週目の平均）、4週目がその翌週がないので計算できなくなります）
fill= 0 で計算できない場合の処理を指示しています。今回の場合では、計算できない1週目の値を0としています。計算できない場合をNAとするときは、fill= 0ではなく、下記のようにしてください。
table <- table %>%
dplyr::group_by(ID) %>%
mutate(loyalty = rollmean(purchase_flg, 2, align = "right", na.pad = TRUE))
②1周分ずらす
今回は、前の週とその前の週の平均をloyaltyとしたいので、1週分データをずらします。
table <- table %>%
group_by(ID) %>%
mutate(lag_loyalty = lag(loyalty, k = 1, default = 0))
これでこうなります。
| ID | Weeks | Brand | purchase flg | loyalty | lag_loyalty |
|---|---|---|---|---|---|
| A | 1 | ABC | 1 | 0.00 | 0.00 |
| A | 2 | ABC | 1 | 1.00 | 0.00 |
| A | 3 | DEF | 0 | 0.50 | 1.00 |
| A | 4 | ABC | 1 | 0.50 | 0.50 |
| B | 1 | DEF | 0 | 0.00 | 0.00 |
| B | 2 | DEF | 0 | 0.00 | 0.00 |
| B | 3 | DEF | 0 | 0.00 | 0.00 |
| B | 4 | ABC | 1 | 0.50 | 0.00 |
default = 0 で、ずらした場合の穴埋め方法を「0で埋める」と指定しています。