廿TT

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

0-1データのNMF(非負値行列因子分解)

今日の川柳

モデル

A_{l,k} \sim \mathrm{Beta}(a,b)
S_{n,1:L} \sim \mathrm{Dirichlet}(\alpha_{1:L})
 z_{n,k} \sim \mathrm{Categorical}(S_{n,1:L})
 X_{n,k} \sim \mathrm{Bernoulli}(A_{k,z_{n,k}})

パラメータ A_{l,k} はトピック×項目の成功確率パラメータ、パラメータ S_{n,1:L} はサンプルごとのトピックの構成割合。

z_{n,k} は潜在変数  z_{n,l,k} 示すトピックのインデックスを表すインジケータ変数です。

変分推論

未知パラメータ A_{l,k}S_{n,1:L} をまとめて \theta と置くと、
対数尤度関数は

 l(\theta) = \sum_{n}\sum_{l}\sum_{k} z_{n,l,k} ( \log S_{n,l} + X_{n,k} \log A_{l,k}+  (1-X_{n,k}) \log (1-A_{l,k}) +\mbox{Const.}

変分事後分布は次のように求まる。

 \log q(A_{l,k}) = (\sum_{n} z_{n,l,k}X_{n,k} + a) \log (A_{l,k}) + (\sum_{n} z_{n,l,k}(1-X_{n,k}) + b) \log (1-A_{l,k})+\mbox{Const.}

これはベータ分布。

 \log q(S_{n,1:L}) = \sum_{n}\sum_{l} z_{n,l,k}\log S_{n,l} + \alpha_l

これはディリクレ分布。

潜在変数 z_{n,l,k} については、

 l(\theta) = \sum_{n}\sum_{l}\sum_{k} z_{n,l,k} ( X_{n,k}\log S_{n,l}+(1-X_{nk})\log S_{n,l} + X_{n,k} \log A_{l,k}+  (1-X_{n,k}) \log (1-A_{l,k}) +\mbox{Const.}

であるから、X_{n,k} = 1 のとき、

 q(z_{n,l,k}) = \exp(\log S_{n,l})\exp( \log A_{l,k})/[ \sum_l \exp(\log S_{n,l})\exp( \log A_{l,k}) ]

 X_{n,k}=0 のとき、

 q(z_{n,l,k}) = \exp(\log S_{n,l}) \exp(\log (1-A_{l,k}))/[ \sum_l \exp(\log S_{n,l})\exp( \log (1-A_{l,k})) ]

これより

 \log q(S_{n,1:L}) = \sum_{n}\sum_{l} (z_{n,l,k}X_{n,k}+z_{n,l,k}(1-X_{n,k}))\log S_{n,l} + \alpha_l

と変形して、潜在変数 z_{n,l,k} についての結果を代入すれば、 z_{n,l,k}(多次元配列)を直接保存することなく、更新式が導ける。

R による実装例

berNMF <- function(X,L,alpha=1,a=1,b=1) {
  N <- nrow(X)
  D <- ncol(X)
  S <- gtools::rdirichlet(N,rep(1,L))
  A <- matrix(rbeta(L*D,1,1),L,D)
  Abar <- 1-A
  Xbar <- 1-X
  for (i in 1:1000) {
    Z_s = S*t((A)%*%t(X/(S%*%A))+(Abar)%*%t(Xbar/(S%*%Abar))) + alpha
    S = exp(digamma(Z_s)-digamma(rowSums(Z_s)))
    Z_a = A*(t(S)%*%(X/(S%*%A))) + a
    Z_b = Abar*(t(S)%*%(Xbar/(S%*%Abar))) + b
    A = exp(digamma(Z_a)-digamma(Z_a+Z_b))
    Abar = exp(digamma(Z_b)-digamma(Z_a+Z_b))
  }
  list(A=Z_a/(Z_a+Z_b), S=Z_s/rowSums(Z_s))
}

例題

【R言語】友達に漫画をおススメするときに利用するレコメンドアルゴリズムについて - What a Wonderful World のデータをお借りして分解してみる。

library(tidyverse)
res <- c(1,0,0,0,0,0,0,0,1,0,
         0,1,1,0,0,0,1,0,0,1,
         1,1,1,0,0,0,0,0,1,1,
         0,0,1,0,1,0,1,0,0,0,
         1,1,0,1,0,1,0,1,0,0,
         1,1,0,0,0,0,0,0,0,1,
         0,1,1,0,1,0,0,0,0,1)

item <- c("僕のヒーローアカデミア","魔法科高校の劣等生","図書館戦争",
          "中間管理録トネガワ","orange","ポプテピピック2nd","黒執事",
          "1日外出録ハンチョウ","ドラゴンボール超","幼女戦記")

user <- c("佐藤","鈴木","橋本","菅野","松本","坂本","小林")

mat <- t(matrix(res, 10,7))
colnames(mat) <- item
rownames(mat) <- user

out <- berNMF(mat, L = 3)
par(mfrow=c(1,2))
image(out$S%*%out$A)
image(mat)

heatmap(out$A,margins = c(13,2))
heatmap(out$S)

f:id:abrahamcow:20190622155859p:plain

f:id:abrahamcow:20190622155916p:plain