心変わりは、人の世の常と申しますから

 ここ半年、今まで属していなかったコミュニティにお邪魔する機会が増えた。増えたというより、半分意識的に、そういう機会を増やしている。当然、最初の腰を上げるのは重いのだけれど、実際に行ってみると、従来の自分の行動パターンからは得られない発想や新しい出会いがあって面白い。いつだったか、ネットワークの研究の話を聞いたとき、多種多様なコミュニティに属している人はそうでない人より年収が高い傾向があるなんてことを聞いたこともある。年収の高い人は別のコミュニティに行けるだけの余裕があるってことなのかもしれない。そんな可能性もあるけれど、別のコミュニティに参加すれば、知らなかった世界が開けたりして、年収のようなものへの作用があるとも考えられる。コミュニティとコミュニティの狭間の人を異人と呼んだりしたと思うのだが、異人の役割といった、このへんの話は赤坂憲雄『異人論序説』に詳しく、面白かった記憶がある。いつも属しているコミュニティにばかりいないで、たまには、外に飛び出してみたりするのは面白いし、それが億劫に感じて、できなくなるような自分には、できることなら、なりたくないものだ。

 新しいコミュニティに行くと感じるのは、コミュニティというものが生き続けているというのはすごいことだということだ。コミュニティのメンバーの各々が、そのコミュニティに対して集まろうという気持ちがなければ、コミュニティは成立しえない。コミュニティを見ていると、積極的にコミュニティを運営しようとしている層と、運営されているコミュニティが生きているなら参加し、協力しようとする層と、参加はするがとくに協力しない層と、離れていく層があると感じる。これらの層がどれくらいの厚みがあって、どれくらいの熱量があるのかがコミュニティの存続・活発度に関わってくると考えられる。各々のメンバーは、それぞれの事情を抱えており、コミュニティへの貢献を一律に強制することは自律的なコミュニティでは難しい。コミュニティのメンバー構成やシステムによっても、メンバーの行動は変わってくる。様々な要因が絡み合っている中で、コミュニティというものが明かりを灯しているのは実はすごいことなんだと最近、実感している。

 コミュニティが存続していることで、属しているメンバーは受ける便益(どういった形かは決まらない。)がある。一方で、コミュニティを存続させるためには貢献が必要で、属しているメンバーにとって、費用(便益同様、どういった形かは決まらない。)となる。ここで、費用を嫌う一方で、便益を受け取るメンバーも、もちろん存在する。人なのだから。コミュニティを運営する人にとって、そういった人への態度というのが難しい。

 個人的に理想として思い描くコミュニティのメンバーのあるべき姿というものがある。それは、余裕があるときは自分が費用を被っても貢献するという姿勢だ。みんなが僅かな自己犠牲を捧げることでコミュニティが成立し、そのコミュニティによって大きな恩恵を得られるというのならばそうすべきだと思う。常に美味しいところだけ持って立ち去ってしまうような姿勢は個人的な理想的見地からすると、望ましくない。自分はそうありたくないし、他人もできることなら、そうあってほしくない。これが、そんな私のエゴである。

ユダヤ人の知恵を借りて資源配分したいときの覚書

 

ユダヤ人の平等な配分の仕方を自動的にやる方法

【用途】
庭から石油が湧いてきたときを想定してほしい。どうやら年間100万トンの産出ができるようだ。兄弟がそれぞれ権利を主張しており、兄は100万トンの権利を持つと主張しており、弟は50万トンの権利を持つと主張している。権利関係を確かめたところ、二人の主張はどうやら正しい。しかし、二人の権利の総量は150万トンで実際に存在する量の100万トンを超えている。このような場面で、どのように石油を配分するのが良いのだろうか。半分ずつに分けるという方法もあるし、割合に応じて2:1に分ける方法もあるが、ユダヤ人の聖典であるところの『タルムード』が規定する分配方法は少し異なる。このケースでは、75万トンと25万トンに分けられるようだ。石油の量が50万トンだと、25万トンずつになり、石油の量が、石油の量が120万トンだと、85万トンと35万トンになる。
この配分方法は一見不思議に見えるが整合性がある。詳しくは「タルムードの破産問題」や「ミシュナの分配」、「布争いの原理」、「仁(nucleolus)」といったキーワードで調べてほしい。
ここでは、その原理に従って、配分量を楽に計算したくなることがある。そんなときのための関数を作成した。

【内容】
JewishAllocという関数を作成した。引数にはtotalとvdemandをとり、totalには分配対象となるものの総量が入り、vdemandにはそれぞれの権利者の正しい権利の量のベクトルが入る。出力として、その権利者の番号とその人に対応する分配量が書かれたデータフレームが出てくる。
パッケージとして、dplyrとmagrittrが読み込まれるが、コードが書きやすいから使用している。使わなくても、該当箇所を書き換えることは難しくはないだろう。

JewishAlloc <- function(total,vdemand){
  #Loading Packages
  library(dplyr)
  library(magrittr)
  #sum of demand
  sdemand <- sum(vdemand)
  #number of people
  n <- length(vdemand)
  #data.frame
  dfdemand <- data.frame(no = 1:n ,
                       D = vdemand,
                       halfD = vdemand/2,
                       A = rep(0,n))
  counter <- 1 #initial counter
  hw <- 0 #initial height of water (metaphor)
  skip <- 0 #0は通常の配分処理を行う。1はdemand通りに配分。2は設定に問題あり。
  dfdemand <- dfdemand %>% arrange(D) #sort by amount
  if(sdemand <= total){
    #If: sdemand > total -> vallocation = vdemand
    dfdemand$A <- dfdemand$D
    skip <- 1
    } else if(0 < total & total < sdemand/2){
      #If: 0 < total <  sdemand/2
      remain <- total #initial remain
      reverse <- 0
      } else if(sdemand/2 <= total & total< sdemand){
        #If: sdemand/2 < total < sdemand
        remain <- sdemand - total #initial remain reverse
        #(空気を水に,水を空気にのイメージ)
        reverse <- 1
        } else{skip <- 2}
  if(skip == 0){
    while((n - counter + 1)*(dfdemand$halfD[counter] - hw) < remain){
      hw <- dfdemand$halfD[counter]
      remain <- remain - hw*(n-counter+1)
      dfdemand$A[counter] <- hw
      counter <- counter + 1
      }
    #dfに逐一入れる。0のとこに最後追加。
    dfdemand$A <- ifelse(dfdemand$A==0, hw + remain/(n- counter + 1), dfdemand$A)
    #reverseが1なら引き算
    if(reverse == 1){
      dfdemand$A <- dfdemand$D - dfdemand$A
    }
    }
  #no でdfをarrangeして元に戻す。
  dfdemand <- dfdemand %>% arrange(no)
  colnames(dfdemand) <- c("no","D","halfD","Alloc")
  if(skip == 2){
    print("something wrong!")
    }else{return(dfdemand[c("no","Alloc")])}
}

イデアのイメージとしては、需要量の多い順に並べて、半分に分けて、上下に貼り付けた筒をつくり、横をくりぬいた箱をつくる。上から水を流してやると、その通りの配分となるイメージだ。hwという変数は水の高さを上げていくイメージ。remainは徐々に水面を上げていってまだ水がどのくらい残っているのかを表している。次の高さまでいけないくらいのremainになったら、等分してやるといった具合だ。reverseという変数は、半分を越したところの計算は対称性を利用してあげると上手くいくので、そのようにしている。空気を水に、水を空気にして計算したあと、対称性を用いて元に戻す感覚だ。(たぶんここのパラグラフは文字だけでは人に伝わりにくいとは思う。)

最初の石油のケースを試してみる。最初の使用ではパッケージの読み込みの出力が出てくる。

t <- 100
vd <- c(100,50)
JewishAlloc(total = t, vdemand = vd)
## 
## Attaching package: 'dplyr'
## The following objects are masked from 'package:stats':
## 
##     filter, lag
## The following objects are masked from 'package:base':
## 
##     intersect, setdiff, setequal, union
##   no Alloc
## 1  1    75
## 2  2    25

二番目のケース。

t <- 50
vd <- c(100,50)
JewishAlloc(total = t, vdemand = vd)
##   no Alloc
## 1  1    25
## 2  2    25

三番目のケース

t <- 120
vd <- c(100,50)
JewishAlloc(total = t, vdemand = vd)
##   no Alloc
## 1  1    85
## 2  2    35

想定通りの出力が出ている。権利の総量に対して十分な量がある場合は、需要量分全てが配分される。変なケースが出るときは、something wrongが出力されるようにした。たとえば、totalが負の値のときは、

t <- -200
vd <- c(100,50)
JewishAlloc(total = t, vdemand = vd)
## [1] "something wrong!"

となる。

権利の主張者が二人より多いときでも配分は出力されるように作成されている。たとえば、四人兄弟で、総量が150、それぞれの主張が100,75,50,25の場合は

t <- 150
vd <- c(100,75,50,25)
JewishAlloc(total = t, vdemand = vd)
##   no Alloc
## 1  1  87.5
## 2  2  62.5
## 3  3  25.0
## 4  4  12.5

となる。

【記憶の検索キーワード】
ユダヤ人, 配分, 知恵, 遺産, 布, タルムード, ミシュナ, 仁(nucleolus), 水を落とすイメージ

壊れるほど愛しても1/3も伝わらない純情な感情との衝動遊戯

 

【ABSTRACT】

一度壊れるほど愛したとき、1/3の感情が伝わるとして、壊れるほど愛する回数を増やしていくときの、すべての感情が伝わっている確率を計算した。感情が複雑になればなるほど、全てを伝えきるのは難しくなるという結論が得られた。

【OBJECTIVE】

SIAM SHADEの曲に『1/3の純情な感情』というものがある。この曲は、こう始まる。

壊れるほど愛しても1/3も伝わらない 純情な愛情は空回り I love you さえ言えないでいるMy heart

では、いったいぜんたい、どのくらい愛せば良いのだろうか。このような疑問が自然と湧いてくる。感情を伝えるのはとても難しいことだというのは周知の通りであるが、感情を全て伝えたいという欲求は否定されるべきではない。ただ、壊れるほど愛した結果、壊してしまってはいけない。そんなわけで、壊れるほど愛する回数を増やしていくとき、感情がどの程度伝わっているのかを考えていく。

【METHODS】

実際に、壊れるほど誰かを愛して、その人にどれくらい感情が伝わったかチェックするという手法が第一に思い浮かぶ。しかし、この手法には問題がいくつかある。壊れるほど愛した結果、その人を壊してしまってはいけないし、どれくらい感情が伝わったかをチェックするのはとても難しい(一番問題なのは壊れるほど愛する誰かの存在なのだが、これはここでは触れずに話を進めることにする。)。

こういう場面で役立つのがモデルだ。現象を近似・抽象化したモデルを作って考える。感情を要素に分解して、壊れるほど愛すると、要素のどれかが確率的に伝わっていくとするモデルをセッティングする。つまり、感情の要素を玉に見立てて、玉を箱に入れて、復元抽出することを想定すると分かりやすい。そのようなモデルで、感情の伝わっている割合、玉で言えば伝わっている玉の種類数の割合を確認していく。

【RESULTS】

感情には3つの要素があってどれか1つが伝わる場合

最も簡単なモデルを作る。伝えたい感情には3つの要素があるとする。1度壊れるほ愛すると、3つの要素のうち1つだけ伝わるとする。その1つの選ばれ方は一様で、それぞれ1/3ずつとする。つまり、ここでは壊れるほど愛すると感情の1/3が伝わるというわけだ。歌詞では1/3も伝わらないとあるが、簡単化のため、1/3とする。非復元抽出としてしまうと、3回愛せば終わってしまうので、復元抽出を考える。
たとえば、A,B,Cの要素があるとして、それぞれ1/3の確率で伝わるとする。5回壊れるほど愛したとして、A,B,A,A,Bと伝わる要素が実現したならば、伝わっているのはAとBで、Cは伝わっていないということになる。
初期値ベクトルと推移行列を用意して積をとれば、n回愛したあとの伝わっている確率は確認できるだろう。行列の積は面倒くさいので、以下、Rを用いて計算していく。

まず、必要なパッケージを読み込む。

library(expm) #行列のべき乗をするためのパッケージ

次に、初期値ベクトルと推移行列を用意する。A,B,Cが伝わっているか否かが問題なので、状態の数は2^3個の8個。伝わっていない状態を0,伝わっている状態を1としたら、(0,0,0),(1,0,0),(0,1,0),(0,0,1),(1,1,0),(1,0,1),(0,1,1),(1,1,1)の8個の状態があり、1回壊れるほど愛すると状態が確率的に推移するので、それを推移行列で表して、計算する。初期値ベクトルは(1,0,0,0,0,0,0,0)の転置したものである。

#初期値ベクトルの作成
vini <- numeric(2^3)
vini[1] <- 1
#推移行列
mtran <- matrix(c(0,1/3,1/3,1/3,0,0,0,0,
                    0,1/3,0,0,1/3,1/3,0,0,
                    0,0,1/3,0,1/3,0,1/3,0,
                    0,0,0,1/3,0,1/3,1/3,0,
                    0,0,0,0,2/3,0,0,1/3,
                    0,0,0,0,0,2/3,0,1/3,
                    0,0,0,0,0,0,2/3,1/3,
                    0,0,0,0,0,0,0,1),
                  nrow = 2^3,byrow = TRUE)

#5回壊れるほど愛したとする
k<-5
pmtran <- mtran%^%k
print(vini%*%pmtran)
##      [,1]        [,2]        [,3]        [,4]      [,5]      [,6]
## [1,]    0 0.004115226 0.004115226 0.004115226 0.1234568 0.1234568
##           [,7]     [,8]
## [1,] 0.1234568 0.617284

これは5回愛した後の(0,0,0),(1,0,0),(0,1,0),(0,0,1),(1,1,0),(1,0,1),(0,1,1),(1,1,1)の状態の確率である。5回壊れるほど愛することができれば、約6割の確率で全ての感情を伝えることができるということが分かる。また3割6分ほどの確率で感情の2/3は伝わっているということになる。

これを関数にする。k回愛した後の状態の確率分布を出力する関数を以下のように作る。

afterk <- function(k){
  vini <- numeric(2^3)
  vini[1] <- 1  #初期値ベクトル
  mtran <- matrix(c(0,1/3,1/3,1/3,0,0,0,0,
                    0,1/3,0,0,1/3,1/3,0,0,
                    0,0,1/3,0,1/3,0,1/3,0,
                    0,0,0,1/3,0,1/3,1/3,0,
                    0,0,0,0,2/3,0,0,1/3,
                    0,0,0,0,0,2/3,0,1/3,
                    0,0,0,0,0,0,2/3,1/3,
                    0,0,0,0,0,0,0,1),
                  nrow = 2^3,byrow = TRUE)    #推移行列
  pmtran <- mtran%^%k
  vini%*%pmtran
}

愛して伝える回数が、1回から15回のケースを計算して、感情が全部伝わっている確率をプロットする。

noftran <- 15
mresult<- apply(matrix(1:noftran, nrow = 1, byrow = TRUE), MARGIN = 2,afterk)
plot(mresult[2^3,], xlab = "伝える回数", ylab = "全部伝わっている確率",type="b")
abline(h=0.95)

y=0.95のところに直線を引いた。11回壊れるほど愛したら、95%以上の確率で全ての感情が伝わっていることが期待できるということだ。こりゃめでたい。

ちなみに、状態を0,1を全ての感情の種類に割り当てたものより、何種類の感情が伝わっているかを表したものの方が、楽に記述できる。結果は変わらない。後の比較のために、y=0.5にも直線を引いた。

afterk <- function(k){
  vini <- numeric(3*1+1)
  vini[1] <- 1  #初期値ベクトル
  mtran <- matrix(c(0,1,0,0,
                    0,1/3,2/3,0,
                    0,0,2/3,1/3,
                    0,0,0,1),
                  nrow = 3+1,byrow = TRUE)    #推移行列
  pmtran <- mtran%^%k
  vini%*%pmtran
}
noftran <- 15
mresult<- apply(matrix(1:noftran, nrow = 1, byrow = TRUE), MARGIN = 2,afterk)
plot(mresult[3+1,], xlab = "伝える回数", ylab = "全部伝わっている確率",type="b")
abline(h=0.95)
abline(h=0.5)

感情には6つの要素があってどれか2つが伝わる場合

感情の要素が3つの場合を考えてきたが、人間の感情はそんなに単純ではない。感情の要素を増やして、感情を複雑にしてみよう。具体的には同じセッティングで感情の要素を6つにして、どれか2つが伝わるとする。同様に関数を作成して、全ての感情が伝わっている確率をプロットする。

afterk <- function(k){
  vini <- numeric(3*2+1)
  vini[1] <- 1  #初期値ベクトル
  mtran <- matrix(c(0,0,choose(6,2),0,0,0,0,
                    0,0,choose(5,1),choose(5,2),0,0,0,
                    0,0,choose(2,2),choose(2,1)*choose(4,1),choose(4,2),0,0,
                    0,0,0,choose(3,2),choose(3,1)*choose(3,1),choose(3,2),0,
                    0,0,0,0,choose(4,2),choose(4,1)*choose(2,1),choose(2,2),
                    0,0,0,0,0,choose(5,2),choose(5,1),
                    0,0,0,0,0,0,choose(6,2)),
                  nrow = 3*2+1,byrow = TRUE)    #推移行列
  mtran <- mtran/choose(6,2)
  pmtran <- mtran%^%k
  vini%*%pmtran
}
noftran <- 15
mresult<- apply(matrix(1:noftran, nrow = 1, byrow = TRUE), MARGIN = 2,afterk)
plot(mresult[3*2+1,], xlab = "伝える回数", ylab = "全部伝わっている確率",type="b")
abline(h=0.95)
abline(h=0.5)

12回壊れるほど愛したら、95%以上の確率で全ての感情が伝わっていることが期待できるということだ。感情が3つのときは11回であったのに比べて必要な回数が増えている。伝える回数の増加に伴う確率の上昇も緩やかになっていることが分かる。これは同じ要素が伝わてしまう確率、つまりダブって伝わる確率が増えているためである。感情の要素をさらに増やしていくと同様のことが確認できる(昔pythonで推移行列を簡単に作成できるコードを書いたのだが、どこかに消えてしまったし、そのアイデアが思い出せないし、すぐに思いつかない。書ける人は書いて確認してほしい。)。このことは、感情が複雑になればなるほど、感情を伝えるのには時間がかかると解釈することができる。

【CONCLUSIONS】

一度壊れるほど愛したとき、1/3の感情が伝わるとして、壊れるほど愛する回数を増やしていくときの、感情の全部が伝わっている確率を計算した結果、感情が複雑になればなるほど、全てを伝えきるのは難しくなるという結論が得られた。

別の応用先としては、ガチャのコンプ問題が考えられる。ガチャの出てくるものが一様の確率で選ばれる復元抽出だった場合、今回のモデルと同様の問題に帰着する。また、以下のような拡張系も予想できる。

伝わる確率が一様だと想定しているが、そうでないケースも考えられる。分布を変えるとどうなるかは今回は試していない。伝わりにくい感情だってあるだろう。また、伝わる確率がそれぞれ独立だということを仮定していたが、あることが伝わっている状態ならば、別のあることは伝わりやすいということや、その逆もありうる。伝えたと思った感情の要素は次は少し弱めにして他の要素が伝わるように工夫することだって考えられる。そういった相関関係や連鎖関係を仮定したモデリングも今回は作っていない。壊れるほど愛することができる関係ならば、相手からのシグナルを受け取ったり、反応を見てみたりしながら、どれが伝わっているかを確認したり、推測したりすることもできるだろう。そんなモデルも考えられる。

今回モデル化したのは、n回伝えた時点での伝わり具合であったが、視点を変えた問題として、全部伝わるまでに何回かかるのかを確率的に考えることができるだろう。おそらく、負の二項分布の拡張になるのだろうと予想しているが、実際にどのような分布になるかは考えていない。

一度壊れるほど愛した場合、壊れるリスクについての検討もしていない。今回は何度壊れるほど愛しても壊れない仮定を置いていた。壊れるリスクを付与したモデルを作っても面白いのかもしれない。

以上挙げたような、拡張可能性を有したモデルであるので、好きに拡張して、壊れるほど愛する際の参考にしてください。

【REFERENCES】

SIAM SHADE1/3の純情な感情
今回の発想の源泉となった曲。聞いたことのない方はぜひ一度聞いてみてください。

「成功裡」という言葉との衝動遊戯

【ABSTRACT】

「成功裡」のような「○○裡」は、"~~ly"という英語もしくはそれに関係する言葉の和訳で造られたものだという仮説の検証を行ったが、筆者の力不足のため完遂はできなかった。

【OBJECTIVE】

「会は成功裡(裏)に終わった。」という文に、自分の日本語感覚は違和を覚える。全く日本語として問題ないのは事実なのだが、「成功裡」という単語がどうも私の日本語感覚にとってみると自然ではないのだ(こういうことは偶に起こる)。過去に一度、この「成功裡」という単語に齟齬を感じたがスルーしていたのだけど、最近、あることが思い浮かんだ。
英訳すると、"The meeting ended successfully."となる。明治時代以降、英語文献の和訳作業の中で、できた言葉なのではないかという仮説に行き着く。つまり、何が言いたいのかというと、successfully = successful + ly = 成功 + ly という式で以て造られた語なのではないかという仮説が浮かんだのだ。lyのところ、裡で上手く意味が合うし、この訳し方、天才では!って自画自賛して和訳した日本人の存在があったのではないか。そういう想像が膨らんだのだ。
秘密裡という言葉もある。これは、secretlyから来ているのではないか。そんなことを思いついたけど、実際のところどうなのだろうか。これを調べていきたい。

【METHODS】

まずは手始めにgoogle大先生にお話しを伺った。しかし、これでは解決しなかったので、ジャパンナレッジで調べてみた。

【RESULTS】

まず、googleで、「成功裡」「成功裡 secretly」「成功裡 語源」などと検索をかけてみたところ、2件の記事が、なるほどと思った。
「成功裏」とは?意味や使い方を解説 | 意味解説

裏 と 裡 : 語句楽散歩
だ。 「裡」には、内側の意味があり、「裡」を「うち」と読むこともあるということが分かった。(後者の記事は、裏原宿を台湾の文章で使うとき、裡原宿と書いていいかどうかという話で、面白かった。)

「裡」という言葉の知識はついたものの、語源は何なのか分からない。せめて初出が日本に西洋文化流入する前であるならば、自分の立てた仮説は否定される。ジャパンナレッジLibを使って、検索をかけて、語源情報もしくは凡例情報を探してみて、関係しているところを以下に、引用する。

3 その状態で。「暗暗裏・成功裏・秘密裏」

"り【裏】[漢字項目]", デジタル大辞泉, JapanKnowledge, https://japanknowledge.com , (参照 2018-11-03)

【二】〔語素〕
状態を表わす漢語に付いて、その状態のうちに物事が行なわれることを表わす。
竹沢先生と云ふ人〔1924〜25〕〈長与善郎〉竹沢先生の人生観・二「真に生きる実践的な力を得、不退の安心裡に住し得る底の現実力となって来なくては嘘だと」
多甚古村〔1939〕〈井伏鱒二〉休日を待つ「隠密裡に調査すべしとの別紙の書類が封入され」

"り【裏・裡】", 日本国語大辞典, JapanKnowledge, https://japanknowledge.com , (参照 2018-11-03)

4 (「裡」とも書く。「…のうちに」の形で)物事の行われる状況を表す。「暗黙の―に理解しあう」「会は成功の―に終わる」

"うち【内】", デジタル大辞泉, JapanKnowledge, https://japanknowledge.com , (参照 2018-11-03)

(13)(「裏」「裡」を訓読したものか。多く「の」を受けて用いられる) 物事の経過する間の状況、環境などを示すのに用いる。終始そのようなさまであるあいだ。「おたがいに暗黙のうちに了解しあった」
*米国及び英国に対する宣戦の詔書‐昭和一六年〔1941〕一二月八日「事態を平和の裡に回復せしめむとし、隠忍久しきに彌(わた)りたるも」

"うち【内】", 日本国語大辞典, JapanKnowledge, https://japanknowledge.com , (参照 2018-11-03)

人の知らないうち。ひそかな状態。内々(ないない)。
*内地雑居未来之夢〔1886〕〈坪内逍遙〉二「皮相論者が下院の勢力を称歎するにも係らず、其実暗々裡(アンアンリ)に、国家の権威を彼貴族輩が握れるならずや」
或る女〔1919〕〈有島武郎〉前・一四「何時でも暗々裡(アンアンリ)に事務長の為めにされてゐるのを意識しない訳には行かなかった」

"あんあん‐り【暗暗裏・暗暗裡】", 日本国語大辞典, JapanKnowledge, https://japanknowledge.com , (参照 2018-11-03)

どの凡例も明治期以降のもので困った。ただ、『日本国語大辞典』の「うち」の説明で、「裡」を訓読して、「(の)うち」にという使われ方が疑われている。もしも、この使い方が西洋文化流入以前の漢文にあるのだとしたら、仮説が否定されてくれるのだが、これ以上の調査はできなかった。

【CONCLUSIONS】

「○○裡」は、"~~ly"という英語もしくはそれに関係する言葉の和訳で造られたものだという仮説は否定できなかった。こういう文献調査・言葉の調査のような訓練を受けたのは大学の教養の講義くらいで、この方面では私は力不足だと感じた。誰か、この仮説の検証を引き継いでいただける方がいれば、ぜひ引き継いで検証していただきたい。
(あと、ジャパンナレッジすごい。)

【REFERENCES】

【RESULTS】にて、それぞれ記載しているので、今回は省略させていただきます。

RのデータフレームでNAを削除して左に詰めたいときの覚書

 

RのデータフレームでNAを削除して左に詰める方法

【用途】

スポーツの試合結果の表があったとき、時折、天候など何らかの理由によって試合日が振り返られることがある。そんなときにNAとなっているところを消して、要素を左に詰めたいという操作をしたくなることがある。そんなときのための技。

【内容】

library(magrittr) #パイプ演算子を愛してるから
df_na <- data.frame(
  V1 = c(1,0,1,0),
  V2 = c(0,NA,1,NA),
  V3 = c(1,1,0,0),
  V4 = c(NA,1,NA,0),
  row.names = c("A","B","C","D")
)
df_na
##   V1 V2 V3 V4
## A  1  0  1 NA
## B  0 NA  1  1
## C  1  1  0 NA
## D  0 NA  0  0

こんなデータフレームがあるとする。これのNAを消して、左に寄せたい。 想定としては、A~Dが選手名やチーム名に相当。V1~V4は時系列で、試合の順番に相当。

df_tume <- apply(df_na,1,na.omit) %>% t()
colnames(df_tume) <- c("v1","v2","v3")
df_tume
##   v1 v2 v3
## A  1  0  1
## B  0  1  1
## C  1  1  0
## D  0  0  0

【記憶の検索キーワード】

データフレーム, NA, 処理, 欠損, 欠測, 削除, 詰める, 寄せる, R, 試合, 振替

怪異・妖怪伝承との衝動遊戯:第2ゲーム

 

「怪異・妖怪伝承との衝動遊戯:第1ゲーム」で書いた内容のRのコードと解説です。

moratoriamuo.hatenablog.com

R MarkdownでHTMLを作成して、はてなブログのHTML編集にコピペしてます。
ディレクトリについては、上手く調整してください。
スクレイピングで得たデータはoni_youyakuフォルダを作成して保存しています。

スクレイピング

必要なライブラリーの読み込みをする。

library(tidyverse)
library(rvest)
library(magrittr)
library(stringr)
library(XML)

データベースの構造を把握するため、オニの一つ目だけ要約を抜き出してみる。

result_oni_1 <- read_html("http://www.nichibun.ac.jp/YoukaiCard/0640010.shtml")
youyaku_table_1 <- result_oni_1 %>% html_table(fill = TRUE)
youyaku_1 <- youyaku_table_1[[11]]$X3[27]
write(youyaku_1, "oni_youyaku_1.txt")

YoukaiCardの番号を抜き出せれば、そこだけ変更すればいけそうだと分かる。

result_oni <- read_html("http://www.nichibun.ac.jp/cgi-bin/YoukaiDB2/ksearch.cgi?Name=%E3%82%AA%E3%83%8B&Pref=&Area=%E5%85%A8%E5%9B%BD")
links_oni <- result_oni %>% html_nodes("td") %>% html_nodes('a') %>% html_attr('href')
#YoukaiCardのTRUEorFALSE
#Card_TF <- str_detect(links_oni, pattern = "YoukaiCard")
#links_oni[Card_TF]
#ってやろうとしたけど、これで十分だった
links_oni <- str_subset(links_oni, pattern = "YoukaiCard")
#ここから、/で始まりshtmlで終わるところを抽出したい(うまいやり方が思い付かず位置でごり押し)
str_count("../../YoukaiCard/")
card_shtml <- str_sub(links_oni, start = 18)
#そこから/と.shtmlを削除したデータも作成(後でtxtファイルの名前に使用)
card_num <- str_sub(card_shtml, end = -7)
#ループ処理で使うurl集
url_oni <- str_c("http://www.nichibun.ac.jp/YoukaiCard/", card_shtml)
#長さが一緒であることの確認。件数。
length(card_num)
length(url_oni)

これでループ回してスクレイピングしようとしたら、途中で文字化けして止まってしまった。
10番目で止まったので、そこを調べてみると

result_oni_10 <- read_html(url_oni[10])
youyaku_table_10 <- result_oni %>% html_table(fill = TRUE)

Error in type.convert.default(out[, i], as.is = TRUE, dec = dec) :
invalid multibyte string at ’シ<88>蜈ィ蝗スシ壹が繝具シ<89>
縲竊帝。樔シシ蜻シ遘ー
と表示された。 エラーのケースは例外処理するコードを書いた。

例外処理した番号をプリントする。

for(i in 1:length(url_oni)){
  tryCatch(
    {
      result_oni <- read_html(url_oni[i])
      youyaku_table <- result_oni %>% html_table(fill = TRUE)
      youyaku <- youyaku_table[[11]]$X3[27]
      name <- str_c("oni_youyaku_",card_num[i],".txt")
      write(youyaku, name)
      Sys.sleep(2)
    }
    , error = function(e){ERROR_num[i] <- 1
                        print(i)}
  )
}

これを回すと496件中105件、エラーしたことが分かった。
原因と対処法が思いつかない。どなたかご教授願いたいです。
代わりに、XMLパッケージのreadHTMLTable()を使ったら、なぜか分からないけど上手くいった。

for(i in 1:length(url_oni)){
      tab <- readHTMLTable(url_oni[i])[11] %>% as.data.frame()
      youyaku <- tab[27,3] %>% as.character()
      name <- str_c("oni_youyaku_",card_num[i],".txt")
      write(youyaku, name)
      Sys.sleep(2)
}

これで各データが入手できた。
全データを結合した文書データも作成しておく。

fnames <- dir(pattern=".txt") 
fnames_list <- as.list(fnames)
all_youyaku <- ""
for(file in fnames_list){
  all_youyaku <- str_c(all_youyaku,scan(file, what = "char", quiet = TRUE))
}
write(all_youyaku, "all_youyaku.txt")

分析

必要なライブラリーの読み込みをする。

library(RMeCab)
library(tidyverse)
library(stringr)
library(wordcloud)
library(tm)
library(topicmodels)
library(ldatuning)

頻度集計

オニ全体の特徴を掴むためにデータ全体で頻度集計。

oni_all_freq <- RMeCabFreq("oni_youyaku/all_youyaku.txt")
oni_all_freqD <- oni_all_freq[order(oni_all_freq$Freq, decreasing = TRUE),] %>% 
  as.data.frame()

自立語(動詞・形容詞・形容動詞)の頻度集計

oni_all_jiritu_freq <- oni_all_freqD %>% filter(Info2=="自立")
freq_dt <- oni_all_jiritu_freq %>% head(30) %>% as.data.frame() %>% select(Term,Freq) %>% t()
freq_dt
##      1      2      3      4      5      6      7      8      9       
## Term "する" "いう" "なる" "ある" "来る" "言う" "出る" "いる" "食べる"
## Freq "431"  "255"  "157"  "154"  " 85"  " 77"  " 69"  " 59"  " 58"   
##      10       11     12     13     14     15     16     17       18    
## Term "逃げる" "行く" "住む" "食う" "死ぬ" "入る" "作る" "入れる" "取る"
## Freq " 58"    " 44"  " 41"  " 41"  " 40"  " 40"  " 32"  " 31"    " 29" 
##      19     20     21     22     23     24     25     26     27    
## Term "見る" "ない" "殺す" "帰る" "聞く" "くる" "つく" "呼ぶ" "持つ"
## Freq " 27"  " 26"  " 24"  " 23"  " 23"  " 22"  " 22"  " 21"  " 21" 
##      28       29       30      
## Term "現れる" "さらう" "つける"
## Freq " 19"    " 18"    " 18"

名詞の頻度集計

oni_all_noun_freq <- oni_all_freqD %>% filter(Info1=="名詞")
freq_noun_dt <- oni_all_noun_freq %>% head(30) %>% as.data.frame() %>% select(Term,Freq) %>% t()
freq_noun_dt
##      1     2     3     4     5     6     7      8      9      10    
## Term "鬼"  "家"  "の"  "昔"  "人"  "日"  "退治" "こと" "よう" "節分"
## Freq "938" "100" "100" " 87" " 86" " 78" " 77"  " 75"  " 68"  " 64" 
##      11     12     13       14    15     16    17     18    19    20   
## Term "それ" "これ" "ところ" "男"  "とき" "夜"  "もの" "娘"  "人"  "時" 
## Freq " 60"  " 58"  " 57"    " 56" " 52"  " 52" " 51"  " 48" " 48" " 48"
##      21    22    23    24    25     26     27    28    29    30    
## Term "豆"  "山"  "目"  "月"  "ため" "正月" "首"  "石"  "姿"  "菖蒲"
## Freq " 47" " 46" " 46" " 42" " 40"  " 39"  " 37" " 34" " 33" " 31"

ワードクラウド

wordcloudで可視化

corpus_oni <- docDF("oni_youyaku/all_youyaku.txt", type = 1)

警告がめっちゃ出たけど、結果は出た。何の警告は調べず放置してしまいました。
ワードクラウドの出力は乱数で変わっていると思われる。

options(warn=-1)
corpus_oni <- corpus_oni %>% filter(POS1 == "名詞"&POS2=="一般"| POS2 == "自立") 
wordcloud(corpus_oni$TERM, corpus_oni$all_youyaku.txt, min.freq= 15, scale=c(15,0.5),
          family ="JP1", random.color=FALSE, color = rainbow(5))

options(warn=0)

トピックモデル

複数文書の読み込んで、文書ターム行列を作成する。

#フォルダのパス
dir_youyaku <- "oni_youyaku"
DTM <- docDF(dir_youyaku, type = 1)

名詞(一般)と動詞を抽出し、トピックモデルを実行する。

DTM_nouns_verbs <- DTM %>% filter( (POS1 == "名詞"&POS2 == "一般") | POS2 == "動詞" )%>% 
  select(-c(POS1,POS2)) %>% 
  data.frame(row.names = 1) %>% t() %>% 
  as.DocumentTermMatrix(weighting = weightTf)

トピック数を何パターンかやってみて、直感で決定した。

これも乱数依存の結果なので、第1ゲームと結果が異なる。(set.seed()しとくべきだった。)

#トピック数をkとする。
k <- 3
lda_result <- LDA(DTM_nouns_verbs,k)
terms(lda_result,10)

k <- 4
lda_result <- LDA(DTM_nouns_verbs,k)
terms(lda_result,10)

k <- 10
lda_result <- LDA(DTM_nouns_verbs,k)
topic10_nv <- terms(lda_result,10) %>% as.data.frame()

k <- 20
lda_result <- LDA(DTM_nouns_verbs,k)
topic_nv20 <- terms(lda_result,10) %>% as.data.frame()

k <- 30
lda_result <- LDA(DTM_nouns_verbs,k)
topic30_nv <- terms(lda_result,10) %>% as.data.frame()
k <- 30
lda_result <- LDA(DTM_nouns_verbs,k)
topic30_nv <- terms(lda_result,10) %>% as.data.frame()
topic30_nv
##     Topic 1 Topic 2 Topic 3 Topic 4 Topic 5 Topic 6  Topic 7 Topic 8
## 1        鬼      家      鬼      鬼      鬼      鬼       鬼      鬼
## 2        腕      鬼      橋    節分      剣    団子     神様    地蔵
## 3        綱      村      夫      頭      戸      土       山      爺
## 4      破風      宿      気    戸口      瘤      矢     場所      手
## 5        家      僧      妻      豆    人々    殿様       川    人形
## 6        姓      娘      神      柊      篩      足       弓      金
## 7      子孫      木    死体      月      手      背       嘘      赤
## 8  ケムダシ    旅人    弓矢      目      青  囲炉裏       涙      字
## 9      先祖    兄弟    鬼神      鰯    一つ    武士 お婆さん      銭
## 10       外    村人    悪鬼  イワシ      里      山       瓶    博打
##    Topic 9 Topic 10 Topic 11 Topic 12 Topic 13 Topic 14 Topic 15 Topic 16
## 1       鬼       月       鬼       鬼       鬼       鬼       男       目
## 2       血       鬼       人     菖蒲     地獄       女       鬼       鬼
## 3       灰       餅     行者       娘       人       火       姿       弟
## 4       弓     若者       島       蓬       田       釜       女       籠
## 5       山       図       竹     節句       地     山姥     地蔵       人
## 6     バラ       金     門松     節供     地名       家       池       姉
## 7       尻     神様       赤   ヨモギ     狂言       牛       木       心
## 8       矢       婆       妻     屋根     罪人     蜘蛛       塩       兄
## 9     ひと       宿       青       家       盆     馬方       馬   ススキ
## 10      土     餓鬼     正月       雨       寺       爺       尊     小僧
##    Topic 17 Topic 18 Topic 19   Topic 20 Topic 21 Topic 22 Topic 23
## 1        鬼       鬼       鬼         鬼       豆       鬼       鬼
## 2        酒     目玉     子供         芽     節分       森       首
## 3      童子       丸       山       上人       鬼       首       寺
## 4        呑       箒 お爺さん     神さま       子       木     村人
## 5        力       魔     集落 おじいさん       家       蛭       興
## 6      神社       姿       谷         牙       晩     里人     勅命
## 7        ヶ       箕       船         舟     川下       村       粥
## 8        首     人間     宝物         川       数       跡       念
## 9    ゾウリ ショウブ       髪     モグラ       年       下       天
## 10       坂     臭い       沖       息子     まき     比べ   オオモ
##    Topic 24 Topic 25 Topic 26 Topic 27 Topic 28 Topic 29 Topic 30
## 1        鬼       鬼       鬼       鬼       鬼       鬼       嫁
## 2        鶏       歯       石       人       年     正月       助
## 3    爺さん       穴       岩       娘       島       骨       鬼
## 4      鳴き       飯       跡       家       角       外       娘
## 5      正体       下       血       妹     怪物     部落     山鳥
## 6      女房       山     伝説       底       亥       福       尾
## 7        隣     鬼面       川       山     部落       内       矢
## 8      博打     柄杓       狐       籠     男子       松     土蔵
## 9        箕     様子        U       金       勘     節分     将軍
## 10       金   婆さん     主人     継母       由     家々     神酒

見えないモノを見ようとして

カレーの香ばしさとタバコの煙を乗せた、大航海時代を想起させる空気が、地下鉄に押し出された風に運ばれる。後楽園駅の改札のことだ。街によって匂い(臭い)は異なる。そんなにおいは、いくら視力が良くても感じることはできない。目に見えるものだけが存在してるわけじゃない。目に見えないものも存在してる。
見たことなくても、あると信じているものは意外に多い。たとえば、昼ドラの修羅場。昼ドラには、ドロドロの三角関係と修羅場が付き物だと思っているけれども、一度も、そういうドロドロを私は見たことがない。今もやっているのか知らないが、石原良純の天気予報も見たことない。良純の天気予報は当たらないって知っている(いや、知識があるというべきか)けれども、実際に良純の天気予報を見て、外れることを確認したことはない。死に際の走馬灯なんてものも経験したことがない。経験していないのに、存在する、もしくは事実であると思い込んでいる。これまた、少し古い話だが、デスブログがある。確認したわけじゃないけれども、面白がって信じている。何かを面白がる誰かがいて、それの形を変えて人に伝えて、それがまた拡散していく。そんな人の好奇心と不正確さこそが、確認なしに存在を信じる原因だろう。
フェイクニュースなんてドラマがあるらしい。見たことはないんだが、デマだとかフェイクニュースだとかがよく拡散される時代になったものだ(もちろん、昔からそういうのはあったのだが)。情報伝達の速度が飛躍的に上昇した現在、噂の伝達速度は音速を超えているだろう。多種多様で大量の、洪水のような情報を受けているのだから、すべての情報の正しさを確認している暇なんてなかろう。確認のための「ふるい」が必要そうだ。個人的には、その「ふるい」は自分の腑に落ちて信じることができるかどうかっていう疑いなんだけど、疑い続けるっていうのは結構、エネルギーを要するもので、疲れる。そんな面倒な作業をスキップするのが「信仰」とか「崇拝」なんじゃなかろうか。この人がおっしゃっているのだから、もしくは、我が神様がおっしゃっているのだから間違いないっていう省略を欲しがる人もいるだろう。威厳や貫禄、権威や正当性にすがりたいってのもよくわかる。それが楽だから。そういう省略を与えるのが「宗教」の一側面なんだろう。宗教を信仰するのは悪いことでもなんでもないけれど、「直面した問題が解けないから」といって、考えることをスキップして宗教に与えられるものを疑わずに受け入れてばかりいると、悲惨な結末に辿り着くかもしれないよって書いておく。(当の本人にとっては悲惨ではなく、救われて幸せなのかもしれないけど。)オウム真理教の信者にしても、いつだったかの占い師に心酔したオセロ中島にしても、自分で考えることを止めた結末がアレだったんじゃないかなって思う。

 

(2012年9月27日に書いたものを編集)