Case7. 価格（相場）を予測する

実際にランダムフォレストを使って、価格予測モデルを作成していきます。

フロー

前処理、データセットの作成
モデル作成用、検証用にデータセットを分離
モデル作成用のデータセットでモデリング
モデルでの予測値（検証用データの各要因をモデルに適用した結果）と検証用データの比較
モデル内容

参考： https://www.kaggle.com/amaiaga/xgboost-v8

# ライブラリの読み込み
library(data.table)
library(dplyr)
library(stringr)
library(ggplot2)
library(randomForest)

# データの読み込み
data <- fread("./data/case07_train.tsv", showProgress = FALSE, data.table = FALSE)

前処理

# 価格が0の商品をデータから取り除く
data <- filter(data, price != 0)

# 商品カテゴリーをレベル別に分解
temp <- str_split(data$category_name, pattern = "/")
data$category01 <- sapply(temp, function(x) x[1])
data$category02 <- sapply(temp, function(x) x[2])
data$category03 <- sapply(temp, function(x) x[3])

データセットの作成

### データセットの作成
model.dat <- data.frame(
  price     = data$price,
  condition = data$item_condition_id)

### カテゴリー数の上限にかからないようにダミー変数化
# 特定のキーワードが含まれていれば1を返す関数の定義
word_contain <- function(cate, desc, ...){
  temp1 <- sapply(..., function(word) {
    ifelse(grepl(word, cate) | grepl(word, desc), 1, 0)
    })
  ifelse(rowSums(temp1) != 0, 1, 0)
}

# ブランド
model.dat$pink    <- word_contain(data$brand_name, data$item_description, "PINK")
model.dat$secret  <- word_contain(data$brand_name, data$item_description, "VICTORIA'S SECRET")
model.dat$nike    <- word_contain(data$brand_name, data$item_description, "NIKE")
model.dat$apple   <- word_contain(data$brand_name, data$item_description, c("APPLE", "MAC"))
model.dat$lularoe <- word_contain(data$brand_name, data$item_description, "LULAROE")

# カテゴリー1
model.dat$beauty     <- word_contain(data$category01, data$item_description, "BEAUTY")
model.dat$electronic <- word_contain(data$category01, data$item_description, "ELECTRONIC")
model.dat$handmade   <- word_contain(data$category01, data$item_description, c("HANDMADE","DYI"))
model.dat$home       <- word_contain(data$category01, data$item_description, c("HOME","HOUSE"))
model.dat$kid        <- word_contain(data$category01, data$item_description, c("KID","BOY","GIRL", "CHILD"))
model.dat$women      <- word_contain(data$category01, data$item_description, "WOMEN")
model.dat$men        <- ifelse(((!grepl("WOMEN", data$category01)) & (grepl("MEN", data$category01)))|
                               ((!grepl("WOMEN", data$item_description)) & (grepl("MEN", data$item_description))),
                               1, 0)
model.dat$athletic   <- word_contain(data$category01, data$item_description, c("ATHLETIC","SPORT"))
model.dat$wine       <- word_contain(data$category01, data$item_description, c("WINE","ALCOCHOL"))

# カテゴリー2
model.dat$athletic_apparel <- word_contain(data$category02, data$item_description, "ATHLETIC APPAREL")
model.dat$makeup    <- word_contain(data$category02, data$item_description, "MAKEUP")
model.dat$blouse    <- word_contain(data$category02, data$item_description, "BLOUSE")
model.dat$shoes     <- word_contain(data$category02, data$item_description, "SHOE")
model.dat$toy       <- word_contain(data$category02, data$item_description, "TOY")
model.dat$jewelry   <- word_contain(data$category02, data$item_description, "JEWELRY")
model.dat$phone     <- word_contain(data$category02, data$item_description, "PHONE")
model.dat$bag       <- word_contain(data$category02, data$item_description, "BAG")
model.dat$dress     <- word_contain(data$category02, data$item_description, "DRESS")
model.dat$pant      <- word_contain(data$category02, data$item_description, c("PANT","JEAN"))
model.dat$accessories <- word_contain(data$category02, data$item_description, "ACCESSORIES")
model.dat$luxury    <- word_contain(data$category02, data$item_description, c("WATCH","JEWELRY","RING","BRACELETS"))

# カテゴリー3
model.dat$tshirt    <- word_contain(data$category03, data$item_description, c("T-SHIRT","TSHIRT"))
model.dat$face      <- word_contain(data$category03, data$item_description, "FACE")
model.dat$game      <- word_contain(data$category03, data$item_description, "GAME")
model.dat$lip       <- word_contain(data$category03, data$item_description, "RIP")
model.dat$eye       <- word_contain(data$category03, data$item_description, "EYE")
model.dat$care      <- word_contain(data$category03, data$item_description, "CARE")
model.dat$top       <- word_contain(data$category03, data$item_description, "TOP")

データセットの分離

モデリング用と検証用にデータセットを分離

# ! すべてのデータを使うと処理に時間がかかるので、注意すること
train <- model.dat[1:100000,]       # トレーニング用
test  <- model.dat[100001:150000,] # 検証用

モデリング

ランダムフォレストでモデリング

# チューニング
train.tune <- tuneRF(train[, -1], train[, 1],  doBest = T)

## mtry = 11  OOB error = 1442.244
## Searching left ...
## mtry = 6     OOB error = 1440.779
## 0.001016172 0.05
## Searching right ...
## mtry = 22    OOB error = 1443.463
## -0.000844914 0.05

# モデリング
train.rf <- randomForest(price ~., data = train, mtry = train.tune$mtry)

モデルの評価

# 検証用データにモデルを適用
test$pred <- predict(train.rf, test)

# 平均二乗誤差（検証用データのpriceと予測値の離れ具合）でモデル精度を評価
(mean((test$price - test$pred) ^ 2)) ^ 1/2

## [1] 692.1059

この数値はいろいろなパターンでモデルを作成し、比較する際に使う。

ggplot(test, aes(x = pred, y = price)) +
    geom_point(alpha = 0.6)

#実際の価格が100ドル未満を対象
filter(test, price < 100) %>%
ggplot(aes(x = pred, y = price)) +
    geom_point(alpha = 0.6)

予測値に100ドル以上のものはない。原因として次のようなことが考えられます。

モデルに高価格ブランドが含まれるかの変数がないこと
価格帯の中心が20ドル付近なので、この辺りの予測値を返す方が誤差が少ないと学習した
モデルの変数（キーワード）全てに該当しない商品が多数あり、それらの予測値が20ドル付近に固まった

モデルの変数（キーワード）を増やすことで、モデルの精度をあげられる可能性がある。

モデルの内容

各要因の価格への影響度合い

varImpPlot(train.rf)

複数の要因を加味した場合、コンディションの価格への影響が大きい。

<< 1.ビジネスの理解　 << 2.データの理解　