File Coverage

blib/lib/Lingua/JA/Summarize.pm

Criterion	Covered	Total	%
statement	9	9	100.0
branch			n/a
condition			n/a
subroutine	3	3	100.0
pod			n/a
total	12	12	100.0

package Lingua::JA::Summarize;

use strict;
use warnings;

our $VERSION = 0.08;
our @EXPORT_OK =
    qw(keyword_summary file_keyword_summary
        %LJS_Defaults %LJS_Defaults_keywords);
our %EXPORT_TAGS = (
    all => \@EXPORT_OK,
);

use base qw(Exporter Class::Accessor::Fast Class::ErrorHandler);

use Carp;
use Encode;
use File::Temp qw(:POSIX);
use Jcode;
use Lingua::JA::Summarize::Mecab;

sub NG () {
    +{ map { $_ => 1 } (
        '(', ')', '#', ',', '"', "'", '`',
        qw(! $ % & * + - . / : ; < = > ? @ [ \ ] ^ _ { | } ~),
        qw(¿Í Éà ʬ »þ Æü ·î ǯ ±ß ¥É¥ë),
        qw(°ì Æó »° »Í ¸Þ Ï» ¼· Ȭ ¶å ½½ É´ Àé Ëü ²¯ Ãû),
        qw(¢¬ ¢­ ¢« ¢ª ¢Í ¢Î ¡À ¡° ¡® ¡³),
        qw(a any the who he she i to and in you is you str this ago about and new as of for if or it have by into at on an are were was be my am your we them there their from all its),
    ) };
}

sub DEFAULT_COST_FACTOR () { 2000 }

my %Defaults = (
    alnum_as_word     => 1,
    concat_nouns      => 1,
    charset           => 'euc',
    default_cost      => 1,
    jaascii_as_word   => 1,
    ng                => NG(),
    mecab             => 'mecab',
    mecab_charset     => 'euc',
    mecab_factory     => sub {
        Lingua::JA::Summarize::Mecab->new(@_),
    },
    omit_number       => 1,
    singlechar_factor => 0.5,
    url_as_word       => 1,
);
our %LJS_Defaults = ();
foreach my $k (keys %Defaults) {
    my $n = 'LJS_' . uc($k);
    $LJS_Defaults{$k} = $ENV{$n} if defined $ENV{$n};
}

our %LJS_ascii_words = ();
our %LJS_encoded_words = ();

__PACKAGE__->mk_accessors(keys %Defaults, qw(stats wordcount));

sub new {
    my ($proto, $fields) = @_;
    my $class = ref $proto || $proto;
    my $self = bless {
        %Defaults,
        %LJS_Defaults,
        ($fields ? %$fields : ()),
    }, $class;
    $self->{wordcount} = 0;

    return $self;
}

my %Defaults_keywords = (
    maxwords => 5,
    minwords => 0,
    threshold => 5
);
our %LJS_Defaults_keywords = ();
foreach my $k (keys %Defaults_keywords) {
    my $n = 'LJS_KEYWORDS_' . uc($k);
    $LJS_Defaults_keywords{$k} = $ENV{$n} if defined $ENV{$n};
}

sub keywords {
    my ($self, $_args) = @_;
    my %args = (
        %Defaults_keywords,
        %LJS_Defaults_keywords,
        ($_args ? %$_args : ()),
    );
    my $stats = $self->{stats};
    my @keywords;

    foreach my $word (
        sort { $stats->{$b}->{weight} <=> $stats->{$a}->{weight} || $a cmp $b }
            keys(%$stats)) {
        last if
            $args{minwords} <= @keywords
                && $stats->{$word}->{weight} < $args{threshold};
        push(@keywords, $word);
        last if $args{maxwords} == @keywords;
    }

    return @keywords;
}

sub analyze_file {
    my ($self, $file) = @_;

    open my $fh, '<', $file or croak("failed to open: $file: $!");
    my $text = do { local $/; <$fh> };
    close $fh;

    $self->analyze($text);
}

sub analyze {
    my ($self, $text) = @_;

    croak("already analyzed") if $self->{stats};
    $self->{stats} = {};

    # adjust text
    Jcode::convert(\$text, 'euc', $self->charset) if $self->charset ne 'euc';
    $text = $self->_prefilter($text);
    $text =~ s/\s*\n\s*/\n/sg;
    $text .= "\n";
    $text = _normalize_japanese($text);
    Jcode::convert(\$text, $self->mecab_charset, 'euc')
            if $self->mecab_charset ne 'euc';

    # write text to temporary file
    my ($fh, $tempfile) = tmpnam();
    print $fh $text;
    close $fh;

    # open mecab
    my $mecab = $self->mecab_factory->($self, $tempfile);

    # read from mecab
    my $longword = {
        text => '',
        cost => 0,
        count => 0,
    };
    my $add_longword  = sub {
        if ($longword->{text}) {
            $self->_add_word(
                $longword->{text},
                $longword->{cost} / (log($longword->{count}) * 0.7 + 1));
        }
        $longword->{text} = '';
        $longword->{cost} = 0;
        $longword->{count} = 0;
    };
    while (my $line = $mecab->getline) {
        chomp $line;
        Jcode::convert(\$line, 'euc', $self->mecab_charset)
                if $self->mecab_charset ne 'euc';
        if ($line =~ /\t/o) {
            my ($word, $pn, $pw, $H) = split(/\t/, $line, 4);
            $word = $self->_postfilter($word);
            $word = $self->_normalize_word($word);
            my $ng = $self->_ng_word($word);
            if ($ng) {
                $add_longword->();
                next;
            }
            if ($H =~ /^̾»ì/) {
                if ($H =~ /(Èó¼«Î©|Âå̾»ì)/) {
                    $add_longword->();
                    next;
                } elsif (! $longword->{text} && $H =~ /ÀÜÈø/) {
                    # ng
                    next;
                }
                if (! $self->concat_nouns && $H !~ /ÀÜÈø/) {
                    $add_longword->();
                }
            } elsif ($H eq 'UnkType') {
                # handle unknown (mostly English) words
                if ($self->jaascii_as_word) {
                    if ($word =~ /^\w/ && $longword->{text} =~ /\w$/) {
                        $add_longword->();
                    }
                } else {
                    $add_longword->();
                    $self->_add_word($word, $pw);
                    next;
                }
            } else {
                $add_longword->();
                next;
            }
            $longword->{text} .= $word;
            $longword->{cost} += $pw; # do not use $pn
            $longword->{count}++;
        } else {
            $add_longword->();
        }
    }
    $add_longword->();
    unlink($tempfile);

    # calculate tf-idf
    $self->_calc_weight;

    1;
}

sub _add_word {
    my ($self, $word, $cost) = @_;
    return if $cost <= 0;
    return if $self->_ng_word($word);
    $self->{wordcount}++;
    Jcode::convert(\$word, $self->charset, 'euc') if $self->charset ne 'euc';
    my $target = $self->{stats}->{$word};
    if ($target) {
        $target->{count}++;
    } else {
        $self->{stats}->{$word} = { count => 1, cost => $cost };
    }
}

sub _calc_weight {
    my $self = shift;
    foreach my $word (keys(%{$self->{stats}})) {
        my $target = $self->{stats}->{$word};
        my $cost = $target->{cost};
        $cost = $self->default_cost * DEFAULT_COST_FACTOR unless $cost;
        $target->{weight} =
            ($target->{count} - 0.5) * $cost / $self->{wordcount} / 6;
        if ($self->_is_singlechar($word)) {
            $target->{weight} *= $self->singlechar_factor;
        }
    }
}

sub _normalize_word {
    my ($self, $word) = @_;
    $word = Jcode->new($word, 'euc')->h2z;
    $word->tr('£°-£¹£Á-£Ú£á-£ú¡Ê¡Ë', '0-9A-Za-z()');
    lc($word);
}

sub _ng_word {
    my ($self, $word) = @_;
    return 1 if $self->omit_number && $word =~ /^\d*$/;
    return 1 if exists $self->{ng}->{$word};
    return 1 if $word !~ /[\w\x80-\xff]/;
    undef;
}

sub _prefilter {
    my ($self, $text) = @_;
    if ($self->alnum_as_word) {
        if ($self->url_as_word) {
            $text =~
                s!(https?://[A-Za-z0-9.:_/?#~\$\-=&%]+|[A-Za-z0-9_][A-Za-z0-9_.']*[A-Za-z0-9_])!_encode_ascii_word($1)!eg;
        } else {
            $text =~
                s!([A-Za-z0-9_][A-Za-z0-9_.']*[A-Za-z0-9_])!_encode_ascii_word($1)!eg;
        }
    }
    $text;
}

sub _postfilter {
    my ($self, $word) = @_;
    if ($word =~ /^[A-Za-z]+$/ &&
            ($self->alnum_as_word || $self->url_as_word)) {
        $word = _decode_ascii_word($word);
    }
    $word;
}

sub _is_singlechar {
    my ($self, $word) = @_;
    my $enc = $self->charset;
    $enc = 'euc-jp' if $enc eq 'euc';
    1 == length decode($enc, $word);
}

sub _encode_ascii_word {
    my ($word) = @_;
    return $word if $word !~ /^qz[a-z]{9}q$/ && $word =~ /^([A-Za-z]{1,25}|[0-9]{1,25})$/;
    return $LJS_encoded_words{$word} if ($LJS_encoded_words{$word});
    for(;;){
        my $p="qz";
        for(1..9){$p.=('a'..'z')[int rand 26];}
        $p.="q";
        unless ($LJS_encoded_words{$word}) {
            $LJS_encoded_words{$word} = $p;
            $LJS_ascii_words{$p} = $word;
            return $p;
        }
    }
}

sub _decode_ascii_word {
    my ($word) = @_;
    return $LJS_ascii_words{$word} if ($LJS_ascii_words{$word});
    return $word;
}

sub _normalize_japanese {
    my ($in) = @_;
    my $out;
    while ($in =~ /([\x80-\xff]{2})/) {
        $out .= $`;
        $in = $';
        if ($1 eq '¡£' || $1 eq '¡¥') {
            $out .= "¡£\n";
        } elsif ($1 eq '¡¤') {
            $out .= "¡¢";
        } else {
            $out .= $1;
        }
    }
    $out .= $in;
    return $out;
}

sub keyword_summary {
    my ($text, $args) = @_;
    my $s = Lingua::JA::Summarize->new($args);
    $s->analyze($text);
    return $s->keywords($args);
}

sub file_keyword_summary {
    my ($file, $args) = @_;
    my $s = Lingua::JA::Summarize->new($args);
    $s->analyze_file($file);
    return $s->keywords($args);
}

1;
__END__