10_kcluster.t

聚类分析的源码集

my ($last_test,$loaded);

######################### We start with some black magic to print on failure.
use lib '../blib/lib','../blib/arch';

BEGIN { $last_test = 36; $| = 1; print "1..$last_test\n"; }
END   { print "not ok 1  Can't load Algorithm::Cluster\n" unless $loaded; }

use Algorithm::Cluster;
no  warnings 'Algorithm::Cluster';

$loaded = 1;
print "ok 1\n";

######################### End of black magic.

sub test;  # Predeclare the test function (defined below)

my $tcounter = 1;
my $want     = '';


#------------------------------------------------------
# Data for Tests
# 

#----------
# dataset 1
#
my $weight1 =  [ 1,1,1,1,1 ];
my $data1   =  [
        [ 1.1, 2.2, 3.3, 4.4, 5.5, ], 
        [ 3.1, 3.2, 1.3, 2.4, 1.5, ], 
        [ 4.1, 2.2, 0.3, 5.4, 0.5, ], 
        [ 12.1, 2.0, 0.0, 5.0, 0.0, ], 
];
my $mask1 =  [
        [ 1, 1, 1, 1, 1, ], 
        [ 1, 1, 1, 1, 1, ], 
        [ 1, 1, 1, 1, 1, ], 
        [ 1, 1, 1, 1, 1, ], 
];

#----------
# dataset 2
#
my $weight2 =  [ 1,1 ];
my $data2   =  [
	[ 1.1, 1.2 ],
	[ 1.4, 1.3 ],
	[ 1.1, 1.5 ],
	[ 2.0, 1.5 ],
	[ 1.7, 1.9 ],
	[ 1.7, 1.9 ],
	[ 5.7, 5.9 ],
	[ 5.7, 5.9 ],
	[ 3.1, 3.3 ],
	[ 5.4, 5.3 ],
	[ 5.1, 5.5 ],
	[ 5.0, 5.5 ],
	[ 5.1, 5.2 ],
];
my $mask2 =  [
	[ 1, 1 ],
	[ 1, 1 ],
	[ 1, 1 ],
	[ 1, 1 ],
	[ 1, 1 ],
	[ 1, 1 ],
	[ 1, 1 ],
	[ 1, 1 ],
	[ 1, 1 ],
	[ 1, 1 ],
	[ 1, 1 ],
	[ 1, 1 ],
	[ 1, 1 ],
];


#------------------------------------------------------
# Tests
# 
my ($clusters, $centroids, $error, $found);
my ($i,$j);

my %params = (

	nclusters =>         3,
	transpose =>         0,
	npass     =>       100,
	method    =>       'a',
	dist      =>       'e',
);

#----------
# test dataset 1
#
($clusters, $centroids, $error, $found) = Algorithm::Cluster::kcluster(

	%params,
	data      =>    $data1,
	mask      =>    $mask1,
	weight    =>  $weight1,
);

#$i=0;$j=0;
#foreach(@{$centroids}) {
#	$j=0;
#	foreach(@{$_}) {
#		printf("%2d,%2d: %7.3f\n",$i,$j++,$_);
#	}
#	++$i;
#}
#
#$i=0;$j=0;
#foreach(@{$clusters}) {
#	printf("%2d: %2d\n",$i++,$_);
#}

#----------
# Make sure that the length of @clusters matches the length of @data
$want = scalar @$data1;       test q( scalar @$clusters );

# Make sure that we got the right number of clusters (in @centroids)
$want = $params{nclusters};       test q( scalar @$centroids );

#----------
# Test the cluster coordinates
$want = '1';       test q( $clusters->[ 0] != $clusters->[ 1] );
$want = '1';       test q( $clusters->[ 1] == $clusters->[ 2] );
$want = '1';       test q( $clusters->[ 2] != $clusters->[ 3] );

$want = '  1.100';       test q( sprintf "%7.3f", $centroids->[$clusters->[0]]->[0] );
$want = '  2.200';       test q( sprintf "%7.3f", $centroids->[$clusters->[0]]->[1] );
$want = '  3.300';       test q( sprintf "%7.3f", $centroids->[$clusters->[0]]->[2] );
$want = '  4.400';       test q( sprintf "%7.3f", $centroids->[$clusters->[0]]->[3] );

$want = '  3.600';       test q( sprintf "%7.3f", $centroids->[$clusters->[1]]->[0] );
$want = '  2.700';       test q( sprintf "%7.3f", $centroids->[$clusters->[1]]->[1] );
$want = '  0.800';       test q( sprintf "%7.3f", $centroids->[$clusters->[1]]->[2] );
$want = '  3.900';       test q( sprintf "%7.3f", $centroids->[$clusters->[1]]->[3] );

$want = ' 12.100';       test q( sprintf "%7.3f", $centroids->[$clusters->[3]]->[0] );
$want = '  2.000';       test q( sprintf "%7.3f", $centroids->[$clusters->[3]]->[1] );
$want = '  0.000';       test q( sprintf "%7.3f", $centroids->[$clusters->[3]]->[2] );
$want = '  5.000';       test q( sprintf "%7.3f", $centroids->[$clusters->[3]]->[3] );

# Test the within-cluster sum of errors
$want = '  6.500';       test q( sprintf "%7.3f", $error);


#----------
# test dataset 2
#
$i=0;$j=0;
($clusters, $centroids, $error, $found) = Algorithm::Cluster::kcluster(

	%params,
	data      =>    $data2,
	mask      =>    $mask2,
	weight    =>  $weight2,
);

#$i=0;$j=0;
#foreach(@{$centroids}) {
#	$j=0;
#	foreach(@{$_}) {
#		printf("%2d,%2d: %7.3f\n",$i,$j++,$_);
#	}
#	++$i;
#}
#
#$i=0;$j=0;
#foreach(@{$clusters}) {
#	printf("%2d: %2d\n",$i++,$_);
#}


#----------
# Make sure that the length of @clusters matches the length of @data
$want = scalar @$data2;       test q( scalar @$clusters );

# Make sure that we got the right number of clusters (in @centroids)
$want = $params{nclusters};       test q( scalar @$centroids );

#----------
# Test the cluster coordinates
$want = '1';       test q( $clusters->[ 0] == $clusters->[ 3] );
$want = '1';       test q( $clusters->[ 0] != $clusters->[ 6] );
$want = '1';       test q( $clusters->[ 0] != $clusters->[ 9] );
$want = '1';       test q( $clusters->[11] == $clusters->[12] );

$want = '  1.500';       test q( sprintf "%7.3f", $centroids->[$clusters->[0]]->[0] );
$want = '  1.550';       test q( sprintf "%7.3f", $centroids->[$clusters->[0]]->[1] );
$want = '  1.500';       test q( sprintf "%7.3f", $centroids->[$clusters->[1]]->[0] );
$want = '  1.550';       test q( sprintf "%7.3f", $centroids->[$clusters->[1]]->[1] );

$want = '  5.333';       test q( sprintf "%7.3f", $centroids->[$clusters->[6]]->[0] );
$want = '  5.550';       test q( sprintf "%7.3f", $centroids->[$clusters->[6]]->[1] );
$want = '  5.333';       test q( sprintf "%7.3f", $centroids->[$clusters->[7]]->[0] );
$want = '  5.550';       test q( sprintf "%7.3f", $centroids->[$clusters->[7]]->[1] );

$want = '  3.100';       test q( sprintf "%7.3f", $centroids->[$clusters->[8]]->[0] );
$want = '  3.300';       test q( sprintf "%7.3f", $centroids->[$clusters->[8]]->[1] );

# Test the within-cluster sum of errors
$want = '  2.023';       test q( sprintf "%7.3f", $error);


#------------------------------------------------------
# Test function
# 
sub test {
	$tcounter++;

	my $string = shift;
	my $ret = eval $string;
	$ret = 'undef' if not defined $ret;

	if("$ret" =~ /^$want$/sm) {

		print "ok $tcounter\n";

	} else {
		print "not ok $tcounter\n",
		"   -- '$string' returned '$ret'\n", 
		"   -- expected =~ /$want/\n"
	}
}

__END__