File Coverage

blib/lib/Algorithm/Cluster/Thresh.pm

Criterion	Covered	Total	%
statement	31	31	100.0
branch	7	8	87.5
condition			n/a
subroutine	7	7	100.0
pod			n/a
total	45	46	97.8

package Algorithm::Cluster::Thresh;
BEGIN {
  $Algorithm::Cluster::Thresh::VERSION = '0.05';
}
# ABSTRACT: Adds thresholding to hierarchical clustering of Algorithm::Cluster
use Algorithm::Cluster;



# Add new method to standard package:
package Algorithm::Cluster::Tree;
BEGIN {
  $Algorithm::Cluster::Tree::VERSION = '0.05';
}
use strict;
use warnings;
use 5.008;

sub cutthresh {
    my ($tree, $thresh) = @_;
    my @nodecluster;
    my @leafcluster;
    # Binary tree: number of internal nodes is 1 less than # of leafs
    # Last node is the root, walking down the tree
    my $icluster = 0;
    # Elements in tree
    my $length = $tree->length;
    # Root node belongs to cluster 0
    $nodecluster[$length-1] = $icluster++;
    for (my $i = $length-1; $i >= 0; $i--) {
        my $node = $tree->get($i);
#        print sprintf "%3d %3d %.3f\n", $i,$nodecluster[$i], $node->distance;
        my $left = $node->left;
        # Nodes are numbered -1,-2,... Leafs are numbered 0,1,2,...
        my $leftref = $left < 0 ? \$nodecluster[-$left-1] : \$leafcluster[$left];
        my $assigncluster = $nodecluster[$i];
        # Left is always the same as the parent node's cluster
        $$leftref = $assigncluster;
#        print sprintf "\tleft  %3d %3d\n", $left, $$leftref;
        my $right = $node->right;
        # Put right into a new cluster, when thresh not satisfied
        if ($node->distance > $thresh) { $assigncluster = $icluster++ }
        my $rightref = $right < 0 ? \$nodecluster[-$right-1] : \$leafcluster[$right];
        $$rightref = $assigncluster;
#        print sprintf "\tright %3d %3d\n", $right, $$rightref;
    }
    return wantarray ? @leafcluster : \@leafcluster;
}

1;

__END__