集合知プログラミング第２章を演習してみた
ピアソン関数
こんな感じの問題があるとします。
ある学校の生徒であるAさんとBさんがいます。 この二人の成績からどれぐらい似ているかを求めなさい。
ちょっと意味不明な問題ですが、こういう問いに答える方法の一つにピアソン関数が存在します。
この仕組みを利用すると両者が似ている場合は1に近い数値を返します。
逆に似ていない場合は0を返します。
以下、サンプルです
# lib/CI/Algorithm/Pearson.pm package CI::Algorithm::Pearson; use strict; use warnings; use List::Util qw/sum/; use List::MoreUtils qw/uniq/; use Carp (); ### 真似した ### http://d.hatena.ne.jp/rin1024/20090411/1239464111 sub calc { my ($class, $data1, $data2 ) = @_; ### local copy my %data1 = %{$data1}; my %data2 = %{$data2}; ### 互いの共通アイテムを抽出 my %seen; my @items = grep { $seen{$_}++ } (keys %data1, keys %data2); Carp::croak "not found common item..." unless scalar @items; ### 合計点を求める my $sum1 = sum map { $data1{$_} } @items; my $sum2 = sum map { $data2{$_} } @items; ### 平方を合計する。 my $sum1Sq = sum map { $data1{$_} ** 2 } @items; my $sum2Sq = sum map { $data2{$_} ** 2 } @items; ### 積を合計 my $pSum = sum map { ( $data1{$_} ) * ( $data2{$_} ) } @items; ### スコア計算 my $n = @items; my $num = $pSum - ( $sum1 * $sum2 / $n ); my $den = sqrt ( ( $sum1Sq - ( $sum1 * $sum1 ) / $n ) * ( $sum2Sq - ( $sum2 * $sum2 ) / $n ) ); if ( $den == 0 ) { Carp::croak 'calc result is 0'; } return $num / $den; # more than -1, less than 1 } 1;
# script/sample.pl #!/usr/bin/env perl use strict; use warnings; use lib 'lib'; use CI::Algorithm::Pearson; use Perl6::Say; my %score_of = ( suzuki => { japanese => 50, math => 70, english => 80, }, sato => { japanese => 55, math => 75, english => 100, }, yamada => { japanese => 100, math => 80, english => 80, }, tanaka => { science => 50, japanese => 50, math => 40, english => 40, }, ); my $result; say "suzuki & sato"; say $result = CI::Algorithm::Pearson->calc($score_of{suzuki},$score_of{sato}); say; say "suzuki & yamada"; say $result = CI::Algorithm::Pearson->calc($score_of{suzuki},$score_of{yamada}); say; say "yamada & tanaka"; say $result = CI::Algorithm::Pearson->calc($score_of{yamada},$score_of{tanaka});
結果
suzuki & sato 0.967867836991654 suzuki & yamada -0.944911182523063 yamada & tanaka 1
鈴木さんと佐藤さんはほぼ似ています
鈴木さんと山田さんはほぼ似ていません
山田さんと田中さんは似ているどころか一致しています
このピアソン関数の仕組みですが、興味ある方はぜひご自身で調べてみて下さい。ここではスルーします。
第２章の演習問題をやってみて思った事はピアソン関数に渡す引数、つまりデータセットをどのようにして用意するか、だと思います。
データセットを準備
書籍ではdeliciousを例にしていましたが、私はYoutubeAPIを利用します。
要件
自分で考えた問題は次のとおりです。
- ある動画を見ているユーザーを抽出して、その2者がどれぐらい似ているかを求める。
- その動画を見ているユーザーは似ている確率が高い
- まったく関係ないユーザーは似ていない確率が高い
仕様
この要件を満たす仕様は次のようにしました
- ある動画にコメントしているユーザーはその動画を見ている
- コメントしているユーザーがお気に入りに登録している動画を抽出
- 動画にはキーワードが登録されているのでそれらを抽出
- これらのキーワードをカウントしていきデータセットを作成
- ピアソン関数で類似度を調べる
やってみた
# script/comparing.pl #!/usr/bin/env perl use strict; use warnings; use lib 'lib'; use CI::Youtube::Entry; use CI::Algorithm::Pearson; use List::Util qw/shuffle/; use Data::Dumper; local $Data::Dumper::Maxdepth = 2; ### お気に入りの動画 my @video_ids = qw/_Z9q7yun6A4/; ### コメントを書いたユーザーは、これらの動画に対して関心を示していると判断 ### 無作為にこのユーザーを選出。このユーザーの類似度は高いと予想 my ( $user1_id, $user2_id ) = shuffle map { $_->{author}->[0]->{name}->{'$t'} } map { CI::Youtube::Entry->search_comments_to($_) } @video_ids; ### あまり関連のないユーザーを適当にピックアップ my $user3_id = 'HektikVImpakt'; ### データセットを作成 my %prefs; for my $user_id ( $user1_id, $user2_id, $user3_id ) { ### お気に入りfeedに動画のキーワードがカンマ区切り ### で格納されているので、それを取り出してノーマライズ my %count_of; $count_of{$_}++ for map { normalize($_) } grep { match_valid($_) } map { split ', ', $_->{'media$group'}->{'media$keywords'}->{'$t'} } CI::Youtube::Entry->search_favorites_of($user_id); $prefs{$user_id} = {%count_of}; } warn Dumper {%prefs}; compare($user1_id, $user2_id); compare($user2_id, $user3_id); compare($user3_id, $user1_id); sub compare { my ( $user1, $user2 ) = @_; my $result = CI::Algorithm::Pearson->calc($prefs{$user1}, $prefs{$user2}); warn "$user1 & $user2"; warn "result : $result\n"; } sub match_valid { $_[0] =~ m/^\d+$/ ? undef : $_[0]; } sub normalize { $_[0] =~ s/[-_]//g; return $_[0]; }
実行結果
iTwiceX & CwalkerLilXveemon1 at script/comparing.pl line 53. result : 0.815893463497082 CwalkerLilXveemon1 & HektikVImpakt at script/comparing.pl line 53. result : 0.25290655887993 HektikVImpakt & iTwiceX at script/comparing.pl line 53. result : 0.317777559302263
ユーザーを無作為に選んでいるのでたまにお気に入り動画の少ないユーザーを選ぶと処理がこけたりしますが
まずます期待している数値がでてきました。
何ができるようになったのか
ここでユーザーAとユーザーBが似ているかどうかを判定する事ができました。
このユーザーAの情報を自分自身に置き換える事ができます。
計算時間はさておき、私が興味のある動画を見ている、私に似たユーザーが、ほかにもお気に入りに登録している動画を推薦する事ができます*1。
でもケッコウメンドウクサイ
実は最初は期待した数値がでなくてこまりました。
データを調べてみると同じ意味を表す単語がハイフンで区切られたり、2008, 2009といった
あまり無関係な数字をキーワードに含まれていました。
これらを除外すると数値が期待している通りになりました。
このように日々変化するデータを見守る作業が必要です。
また、その演算結果が正しいかどうかは開発者のみでは判断できないので、定期的なレビューが必要になると思います。
第3章では大量にデータが存在する場合に対してどのような対策を行うのか、といったクラスターの概念が紹介されています。
興味のある方はぜひ
ソースコード
CI::Youtube::Entryを忘れていた
package CI::Youtube::Entry; use strict; use warnings; use Cache::FileCache; use WebService::Simple; use URI; use JSON (); use Data::Dumper; local $Data::Dumper::Maxdepth = 3; sub lookup_video { my ( $class, $video_id ) = @_; my $uri = URI->new("http://gdata.youtube.com/feeds/api/videos/$video_id"); $class->_lookup_entry($uri); } sub search_favorites_of { my ( $class, $user_id ) = @_; my $uri = URI->new("http://gdata.youtube.com/feeds/api/users/$user_id/favorites"); $class->_search_entries($uri); } sub search_comments_to { my ( $class, $video_id ) = @_; my $uri = URI->new("http://gdata.youtube.com/feeds/api/videos/$video_id/comments"); $class->_search_entries($uri); } sub _lookup_entry { my ( $class, $uri ) = @_; $uri->query_form( v => 2, alt => 'json' ); my $data = $class->_get_data_from($uri) or return; $data->{entry}; } sub _search_entries { my ( $class, $uri ) = @_; my $start_index = 1; my $max_results = 25; $uri->query_form( v => 2, alt => 'json', 'start-index' => $start_index, 'max-results' => $max_results, ); ### 1ページ目 my $data = $class->_get_data_from($uri); my $total = $data->{feed}->{'openSearch$totalResults'}->{'$t'} || 0; $total = $total > 500 ? 500 : $total; return unless $total; my $entry = $data->{feed}->{entry} or die; my @entries = _to_array($entry); ### 2ページ目以降 while ( $start_index < $total ) { $uri->query_form( v => 2, alt => 'json', 'start-index' => $start_index, 'max-results' => $max_results, ); my $data = $class->_get_data_from($uri); my $entry = $data->{feed}->{entry} or die; push @entries, _to_array( $entry ); $start_index += $max_results; } return @entries; } sub _get_data_from { my ( $class, $uri ) = @_; my $cache = Cache::FileCache->new( { namespace => 'MyNamespace', default_expires_in => 24 * 60 * 60, } ); ### キャッシュ機能使いたい my $ws = WebService::Simple->new( base_url => $uri, cache => $cache, # こうじゃなかったっけ？動かないのでParseは自分でしておく # response_parser => 'JSON', ); my $response = eval { $ws->get }; if ( $@ ) { warn $@; return; } my $content = $response->decoded_content; return JSON::decode_json($content); } sub _to_array { ref $_[0] eq 'ARRAY' ? @{$_[0]} : $_[0]; } sub _to_arrayref { ref $_[0] eq 'ARRAY' ? $_[0] : [$_[0]]; } sub _match_comment_id { $_[0] =~ m/comment:(\w+)$/ ? $1 : undef; } sub _match_video_id { $_[0] =~ m/video:(\w+)$/ ? $1 : undef; } 1;
