Hatena::ブログ(Diary)

驚異のアニヲタ社会復帰への道

Prima Project

2014-12-26

MikuHatsune2014-12-26

第26羽 ココア「チノちゃん、スリーサイズ教えて」チノ「嫌ですよ」

この記事はごちうさ住民 Advent Calendar 2014の第26日目の記事です(勝手に参加。

 

ひと目で尋常でない解析ネタだと見抜いたよ

f:id:MikuHatsune:20141225225419j:image:small:left「チノちゃん、スリーサイズ教えて」

 

 

f:id:MikuHatsune:20141225225504j:image:small:left「嫌ですよ」

 

 

f:id:MikuHatsune:20141225225419j:image:small:left(´・ω:;.:...

 

 

 

データを愛した少女と解析に愛された少女

f:id:MikuHatsune:20141225225419j:image:small:left「というわけでお馴染みのスリーサイズ解析をするよっ。

まずは公式設定から年齢と身長だけ入手できたから

アイマスデータセットと機械学習を用いて年齢と身長から、体重、スリーサイズを推定するよっ。

 

主成分分析をする

ブラのサイズ推定をする

SPADE法で分化解析をする

Trajectory detection で成長度推定をする

viSNEによる次元削減とクラスタリングをする

 

f:id:MikuHatsune:20141225225419j:image:small:leftという感じでやろう」

 

 

 

初めてデータを扱った日の事憶えてる? 他人のデータでスリーサイズ推定しようとしたわよね

f:id:MikuHatsune:20141225225505j:image:small:leftアイマスデータセットは年齢、身長、体重、スリーサイズの6次元のデータで

アイマスのみならずスクフェス、GF(仮)、WUG、ハナヤマタの登場人物を含む369人のデータセットだ」

 

f:id:MikuHatsune:20141225225506j:image:small:left「推定は面倒なのでrandomForest パッケージよりrandomforestを使用するわ〜。

交差検証や推定精度は面倒くさいのでやらないけど、適当な推定精度はあるわ〜」

 

f:id:MikuHatsune:20141225225505j:image:small:left「私の胸が79.1…だと…!?」

 

 

 

ラッキーアイテムはおっぱいと罪と罰

f:id:MikuHatsune:20141225225419j:image:small:leftスリーサイズが推定できたら、次はブラのサイズ推定をしようねっ。

身長、おっぱい、ウエストからなるおっぱい関数を用いてブラのサイズを推定するよっ」

 

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

 

f:id:MikuHatsune:20141225225505j:image:small:left「私のブラのサイズがB…だと…!?」

 

 

f:id:MikuHatsune:20141225225507j:image:small:left「リゼ先輩と同じサイズで嬉しいッ…」

 

 

f:id:MikuHatsune:20141225225419j:image:small:left「チノちゃんはまだまだ大きくなるよっ」

 

 

f:id:MikuHatsune:20141225225504j:image:small:left「余計なお世話です」

 

 

f:id:MikuHatsune:20141225225507j:image:small:left「このおっぱいがBカップなわけない…

ちなみに長内転筋腱がきちんと作画に描きこまれているのは高評価…」

 

f:id:MikuHatsune:20141225232451p:image

第1羽

 

f:id:MikuHatsune:20141225225419j:image:small:left「全然関係ないけど

ここ、わんこが濡れなくてよかったっ!!だからねっ!!」

 

f:id:MikuHatsune:20141225232452p:image

第4羽

 

ココアと悪意なき殺意

f:id:MikuHatsune:20141225225419j:image:small:left「チノちゃんチノちゃん、今は小さくてもまだまだ大きくなるはずだよっ」

 

 

f:id:MikuHatsune:20141225225504j:image:small:left「うるさいですね」

 

 

f:id:MikuHatsune:20141225225419j:image:small:left「チノちゃんがどれくらい大きくなるか解析してみようよ」

 

 

f:id:MikuHatsune:20141225225506j:image:small:left「とりあえずPCAね〜」

 

 

f:id:MikuHatsune:20141225232453p:image

f:id:MikuHatsune:20141225225505j:image:small:left機械学習で推定したデータを用いているから、結局密集してしまう感じだな」

 

 

 

解析をする解析

f:id:MikuHatsune:20141225225419j:image:small:left「SPADEというBioinformaticsの最新手法があるんだよ。とりあえずやっておいたよ。

スリーサイズデータを多次元データとみなして、各マーカーの発現量に応じたFCM解析と同様なものと見做すと、

幹細胞の分化がそのままチノちゃんの成長分化とそっくりそのまま考えられるんだよっ!!」

f:id:MikuHatsune:20141225232454p:image

f:id:MikuHatsune:20141225225505j:image:small:left「チマメ隊は見事にロリ集団だな」

 

 

f:id:MikuHatsune:20141225225504j:image:small:left「納得いきません」

 

 

 

Call Me Sister.

f:id:MikuHatsune:20141225225419j:image:small:left「チノちゃんチノちゃん、WanderlustというBioinformaticsの最新手法もやってみたよっ。

 

 

f:id:MikuHatsune:20141225225505j:image:small:left「多次元データ内のあるサンプルを分化開始の細胞と見做すと、そこからの分化度を定量化する手法だな。

SPADEと同じように考えると、一番ロリな女の子からどれくらい成長しているかが分かるな」

 

f:id:MikuHatsune:20141225232455p:image

f:id:MikuHatsune:20141225225419j:image:small:left「チノちゃんチノちゃん、私、チノちゃんのお姉ちゃんになったよっ」

 

 

f:id:MikuHatsune:20141225225504j:image:small:left「お姉さんはいりません」

 

 

f:id:MikuHatsune:20141225225507j:image:small:left「(リゼ先輩も私よりお姉ちゃんに…ゴクリンコ)」

 

 

 

プールに濡れて 雨に濡れて涙に濡れて

f:id:MikuHatsune:20141225225506j:image:small:left「この回はヘタなエロゲ原作アニメよりエロいわ〜」

 

 

f:id:MikuHatsune:20141225225505j:image:small:left「viSNE は生のパラメータと次元削減後のパラメータが似る確率をKL情報量を用いて推定する手法だな。

ぶっちゃけよくわかってないぞ」

 

f:id:MikuHatsune:20141226102111p:image

 

f:id:MikuHatsune:20141225225507j:image:small:left「(リゼ先輩と離れちゃった…)」

 

 

f:id:MikuHatsune:20141225225505j:image:small:left「チマメ隊はまた一緒だな」

 

 

f:id:MikuHatsune:20141225225504j:image:small:left「もうチマメ隊でいいです…」

 

 

 

青山スランプマウンテン

f:id:MikuHatsune:20141225225507j:image:small:left「(髪下ろした先輩のワンピース姿が可愛すぎる…(青ブルマン関係ない)」

 

 

 

対お姉ちゃん用決戦部隊、通称チマメ隊

f:id:MikuHatsune:20141225231128j:image:small:left「なんでメグだけAカップなんだよ!!」

 

 

f:id:MikuHatsune:20141225231129j:image:small:left「ワ,ワカンナイヨー」

 

 

f:id:MikuHatsune:20141225225504j:image:small:left「メグだけわずかに身長が私より高いので、体重もおっぱいも大きくなったようですね。私もがんばれば…」

 

 

f:id:MikuHatsune:20141225225419j:image:small:left「チノちゃんは今のままでいいよ〜」

 

 

f:id:MikuHatsune:20141225225505j:image:small:left「(なんで私がBカップなんだ…)」

 

 

 

社畜は白い外套を纏いウサギを駆りて聖夜の業務を征く

この解析は社畜の合間をぬって24,25日に行われました。

25日は所属部局でクリスマスコンサートと称して合唱をさせられました。

 

君のためなら精進する

f:id:MikuHatsune:20141225225419j:image:small:left「うーん…、やっぱりうまくいかないなあ」

 

 

f:id:MikuHatsune:20141225225504j:image:small:left「じゃあ…、実際に私で確かめてもいいですよ」

 

 

二人は夜の街へと消えていった…

 

結論:SSが雑!!




推定結果

f:id:MikuHatsune:20141225225419j:image:small:leftココア

15歳/154cm/42.8kg/78.8cm/56.0cm/80.0cm/B

 

f:id:MikuHatsune:20141225225504j:image:small:leftチノ

13歳/144cm/37.0kg/72.3cm/53.1cm/75.1cm/AA

 

f:id:MikuHatsune:20141225225505j:image:small:leftリゼ

16歳/160cm/45.2kg/79.1cm/57.0cm/79.2cm/B

 

f:id:MikuHatsune:20141225225506j:image:small:leftチヤ

15歳/157cm/43.9kg/81.9cm/56.1cm/82.0cm/D

 

f:id:MikuHatsune:20141225225507j:image:small:leftシャロ

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)
}

atgatg 2015/01/22 00:11 主成分分析で相関係数を使って分析しているけど、それって意味あることなのかなと思った。年齢に伴って、それなりの変数が関係し合っているし、それを重みを考えた合成関数とすることに、何だかなぁと思う。無限の場合には、主成分分析の有効性はあると思うけど、主成分分析というのは、正当性がなくてもそれなりの結果がでるから、よく使われるけど、なんだかなぁといつも思う。

次にブラサイズ推定を見た。乳関数を試した。いろいろ試したけど、やはり身長、バスト、ウエストだけでは無理がある。キャラにはいないと思うけど、体重に相当な重みがあってヒップが大きい人っているけど、そのような人のカップは小さいわけではないし、またバストとウエストとが同じ値にするとカップが小さくなる計算になることを考えると、乳関数って、ちょっと使えないなと思う。

SPADE での解析結果の図を見ようとしたけど、 jpg なのね。拡大できないのが残念。よく Web 上で、ビットマップが使われているけど、折角、別画面で表示してみても、拡大して見られるわけではなく、残念という感じがする。学術関係のプレス発表のサイトでもそうなのだけど、そんな図であるとがっかりする。知りたいことがよく見えないのだから。それより何しろ、キャラ名がでていても、私には判らないし、また、その結果内容を知ろうとしても、図は拡大できないし、私には判らんのだよぉー。確か SPEDE は、t 分布を基礎としていたかと記憶している(記憶間違いかもしれない)けど、それなりに連鎖分類でき分離もされ、分類や形態を表現するのに使えそうですね。社会学、経済政治学などでも使われていくような気がするので、キャラを使って、解析結果をもっと詳しく説明してくれるとありがたいです。この解析手法は、フローや容量を含めた関係情報学などやっている人に使われていくのではないかと思うから。
これは次の Trajectory detection とも関係して、面白そう。でも、31ドルなんて払えないし、私にはもう、 Let it go な気分でしかない。viSNE も同じだけど、でも、著者のサイトに行くといい感じ。後で、ゆっくり見てみようと思う。昨年は著者のサイトがあることに気がつかなかったけど、こうして、再度紹介してくれると、興味が再び湧き上がる。Med さん、ありがとう。勿論、Dana Peer Lab にも感謝感謝。ここのサイト(Dana Peer Lab)でも、やはり図は png なのだけど、それでも拡大できるように配慮されているね。

MikuHatsuneMikuHatsune 2015/02/25 23:47 > 主成分分析で相関係数を使って分析しているけど、それって意味あることなのかなと思った。
PCA、とりあえず使う感がこの業界にあります。普通は完全独立なパラメータは存在しないので、それなりにまとまってそれなりに統計学的に計算結果は出るけれども、やはりそこは人が解釈できるようにならないと駄目だとは思います。

> 身長、バスト、ウエストだけでは無理がある。
無理

> jpg なのね
はてなブログ、svgがデフォで貼れなくて、ちょっと細工が必要で面倒なためやってないです。

> フローや容量を含めた関係情報学などやっている人に使われていくのではないかと思うから。
流行ってほしい(願望

> 31ドルなんて払えない
私もです。

スパム対策のためのダミーです。もし見えても何も入力しないでください
ゲスト


画像認証

トラックバック - http://d.hatena.ne.jp/MikuHatsune/20141226/1419532246