たつをの ChangeLog

68 件 見つかりました。

1 2 3 4 5 6 7 8 9 10 11 12 13 14 [ 次へ ]

「テキストから辞書にある文字列をすべて取り出す簡単なプログラム (Pure Perl)」[2014-05-09-1]の話の続きです。事情により Pure Perl で書きましたが、今回は SUFARY.pm (suffix arrays) を使ったバージョン。suffix arrays による擬似 TRIE です。

結論から言うと、手元の実験環境においては Pure Perl 版よりも 3.5 倍も時間がかかっています。実装がアレなのかもしれませんが、まあたいていの場合は Pure Perl 版で OK ということで。

■実験:
- 辞書とテキスト
-- 辞書:2万3千エントリ(平均文字列長4)
-- テキスト:2500行(平均文字列長71)
- 実行速度(3回平均)
-- Pure Perl 版:2.3秒
-- SUFARY.pm 版:8.2秒

■コード (fesa.pl):
#!/usr/bin/perl
use strict;
use warnings;
use Encode;
use utf8;
use open ':utf8';
binmode STDIN, ':utf8';
binmode STDOUT, ':utf8';

use SUFARY;

use Getopt::Long;
my $answer_mode = 0; # input with answer?
my $debug_mode = 0;
GetOptions (
    "answer" => \$answer_mode,
    'debug' => \$debug_mode,
    );

my $wordset_fn = shift;
my $sa = SUFARY->new($wordset_fn);

while (<>) {
    print "[INPUT] $_" if $debug_mode;
    chomp;
    $_ = Encode::decode_utf8($_) if not utf8::is_utf8($_);
    my $ans = ($_ =~ s/^((.+?)\t)//) ? $2 : ""  if $answer_mode;

    my @c = split(//, $_);
    my %m;
    for (my $i = 0; $i < @c; $i++) {
        my $key;
	my ($left, $right) = (0, $sa->{'arraysize'}-1);
        for (my $j = $i; $j < @c; $j++) {
            $key .= $c[$j];
            my $ekey = Encode::encode('utf8', $key);
            ($left, $right) = $sa->range_search($ekey, $left, $right);
            last if not defined $left and not defined $right;
            my ($l, $r) = $sa->range_search($ekey."\t", $left, $right);
            next if not defined $left and not defined $right;
            if ($r - $l >= 0) {
                my $li = $sa->get_position($l);
                my $s = Encode::decode_utf8($sa->get_line($li));
                my ($k, $v) = $s =~ /^(.+)\t(.+)$/;
                print "[MATCH] $k ($v)\n" if $debug_mode;
                $m{$v}++;
            }
        }
    }
    
    print "$ans "if $answer_mode;
    print join(" ", map {"$_:$m{$_}"} sort {$a <=> $b} keys %m)."\n";
#    print join(" ", map {"$_:1"} sort {$a <=> $b} keys %m)."\n";
}

■実行例:辞書とテキストは前回[2014-05-09-1]と同じ。
% mkary -l -q fepp-dic.txt
% ./fesa.pl -a fepp-dic.txt < fepp-test.txt
1 1:1 2:1 3:1
0 2:1 3:1 4:1
1 5:1 6:1 7:1 8:1
0 7:1 9:1

入力テキストに辞書の語が含まれているかどうか調べるタスク。
入力テキストの文字位置をずらしながら、各位置で正規表現による「辞書引き」を行い漏れなく調べる方針。

■サンプルコード(regexdic.pl):
#!/usr/bin/perl
use strict;
use warnings;
use utf8;
use open ':utf8';
binmode STDIN, ":utf8";
binmode STDOUT, ":utf8";

my $dic_fn = shift @ARGV;

my %token;
open(my $fh, "<:utf8", $dic_fn) or die;
while (<$fh>) {
    chomp;
    next if /^\s*$/;
    my ($k, $c)  = split(/\t/, $_, 2);
    $token{length($k)}{$k} = $c;
}
close($fh);

my %pat;
foreach my $i (keys %token) {
    $pat{$i} = join("|", keys %{$token{$i}});
}

while (<>) {
    print "> $_";
    chomp;
    next if /^\s*$/;
    my $s_ref = get_matched_strings(\%pat, $_);
    print join("\n", map {"$_\t".$token{length($_)}{$_}} sort keys %$s_ref)."\n";
}

sub get_matched_strings {
    my ($pat_ref, $text) = @_;
    my %match;
    for (my $i = 0; $i < length($text); $i++) {
	foreach my $len (keys %{$pat_ref}) {
	    $match{$1}++ if $text =~ /^.{$i}($pat_ref->{$len})/;
	}
    }
    return \%match;
};

■辞書(aiueo.dic):スペース連続はタブ。
あいう  r:aiu
あい    r:ai,k:愛
いえ    r:ie,k:家
いうえ  r:iue
うあい  r:uai
えあ    r:ea
おい    r:oi,k:甥

■実行例:
% echo 'あいうえおい' | ./regexdic.pl aiueo.dic
> あいうえおい
あい    r:ai,k:愛
あいう  r:aiu
いうえ  r:iue
おい    r:oi,k:甥

ちゃんとした実装にはほど遠いが、急ぎのときのコピペ用に。

文字列長ごとに正規表現を分けているのは、辞書に「あいう」「あい」がある場合に、入力テキスト「あいうえお」で両方にマッチさせるため。事前処理で「あいう」に「あい」が含まれるという情報を持たせて longest のみ得るという方式なら分けなくてもよいがちょっと面倒。なお、longest のみを得る場合は下記のようなパターンを作れば良い。
$pat_all = join("|", sort {length($b) <=> length($a)} keys %token_all);

入力文字列を一文字ずつずらしながらマッチさせているのは、辞書に「あいう」「いうえ」がある場合に、入力テキスト「あいうえお」で両方にマッチさせるため。

ref.
- [を] 正規表現でCommon Prefix Search [2007-05-15-1]
- [を] SUFARY.pm で Longest Common Prefix Search[2007-05-15-5]

簡単なテキスト検索 CGI の雛型」を改訂。
テキスト走査によるgrep的なシンプルな検索を行います。
新たにページ分割機能を付けました。

■コード(textgrep.cgi):
#!/usr/bin/perl -T
use strict;
use warnings;
use CGI;
use HTML::Template;

my $filename = "test.txt";
my $n = 10;

my $q = new CGI;
my $from = $q->param('f') || 1;
my $next_line = $from + $n;
my $pre_line = ($from - $n > 1) ? $from - $n : 1;

my $key_org = $q->param('key') || "";
my $key = quotemeta $key_org;
$key =~ s/[<>]//g;

my $url = $q->url(-query => 1);
$url =~ s/[;&]f=(\d+)//;

print $q->header(-charset => 'UTF-8');

my $str = "";
if (not $key =~ /^\s*$/) {
   if (open(my $fh, "<", $filename)) {
       my $count = 0;
       while (<$fh>) {
	   my $line = $_;
	   next if not $line =~ s|($key)|<font color="red">$1</font>|g;
	   $count++;
	   next if $count < $from;
	   last if $count >= $from + $n;
	   $str .= "$count: ".$line;
       }
       close($fh);
       $str = "NOT FOUND" if $str eq "";
    } else {
	$str = "ERROR: Can't open '$filename'";
    }
}

my $template = join("", <DATA>);
my $t = HTML::Template->new(scalarref => \$template,
			    global_vars => 1,
			    die_on_bad_params => 0);
$t->param(from => $from);
$t->param(str => $str);
$t->param(next_line => $next_line);
$t->param(pre_line => $pre_line);
$t->param(path => $url);
$t->param(key => $key_org);

print $t->output();

__DATA__
<html lang="ja">
<head>
<meta http-equiv="Content-Type" content="text/html; charset=UTF-8">
<title>Text Search</title>
</head>
<body>
<form action="" method="get">
<input type="text" name="key" value="<TMPL_VAR name=key>">
<input type="submit">
</form>
<TMPL_IF name=str>
<a href="<TMPL_VAR name=path>&f=<TMPL_VAR name=pre_line>">&lt;&lt;</a>
<a href="<TMPL_VAR name=path>&f=<TMPL_VAR name=next_line>">&gt;&gt;</a>
<hr>
<pre><TMPL_VAR name=str></pre>
<hr>
<a href="<TMPL_VAR name=path>&f=<TMPL_VAR name=pre_line>">&lt;&lt;</a>
<a href="<TMPL_VAR name=path>&f=<TMPL_VAR name=next_line>">&gt;&gt;</a>
</TMPL_IF>
</body>
</html>

■設置例:
http://chalow.net/misc/textgrep.cgi

関連


- 簡単なテキスト検索 CGI の雛型 http://ta2o.net/tools/stct/
(今回のCGIの原型その1)

- [を] 巨大なテキストファイルをブラウザで覗き見するための簡単な CGI[2011-03-08-2]
(今回のCGIの原型その2)

- [を] SUFARYを用いた簡単辞書検索CGIの雛形[2011-03-15-2]
(インデックスを使った高速版)

SUFARY を用いたテキスト検索 CGI(行単位、プレフィックスマッチ)の最近(というか数年前)書き直した雛形を公開。言語は Perl です。

- SUFARY::search()ではなく SUFARY::range_search() を使うと検索結果インデックスポインタの配列が生成されないのでメモリ的にお得!
- SUFARYの返し値は内部文字列になってない。注意。
- Exactにマッチさせたい場合は、例えば各行を「^エントリ文字列\t...$」というフォーマットにし、内部で末尾に "\t" を付加したキーで検索します。定番処理です。
- 簡単なページ送り機能付き!
- テンプレート(__DATA__以降)に日本語文字を入れる場合は、「use utf8;」をコメントアウトするか、「my $template = encode('utf-8', ...);」にする。

コード

sals.cgi
#!/usr/bin/perl -T
use strict;
use warnings;
use CGI;
use SUFARY;
use Encode;
use URI::Escape;
use HTML::Template;
use utf8;
binmode STDOUT, ":utf8";

my $fn = "test-dic.txt";
my $sa = SUFARY->new($fn);

my $q = new CGI;
my $key = $q->param('key');
my $start = $q->param('start') || 1;
my $num = $q->param('num') || 10;

my $r_ref = search($sa, $key);

my $template = join("", <DATA>);
my $t = HTML::Template->new(scalarref => \$template,
			    global_vars => 1,
			    die_on_bad_params => 0);
$t->param(key => $key);
$t->param(ekey => URI::Escape::uri_escape($key));
$t->param(results => $r_ref->{cont}) if %$r_ref;
$t->param(pre => $r_ref->{pre}) if %$r_ref;
$t->param(nex => $r_ref->{nex}) if %$r_ref;

print $q->header(-charset => 'UTF-8'), decode('utf-8', $t->output());

sub search {
    my ($sa, $key) = @_;
    return {} if $key eq "";

    my ($left, $right) = $sa->range_search($key);
    return {} if not defined $left and not defined $right;

    my $n = $right - $left + 1;
    my $from = $left + $start - 1;
    return {} if $right < $from;
    my $to = $from + $num - 1;
    $to = $right if $to > $right;

    my @rv;
    for (my $k = $from; $k <= $to; $k++) {
	my $pos = $sa->get_position($k);
	my $str = $sa->get_line($pos);
	push @rv, {line => $str};
    }

    my $pre = ($start - $num > 0) ? $start - $num : 0;
    my $nex = ($start + $num <= $n) ? $start + $num : 0;

    return {cont => \@rv, pre => $pre, nex => $nex};
}

__DATA__
<html lang="ja">
<head>
<meta http-equiv="Content-Type" contet="text/html; charset=UTF-8">
<title></title>
</head>
<body>
<h1></h1>

<form>
<input type="input" name="key" size="30" value="<TMPL_VAR name=key>">
<input type="submit">
</form>

<TMPL_IF name=results>
<TMPL_LOOP name=results>
<TMPL_VAR name=line><br>
</TMPL_LOOP>
</TMPL_IF>

<TMPL_IF name=pre>
<a href="?key=<TMPL_VAR name=ekey>&start=<TMPL_VAR name=pre>">&lt;&lt;</a>
</TMPL_IF>
<TMPL_IF name=nex>
<a href="?key=<TMPL_VAR name=ekey>&start=<TMPL_VAR name=nex>">&gt;&gt;</a>
</TMPL_IF>

</body>
</html>

データの準備

SUFARY
% tail -5 test-dic.txt
龍尾神社
龍滕 LONG TENG(赤坂)
1万円入りま〜す
1日なのでお休みです
Tシャツ・ラブ・サミットでTシャツを買ってきた!
% mkary -l test-dic.txt
「-l」オプションで行頭にインデックスを張ります。

実行例

画像

参考

- SUFARY 臨時復旧ページ http://ta2o.net/tools/sufary/
SUFARYの入手はここから。)
- [を] 郵便番号検索 ybks 公開、というか再公開[2006-04-23-2]
(古い雛形を元にしたもの。)
- [を] さくらの500円レンタルサーバーで SUFARY.pm を動かす[2008-08-20-3]
(インストール方法の一例。)
- [を] SUFARY Hacks (1) 最長の繰り返し文字列を探す[2006-04-24-2]
SUFARY Hacks の続きを書こうかな…。)
この記事に言及しているこのブログ内の記事

テキストファイルから指定した行を取り出すタスクについて。

頭から走査する方法


まずはファイルの頭から走査していくナイーブな方法。

■コード(getline-naive.pl):
#!/usr/bin/perl
use strict;
use warnings;
my $qidx = shift @ARGV; # start from 0
my $tgtfn = shift @ARGV;
open(my $fh, "<", $tgtfn) or die;
while (<$fh>) {
    next if $. != $qidx + 1;
    print;
    last;
}
close $fh;

先頭行は0行目になる仕様。

■実行例:
% cat test.dic
Japan
Tokyo
Yokohama
This is a pen
Hello World
% ./getline-naive.pl 2 test.dic
Yokohama

インデックスを使う方法


頭から走査する方法はファイルサイズが巨大になると破綻するのでインデックスを使う。
まずインデックスを作成するプログラム。

■コード(mkidx.pl):
#!/usr/bin/perl
use strict;
use warnings;
my $ip = 0;
while (<>) {
    print pack("N", $ip);
    $ip += length($_);
}

■実行例:
% ./mkidx.pl test.dic > test.dic.ary
% od -t x1 test.dic.ary
0000000  00 00 00 00 00 00 00 06 00 00 00 0c 00 00 00 15
0000020  00 00 00 23
0000024

各行の先頭バイト位置を固定長バイトにして出力。
SUFARY の "mkary -l -ns" と同じ出力になる。
というか、互換にしてみた。

N行目(0始まり)の開始バイト位置は「N * sizeof(unsigned long)」個目に格納されている。
なので、あとは seek と read で行を取り出せばOK。
ゆえに頭から見ていく前述の方法よりも高速になる。

ということで、インデックスを使った指定行取り出しプログラム。

■コード(getline.pl):
#!/usr/bin/perl
use strict;
use warnings;

my $len_of_N = 4;

my $qidx = shift @ARGV;	# start from 0
my $tgtfn = shift @ARGV;
my $idxfn = shift @ARGV || $tgtfn.".ary";

my $tfsz = -s $tgtfn;
my $ifsz = -s $idxfn;
die if $qidx < 0 or $qidx * $len_of_N >= $ifsz;

my $buf = "";

open(my $fi, "<", $idxfn) or die;
seek $fi, $qidx * $len_of_N, 0;
read $fi, $buf, $len_of_N;
my $ixf = unpack("N", $buf);
my $ixt = (tell $fi < $ifsz) ? do {
    read $fi, $buf, $len_of_N;
    unpack("N", $buf);
} : $tfsz;
close $fi;

open(my $fh, "<", $tgtfn) or die;
seek $fh, $ixf, 0;
read $fh, $buf, $ixt - $ixf;
close $fh;

print $buf;

■実行例:
% ./getline.pl 2 test.dic
Yokohama

速度比較


実際に取り出し速度を測定して比較してみた。
使ったデータは60Mバイト3万行のテキストファイル。
指定した200行を取り出すタスク(プログラムを200回起動する)。
それぞれの実行時間を測定した。

結果:インデックスを使う手法の方が頭から走査する手法よりも10倍高速であった。

補足


- なぜ「$len_of_N = 4」なのかというと、pack の N は 32ビット(4バイト)ゆえ。"perldoc -f pack" に書いてある。(追記100811

関連記事


- [を] 文字列の ID 化と相互変換を SUFARY を使って行う方法[2008-04-10-2]
- インデックスを使った指定行取り出しプログラム(Pure Ruby) - Maeの(Mae向きな)日記
http://d.hatena.ne.jp/rahaema/20100811#p1

1 2 3 4 5 6 7 8 9 10 11 12 13 14 [ 次へ ]

たつをの ChangeLog
Powered by chalow