use List::Util (sum); use List::MoreUtils qw(uniq); use Algorithm::Cluster; my $data = { apple => [qw( red round plant fruit)], orange => [qw(orange round plant fruit)], pumpkin => [qw(orange round plant vegetable)], ball => [qw( red round toy)], }; # list of all attributes my @items = sort keys %$data; my @attr = sort(uniq( map { @{$data->{$_}} } keys %$data)); # data set recast as vectors my $datav; for my $item (@items) { my $vec; for my $attr (@attr) { push @$vec, scalar grep($_ eq $attr, @{$data->{$item}}); } push @$datav, $vec; } # keep track of all item sets for which items had the same distance my $scores; for my $i (0..@items-1) { for my $j ($i+1..@items-1) { my $score = pair_score($datav->[$i],$datav->[$j]); push @{$scores->{$score}}, ($i,$j); } } # now go through the sets of items with # same scores and hierarchically cluster them # based on a distance matrix generated by the score function for my $score (sort {$b <=> $a} keys %$scores) { my @item_idx = uniq(@{$scores->{$score}}); printf("score %d items %s\n",$score,join(",",@items[@item_idx])); cluster_and_report(@item_idx); } # distances matrix sub distance_matrix { my @item_idx = @_; my $distances; for my $i (0..@item_idx-1) { push @{$distances},[]; for my $j (0..$i-1) { push @{$distances->[-1]}, pair_score( $datav->[$item_idx[$i]],$datav->[$item_idx[$j]] ); } } return $distances; } # decide how to score a pair of items sub pair_score { my ($x,$y) = @_; my $score = 0; for my $i (0..@$x-1) { if($x->[$i] == $y->[$i]) { $score += $x->[$i]; # +1 score for a shared attribute } else { #$score--; # potential penalty for unshared attributes } } return $score; } sub cluster_and_report { my @item_idx = @_; my $zerov = [ map { 0 } @attr ]; my %param = ( data => distance_matrix(@item_idx), mask => [ map { $zerov } @item_idx ], weight => [ map { 1 } @attr ], transpose => 0, dist => "e", method => "s", ); my $tree = Algorithm::Cluster::treecluster(%param); for my $cut_level (1..int(@item_idx)) { my ($clusters) = $tree->cut($cut_level); #printdumper($clusters); my @cluster_ids = uniq(@$clusters); for my $cluster_id (@cluster_ids) { my @cluster_item_idx = map { $item_idx[$_] } grep($clusters->[$_] == $cluster_id, (0..@item_idx-1)); my @shared_vector = shared_vector( map { $datav->[$_] } @cluster_item_idx); my @shared_attr = map { $attr[$_] } grep($shared_vector[$_], (0..@shared_vector-1)); printinfo(sprintf("cut level %d cluster,items,attr %d %d %d %s %s", $cut_level, $cluster_id, int(@cluster_item_idx), int(@shared_attr), join(",",@items[@cluster_item_idx]), join(",",@shared_attr))); } } } # use the shared attributes as a string to find sets of # items that share same attribute sub shared_vector { my @datav = @_; my $shared; for my $i (0..@{$datav[0]}-1) { if(grep($_->[$i] == 1, @datav) == @datav) { push @$shared, 1; } else { push @$shared, 0; } } return @$shared; }