集合知プログラミング 3.3をperl化してみた(階層化クラスタリング)

Perl 集合知プログラミング

今回は、ブログから抽出したキーワード群をクラスタリングする方法。
とりあえず、階層化はできてたけど、出力結果が若干違ったから、もしかしたら一部間違ってるかも…。
追記(23:41):pythonのソースで実行してみたら同じ結果だった。


■ 流れ
テキストファイルに入ってるデータを読み込む。
　一行目は列のタイトル(単語名？)
　一行目以降の一カラム目は行(ブログ)の名前。
読み込んだデータをクラスタリングする。
　すべての組を何回もループさせて、その中から距離の近い組を新しいクラスタとして配置。
　全部のクラスタリングが終わるまで続ける？


■ ソース

#!/usr/bin/perl -w

use strict;
use Dumpvalue;

package Clusters;

# this subroutean is get first line that means row names,
# and, othe line's first column is each column name.
# those data insert big list.
# * rownames and colnames useful index keys.
sub readfile {
  my($self, $filename) = @_;

  # get file data
  open my $file, '<', $filename;
  # first line is column titles
  my @colnames = split('\t', <$file>);
  my @lines = <$file>;
  close $file;

  # set data
  my @rownames = ();
  my @data = ();
  foreach my $line(@lines) {
    my @p = split('\t', $line);
    # each line's first column is colum name
    unshift(@rownames, shift(@p));
    # other column is this line's data
    unshift(@data, \@p);
  }

  return \@rownames, \@colnames, \@data;
}

sub hcluster {
  # $rows: array reference
  # $distance: subroutean reference
  my($self, $rows, $distance) = @_;
  my $currentclustid = -1;
  my %distances = ();

  # Clusters are lines first.
  my @clust;
  map {
    push(@clust, Bicluster->new(vec => $rows->[$_], id => $_));
  } (0..$#$rows);

  while ($#clust > 0) {
    my @lowestpair = (0,1);
    my $closest = $distance->($clust[0]->{vec}, $clust[1]->{vec});

    # 全ての組をループし、もっとも距離の近い組を探す
    foreach my $i(0..$#clust) {
      foreach my $j($i+1..$#clust){
	# 距離をキャッシュしてあればそれを使う
	if (!defined($distances{$clust[$i]->{id}}{$clust[$j]->{id}})) {
	  $distances{$clust[$i]->{id}}{$clust[$j]->{id}} = $distance->($clust[$i]->{vec}, $clust[$j]->{vec});
	}
	my $d = $distances{$clust[$i]->{id}}{$clust[$j]->{id}};
	if ($d < $closest) {
	  $closest = $d;
	  @lowestpair = ($i, $j);
	}
      }
    }

    # 二つのクラスタの平均を計算する
    my @mergevec = ();
    foreach my $i(0..$#{$clust[0]->{vec}}) {
      push(@mergevec, ($clust[$lowestpair[0]]->{vec}->[$i] + $clust[$lowestpair[1]]->{vec}->[$i]) / 2.0);
    }

    # 新たなクラスタを作る
    my $newcluster = Bicluster->new(
	id       => $currentclustid,
	vec      => \@mergevec,
	left     => $clust[$lowestpair[0]],
	right    => $clust[$lowestpair[1]],
	distance => $closest,
      );

    # 元のセットではないクラスタのIDは負にする
    $currentclustid = -1;
    splice(@clust, $lowestpair[1], 1);
    splice(@clust, $lowestpair[0], 1);
    push(@clust, $newcluster);
  }

  return $clust[0];
}

1;

# 階層的なツリーを表現するのに使うこれらのすべてのプロパティを持つBiclusterというクラス
package Bicluster;

sub new {
  my($self, %attr) = @_;
  return bless {
    id       => $attr{id},
    vec      => $attr{vec},
    left     => $attr{left},
    right    => $attr{right},
    distance => $attr{distance},
  }, $self;
}

1;

package main;

my($blognames, $words, $data) = Clusters->readfile('blogdata.txt');
my $start = time;
my $clust = Clusters->hcluster($data, \&pearson);
my $end = time;

printclust($clust, $blognames, 0);

#Dumpvalue->new->dumpValue($cluster);

sub pearson {
  my($v1, $v2) = @_;
  my($sum1, $sum2, $sum1Sq, $sum2Sq, $pSum) = (0, 0, 0, 0, 0);

  map {
    $sum1 += $_;
    $sum1Sq += $_ ** 2;
  } @$v1;

  map {
    $sum2 += $_;
    $sum2Sq += $_ ** 2;
  } @$v2;

  map {
    $pSum += $v1->[$_] * $v2->[$_];
  } 0..$#$v1;

  my $num = $pSum - ($sum1 * $sum2 / scalar(@$v1));
  my $den = sqrt(($sum1Sq - $sum1 ** 2 / scalar(@$v1)) * 
                 ($sum2Sq - $sum2 ** 2 / scalar(@$v1)));

  if ($den == 0) {
    return 0;
  }
  return 1.0 - $num / $den;
}

sub printclust {
  my($clust, $labels, $n) = @_;

  # 階層化のレイアウトにするためにインデントする
  foreach my $i(0..$n) {
    print " ";
  }

  if ($clust->{id} < 0) {
    # 負のidはこれが枝である事を示している
    print '-', "\n";
  }
  else {
    # 正のidはこれが終端だという事を示している
    if ($labels == undef) {
      print $clust->{id}, "\n";
    }
    else {
      print $labels->[$clust->{id}], "\n";
    }
  }

  # 右と左の枝を表示
  if ($clust->{left}) {
    printclust($clust->{left}, $labels, $n + 1);
  }
  if ($clust->{right}) {
    printclust($clust->{right}, $labels, $n + 1);
  }
}

1;


■ 出力結果

yuki@localhost>$ perl cluster.pl
 -
  -
   -
    -
     -
      -
       Creating Passionate Users
       Techdirt
      -
       Joel on Software
       Blog Maverick
     -
      -
       Bloggers Blog: Blogging the Blogsphere
       BuzzMachine
      -
       Steve Pavlina's Personal Development Blog
       Topix.net Weblog
    -
     -
      -
       PaulStamatiou.com
       -
        A Consuming Experience (full feed)
        -
         Official Google Blog
         -
          The Unofficial Apple Weblog (TUAW)
          Joystiq
      -
       Slashdot
       Mashable!
     -
      -
       Joi Ito's Web
       we make money not art
      -
       Oilman
       Copyblogger
   -
    -
     -
      -
       Dave Shea's mezzoblue
       lifehack.org
      -
       MetaFilter
       SpikedHumor
     -
      -
       Signum sine tinnitu--by Guy Kawasaki
       Treehugger
      -
       Shoemoney - Skills to pay the bills
       -
        Go Fug Yourself
        The Superficial - Because You're Ugly
    -
     -
      -
       Instapundit.com
       Schneier on Security
      -
       Online Marketing Report
       -
        Daily Kos
        Talking Points Memo: by Joshua Micah Marshall
     -
      -
       ongoing
       Eschaton
      -
       Derek Powazek
       flagrantdisregard
  -
   -
    -
     -
      -
       The Blotter
       Michelle Malkin
      -
       Bloglines | News
       -
        Boing Boing
        MAKE Magazine
     -
      -
       Autoblog
       TechEBlog
      -
       Wired News: Top Stories
       43 Folders
    -
     -
      -
       gapingvoid: "cartoons drawn on the back of business cards"
       -
        Gawker
        Gothamist
      -
       WWdN: In Exile
       -
        Crooks and Liars
        Hot Air
     -
      -
       -
        The Huffington Post | Raw Feed
        Wonkette
       -
        ProBlogger Blog Tips
        Sifry's Alerts
      -
       -
        Micro Persuasion
        Publishing 2.0
       -
        Deadspin
        Neil Gaiman's Journal
   -
    -
     -
      -
       -
        Think Progress
        Power Line
       -
        TMZ.com
        Engadget
      -
       -
        Seth's Blog
        The Viral Garden
       -
        Quick Online Tips
        -
         Read/WriteWeb
         -
          CoolerHeads Prevail
          Download Squad
     -
      -
       -
        Scobleizer - Tech Geek Blogger
        Valleywag
       -
        456 Berea Street
        O'Reilly Radar
      -
       -
        Lifehacker
        -
         Search Engine Watch Blog
         -
          Search Engine Roundtable
          -
           Google Blogoscoped
           Google Operating System
       -
        kottke.org
        Signal vs. Noise
    -
     -
      -
       -
        Gizmodo
        Kotaku
       -
        Little Green Footballs
        Andrew Sullivan | The Daily Dish
      -
       -
        Jeremy Zawodny's blog
        PerezHilton.com
       -
        Matt Cutts: Gadgets, Google, and SEO
        -
         John Battelle's Searchblog
         -
          Pharyngula
          ScienceBlogs : Combined Feed
     -
      -
       -
        Cool Hunting
        SimpleBits
       -
        NewsBusters.org - Exposing Liberal Media Bias
        Captain's Quarters
      -
       -
        TechCrunch
        GigaOM
       -
        plasticbag.org
        Joho the Blog