主成分分析に持ち込みたいが、欠損値があると計算できないので、ミス・モノクロームの欠損値を他のガールフレンドたちのデータから推定する。
昔の双葉杏みたいに、とりあえず身長と年齢から推定してみて、スリーサイズが揃ったらもう一回してみる、なんてことをやってみたのだが、身長と年齢だけで推定してもたいそうずれる、というわけでもなかったので面倒だからこれでやめた。
なにも考えず今回はランダムフォレストを使用した。
imputationも考えたけどとりあえずこれでやる。
dat <- read.csv("girlfrienddata.txt") # か、"clipboard" で読み込み # jpg が00…でIDついているので、これを振る # するとjpgとファイル名が一致するのでプロットできる pngID <- mapply(function(x) paste(paste(rep("0", 3-nchar(x)), collapse=""), x, sep=""), dat$ID) pngID <- pngID[dat$grade > 0] # 残念ながら、学園生じゃない人はお呼びじゃない dat1 <- dat[dat$grade > 0, c(3,9:13)] rownames(dat1) <- dat$name[dat$grade > 0] plot(dat1)
library(randomForest) monokuro <- dat1["ミス・モノクローム",] tmp <- c(predict(randomForest(weight ~ grade + height, na.omit(dat1)), monokuro), predict(randomForest(B ~ grade + height, na.omit(dat1)), monokuro), predict(randomForest(W ~ grade + height, na.omit(dat1)), monokuro), predict(randomForest(H ~ grade + height, na.omit(dat1)), monokuro))
推定結果はこんな感じ。
ミス・モノクローム ミス・モノクローム ミス・モノクローム ミス・モノクローム
46.50002 77.21205 57.04593 79.35729
これは身長と学年からだけで推定したものなので、これらを補完したとして、全プロフィールでもう一回推定すると
monokuro[, c("weight", "B", "W", "H")] <- tmp dat1["ミス・モノクローム", c("weight", "B", "W", "H")] <- round(c(predict(randomForest(weight ~ ., na.omit(dat1)), monokuro), predict(randomForest(B ~ ., na.omit(dat1)), monokuro), predict(randomForest(W ~ ., na.omit(dat1)), monokuro), predict(randomForest(H ~ ., na.omit(dat1)), monokuro)), 1) # 小数点以下を適当に切り上げる
grade height weight B W H ミス・モノクローム 2 155 45.9 78 57.1 79.9
あんまり変わらないんだねぇ…
one-leave out CVで推定精度を確かめてみると、悪くはなさげなのだがバストが9cm過大評価みたいな人が出てくるみたいなのでまあどんまい。
# one-leave out cross validation >|r| cv1 <- dat1 for(i in seq(nrow(dat1))){ cv1[i, "weight"] <- predict(randomForest(weight ~ ., dat1[-i,]), dat1[i,]) cv1[i, "B"] <- predict(randomForest(B ~ ., dat1[-i,]), dat1[i,]) cv1[i, "W"] <- predict(randomForest(W ~ ., dat1[-i,]), dat1[i,]) cv1[i, "H"] <- predict(randomForest(H ~ ., dat1[-i,]), dat1[i,]) }
summary((cv1-dat1)[,3:6])
weight B W H Min. :-6.95930 Min. :-17.27461 Min. :-8.30925 Min. :-8.18574 1st Qu.:-1.41144 1st Qu.: -2.44765 1st Qu.:-1.68673 1st Qu.:-1.98771 Median : 0.14855 Median : 0.12368 Median : 0.47311 Median :-0.08046 Mean :-0.02974 Mean : -0.04963 Mean :-0.06769 Mean :-0.06140 3rd Qu.: 1.02762 3rd Qu.: 2.43428 3rd Qu.: 1.95546 3rd Qu.: 2.07859 Max. : 4.75344 Max. : 9.57465 Max. : 4.93675 Max. : 9.37823
