この記事はごちうさ住民 Advent Calendar 2014の第26日目の記事です(勝手に参加。
ひと目で尋常でない解析ネタだと見抜いたよ
「チノちゃん、スリーサイズ教えて」
「嫌ですよ」
(´・ω:;.:...
データを愛した少女と解析に愛された少女
「というわけでお馴染みのスリーサイズ解析をするよっ。
まずは公式設定から年齢と身長だけ入手できたから
アイマスデータセットと機械学習を用いて年齢と身長から、体重、スリーサイズを推定するよっ。
主成分分析をする
ブラのサイズ推定をする
SPADE法で分化解析をする
Trajectory detection で成長度推定をする
viSNEによる次元削減とクラスタリングをする
という感じでやろう」
初めてデータを扱った日の事憶えてる? 他人のデータでスリーサイズ推定しようとしたわよね
「アイマスデータセットは年齢、身長、体重、スリーサイズの6次元のデータで
アイマスのみならずスクフェス、GF(仮)、WUG、ハナヤマタの登場人物を含む369人のデータセットだ」
「推定は面倒なのでrandomForest パッケージよりrandomforestを使用するわ〜。
交差検証や推定精度は面倒くさいのでやらないけど、適当な推定精度はあるわ〜」
「私の胸が79.1…だと…!?」
ラッキーアイテムはおっぱいと罪と罰
「スリーサイズが推定できたら、次はブラのサイズ推定をしようねっ。
身長、おっぱい、ウエストからなるおっぱい関数を用いてブラのサイズを推定するよっ」
name age height weight B W H cup ココア 15 154 42.8 78.8 56 80 B チノ 13 144 37 72.3 53.1 75.1 AA リゼ 16 160 45.2 79.1 57 79.2 B チヤ 15 157 43.9 81.9 56.1 82 D シャロ 15 151 40.7 78.6 55.9 80 B マヤ 13 140 35.4 72.3 52.9 75 AA メグ 13 145 37.9 73 53.1 75.8 A 青山ブルーマウンテン 25 163 46.2 84.2 57.8 85.1 D
「私のブラのサイズがB…だと…!?」
「リゼ先輩と同じサイズで嬉しいｯ…」
「チノちゃんはまだまだ大きくなるよっ」
「余計なお世話です」
「このおっぱいがBカップなわけない…
ちなみに長内転筋腱がきちんと作画に描きこまれているのは高評価…」
第1羽
「全然関係ないけど
ここ、わんこが濡れなくてよかったっ!!だからねっ!!」
第4羽
ココアと悪意なき殺意
「チノちゃんチノちゃん、今は小さくてもまだまだ大きくなるはずだよっ」
「うるさいですね」
「チノちゃんがどれくらい大きくなるか解析してみようよ」
「とりあえずPCAね〜」
「機械学習で推定したデータを用いているから、結局密集してしまう感じだな」
解析をする解析
「SPADEというBioinformaticsの最新手法があるんだよ。とりあえずやっておいたよ。
スリーサイズデータを多次元データとみなして、各マーカーの発現量に応じたFCM解析と同様なものと見做すと、
幹細胞の分化がそのままチノちゃんの成長分化とそっくりそのまま考えられるんだよっ!!」
「チマメ隊は見事にロリ集団だな」
「納得いきません」
Call Me Sister.
「チノちゃんチノちゃん、WanderlustというBioinformaticsの最新手法もやってみたよっ。
「多次元データ内のあるサンプルを分化開始の細胞と見做すと、そこからの分化度を定量化する手法だな。
SPADEと同じように考えると、一番ロリな女の子からどれくらい成長しているかが分かるな」
「チノちゃんチノちゃん、私、チノちゃんのお姉ちゃんになったよっ」
「お姉さんはいりません」
「(リゼ先輩も私よりお姉ちゃんに…ｺﾞｸﾘﾝｺ)」
プールに濡れて 雨に濡れて涙に濡れて
「この回はヘタなエロゲ原作アニメよりエロいわ〜」
「viSNE は生のパラメータと次元削減後のパラメータが似る確率をKL情報量を用いて推定する手法だな。
ぶっちゃけよくわかってないぞ」
「(リゼ先輩と離れちゃった…)」
「チマメ隊はまた一緒だな」
「もうチマメ隊でいいです…」
青山スランプマウンテン
「(髪下ろした先輩のワンピース姿が可愛すぎる…(青ブルマン関係ない)」
対お姉ちゃん用決戦部隊、通称チマメ隊
「なんでメグだけAカップなんだよ!!」
「ﾜ,ﾜｶﾝﾅｲﾖｰ」
「メグだけわずかに身長が私より高いので、体重もおっぱいも大きくなったようですね。私もがんばれば…」
「チノちゃんは今のままでいいよ〜」
「(なんで私がBカップなんだ…)」
社畜は白い外套を纏いウサギを駆りて聖夜の業務を征く
この解析は社畜の合間をぬって24，25日に行われました。
25日は所属部局でクリスマスコンサートと称して合唱をさせられました。
君のためなら精進する
「うーん…、やっぱりうまくいかないなあ」
「じゃあ…、実際に私で確かめてもいいですよ」
二人は夜の街へと消えていった…
結論：SSが雑!!
推定結果
ココア
15歳/154cm/42.8kg/78.8cm/56.0cm/80.0cm/B
チノ
13歳/144cm/37.0kg/72.3cm/53.1cm/75.1cm/AA
リゼ
16歳/160cm/45.2kg/79.1cm/57.0cm/79.2cm/B
チヤ
15歳/157cm/43.9kg/81.9cm/56.1cm/82.0cm/D
シャロ
15歳/151cm/40.7kg/78.6cm/55.9cm/80.0cm/B
画像は公式HPから。
スクリプト
# スリーサイズ推定 g <- data.frame(age=c(15,13,16,15,15,13,13,25), height=c(154,144,160,157,151,140,145,163)) rownames(g) <- c("ココア", "チノ", "リゼ", "チヤ", "シャロ", "マヤ", "メグ", "青山ブルーマウンテン") dat <- read.delim("girl.txt") rownames(dat) <- dat$name dat <- dat[, -c(1, 8)] library(randomForest) k <- c("weight", "B", "W", "H") # 年齢と身長だけから体重とBWHを推定する rf <- mapply(function(x) randomForest(eval(parse(text=k[x])) ~ age + height, data=dat), seq(k), SIMPLIFY=FALSE) p1 <- sapply(rf, predict, g) colnames(p1) <- k g1 <- cbind(g, p1) # 推定したデータからもう一回推定する rf <- mapply(function(x) randomForest(eval(parse(text=k[x])) ~ . - eval(parse(text=k[x])), data=dat), seq(k), SIMPLIFY=FALSE) p2 <- sapply(rf, predict, g1) colnames(p2) <- k g2 <- cbind(g, p2) # 推定したデータ # PCA # 公式HPから Twitter画像を取っておく pngs <- list.files(pattern="jpg") library(png) library(jpeg) pics <- mapply(function(x) readJPEG(x, native=TRUE), pngs) ra <- 1 #原点に近いところが潰れるので拡大したかったけど、等倍でやった。 xy0 <- sapply(pics, dim)[1:2, ] #pixel xy0[] <- min(xy0) xy0[2,] <- 200 # なんか横が潰れるのでテコ入れ rownames(xy0) <- c("height", "width") s0 <- 0.008 #拡大縮小率 data1 <- rbind(dat, g2) pca_score <- scale(data1) %*% eigen(cor(data1))$vectors *sqrt(nrow(data1)/(nrow(data1) - 1)) par(mar=c(4.5, 5, 3, 2), cex.lab=2) plot(pca_score[, 1:2], type="n", xlab="", ylab="← グラマー 年相応スタイル スレンダー →") mtext("← 大人\tスタイル\tロリ →", 1, line=3, cex=2) title("アニメキャラ分析", cex.main=2) abline(h=0, v=0, lty=3, col=grey(0.5), lwd=2) text(pca_score[, 1:2], rownames(pca_score)) lay0 <- pca_score[rownames(g2), 1:2] for(i in seq(pics)){ xleft=lay0[i, 1]*ra - xy0[2, i]/2*s0 ybottom=lay0[i, 2]*ra - xy0[1, i]/2*s0 xright=lay0[i, 1]*ra + xy0[2, i]/2*s0 ytop=lay0[i, 2]*ra + xy0[1, i]/2*s0 rasterImage(image=pics[[i]], xleft=xleft, ybottom=ybottom, xright=xright, ytop=ytop, xpd=TRUE) } # SPADE # 前回と比べていろいろ仕様が変わってるんだけど… library(spade) library(flowViz) dat <- read.csv("animegirls.csv") # 推定したごちうさメンバーを含むデータセット dat1 <- subset(dat, select=-c(name, type)) fcs <- new("flowFrame", as.matrix(data1)) fcs <- new("flowFrame", as.matrix(round(data1*100))) # 強制的に整数化 write.FCS(fcs, "animedata.fcs", what="integer") downsample_file_path <- paste(output_dir, "animedata.fcs.downsample.fcs", sep="/") cells_file_path <- paste(output_dir, "/", "clusters.fcs", sep="") clust_file_path <- paste(output_dir, "/", "clusters.table", sep="") graph_file_path <- paste(output_dir, "/", "mst.gml", sep="") set.seed(2) data_file_path = "animedata.fcs" output_dir <- "fcs" SPADE.driver(data_file_path, out_dir=output_dir, k=30, clustering_samples = 5000) density_file_path <- paste(output_dir, "animedata.fcs.density.fcs", sep="/") SPADE.addDensityToFCS(data_file_path, density_file_path) SPADE.FCSToTree(downsample_file_path, cells_file_path, graph_file_path, clust_file_path, k=30) upsample_file_path <- "upsamle.fcs" SPADE.addClusterToFCS(density_file_path, upsample_file_path, cells_file_path) up <- read.FCS("upsamle.fcs") write.table(up@exprs[, "cluster"], "clusterID.txt", row.names=FALSE, col.names=FALSE) cl <- unlist(read.csv("clusterID.txt", header=FALSE)) # クラスター番号 table(cl) # クラスターに所属する女の子の数 tab <- paste(getwd(), "/", output_dir, "/tables/bySample/animedata.fcs.density.fcs.cluster.fcs.anno.Rsave_table.csv", sep="") cvs <- read.csv(tab) # SPADE を実行した後のいろいろな統計量 mst_graph <- igraph:::read.graph(paste(output_dir,"mst.gml",sep=.Platform$file.sep),format="gml") clust <- read.table(paste(output_dir, "/clusters.table", sep=""), sep=" ", header=TRUE) lay0 <- read.table(paste(output_dir,"layout.table",sep=.Platform$file.sep)) pngs <- list.files(pattern="jpg") library(png) library(jpeg) pics <- mapply(function(x) readJPEG(x, native=TRUE), pngs) ra <- 1 #原点に近いところが潰れるので拡大したかったけど、等倍でやった。 xy0 <- sapply(pics, dim)[1:2, ] #pixel xy0[] <- min(xy0) xy0[2,] <- 200 # なんか横が潰れるのでテコ入れ rownames(xy0) <- c("height", "width") s0 <- 0.0025 #拡大縮小率 b <- list(c(2,6,7),1,c(3,5),c(4),c(),c(8)) # 画像を貼る順番 par(mfrow=c(2, 3), mar=c(0, 0, 3, 0)) for(m in seq(ncol(dat))){ l <- colnames(dat)[m] cut0 <- seq(min(dat[, l]), max(dat[, l]), length=99) # ノードの色付け g0 <- mst_graph V(g0)$label <- NA V(g0)$size <- log(cvs$count, 1.15) V(g0)$frame.color <- "black" f <- tapply(dat[, l], cl, median) V(g0)$color <- bluered(length(f))[rank(f, ties.method="random")] plot(g0, layout=as.matrix(lay0)) title(colnames(clust)[m], cex.main=3) for(i in b[[m]]){ xleft=xy[i, 1]*ra - xy0[2, i]/2*s0 ybottom=xy[i, 2]*ra - xy0[1, i]/2*s0 xright=xy[i, 1]*ra + xy0[2, i]/2*s0 ytop=xy[i, 2]*ra + xy0[1, i]/2*s0 rasterImage(image=pics[[i]], xleft=xleft, ybottom=ybottom, xright=xright, ytop=ytop, xpd=TRUE) } } # Wanderlust, Trajectory detection # s の設定 loli <- which(rownames(data1) == "横山千佳") res <- trajectory_detection(data1, s=loli, k=35, l=15, nl=20, ng=30) # おっぱい関数をやったあとで a <- as.data.frame(t(mapply(function(i) unlist(oppai(dat$height[i], dat$B[i], dat$W[i] ,correct=TRUE)[2:4]), seq(nrow(dat))))) rownames(a) <- rownames(dat) ll <- tail(dat, 8) ub <- as.numeric(as.vector(a$u_bust)) lv_idx <- replace(seq(12), 1:4, 4:1) cup_size <- c("AA",LETTERS[1:4]) cols <- rainbow(length(cup_size))[match(ll$cup, cup_size)] idx <- match(rownames(ll), rownames(dat)[order(dat$score)]) pngs <- list.files(pattern="jpg") library(png) library(jpeg) pics <- mapply(function(x) readJPEG(x, native=TRUE), pngs) ra <- 1 #原点に近いところが潰れるので拡大したかったけど、等倍でやった。 xy0 <- sapply(pics, dim)[1:2, ] #pixel xy0[] <- min(xy0) xy0[2,] <- 40000 # なんか横が潰れるのでテコ入れ rownames(xy0) <- c("height", "width") s0 <- 0.001 #拡大縮小率 par(mar=c(4.5, 4.5, 2, 2), cex.lab=1.6, cex.axis=1.6) plot(sort(dat$score), pch=16, xlab="アニメキャラ", ylab="Trajectory score") points(idx, ll$score, col=cols, pch=16, cex=2) legend("topleft", legend=cup_size, col=rainbow(length(cup_size)), pch=16, bty="n", cex=1.5, title="ブラサイズ") #lay0 <- matrix(unlist(locator(8)), nc=2) for(i in seq(pics)){ arrows(lay0[i,1], lay0[i,2], idx[i], ll$score[i], lwd=3, length=0.15, col=cols[i]) xleft=lay0[i, 1]*ra - xy0[2, i]/2*s0 ybottom=lay0[i, 2]*ra - xy0[1, i]/2*s0 xright=lay0[i, 1]*ra + xy0[2, i]/2*s0 ytop=lay0[i, 2]*ra + xy0[1, i]/2*s0 rasterImage(image=pics[[i]], xleft=xleft, ybottom=ybottom, xright=xright, ytop=ytop, xpd=TRUE) } # viSNE library(tsne) # 論文で言っているパラメータに合わせる。 # 他のパラメータは、t-SNEの元の論文のデフォルトパラメータにしてある。 tsne_sub2 <- tsne(sub2, max_iter = 500, perplexity=30, whiten=FALSE) library(gplots) cup_size <- c("AAA未満","AAA","AA",LETTERS[1:7],"H以上") cols <- colorpanel(length(cup_size), "blue", grey(0.9), "red") pngs <- list.files(pattern="jpg") library(png) library(jpeg) pics <- mapply(function(x) readJPEG(x, native=TRUE), pngs) ra <- 1 #原点に近いところが潰れるので拡大したかったけど、等倍でやった。 xy0 <- sapply(pics, dim)[1:2, ] #pixel xy0[] <- min(xy0) xy0[2,] <- 160 # なんか横が潰れるのでテコ入れ rownames(xy0) <- c("height", "width") s0 <- 0.05 #拡大縮小率 #idx <- match(g$name, rownames(dat)) lay0 <- tsne_sub2[idx,] par(cex.axis=1.6) plot(tsne_sub2, pch=16, xlab="", ylab="", type="n") abline(h=0, v=0, lty=3, lwd=2, col=grey(0.2)) points(tsne_sub2, pch=16, col=cols) legend("topright", legend=cup_size, col=cols, pch=16, bty="n") for(i in seq(pics)){ xleft=lay0[i, 1]*ra - xy0[2, i]/2*s0 ybottom=lay0[i, 2]*ra - xy0[1, i]/2*s0 xright=lay0[i, 1]*ra + xy0[2, i]/2*s0 ytop=lay0[i, 2]*ra + xy0[1, i]/2*s0 rasterImage(image=pics[[i]], xleft=xleft, ybottom=ybottom, xright=xright, ytop=ytop, xpd=TRUE) }
