HTML::FeaturedImage - URLに含まれる画像のうち、重要そうなものを取り出すためのPerlモジュール

yuisekiが「エントリのメイン画像抽出があるといいかも」と言ってたときに、昼飯まで暇だったので作った。結果のサンプルはこちら。
仕組みはてきとう。まずURLをたくさん与え、その先にある画像の数を数える。たくさんのページに~~でてきたり、何度もおなじページに~~出てくる画像はどうでもいいものとして、消す。よくあるやり方だけど強力。
よく考えるとHTML::じゃない感じがしてきた。あとで直すかも。HTML::としてふさわしくするため、Web::Scraperにcontent渡せるようにした。

$content = "<html>...";
$hfi->add_page($url, $content);

あと、リンク先が画像っぽいURLのときにはa hrefも取るようにした。閾値のキャッシュとかちょっとアルゴリズム変更とか、細かいところも変更。ちょっとノイズ入るようになったけど、たぶん欲しい物は確実に全部取れるチューニングになってると思う。閾値の式とか画像っぽいURL判定は設定とかプラグインに出したほうがいいかもな。

サンプルを生成するipic.pl

#!/usr/bin/perl
use strict;
use warnings;

use URI;
use XML::Feed;
use Template;

use HTML::FeaturedImage;

my $home = shift or die 'usage : ./ipic.pl http://www.akibablog.net/';
my @feeds = XML::Feed->find_feeds($home);
die 'no feed' unless (@feeds);

my $feed = XML::Feed->parse(URI->new($feeds[0]));

my $template = <<"TEMPLATE";
<html>
<head><title>demo: HTML::FeaturedImage</title></head>
<body>
[% FOR url IN hfi.urls %]
<div>
<h3>[% url %]</h3>
<h4>original</h4>
<p>[% FOR imageurl IN hfi.original(url) %]<a href="[% imageurl %]"><img src="[% imageurl %]" width="80"></a>[% END %]</p>
<h4>predicted</h4>
<p>[% FOR imageurl IN hfi.predict(url) %]<a href="[% imageurl %]"><img src="[% imageurl %]" width="80"></a>[% END %]</p>
</div>
[% END %]</body>
</html>
TEMPLATE

my $hfi = HTML::FeaturedImage->new;

for my $entry ($feed->entries) {
    my $url = $entry->link;
    $hfi->add_page($url);
}

my $tt = Template->new;
$tt->process(\$template, {hfi => $hfi});

HTML/FeaturedImage.pm

package HTML::FeaturedImage;
use strict;
use warnings;

use URI;
use Web::Scraper;
use List::MoreUtils qw(:all);
use Statistics::Lite qw(:all);

sub new {
    my $pkg = shift;
    bless {}, $pkg;
}

sub urls {
    my $self = shift;
    return @{$self->{urls}};
}

sub add_page {
    my ($self, $url, $content) = @_;
    push @{$self->{urls}}, $url;
    my $uri = URI->new($url);
    
    my $scraper = scraper {
        process "img", 'imgs[]' => '@src';
        process "a", 'anchors[]' => '@href';
    };
    my @args = ($uri);
    unshift @args, \$content if (defined $content);
    my $r = $scraper->scrape(@args);
    
    my @imgs;
    push @imgs, @{$r->{imgs}};
    push @imgs, grep /\.(jpe?g|gif|png|bmp)$/i, @{$r->{anchors}};
    
    map {$self->{db}->{all}->{$_}++} uniq @imgs;
    map {$self->{db}->{$url}->{$_}++} uniq @imgs;
    delete $self->{threshold} if (defined $self->{threshold});
    return $self;
}

sub threshold {
    my $self = shift;
    
    return $self->{threshold} if (defined $self->{threshold});
    
    my @dba = values %{$self->{db}->{all}};
    $self->{threshold} = mean(@dba) + stddevp(@dba)/2;
}

sub predict {
    my ($self, $url) = @_;
    
    my @informative_imgs;
    my $img_db = $self->{db};
    my $all = $img_db->{all};
    
    my $imgs = $img_db->{$url};
    while (my ($img, $num) = each %$imgs) {
        if ($self->threshold >= $all->{$img}) {
            push @informative_imgs, $img;
        }
    }
    
    return @informative_imgs;
}

sub original {
    my ($self, $url) = @_;
    
    return keys %{$self->{db}->{$url}};
}

1;