サイトの言語を判定する perl script

とあるサービスを作るために必要となったのがサイトの言語判定。まぁもう少しわかりやすく言うと、多言語サイトを対象としてクロールすることを考えたりすると、そのサイトがどんな言語で記述されているかを把握しておく必要があるってわけです。

でもって CPAN でモジュールをあさって見るも、日本語や中国語のような全角系？2byte 系？の言語に対応した判定器がないわけです。

• Lingua::Identify
• Text::Language::Guess
• Text::Ngram::LanguageDetermine

そんな中で見つけたのが Lingua::LanguageGuesser というモジュールです。CPAN には登録されていませんが、東京大学情報基盤センター中川研究室で公開されている専門用語（キーワード）自動抽出サービス「言選Web」で用いられている言語判定器です。

では実際にサンプルスクリプトを用意して実験をしてみます。コマンドラインから URL の引数を受け取ってコンテンツを取得し、html タグなどを除去した後に、先頭から 1000 文字で言語判定を行うスクリプトです。

use Lingua::LanguageGuesser;
use LWP::Simple;
use Encode;
use strict;
use warnings;

my $url  = $ARGV[0] || 'http://www.yahoo.jp/';
my $html = get($url);
my $text = substr tag_cleaning($html), 0, 1000;
my $code = guesser($text);
print "code = $code\n";

sub tag_cleaning {
    my $html = shift;
    $html =~ s{<!-.*?->}{}xmsg;
    $html =~ s{<script[^>]*>.*?<\/script>}{}xmgs;
    $html =~ s{<style[^>]*>.*?<\/style>}{}xmgs;
    $html =~ s{<.*?>}{}xmsg;
    $html =~ s{ }{ }xmg;
    $html =~ s{"}{\'}xmg;
    $html =~ s{\r\n}{\n}xmg;
    $html =~ s{^\s*(.+)$}{$1}xmg;
    $html =~ s{^\t*(.+)$}{$1}xmg;
    $html;
}

sub guesser {
    my $str = shift;
    my $guesser = Lingua::LanguageGuesser->guess( { utf8 => 'auto', MaxLine => 1000 }, $str );
    my $lang = 'undefined';
    eval { $lang = lc( $guesser->best_scoring ); };
    if ($@) {
        warn "error:$@\n";
    }
    return $lang;
}

1;

実行結果はこんな感じです。この例はうまくいくように調整した例なのですが、正直言っていろいろ試験をしてみると 2byte 系の文字はそれなりの判定精度だと感じるのですが、肝心の ascii 系？の言語の判定精度はイマイチだと感じてしまう結果が多いです。中でもキモになるのは、上記スクリプトのタグ除去 tag_cleaning 関数の部分です。タグが混在していると非常に不安定な結果になってしまいます。

もっともこのモジュールは教師データを与えることで精度を向上させることができ、create_model.pl などのツールも用意されているので、自前で頑張り抜くことも可能です。

まぁもっとも Lingua::LanguageGuesser をいろいろ貪った後で気がついた方法がありまして、Google Translate API を使う方法がありました。正直言って Google クオリティがある意味保証されているので安心感のある実装方法です。唯一の難点は API をたたいているので、レイテンシが多少あることと、何故か 270 文字をクエリとして渡せない点でしょうか。ここでは安全を見て 200 文字を渡すようにしています。

use LWP::Simple;
use WebService::Simple;
use Encode;
use strict;
use warnings;

my $url         = $ARGV[0] || 'http://www.yahoo.jp/';
my $html        = get($url);
my $text        = substr tag_cleaning($html), 0, 200;
my $googletrans = WebService::Simple->new(
    base_url        => 'http://ajax.googleapis.com/ajax/services/',
    response_parser => 'JSON',
    params          => { v => '1.0' },
);

my $response = $googletrans->get( "language/detect", { "q" => $text } );
my $srclang  = $response->parse_response->{responseData}->{language};
my $dstlang  = 'ja';
print "$srclang\n";

sub tag_cleaning {
    my $html = shift;
    $html =~ s{<!-.*?->}{}xmsg;
    $html =~ s{<script[^>]*>.*?<\/script>}{}xmgs;
    $html =~ s{<style[^>]*>.*?<\/style>}{}xmgs;
    $html =~ s{<.*?>}{}xmsg;
    $html =~ s{ }{ }xmg;
    $html =~ s{"}{\'}xmg;
    $html =~ s{\r\n}{\n}xmg;
    $html =~ s{^\s*(.+)$}{$1}xmg;
    $html =~ s{^\t*(.+)$}{$1}xmg;
    $html;
}

1;

こちらのスクリプトの実行結果です。実行精度はかなり良いと感じる一方でレイテンシは本当に気になります。場合によっては判定に数秒かかるときもあります。

というわけで、実サービスで使うとしたら実行速度を要する場合には Lingua::LanguageGuesser を用い、遅くても良いから精度を求める場合には Google Translate API を使うと良いのではないでしょうか。