File Coverage

blib/lib/Lingua/ZH/Keywords.pm
Criterion Covered Total %
statement 10 12 83.3
branch n/a
condition n/a
subroutine 4 4 100.0
pod n/a
total 14 16 87.5


line stmt bran cond sub pod time code
1             # $File: //member/autrijus/Lingua-ZH-Keywords/Keywords.pm $ $Author: autrijus $
2             # $Revision: #9 $ $Change: 3723 $ $DateTime: 2003/01/20 22:15:45 $
3              
4             package Lingua::ZH::Keywords;
5             $Lingua::ZH::Keywords::VERSION = '0.04';
6              
7 2     2   1529 use strict;
  2         4  
  2         95  
8 2     2   13 use vars qw($VERSION @ISA @EXPORT @StopWords);
  2         5  
  2         173  
9              
10 2     2   12 use Exporter;
  2         6  
  2         90  
11 2     2   4700 use Lingua::ZH::TaBE ();
  0            
  0            
12              
13             =head1 NAME
14              
15             Lingua::ZH::Keywords - Extract keywords from Chinese text
16              
17             =head1 SYNOPSIS
18              
19             # Exports keywords() by default
20             use Lingua::ZH::Keywords;
21              
22             print join(",", keywords($text)); # Prints five keywords
23             print join(",", keywords($text, 10)); # Prints ten keywords
24              
25             =head1 DESCRIPTION
26              
27             This is a very simple algorithm which removes stopwords from the
28             text, and then counts up what it considers to be the most important
29             B. The C subroutine returns a list of keywords
30             in order of relevance.
31              
32             The stopwords list is accessible as C<@Lingua::ZH::Keywords::StopWords>.
33              
34             If the input C<$text> is an Unicode string, the returned keywords
35             will also be Unicode strings; otherwise they are assumed to be
36             Big5-encoded bytestrings.
37              
38             =cut
39              
40             @ISA = qw(Exporter);
41             @EXPORT = qw(keywords);
42              
43             @StopWords = qw(
44             提供 相關 我們 可以 如何 因為 目前 如果 其他 我的 大家 沒有 主要 所以
45             以上 這個 所有 有關 就是 他們 因此 但是 以及 是否 由於 對於 任何 什麼
46             這些 現在 無法 成為 可能 不過 包括 必須 關於 這是 這樣 以下 已經 你的
47             雖然 許多 也是 不是 除了 還是 為了 之後 只要 其中 都是 各種 還有 非常
48             而且 這種 其它 不要 我要 他的 只是 各位 只有 的話 不能 這裡 相當 我是
49             全部 很多 可是 或是 其實 那麼 你們 下列 如此 另外 然後 各項 才能 不會
50             甚至 總會 不得 怎麼 即可 作為 至於 當然 根據 我想 能夠 之間 為何 不知
51             例如 期間 時候 也有 常見 並且 容易 我有 實際 有人 有些 分別 並不 以後
52             使得 經由 重新 如下 在此 這麼 那些 整個 都有 這次 之前 令人 來的 就會
53             上述 位於 那個 而已 使用 假如 於是 還得 是在 無法 何況 曾經 我們的
54             );
55              
56             my $Tabe;
57              
58             sub keywords {
59             $Tabe ||= Lingua::ZH::TaBE->new;
60              
61             eval { require Encode::compat } if $] < 5.007;
62             my $is_utf8 = eval { require Encode; Encode::is_utf8($_[0]) };
63              
64             my (%hist, %ref);
65             $hist{$_}++ for grep {
66             length > 2 and index($_, '一') == -1
67             } $Tabe->split(
68             $is_utf8 ? Encode::encode(big5 => $_[0]) : $_[0]
69             );
70             delete @hist{@StopWords};
71              
72             my $count = $_[1] || 5;
73              
74             # By occurence, then freq, then lexical order
75             map {
76             $is_utf8 ? Encode::decode(big5 => $_) : $_
77             } grep length, (sort {
78             $hist{$b} <=> $hist{$a}
79             or
80             ($ref{$b} ||= freq($b)) <=> ($ref{$a} ||= freq($a))
81             or
82             $b cmp $a
83             } keys %hist)[ 0 .. $count-1 ];
84             }
85              
86             sub freq {
87             my $tsi = $Tabe->Tsi($_[0]);
88             $Tabe->TsiDB->Get($tsi);
89             return $tsi->refcount;
90             }
91              
92             1;
93              
94             __END__