廿TT

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

詩のリフレインを可視化するベイズモデル (rstan)

今日の川柳

中原中也のサーカスという詩をたぶんあなたはすでにご存知だろう。

幾時代かがありまして
  茶色い戦争ありました

幾時代かがありまして
  冬は疾風(しっぷう)吹きました

幾時代かがありまして
  今夜此処(ここ)での一(ひ)と殷盛(さか)り
    今夜此処での一と殷盛り

サーカス小屋は高い梁(はり)
  そこに一つのブランコだ
見えるともないブランコだ

頭倒(あたまさか)さに手を垂れて
  汚れ木綿(もめん)の屋蓋(やね)のもと
ゆあーん ゆよーん ゆやゆよん

それの近くの白い灯(ひ)が
  安値(やす)いリボンと息を吐(は)き

観客様はみな鰯(いわし)
  咽喉(のんど)が鳴ります牡蠣殻(かきがら)と
ゆあーん ゆよーん ゆやゆよん

      屋外(やがい)は真ッ闇(くら) 闇の闇
      夜は劫々と更けまする
      落下傘奴(らっかがさめ)のノスタルジア
      ゆあーん ゆよーん ゆやゆよん

サーカス: 中原中也・全詩アーカイブ

「幾時代かがありまして」の反復ではじまり「ゆあーん ゆよーん ゆやゆよん」の反復で終わる。

この流れを可視化したい。

モデル

以下のモデルを考える。

「サーカス」の単語一つ一つ w_i, i=1,\ldots,n_w はカテゴリカル分布に従う。

w_i \sim \mathrm{Categorical}(p_i)

p_i が常に一定だとすると詩の流れが表現できない。一方で全部バラバラだとしてもそれは単に詩に表れた単語を順番に読み上げてるだけになってしまう。

そこで p_i の変化に次のような制約を置く。

p_i = \lambda \theta+ (1-\lambda) p_{i-1}

0<\lambda<1, \sum \theta_j =1 かつ \theta_j>0

\theta は後半の単語の分布を決めるパラメータで \lambda は変化の速さを決めるパラメータである。

\lambda の分だけ詩のトピックが「前半」から「後半」に推移していく。1-\lambda の分だけ「前半」のトピックが残存する。

これらには標準的な以下の事前分布を置く。

 \lambda \sim \mathrm{Beta}(a,b)

 \theta \sim \mathrm{Dirichlet}(\alpha)

実際に推定する際はハイパーパラメータは全部1に設定したので一様分布を仮定したのと同じである。

Stan のコード

はい。

data{
  int n_w;
  int n_vocab;
  int w[n_w];
  vector[n_vocab] alpha;
  real a;
  real b;
}
parameters{
  simplex[n_vocab] base;
  simplex[n_vocab] theta;
  real<lower=0,upper=1> lambda;
}
transformed parameters{
  simplex[n_vocab] p[n_w];
  p[1,] = base;
  for(i in 2:n_w){
    p[i,] = (lambda)*theta + (1-lambda)*p[i-1,];
  }
}
model{
  for(i in 1:n_w){
    w[i] ~ categorical(p[i,]);
  }
  theta ~ dirichlet(alpha);
  base ~ dirichlet(alpha);
  lambda ~ beta(a,b);
}
generated quantities{
  int pred[n_w];
  for(i in 1:n_w){
    pred[i] = categorical_rng(p[i,]);
  }
}

結果

これが各単語の出現確率の推移だ。

f:id:abrahamcow:20181024221431p:plain

はい。

3回以上登場した単語だけ抜き出してみる。

f:id:abrahamcow:20181024221532p:plain

「まし」「あり」「て」「が」「か」「幾」「時代」ではじまり「ゆ」「の」「と」「ん」で終わる。

改めて助詞に注目してみると出だしは「が」「か」みたいな強い響きのものが多く、次第に「の」「と」みたいな柔らかい響きのものが増えていく気がする。

強いとか柔らかいとかは僕の主観です。

学習したこの単語の分布からランダムにサンプリングしていくつか詩を作ってみる。

を幾やゆ見えるあり頭か小屋茶色い蓋灯蓋そこありよん戦争値いの高いて汚れゆ 時代あり更けそこ近く屋まし時代よーはたまし鰯ッよー小屋更けブランコに観客それ落下傘木綿ないよんの屋外ゆゆ鰯そこましとゆやゆが がのだゆあー時代ましゆノスタルヂア咽喉殻る今夜盛り近く此処てノスタルヂアんあーた灯ゆあー疾風 ゆ今夜劫それ落下傘見えるにます鰯々鰯灯時代の咽喉手見えるはがよん近く近くと が咽喉観客近く屋外灯よー殻あー劫よんみな灯あーまし 冬牡蠣奴それ 手んゆよー殻ん今夜観客盛り屋外時代 よー鰯ゆ殷まし鰯ブランコ屋ゆそれゆ  時代ましまし鰯

幾更けて盛り今夜よー も今夜やゆ殷あり戦争まし時代様よーと闇劫たも梁まし近くゆで時代も今夜息ゆやゆだそこ奴ゆブランコもまし汚れよん鰯ノスタルヂアブランコ一灯息もを劫頭白いだよーを時代よん見える劫灯 値い牡蠣も倒さ殷 ゆゆ 安手蓋とあー此処此処ましゆもと見える幾値い屋よー頭ゆに此処よんでよー此処よー 殷牡蠣殷も蓋 んはのゆをもと一つそこんが 灯ん闇ゆ々よー此処様も此処まし鰯鰯闇様様闇鳴りあーリボンよんよん近く息々あー吹き梁ノスタルヂア奴近く手のに真戦争梁蓋殻 ブランコもよんんゆブランコだ

小屋疾風木綿か奴サーカスない幾々一今夜まし一盛り灯よーだ真灯汚れやゆ頭牡蠣あり吐き時代近くか疾風小屋だ今夜観客見えるをもるあー今夜今夜ありゆますリボンん灯手サーカスます殻蓋茶色い梁だ更けやゆ戦争小屋が闇であー更けのはかで真一ない吹き吐きが白いッん値い手は見える牡蠣見える垂れが あーにのを牡蠣真頭殻ます冬はよー茶色いましゆ幾サーカスの見える安る垂れ値い近くて一つか闇一更けが殻がに闇それ蓋ゆてがゆ屋蓋観客落下傘がだのと一にに咽喉がに見える真見えるよー灯は闇咽喉吐きがのッんがの様近く々蓋値い

ゴミですね。

岩波データサイエンス Vol.2

岩波データサイエンス Vol.2

ベイズモデリングの世界

ベイズモデリングの世界

R のコード

library(RMeCab)
library(rstan)
library(tidyverse)
library(ggrepel)
rstan_options(auto_write = TRUE)
circus <- 
"幾時代かがありまして
茶色い戦争ありました

幾時代かがありまして
冬は疾風吹きました

幾時代かがありまして
今夜此処での一と殷盛り
今夜此処での一と殷盛り

サーカス小屋は高い梁
そこに一つのブランコだ
見えるともないブランコだ

頭倒さに手を垂れて
汚れ木綿の屋蓋のもと
ゆあーん ゆよーん ゆやゆよん

それの近くの白い灯が
安値いリボンと息を吐き

観客様はみな鰯
咽喉が鳴ります牡蠣殻と
ゆあーん ゆよーん ゆやゆよん


屋外は真ッ闇 闇の闇
夜は劫々と更けまする
落下傘奴のノスタルヂアと
ゆあーん ゆよーん ゆやゆよん"
w_raw <-unlist(RMeCabC(circus))
vocab <-unique(w_raw)
n_vocab <- length(vocab)
w <- sapply(w_raw, function(x)which(vocab %in% x))
n_w <- length(w)
unigram_beta_dir <- stan_model("~/Documents/unigram_beta_dir.stan")
datlist <- list(w=w,n_w=n_w,n_vocab=n_vocab,alpha=rep(1,n_vocab),a=1,b=1)
fit1 <- sampling(unigram_beta_dir,datlist,seed=1984,core=4)

traceplot(fit1)
print(all(summary(fit1)$summary[,"Rhat"]<1.1,na.rm = TRUE))
# #TRUE
phat <- matrix(get_posterior_mean(fit1,"p")[,"mean-all chains"],n_w,n_vocab,byrow = TRUE)
lambda <-get_posterior_mean(fit1,"lambda")[,"mean-all chains"]

# base <-get_posterior_mean(fit1,"base")[,"mean-all chains"]
# theta <-get_posterior_mean(fit1,"theta")[,"mean-all chains"]
# 
# df <-data.frame(vocab,base,theta,stringsAsFactors = FALSE)
# ggplot(top_n(df,20,wt=base),aes(x=reorder(vocab,base),y=base))+
#   geom_col()+
#   coord_flip()+
#   theme_bw(base_family="Osaka")
# 
# ggplot(top_n(df,20,wt=theta),aes(x=reorder(vocab,theta),y=theta))+
#   geom_col()+
#   coord_flip()+
#   theme_bw(base_family="Osaka")
dfcount <-data_frame(word=w_raw) %>% 
  group_by(word) %>% 
  tally()

dfphat <- as.data.frame(phat) %>% 
  set_names(vocab) %>% 
  mutate(position=row_number()) %>% 
  gather(word,value,-position) %>% 
  left_join(dfcount)

dfphat_3 <- dplyr::filter(dfphat,n>=3)

ggplot(dfphat,aes(x=position,y=value,group=word))+
  geom_line()

ggplot(dfphat_3,aes(x=position,y=value,colour=word))+
  geom_line()+
  scale_colour_discrete(guide = 'none') +
  geom_text_repel(data = dplyr::filter(dfphat_3,position==1|position==n_w),
             aes(label = word),family="Osaka")

ex_pred <- rstan::extract(fit1,"pred")

set.seed(1234)
cat(paste(vocab[ex_pred[[1]][sample.int(4000,1),]],collapse = ""))
cat(paste(vocab[ex_pred[[1]][sample.int(4000,1),]],collapse = ""))
cat(paste(vocab[ex_pred[[1]][sample.int(4000,1),]],collapse = ""))

#save(fit1,file = "circus2.Rdata")
#load(file = "circus2.Rdata")

モデルの拡張

 \lambda を一定にせずランダムウォークさせるとか、\theta が連ごとに異なるようにするとかいろいろ考えれる。

でもそうすると推定は難しくなる。

中原中也全詩集 (角川ソフィア文庫)

中原中也全詩集 (角川ソフィア文庫)

参考

statmodeling.hatenablog.com

言い忘れてたけど、この記事を参考にしました。