廿TT

譬如水怙牛過窓櫺 頭角四蹄都過了 因甚麼尾巴過不得

線形次元削減をRで(ベイズ推論による機械学習入門)

ベイズ推論による機械学習入門』で解説されていた線形次元削減です。

D 行 N 列の観測データを  Y=(y_1,\ldots,y_N) を M 行 N 列の潜在変数 X=(x_1,\ldots,x_N) で表現することが目標です。
D 行 M 列のパラメータ W と D 次元のベクトル μ を使って

y_n \approx Wx_n+\mu

という形で近似します。

機械学習スタートアップシリーズ ベイズ推論による機械学習入門 (KS情報科学専門書)

機械学習スタートアップシリーズ ベイズ推論による機械学習入門 (KS情報科学専門書)

詳しくは本を見て下さい。

実装例

library(jpeg)
library(tcltk)
shirime <-readJPEG("Buson_Nopperabo.jpg")[,,1]
mat4img <- function(mat1){
  t(apply(mat1,2,rev))
}

doVB <-function(Y,M,seed=1234){
  set.seed(seed)
  N <-ncol(Y)
  D <-nrow(Y)
  X <- matrix(rnorm(M*N),M,N)
  W <- matrix(rnorm(M*D),D,M)
  I_D <- diag(1,D)
  S_Dinv <- diag(1,D)
  S_Winv <- diag(1,M)
  I_M <- diag(1,M)
  pb <- txtProgressBar(min = 1, max = 1000, style = 3)
  for(i in 1:1000){
    mu <-drop(rowSums(Y - W%*%X)%*%solve(N*I_D+S_Dinv))
    W <-((Y-mu)%*%t(X)) %*% solve(X%*%t(X)+S_Winv)
    X <-t(t(Y-mu)%*%W %*% (solve(t(W)%*%W+I_M)))
    setTxtProgressBar(pb, i)
  }
  list(W=W,X=X,mu=mu)
}

もとの画像。400行、772列。

image(mat4img(shirime))

f:id:abrahamcow:20180629023537p:plain

蕪村妖怪絵巻 - Wikipediaより)

M = 3 のとき

out3<-doVB(shirime,3)
image(mat4img(out3$W%*%out3$X+out3$mu),main="M=3")

f:id:abrahamcow:20180629023700p:plain

M = 10 のとき

out10<-doVB(shirime,10)
image(mat4img(out10$W%*%out10$X+out10$mu),main="M=10")

f:id:abrahamcow:20180629023747p:plain

M = 30 のとき

out30<-doVB(shirime,30)
image(mat4img(out30$W%*%out30$X+out30$mu),main="M=30")

f:id:abrahamcow:20180629023835p:plain

M = 50 のとき

out50<-doVB(shirime,50)
image(mat4img(out50$W%*%out50$X+out50$mu),main="M=50")

f:id:abrahamcow:20180629023857p:plain

アヤメの次元削減

library(tidyverse)

iris_out <-doVB(as.matrix(t(iris[,-5])),2)

iris2 <- as.data.frame(t(iris_out$X)) %>% 
  rename(X1=V1,X2=V2) %>% 
  mutate(Species=iris$Species)

ggplot(iris2,aes(x=X1,y=X2,colour=Species))+
  geom_point()

f:id:abrahamcow:20180629024148p:plain

abrahamcow.hatenablog.com