Perlでベイジアンフィルタ
Perlでシンプルなベイジアンフィルタを作ってみました。ベイジアンフィルタ を倣って、ベイズ確率で歌詞を見分けるフィルタです。
アルゴリズムは ベイジアンフィルタについて のPaul Graham版そのまんまです。トークンはスペースで区切るのみですので日本語の歌詞では使えません。英単語のstem化もしていません。（レポート用に作ったのでちょっと手抜きですいません。）
実験してみると、一応動きました。学習させたのは、カーペンターズの歌詞とメタリカの歌詞ｗ。曲数がそこそこあって、個性の離れているアーティスト2組を適当に選んだだけ。メタリカをスパムとして、学習には100曲ずつ使い、学習に使わなかった曲で実験しました。結果は、
誤認識が多いですが、曲によって歌詞の内容もまちまちなのでそんなものなのかな。
use strict; use warnings; use utf8; use Data::Dumper; binmode STDOUT, ":encoding(shiftjis)"; my ($badfile, $goodfile) = ("lyrics/bad.dat", "lyrics/good.dat"); # shiftjisで入力 my ($nbad, $ngood, %b, %g); # 学習 &readfile($badfile, \$nbad, \%b); &readfile($goodfile, \$ngood, \%g); # 判別対象ファイルの読み込み <STDIN> my $count = 0; print "baysian[$count]>"; while (my $line = <STDIN>) { chomp($line); $line =~ s/[\.,]//g; # . ,を削除 last if $line eq ""; my $result = &comp($line); print "score: $result->{score}\n\n"; my @a = @{$result->{pw}}; for (my $i=0; $i<=$#a; $i++) { print "pw: $a[$i]->{p}\t, w: $a[$i]->{w}\n"; last if $i>=15; } print "baysian[".++$count."]>"; } exit(0); sub comp { # 確率計算 # Paul Graham 方式 my $line = shift; chomp($line); my @words = split(/ /, $line); my @pw; # 確率 foreach my $w (sort @words) { next if ($#pw>-1 && $w eq $pw[-1]->{w}); # 重複を省く my $p; if ($b{$w} || $g{$w}) { unless ($b{$w}) { $b{$w} = 0; } unless ($g{$w}) { $g{$w} = 0; } $p = ( $b{$w}/$nbad ) / ( ( 2 * $g{$w}/$ngood ) + ( $b{$w}/$nbad ) ); if ($p < 0.01) { $p=0.01; } elsif ($p > 0.99) { $p=0.99; } } else { $p = 0.4; # no data } push (@pw, { 'w' => $w, 'p' => $p}); } # 0.5 から離れたもの15個を選ぶ @pw = sort { abs(0.5 - $b->{'p'}) <=> abs(0.5 - $a->{'p'}) } @pw; # print Dumper(@pw); # 複合確率 my ($count, $multi1, $multi2) = (0, 1, 1); foreach my $w(@pw) { last if (++$count > 15); $multi1 *= $w->{p}; $multi2 *= (1-$w->{p}); } my $score = $multi1 / ($multi1 + $multi2); my $result = { score => $score, pw => \@pw, }; return $result; } sub readfile { my ($file, $count, $w) = @_; open my $fh, "<:encoding(shiftjis)", $file or die "Can't open file $file: $!"; while (my $line = <$fh>) { # 1行1ドキュメント chomp($line); $line =~ s/[\.,]//g; # . ,を削除 my @words = split(/ /, $line); # スペース区切りでトークン化 my %wc; foreach (@words) { $wc{$_} = 1; } foreach (sort keys %wc) { $$w{$_} += 1; } $$count++; } if ($$count <= 0) { die "invalid file $file"; } close($fh); }
ちなみに
