集合知プログラミング 3.3をperl化してみた(はてダ用)

http://d.hatena.ne.jp/rin1024/20090420/1240222617
http://d.hatena.ne.jp/rin1024/20090421/1240317936
ここら辺を、はてダのデータ元にクラスタリングできるように修正してみた。

■ 集合知プログラミング 3.3をperl化してみた(形態素解析+単語数カウント)の方
はてダRSSの記事ごとに取得して、その記事の中での単語の数をカウントして配列で返すように修正。

#!/usr/bin/perl

package FeedParser;

use LWP::UserAgent;
use XML::Simple;

sub new {
  return bless {}, shift;
}

sub parse {
  my $self = shift;
  my $url = shift;
  my $ua  = LWP::UserAgent->new;
  my $feed = XMLin($ua->simple_request(
      HTTP::Request->new('GET', $url)
    )->content);
  return $feed;
}

1;

package main;

use utf8;
use strict;
use warnings;
use Dumpvalue;
use MeCab;

my $mecab  = MeCab::Tagger->new;
my $parser = FeedParser->new;

sub getWordCounts {
  my $url = shift;
  my @lines;
  my $id = 1;

  # parse xml data
  my $documents = $parser->parse($url);
  
  # analysis entry data
  foreach my $entry(@{$documents->{item}}) {
    my $summary;
    if ($entry->{summary}) {
      $summary = $entry->{summary};
    }
    elsif($entry->{description}) {
      $summary = $entry->{description};
    }
    else {
      $summary = $entry->{content};
    }
    
    # title
    %{$lines[$id]} = ();
    $lines[$id]->{'blog_title'} = $entry->{title};
    
    # extract attributes
    my $node = getWords($summary);
    for (;$node;$node = $node->{next}) {
      next unless defined $node->{surface};
      my $word = $node->{surface};
      my($hinsi, $yomi) = (split( /,/, $node->{feature}))[0,7];
      next if defined $yomi && $yomi eq '*';
      
      # add column name
      if (!defined($lines[0]->{$word}) && $word ne 'blog_title') {
        $lines[0]->{$word} = 'true';
      }
      
      # counter
      unless (defined $lines[$id]->{$word}) {
        $lines[$id]->{$word} = 0;
      }
      $lines[$id]->{$word}++;
    }
    $id++;
  }
  return \@lines;
}

sub getWords {
  my $content = shift;
  # triming html tags.
  $content =~ s/\<(.*?)\>//g;
  # lower case
  $content = lc($content);
  # return results.
  return $mecab->parseToNode($content);
}

# do execute
my($lines) = getWordCounts('http://d.hatena.ne.jp/rin1024/rss');

# show columns
my $wc = shift @$lines;
print "blog_title", "\t";
foreach my $key(keys(%$wc)) {
  print $key, "\t";
}
print "\n";
foreach my $line(@$lines) {
  print $line->{'blog_title'}, "\t";
  foreach my $key(keys(%$wc)) {
    my $num = defined $line->{$key} ? $line->{$key} : 0;
    print $num, "\t";
  }
  print "\n";
}

1;

■ 集合知プログラミング 3.3をperl化してみた(階層化クラスタリング)の方
読み込むテキストを↑のスクリプトで生成したのに変えたくらい。

#!/usr/bin/perl

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('hated.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;

■ はてダRSSを元に生成されたテキストデータ

blog_title	shibuya	/	けど	違う	でも	newfe	my	で	水曜	ね	間違っ	人	且つ	もんもん	ボタン	たら	度	分から	request	総数	mixi	する	ハード	カンファレンス	newdatarequest	名	面倒	交通	マイミク	面白	方法	続い	$	もの	っと	群	面白く	ー	lwp	相手	承諾	つくら	突っ	edition	直接	一	realvnc	初	詳しい	た	。	割る	{	知ら	今回	ゼミ	に	って	イク	perl	ユーザー	まし	bless	)	表示	データ	室	めんどくさい	}	com	途中	押さ	bin	かも	=	#!/	列	さ	一部	死ね	火曜	大学	http	思っ	：	ぼけ	会社	テキストファイル	できる	professi	…	shift	pm	(	デスク	ない	www	まぁ	■	メール	add	セットアップ	てる	送っ	全然	だ	系	なんだか	usr	です	://	被っ	タイトル	カウント	とかし	？)	接続	vnc	xmlin	流れ	うだうだ	僕	言わ	opensocial	閲覧	入っ	($	アシスタント	か	//	目	リモート	み	url	聴か	研究	トップ	工業	これ	feedparser	訪問	とか	()	ん	関係	・	simple	立っ	て	なっ	もしか	の	function	parse	pc	クラスタリング	その後	も	ダメ	var	professional	だけ	home	real	ブログ	ログイン	から	さすが	費	のに	_	package	　	アプリカンファ	xp	！	コミュニティ	ua	作っ	jpa	self	悔しい	キーワード	ので	そう	::	出力	xml	なー	者	new	読み込む	{},	が	抽出	ます	近似	単語	やっぱり	一覧	来る	とりあえず	し	昨日	->	();	違っ	階層	重複	と	木曜	useragent	、	は	化	use	.	大杉	説明	な	若干	;	れ	を	ちょっと	でき	feed	一行	同じ	結果	return	sub	取得	双方	側	
[Perl]集合知プログラミング 3.3をperl化してみた(階層化クラスタリング)	0	0	1	0	0	0	0	0	0	0	1	0	0	0	0	1	0	0	0	0	0	1	0	0	0	1	0	0	0	0	1	0	0	0	0	1	0	0	0	0	0	0	0	0	0	0	0	0	0	3	3	0	0	0	1	0	1	0	0	0	0	0	0	0	0	1	0	0	0	0	0	0	0	1	0	0	1	0	1	0	0	0	0	0	0	0	0	1	0	0	1	0	0	1	0	0	0	0	1	0	0	0	2	0	0	0	0	0	0	0	0	0	1	0	0	1	0	0	0	1	0	0	0	0	0	1	0	0	0	0	2	0	0	0	0	0	0	0	0	0	0	0	0	0	0	0	0	0	1	0	1	1	0	0	0	1	0	0	0	0	0	0	0	0	1	0	2	0	0	0	0	0	2	0	0	0	0	0	0	0	0	0	1	0	0	0	1	0	0	0	0	1	0	1	1	0	0	1	0	0	0	1	2	0	0	0	1	1	0	0	0	0	4	3	1	0	0	0	0	0	1	0	0	2	0	1	0	2	0	1	0	0	0	0	0	
[雑記]今週って	1	0	0	1	1	0	0	1	1	1	0	0	0	0	0	0	0	0	0	0	1	0	0	1	0	0	0	1	0	0	0	1	0	0	0	0	0	0	0	0	0	0	0	0	0	0	0	0	0	0	2	0	0	0	0	0	0	0	1	1	0	0	0	1	0	0	0	0	0	0	0	0	0	0	0	0	0	0	0	1	1	0	0	0	3	0	0	0	0	0	0	0	1	1	0	0	0	0	0	0	0	0	0	0	0	0	0	0	0	1	0	0	0	0	0	0	0	0	0	0	0	0	1	0	0	0	0	0	1	0	0	0	0	0	0	0	0	0	0	0	0	0	0	0	1	0	0	0	3	1	0	1	0	0	0	0	0	1	0	0	0	1	0	0	0	0	0	0	1	0	0	0	0	1	0	2	0	0	0	1	0	0	0	0	1	0	0	0	0	0	0	0	0	0	0	1	0	0	0	0	1	0	0	0	0	0	0	0	0	0	2	0	0	1	0	0	1	0	0	0	0	0	1	0	0	0	0	0	0	0	0	0	0	0	0	
[Perl]集合知プログラミング 3.3をperl化してみた(形態素解析+単語数カウント)	0	2	0	0	0	0	4	0	0	0	0	0	0	0	0	0	0	0	2	0	0	0	0	0	0	0	0	0	0	0	0	0	4	0	0	0	0	0	2	0	0	0	0	0	0	0	0	0	0	0	0	0	2	0	0	0	0	0	0	1	0	0	1	0	0	0	0	0	1	0	0	0	1	0	4	1	0	0	0	0	0	0	1	0	0	0	0	0	0	0	0	3	0	1	0	0	0	0	0	0	0	0	0	0	0	0	0	0	1	0	0	0	0	0	0	0	0	0	1	0	0	0	0	0	0	0	1	0	0	0	0	0	0	1	0	0	0	0	0	1	0	0	0	0	0	0	2	0	0	0	0	0	0	1	0	0	0	0	0	0	0	0	0	0	0	0	0	0	0	0	1	1	0	0	0	0	0	2	0	0	1	0	0	0	0	4	0	1	0	0	3	0	1	0	0	0	0	0	0	0	0	0	0	0	3	0	0	0	0	0	0	2	0	0	0	2	0	0	0	0	0	7	0	0	0	0	1	0	0	0	1	2	0	0	0	
[雑記]研究室が意外と面白そうだった。	0	0	0	0	1	0	0	1	0	0	0	2	0	0	0	0	0	1	0	0	0	0	1	0	0	0	1	0	0	0	0	0	0	0	1	0	0	1	0	0	0	0	1	0	0	1	0	1	1	3	3	0	0	1	0	1	0	0	0	0	0	1	0	0	0	0	1	0	0	0	0	0	0	0	0	0	0	1	0	0	0	1	0	1	0	1	1	0	0	0	0	0	0	0	0	2	0	1	0	0	0	1	0	0	1	1	1	1	0	1	0	0	0	0	1	0	0	0	0	0	0	1	0	0	0	0	0	0	0	0	0	0	0	0	1	1	0	1	1	0	0	1	0	1	0	0	0	1	4	0	0	3	0	0	1	0	2	0	0	0	0	0	0	0	0	0	0	1	0	0	0	0	0	0	0	1	0	0	0	0	0	0	0	1	0	0	0	0	1	0	0	0	0	1	0	0	0	0	0	0	0	0	0	1	0	0	0	0	0	0	0	0	3	4	0	0	0	1	1	0	0	0	1	0	1	0	0	0	0	0	0	0	0	0	0	
[雑記][JavaScript]はじめてのmixiアプリ？	0	1	1	0	0	0	0	1	0	0	0	0	0	0	0	0	1	0	0	2	0	0	0	0	0	0	0	0	0	0	0	0	0	1	0	0	1	0	0	0	0	0	0	0	0	0	0	0	0	3	1	1	0	0	0	0	3	0	0	0	1	0	0	1	0	0	0	0	0	0	0	0	0	0	1	0	0	1	0	0	0	0	0	0	0	0	0	0	0	0	0	0	0	1	0	2	0	0	0	0	0	0	2	0	0	1	0	0	0	0	0	1	0	1	0	0	0	0	0	0	0	0	0	0	0	1	0	0	0	0	0	0	2	0	0	0	0	0	0	0	3	0	0	1	0	0	0	0	3	0	0	4	0	0	0	0	0	0	0	0	0	0	0	0	0	0	0	0	0	0	0	0	0	0	0	1	4	0	1	0	0	0	0	0	0	0	0	0	0	2	0	0	0	0	1	1	1	0	0	0	0	1	4	0	0	0	0	0	1	2	0	0	2	2	0	0	0	0	0	0	0	0	1	2	0	0	0	0	1	0	0	0	0	1	2	
[雑記][JavaScript]mixiアプリカンファレンスに落選したのでやっつけでアプリ作ろうとした(途中)	0	0	1	0	0	1	0	0	0	0	0	0	0	1	0	0	0	0	2	0	1	0	0	0	1	0	0	0	1	1	0	0	0	0	0	0	0	0	0	0	0	1	0	0	0	0	0	0	0	1	2	0	1	0	0	0	0	1	0	0	0	0	0	0	1	0	0	0	0	0	1	0	0	0	1	0	0	0	0	0	0	0	0	1	0	0	0	0	0	0	0	0	0	2	0	1	0	0	0	0	1	0	1	0	0	0	0	0	0	0	0	0	0	0	0	0	0	0	0	0	0	0	0	1	2	0	0	0	0	1	0	0	1	0	0	0	0	0	0	0	0	0	1	0	0	1	0	0	2	0	0	2	1	0	0	0	0	0	0	1	0	0	0	0	0	0	1	0	0	0	0	0	0	0	0	1	2	0	1	0	0	1	0	1	1	0	0	0	0	2	0	0	0	0	0	0	0	0	1	1	0	1	0	0	0	1	0	0	0	1	0	0	1	0	0	0	3	0	0	1	0	0	0	2	0	0	0	0	0	0	0	0	1	0	0	
[雑記]Windows XP Home Editionで簡単リモート接続	0	1	0	0	0	0	0	0	0	0	0	0	1	0	1	1	0	0	0	0	0	0	0	0	0	0	0	0	0	0	0	0	0	0	0	0	0	0	0	2	1	0	0	1	1	0	1	0	0	0	0	0	0	0	0	0	0	0	0	0	0	0	0	0	0	0	0	1	0	1	0	1	0	0	0	0	0	0	0	0	0	0	1	1	0	0	0	0	1	1	0	0	0	0	1	1	1	0	0	1	0	0	0	1	0	2	0	0	0	0	1	0	0	0	0	0	1	1	0	0	1	0	0	0	0	0	0	1	0	0	0	2	0	0	0	0	1	0	0	0	0	2	0	0	0	1	0	0	4	0	0	1	0	0	0	0	0	0	1	0	1	0	1	1	0	1	0	0	0	1	0	0	0	0	1	0	0	0	0	0	0	0	0	0	0	0	0	0	1	0	0	0	0	2	0	0	0	0	0	0	0	0	1	0	0	0	0	0	0	3	0	0	4	0	0	0	2	0	0	0	0	0	0	0	0	0	0	0	0	0	0	0	0	0	0	

■ 実行結果

[yuki@sorauta 3]$ perl clusters_hatena.pl
 -
  [Perl]集合知プログラミング 3.3をperl化してみた(形態素解析+単語数カウント)
  -
   [雑記]今週って
   -
    [雑記]Windows XP Home Editionで簡単リモート接続
    -
     [雑記]研究室が意外と面白そうだった。
     -
      [Perl]集合知プログラミング 3.3をperl化してみた(階層化クラスタリング)
      -
       [雑記][JavaScript]mixiアプリカンファレンスに落選したのでやっつけでアプリ作ろうとした(途中)
       [雑記][JavaScript]はじめてのmixiアプリ？

・・・どうにも何かがおかしい気がしてならない。
せめて集合値の記事のクラスタリングくらい通らないかなー。
甘い考えでした。
今から原因調査する予定。