Algorithm-Cluster
view release on metacpan or search on metacpan
perl/Cluster.pm view on Meta::CPAN
$param->{mask} = $default->{mask};
}
}
#----------------------------------
# Check the weight array
#
unless(ref $param->{weight} eq 'ARRAY') {
module_warn("Parameter 'weight' does not point to an array, ignoring it.");
$param->{weight} = $default->{weight};
} else {
my $weight_length = scalar @{ $param->{weight} };
if ($param->{transpose} eq 0) {
unless ($param->{ncols} == $weight_length) {
module_warn("Data matrix has $param->{ncols} columns, but weight array has $weight_length items.\nIgnoring the weight array.");
$param->{weight} = $default->{weight}
}
}
else {
unless ($param->{nrows} == $weight_length) {
module_warn("Data matrix has $param->{nrows} rows, but weight array has $weight_length items.\nIgnoring the weight array.");
$param->{weight} = $default->{weight}
}
}
}
return 1;
}
sub check_distance_matrix {
my $distances = $_[0];
perl/Cluster.xs view on Meta::CPAN
RETVAL = newSViv(0);
obj = newSVrv(RETVAL, class);
sv_setiv(obj, PTR2IV(tree));
SvREADONLY_on(obj);
OUTPUT:
RETVAL
int
length (obj)
SV* obj
CODE:
RETVAL = (INT2PTR(Tree*,SvIV(SvRV(obj))))->n;
OUTPUT:
RETVAL
SV *
get (obj, index)
SV* obj
perl/Cluster.xs view on Meta::CPAN
OUTPUT:
RETVAL
SV *
_mean(input)
SV * input;
PREINIT:
int array_length;
double * data; /* one-dimensional array of doubles */
CODE:
if(SvTYPE(SvRV(input)) != SVt_PVAV) {
XSRETURN_UNDEF;
}
data = malloc_row_perl2c_dbl (aTHX_ input, &array_length);
if (data) {
RETVAL = newSVnv( mean(array_length, data) );
free(data);
} else {
croak("memory allocation failure in _mean\n");
}
OUTPUT:
RETVAL
SV *
_median(input)
SV * input;
PREINIT:
int array_length;
double * data; /* one-dimensional array of doubles */
CODE:
if(SvTYPE(SvRV(input)) != SVt_PVAV) {
XSRETURN_UNDEF;
}
data = malloc_row_perl2c_dbl (aTHX_ input, &array_length);
if (data) {
RETVAL = newSVnv( median(array_length, data) );
free(data);
} else {
croak("memory allocation failure in _median\n");
}
OUTPUT:
RETVAL
SV *
perl/Record.pm view on Meta::CPAN
if (defined $param{geneclusters}) {
$geneclusters = $param{geneclusters};
if (ref($geneclusters) eq "ARRAY") {
if (scalar @{$geneclusters} != $ngenes) {
die "k-means solution found, but its size does not agree with the number of genes";
}
$gene_cluster_type = 'k'; # k-means clustering result
}
elsif (ref($geneclusters) eq "Algorithm::Cluster::Tree") {
$gene_cluster_type = 'h'; # hierarchical clustering result
my $n = $geneclusters->length;
if ($n != $ngenes - 1) {
die "Size of the hierarchical clustering tree ($n) should be equal to the number of genes ($ngenes) minus one";
}
}
else {
die "Cannot understand gene clustering result! $!";
}
}
if (defined $param{expclusters}) {
$expclusters = $param{expclusters};
if (ref($expclusters) eq "ARRAY") {
if (scalar @$expclusters != $nexps) {
die "k-means solution found, but its size does not agree with the number of experiments";
}
$exp_cluster_type = 'k'; # k-means clustering result
}
elsif (ref($expclusters) eq "Algorithm::Cluster::Tree") {
$exp_cluster_type = 'h'; # hierarchical clustering result
my $n = $expclusters->length;
if ($n != $nexps - 1) {
die "Size of the hierarchical clustering tree ($n) should be equal to the number of experiments ($nexps) minus one";
}
}
else {
die "Cannot understand experiment clustering result! $!";
}
}
my @gorder;
if (defined $self->{gorder}) {
perl/Record.pm view on Meta::CPAN
my $transpose = $param{transpose};
my ($extension, $keyword);
if ($transpose==0) {
$extension = 'gtr';
$keyword = 'GENE';
}
else {
$extension = 'atr';
$keyword = 'ARRY';
}
my $nnodes = $tree->length;
open OUTPUT, ">$jobname.$extension" or die 'Error: Unable to open output file';
my @nodeID = ('') x $nnodes;
my @nodedist;
my $i;
for ($i = 0; $i < $nnodes; $i++) {
my $node = $tree->get($i);
push (@nodedist, $node->distance);
}
for (my $nodeindex = 0; $nodeindex < $nnodes; $nodeindex++) {
my $min1 = $tree->get($nodeindex)->left;
perl/examples/ex5_treecluster view on Meta::CPAN
data => $data,
mask => $mask,
weight => $weight,
);
my $tree;
my ($i,$j,$n);
my $tree = Algorithm::Cluster::treecluster(%params);
$n = $tree->length;
for ($i = 0; $i < $n; $i++) {
my $node = $tree->get($i);
printf("%3d: %3d %3d %7.3f\n",-1-$i,$node->left,$node->right,$node->distance);
}
print "--------------[pairwise single linkage]-------\n";
$params{method} = 's';
$tree = Algorithm::Cluster::treecluster(%params);
$n = $tree->length;
for ($i = 0; $i < $n; $i++) {
my $node = $tree->get($i);
printf("%3d: %3d %3d %7.3f\n",-1-$i,$node->left,$node->right,$node->distance);
}
print "--------------[pairwise centroid linkage]-------\n";
$params{method} = 'c';
$tree= Algorithm::Cluster::treecluster(%params);
$n = $tree->length;
for ($i = 0; $i < $n; $i++) {
my $node = $tree->get($i);
printf("%3d: %3d %3d %7.3f\n",-1-$i,$node->left,$node->right,$node->distance);
}
print "--------------[pairwise maximum linkage]-------\n";
$params{method} = 'm';
$tree = Algorithm::Cluster::treecluster(%params);
$n = $tree->length;
for ($i = 0; $i < $n; $i++) {
my $node = $tree->get($i);
printf("%3d: %3d %3d %7.3f\n",-1-$i,$node->left,$node->right,$node->distance);
}
print "--------------------[tree sorting]-------------\n";
my $order = [ 1,2,3,4,5,6,1,1,1,2,2,2,2 ];
my @indices = $tree->sort($order);
for ($i = 0; $i < $n; $i++) {
perl/t/02_tree.t view on Meta::CPAN
my $node;
my $node1 = Algorithm::Cluster::Node->new(1,2,3.1);
my $node2 = Algorithm::Cluster::Node->new(-1,3,5.3);
my $node3 = Algorithm::Cluster::Node->new(4,0,5.9);
my $node4 = Algorithm::Cluster::Node->new(-2,-3,7.8);
my @nodes = [$node1,$node2,$node3,$node4];
my $tree = Algorithm::Cluster::Tree->new(@nodes);
is ($tree->length, 4);
$node = $tree->get(0);
is ($node->left, 1);
is ($node->right, 2);
is (sprintf ("%7.4f", $node->distance), ' 3.1000');
$node = $tree->get(1);
is ($node->left, -1);
is ($node->right, 3);
is (sprintf ("%7.4f", $node->distance), ' 5.3000');
perl/t/10_kcluster.t view on Meta::CPAN
#
($clusters, $error, $found) = Algorithm::Cluster::kcluster(
%params,
data => $data1,
mask => $mask1,
weight => $weight1,
npass => 100,
);
#----------
# Make sure that the length of @clusters matches the length of @data
ok( scalar @$data1 == scalar @$clusters);
#----------
# Test the cluster coordinates
ok ( $clusters->[ 0] != $clusters->[ 1] );
ok ( $clusters->[ 1] == $clusters->[ 2] );
ok ( $clusters->[ 2] != $clusters->[ 3] );
# Test the within-cluster sum of errors
ok( sprintf ("%7.3f", $error) == ' 1.300');
perl/t/10_kcluster.t view on Meta::CPAN
($clusters, $error, $found) = Algorithm::Cluster::kcluster(
%params,
data => $data2,
mask => $mask2,
weight => $weight2,
npass => 100,
);
#----------
# Make sure that the length of @clusters matches the length of @data
ok (scalar @$data2 == scalar @$clusters);
#----------
# Test the cluster coordinates
ok ($clusters->[ 0] == $clusters->[ 3]);
ok ($clusters->[ 0] != $clusters->[ 6]);
ok ($clusters->[ 0] != $clusters->[ 9]);
ok ($clusters->[11] == $clusters->[12]);
# Test the within-cluster sum of errors
perl/t/12_treecluster.t view on Meta::CPAN
transpose => 0,
method => 'a',
dist => 'e',
data => $data1,
mask => $mask1,
weight => $weight1,
);
$tree = Algorithm::Cluster::treecluster(%params);
# Make sure that @clusters and @centroids are the right length
is (scalar(@$data1) - 1, $tree->length );
$node = $tree->get(0);
is ($node->left, 2);
is ($node->right, 1);
is (sprintf("%7.3f", $node->distance), " 2.600");
$node = $tree->get(1);
is ($node->left, -1);
is ($node->right, 0);
is (sprintf("%7.3f", $node->distance), " 7.300");
perl/t/12_treecluster.t view on Meta::CPAN
is ($node->left, 3);
is ($node->right, -2);
is (sprintf("%7.3f", $node->distance), " 21.348");
#--------------[PSLcluster]-------
$params{method} = 's';
$tree = Algorithm::Cluster::treecluster(%params);
# Make sure that @clusters and @centroids are the right length
is (scalar(@$data1) - 1, $tree->length );
$node = $tree->get(0);
is ($node->left, 1);
is ($node->right, 2);
is (sprintf("%7.3f", $node->distance), " 2.600");
$node = $tree->get(1);
is ($node->left, 0);
is ($node->right, -1);
is (sprintf("%7.3f", $node->distance), " 5.800");
perl/t/12_treecluster.t view on Meta::CPAN
is ($node->left, -2);
is ($node->right, 3);
is (sprintf("%7.3f", $node->distance), " 12.908");
#--------------[PCLcluster]-------
$params{method} = 'c';
$tree = Algorithm::Cluster::treecluster(%params);
# Make sure that @clusters and @centroids are the right length
is (scalar(@$data1) - 1, $tree->length );
$node = $tree->get(0);
is ($node->left, 1);
is ($node->right, 2);
is (sprintf("%7.3f", $node->distance), " 2.600");
$node = $tree->get(1);
is ($node->left, 0);
is ($node->right, -1);
is (sprintf("%7.3f", $node->distance), " 6.650");
perl/t/12_treecluster.t view on Meta::CPAN
is ($node->left, -2);
is ($node->right, 3);
is (sprintf("%7.3f", $node->distance), " 19.437");
#--------------[PMLcluster]-------
$params{method} = 'm';
$tree = Algorithm::Cluster::treecluster(%params);
# Make sure that @clusters and @centroids are the right length
is (scalar(@$data1) - 1, $tree->length );
$node = $tree->get(0);
is ($node->left, 2);
is ($node->right, 1);
is (sprintf("%7.3f", $node->distance), " 2.600");
$node = $tree->get(1);
is ($node->left, -1);
is ($node->right, 0);
is (sprintf("%7.3f", $node->distance), " 8.800");
perl/t/12_treecluster.t view on Meta::CPAN
transpose => 0,
method => 'a',
dist => 'e',
data => $data2,
mask => $mask2,
weight => $weight2,
);
$tree = Algorithm::Cluster::treecluster(%params);
# Make sure that @clusters and @centroids are the right length
is (scalar(@$data2) - 1, $tree->length);
$node = $tree->get(0);
is ($node->left, 5);
is ($node->right, 4);
is (sprintf("%7.3f", $node->distance), " 0.003");
$node = $tree->get(1);
is ($node->left, 9);
is ($node->right, 12);
perl/t/12_treecluster.t view on Meta::CPAN
is ($node->right, -10);
is (sprintf("%7.3f", $node->distance), " 12.741");
#--------------[PSLcluster]-------
$params{method} = 's';
$tree = Algorithm::Cluster::treecluster(%params);
# Make sure that @clusters and @centroids are the right length
is (scalar(@$data2) - 1, $tree->length );
$node = $tree->get(0);
is ($node->left, 4);
is ($node->right, 5);
is (sprintf("%7.3f", $node->distance), " 0.003");
$node = $tree->get(1);
is ($node->left, 9);
is ($node->right, 12);
perl/t/12_treecluster.t view on Meta::CPAN
is ($node->left, 6);
is ($node->right, -11);
is (sprintf("%7.3f", $node->distance), " 3.535");
#--------------[PCLcluster]-------
$params{method} = 'c';
$tree = Algorithm::Cluster::treecluster(%params);
# Make sure that @clusters and @centroids are the right length
is (scalar(@$data2) - 1, $tree->length );
$node = $tree->get(0);
is ($node->left, 4);
is ($node->right, 5);
is (sprintf("%7.3f", $node->distance), " 0.003");
$node = $tree->get(1);
is ($node->left, 12);
perl/t/12_treecluster.t view on Meta::CPAN
is ($node->left, -10);
is ($node->right, -11);
is (sprintf("%7.3f", $node->distance), " 11.536");
#--------------[PMLcluster]-------
$params{method} = 'm';
$tree = Algorithm::Cluster::treecluster(%params);
# Make sure that @clusters and @centroids are the right length
is ( scalar(@$data2) - 1, $tree->length );
$node = $tree->get(0);
is ($node->left, 5);
is ($node->right, 4);
is (sprintf("%7.3f", $node->distance), " 0.003");
$node = $tree->get(1);
is ($node->left, 9);
is ($node->right, 12);
perl/t/12_treecluster.t view on Meta::CPAN
[10.0, 19.3, 2.2, 3.7, 9.1, 1.2, 9.3, 15.7, 6.3, 16.0, 11.5]
];
%params = (
method => 's',
data => $matrix,
);
$tree = Algorithm::Cluster::treecluster(%params);
# Make sure that @clusters and @centroids are the right length
is ( scalar(@$matrix) - 1, $tree->length );
$node = $tree->get(0);
is ($node->left, 2);
is ($node->right, 3);
is (sprintf("%7.3f", $node->distance), " 1.000");
$node = $tree->get(1);
is ($node->left, 4);
is ($node->right, 6);
is (sprintf("%7.3f", $node->distance), " 1.100");
perl/t/14_kmedoids.t view on Meta::CPAN
my %params1 = (
nclusters => 4,
distances => $matrix,
npass => 10000,
);
($clusters, $error, $found) = Algorithm::Cluster::kmedoids(%params1);
#----------
# Make sure that the length of @clusters matches the length of @data
is (scalar @$matrix, scalar @$clusters );
#----------
# Test the cluster assignments
is ($clusters->[ 0], 9);
is ($clusters->[ 1], 9);
is ($clusters->[ 2], 2);
is ($clusters->[ 3], 2);
is ($clusters->[ 4], 4);
is ($clusters->[ 5], 5);
perl/t/14_kmedoids.t view on Meta::CPAN
my %params2 = (
nclusters => 4,
distances => $matrix,
npass => 1,
initialid => $initialid,
);
($clusters, $error, $found) = Algorithm::Cluster::kmedoids(%params2);
#----------
# Make sure that the length of @clusters matches the length of @data
is (scalar @$matrix, scalar @$clusters );
#----------
# Test the cluster assignments
is ($clusters->[ 0], 9);
is ($clusters->[ 1], 9);
is ($clusters->[ 2], 2);
is ($clusters->[ 3], 2);
is ($clusters->[ 4], 4);
is ($clusters->[ 5], 2);
perl/t/15_distancematrix.t view on Meta::CPAN
$matrix = Algorithm::Cluster::distancematrix(
transpose => 0,
dist => 'e',
data => $data,
mask => $mask,
weight => $gweight,
);
#----------
# Make sure that the length of $matrix matches the length of @data1
is (scalar @$data, scalar @$matrix);
#----------
# Test the values in the distance matrix
is (sprintf ("%7.3f", $matrix->[1]->[0] ), ' 5.800');
is (sprintf ("%7.3f", $matrix->[2]->[0] ), ' 8.800');
is (sprintf ("%7.3f", $matrix->[2]->[1] ), ' 2.600');
is (sprintf ("%7.3f", $matrix->[3]->[0] ), ' 32.508');
is (sprintf ("%7.3f", $matrix->[3]->[1] ), ' 18.628');
perl/t/15_distancematrix.t view on Meta::CPAN
$matrix = Algorithm::Cluster::distancematrix(
transpose => 1,
dist => 'e',
data => $data,
mask => $mask,
weight => $eweight,
);
#----------
# Make sure that the length of $matrix matches the length of @data1
is (scalar @{$data->[0]}, scalar @$matrix );
#----------
# Test the values in the distance matrix
is (sprintf ("%6.2f", $matrix->[1]->[0] ), ' 26.71');
is (sprintf ("%6.2f", $matrix->[2]->[0] ), ' 42.23');
is (sprintf ("%6.2f", $matrix->[2]->[1] ), ' 3.11');
is (sprintf ("%6.2f", $matrix->[3]->[0] ), ' 15.87');
( run in 0.666 second using v1.01-cache-2.11-cpan-65fba6d93b7 )