芸能人の相関関係を探ってみるスクリプト
ちょっとした実験をしてみました。芸能人の相関関係を機械的に探索してみます。
具体的には「○○というタレントと関係が深い芸能人は？」といった、芸能人にフォーカスした類似検索みたいな実験です。
技術的には「潜在的意味インデキシング」（Latent Semantic Indexing）といった手法を使います。
これは普通は自然言語処理の世界で使われるテクニックですが、なにも言語だけでなく他のデータ素材でも面白い結果が得られるかもしれないので、やってみようという試みです。
以下に大まかな手順をまとめます。
- wikipedia から有名人のリストを抽出
- それらの有名人リストについて、一人ずつ「誰と関連が深いか」を集計。具体的には有名人個々のwikipediaのページ中に、先ほど抽出しておいた人名リストとマッチする人名がどれだけ掲載されているかをピックアップしていきます。
- 上記の方法で有名人の間の相関を表す共起行列を生成する。
- 生成した共起行列に対して次元圧縮の処理をかける
- 出来上がったデータセットに対して、適当なタレントの名前で近傍検索を実施。関係が深い有名人を数名ずつリストアップ
こんな感じです。以下、具体的に書いていきます。
STEP-1: wikipediaから有名人のリスト抽出
wikipediaの男性タレント のような芸能人をリストしているページから人名リンク部分の文字列を抽出します。今回の対象は男性タレント、女性タレント、グラビアアイドルに絞っています。
スクリプトは以下のとおり。ベタに正規表現で引っこ抜いてます。
use strict; use LWP::UserAgent; use List::MoreUtils qw(uniq); my $base_url = 'http://ja.wikipedia.org/wiki/'; my @names; my $ua = LWP::UserAgent->new; for my $label ( qw( 男性タレント 女性タレント グラビアアイドル一覧 )) { my $url = $base_url . $label; my $req = HTTP::Request->new( GET => $url ); my $res = $ua->request($req); my $content = $res->content; my @matches = $content =~ /<li><a href="[^\"]+" title="([^\"]+)">[^<]+<\/a><\/li>/g; for (@matches) { next if $_ =~ /一覧/; next if $_ eq '俳優'; # noise push @names, $_; } } # uniq化 @names = uniq sort @names; # ファイル出力 open my $fh, "+>", "names" or die "names : $!"; print $fh join( "\n", @names ); close $fh;
「一覧」とか「俳優」とかの文字列が出てきてますが、ノイズ除去です。AdHocなコードなんでここら辺は気にしないでください。
うまくいくと「names」という名前のテキストファイルが出力されます。中身は有名人の名前リストになっています。1300人弱ぐらいのリストです。
このリストを使って次のステップに進みます。
STEP-2: 個々のページから人名リンク部分を抽出する（ための準備運動）
先ほど作ったnamesという人名リストですが、今度はこれらの人名にページについて個々にwikipediaからfetchしていき、その中からリストに載っている人名をピックアップしていきます。
ですがその前に準備運動をします。
こういった「リストに対するリストのマッチング処理」をなにも考えずに書くとループ内ループになってしまってとても遅いので、TRIEなデータ構造を作ってから一気に抽出処理を行いたいと思います。
TRIEなデータ構造といえば、以前にこのブログでも紹介したDartsが有名です。Dartsはめちゃめちゃパワフルなツールです。（もともとはMeCabの処理のベース部分）
しかし、今回はデータ数も少ないことだし、Dartsを使うのもちょっと大げさに思います。
そこでperlだけで簡単にTRIEな処理できないかな、と思って探していたら、弾さんがずいぶん前にmk_trie_regexp.plというコードを公開されてました。リストを引数で渡すとTRIE化された正規表現を生成してくれる、といったものでした。
おお、まさにそのまんまです！なので今回はこれを丸々使わせていただきました。コードは弾さんのブログを参照してください。
このスクリプトをコピッてきてnamesを引数にして実行すると、あっという間にnames.rxというファイルができあがりました。中をのぞくとバイナリ化された正規表現の塊が。。。
いまさらながらid:dankogai SUGEEEと思いました。まる。
STEP-3: 個々のページからの人名抽出（共起行列の作成）
さて、STEP1で作った人名リスト（names）とSTEP2で作ったTRIE化された正規表現ファイル（names.rx）を使って、実際に個々のページを取得しながら人名部分を引っこ抜いていきます。
それと同時に共起マトリックスを作っていきます。
共起マトリックスについては拙作のStatistics::Associationsというモジュールを使うと間単です。これはもともとは連関係数を算出するためのモノなんですが、処理の途中で共起マトリックスを生成するメソッドがあるので、今回はそれを使っています。
use strict; use warnings; use LWP::UserAgent; use HTML::TreeBuilder; use Statistics::Associations; use Storable qw(nstore); # trieな正規表現をロード my $regexp = do "names.rx"; # もろもろ準備 my $base_url = 'http://ja.wikipedia.org/wiki/'; my $ua = LWP::UserAgent->new; my $asso = Statistics::Associations->new; my @label; # 人名リストを開いて1件ずつ処理 open my $fh, "<", "names" or die $!; while ( my $name = <$fh> ) { chomp $name; # wikipediaからデータ取得 my $url = $base_url . $name; my $req = HTTP::Request->new( GET => $url ); my $res = $ua->request($req); my $content = $res->content; # TRIE-Regexpでマッチする人物を探す my $tree = HTML::TreeBuilder->new; $tree->parse($content); $tree->eof(); my @hits = (); for my $tag ( $tree->find('a') ) { my $text = $tag->as_text; if ( my @hit = $text =~ /$regexp/g ) { @hits = ( @hits, @hit ); } } # 自分含めて5人以上のヒットがない場合は足きり my $cnt = 0; for (@hits) { $cnt++ if $_ ne $name; } next if $cnt < 5; # 共起行列化する for (@hits) { print "$name\t=>\t$_\n"; $asso->make_matrix( $name => $_ ); } # ラベル用変数 push @label, $name; } close $fh; # 行列データとラベルをセットにしてシリアライズ my $matrix = $asso->matrix; my $save_data = { label => \@label, matrix => $matrix, }; nstore( $save_data, "matrix.bin" );
うまく動くと「matrix.bin」というStorableのファイルが生成されます。
STEP-4: 次元圧縮処理
さて今出来上がったmatrix.binですが、これはこれで個々の有名人の特徴ベクトルとして使える形にはなっています。
が、次元数がやや高いので処理に時間がかかるし、あとノイズと思わしきデータを多分に含んでいる（と思う）ので、次元圧縮の処理をかけてあげます。
次元圧縮の方法は色々あるようですが、潜在的意味インデキシングということでSVD（特異値分解）による圧縮処理をかけます。これに使うモジュールはAlgorithm::DimReductionです。これまた拙作のいい加減なモジュールなんですが、ちゃんと動くのかどうかの検証も含めて（？）使ってみます。
use strict; use warnings; use Storable qw(retrieve nstore); use Algorithm::DimReduction; # データ復元 my $data = retrieve("matrix.bin"); my $label = $data->{label}; my $matrix = $data->{matrix}; # 次元圧縮 my $reductor = Algorithm::DimReduction->new; my $result = $reductor->analyze($matrix); my $reduced_matrix = $reductor->reduce( $result, 100 ); # ラベルとベクトルを key => value にしてシリアライズしておく my $tarent_vector; for my $i ( 0 .. @$label - 1 ) { my $name = $label->[$i]; my $vec = $reduced_matrix->[$i]; $tarent_vector->{$name} = $vec; } nstore( $tarent_vector, "tarent_vector.bin" );
この実験では元データが800次元程度だったんですが、それを100次元に圧縮しています。
出力は「tarent_vector.bin」です。これもStorableでシリアライズされたものです。
STEP-5: 近傍検索
さて最後のステップです。
STEP-5で出来上がった「tarent_vector.bin」を使って実際に近傍を探すようなスクリプトを準備します。標準入力から人名を入れるとその人物と関係が深い人（距離が近い人）を10人返すようなスクリプトです。
use strict; use warnings; use Data::Dumper; use Storable qw(retrieve); # データ復元 my $featured_vector = retrieve("tarent_vector.bin"); # 標準入力からのデータ取得 print "INPUT NAME : "; my $query = <>; chomp $query; my $query_vec = $featured_vector->{$query}; # 近傍検索 my @sorted = sort { $a->{dist} <=> $b->{dist} } map { my $name = $_; my $vec = $featured_vector->{$name}; my $dist = distance( $query_vec, $vec ); { name => $name, dist => $dist } } keys %$featured_vector; # 上位10件を表示 for ( 1 .. 10 ) { print Dumper shift @sorted; } # ユークリッド距離を計算する関数 sub distance { my $vector_1 = shift; my $vector_2 = shift; my $sum; for my $i ( 0 .. @{$vector_1} - 1 ) { my $d = ( $vector_1->[$i] - $vector_2->[$i] )**2; $sum += $d; } my $distance = sqrt($sum); return $distance; }
近傍検索のところがちょっとトリッキーな書き方になってますが、よく見れば何てことはない、ごく普通のコードです。
距離の測定はユークリッド距離です。
実際に試してみる
さて、それでは何件か実験してみましょう。
[miki@vmware whozwho]$ perl step_5_centroid.pl
INPUT NAME : ビートたけし
$VAR1 = {
'name' => 'ビートたけし',
'dist' => 0
};
$VAR1 = {
'name' => '井手らっきょ',
'dist' => '1.9061323976382'
};
$VAR1 = {
'name' => '東国原英夫',
'dist' => '2.30227192019011'
};
$VAR1 = {
'name' => 'ガダルカナル・タカ',
'dist' => '2.40693419368856'
};
$VAR1 = {
'name' => 'ビートキヨシ',
'dist' => '2.41870098542485'
};
$VAR1 = {
'name' => 'つまみ枝豆',
'dist' => '2.54338970233499'
};
$VAR1 = {
'name' => '玉袋筋太郎',
'dist' => '2.57038842432254'
};
$VAR1 = {
'name' => '北野大',
'dist' => '2.67351055471085'
};
$VAR1 = {
'name' => '山本モナ',
'dist' => '2.67434755684951'
};
$VAR1 = {
'name' => 'ラッシャー板前',
'dist' => '2.7245071250756'
};おお、いい線いってるじゃないですか！！
じゃ、次はらっきょ行ってみよう！
[miki@vmware whozwho]$ perl step_5_centroid.pl
INPUT NAME : 井手らっきょ
$VAR1 = {
'name' => '井手らっきょ',
'dist' => 0
};
$VAR1 = {
'name' => 'ビートキヨシ',
'dist' => '0.689638969337497'
};
$VAR1 = {
'name' => 'つまみ枝豆',
'dist' => '0.818146150220101'
};
$VAR1 = {
'name' => '玉袋筋太郎',
'dist' => '0.863749924728016'
};
$VAR1 = {
'name' => 'ガダルカナル・タカ',
'dist' => '0.923247859751'
};
$VAR1 = {
'name' => 'ラッシャー板前',
'dist' => '0.989808012671323'
};
$VAR1 = {
'name' => '東国原英夫',
'dist' => '1.01993545987287'
};
$VAR1 = {
'name' => '春一番 (お笑い)',
'dist' => '1.05874201697919'
};
$VAR1 = {
'name' => 'チャーリー浜',
'dist' => '1.06280045719736'
};
$VAR1 = {
'name' => '水道橋博士',
'dist' => '1.11981167428265'
};
[miki@vmware whozwho]$なんと、らっきょの検索結果にビートたけしが入っていない！
ビートたけしからはらっきょは近いけど、らっきょからはビートたけしへの距離は遠いんですね。
うーん、師弟関係の奥の深さがうかがえる・・・。（偶然？）
[miki@vmware whozwho]$ perl step_5_centroid.pl
INPUT NAME : タモリ
$VAR1 = {
'name' => 'タモリ',
'dist' => 0
};
$VAR1 = {
'name' => '大橋巨泉',
'dist' => '5.00525742176527'
};
$VAR1 = {
'name' => '関根勤',
'dist' => '5.64037484635444'
};
$VAR1 = {
'name' => '所ジョージ',
'dist' => '5.68146498788863'
};
$VAR1 = {
'name' => '明石家さんま',
'dist' => '5.96540354148207'
};
$VAR1 = {
'name' => '柴田理恵',
'dist' => '6.65945190896995'
};
$VAR1 = {
'name' => '半田健人',
'dist' => '6.6868712823848'
};
$VAR1 = {
'name' => '川合俊一',
'dist' => '6.78903333621352'
};
$VAR1 = {
'name' => '長州小力',
'dist' => '6.79958261996373'
};
$VAR1 = {
'name' => 'デーモン小暮閣下',
'dist' => '6.80311441857469'
};
[miki@vmware whozwho]$うーん、これはなんとなく微妙ですね。タモリは色々な人と相関がありすぎるのかな。微妙。。
[miki@vmware whozwho]$ perl step__centroid.pl
INPUT NAME : 和田アキ子
$VAR1 = {
'name' => '和田アキ子',
'dist' => 0
};
$VAR1 = {
'name' => 'インリン・オブ・ジョイトイ',
'dist' => '1.40438463099543'
};
$VAR1 = {
'name' => '島崎和歌子',
'dist' => '1.4122884072746'
};
$VAR1 = {
'name' => '峰竜太',
'dist' => '1.43517105833613'
};
$VAR1 = {
'name' => '氷川きよし',
'dist' => '1.48279977906097'
};
$VAR1 = {
'name' => '関暁夫',
'dist' => '1.49967896729671'
};
$VAR1 = {
'name' => '柴田理恵',
'dist' => '1.51279104834421'
};
$VAR1 = {
'name' => '賀集利樹',
'dist' => '1.51950846327352'
};
$VAR1 = {
'name' => '梅宮辰夫',
'dist' => '1.53054365138177'
};
$VAR1 = {
'name' => 'デーブ・スペクター',
'dist' => '1.54233130881912'
};
[miki@vmware whozwho]$これまた微妙だぁぁ。峰竜太が入ってきてるのは納得できるけど、島崎和歌子ってどうなんだろ。
と思ったら、wikipediaの島崎和歌子のページにこんな記述が。
酒癖は悪く、朝になっても飲み続ける、飲む相手を帰さないなどのエピソードからアッコさん（和田アキ子）になぞらえて「ワッコさん」と呼ばれる（命名は松本人志。ダウンタウンDXにて）。
ワッコさんか。だとしたらアリだな ww
じゃ志村先生だとどうだ？
[miki@vmware whozwho]$ perl step_5_centroid.pl
INPUT NAME : 志村けん
$VAR1 = {
'name' => '志村けん',
'dist' => 0
};
$VAR1 = {
'name' => '加藤茶',
'dist' => '4.38397227638264'
};
$VAR1 = {
'name' => '桑野信義',
'dist' => '4.5991117174137'
};
$VAR1 = {
'name' => '吉幾三',
'dist' => '4.900687314867'
};
$VAR1 = {
'name' => '優香',
'dist' => '4.91630134175693'
};
$VAR1 = {
'name' => '渡辺美奈代',
'dist' => '4.93132675684924'
};
$VAR1 = {
'name' => '肥後克広',
'dist' => '4.95427861702032'
};
$VAR1 = {
'name' => '上島竜兵',
'dist' => '4.99335760504688'
};
$VAR1 = {
'name' => '仲本工事',
'dist' => '5.02296088718064'
};
$VAR1 = {
'name' => '小林恵美',
'dist' => '5.07556815865209'
};
[miki@vmware whozwho]$おお！良いんじゃないでしょうか？
だいたいオッケーです！！
まとめ
キリがないのでここらでまとめます。
有名人で潜在的意味インデキシング実験、なんとなく雰囲気は出せたみたいです。
元データがwikipediaということもあり、人物によって記事内容の濃さがだいぶ異なるので、うまくいく時もありますが、まるっきし駄目なケースもあります。
正直いうと、ここで掲載した事例はどれもまぁまぁ上手くいったケースばかりです。もうちょっと無名な人（というと失礼ですが）でためすとデタラメな結果になります。
おそらく大物タレントやその周辺の人々（取り巻き？）はwikipediaにおいても情報が充実しているので、ベクトル空間上もわかりやすい位置関係にマッピングされるけど、そうでない人々はやはり情報量が少ないのかな、と思います。
ということは、「情報の充実度」を考慮して、もう少し全体のデータを平準化させるような条件を色々設定して共起行列を作ってあげれば良いかもしれません。どうすれば良いかは、ぱっとは思いつきませんが。。
ま、結論としては「人名」という単語の共起だけですべてが語りつくせてしまうほど、人間の関係性ってのは単純じゃないけども、でも少しだけなら相関関係の片鱗が見えるぞ、といったところでしょうか？
というわけで、実験レポートでした。
