File Coverage

blib/lib/Algorithm/MCL.pm
Criterion Covered Total %
statement 1 3 33.3
branch n/a
condition n/a
subroutine 1 1 100.0
pod n/a
total 2 4 50.0


line stmt bran cond sub pod time code
1             package Algorithm::MCL;
2              
3             # ABSTRACT: perl module implementing Markov Cluster Algorithm using PDL
4              
5              
6              
7 1     1   31150 use PDL;
  0            
  0            
8             use Inline 'Pdlpp';
9             use Mouse;
10              
11             no PDL::NiceSlice;
12              
13             BEGIN {
14             $PDL::BIGPDL = 1;
15             }
16              
17              
18             has '_allVerts' => ( is => 'rw', isa => 'HashRef', default => sub { {} } );
19             has '_vectors' => ( is => 'rw', isa => 'HashRef', default => sub { {} } );
20             has '_orderedAllVerts' => ( is => 'rw', isa => 'ArrayRef', default => sub { [] } );
21              
22              
23              
24             sub addEdge {
25             my $self = shift;
26             my ( $vertex1, $vertex2, $edgeWeight ) = @_;
27              
28             $self->addDirectEdge($vertex1, $vertex2, $edgeWeight);
29             $self->addDirectEdge($vertex2, $vertex1, $edgeWeight);
30             }
31              
32              
33              
34             sub addDirectEdge {
35             my $self = shift;
36             my ( $from, $to, $edgeWeight ) = @_;
37              
38             $edgeWeight ||= 1;
39              
40             unless ( $self->_allVerts->{$from} ) {
41             push @{$self->_orderedAllVerts}, "$from";
42             $self->_allVerts->{$from} = $from;
43             }
44             unless ( $self->_allVerts->{$to} ) {
45             push @{$self->_orderedAllVerts}, "$to";
46             $self->_allVerts->{$to} = $to;
47             }
48              
49             my $vertexEdges = $self->_vectors->{ $from };
50             unless ( $vertexEdges )
51             {
52             $vertexEdges = {};
53             $self->_vectors->{ $from } = $vertexEdges;
54             }
55              
56             $vertexEdges->{ $to } = $edgeWeight;
57              
58             my $toVertexEdges = $self->_vectors->{ $to };
59             unless ( $toVertexEdges )
60             {
61             $toVertexEdges = {};
62             $self->_vectors->{ $to } = $toVertexEdges;
63             }
64              
65             unless (defined $toVertexEdges->{$from})
66             {
67             $toVertexEdges->{$from} = 0;
68             }
69             }
70              
71              
72              
73             sub run {
74             my $self = shift;
75              
76             my @verts = @{$self->_orderedAllVerts};
77             my $numOfVerts = scalar @verts;
78              
79             my $vertsOffsets = {};
80             for (my $kk=0; $kk < $numOfVerts; ++$kk)
81             {
82             $vertsOffsets->{ $verts[ $kk ] } = $kk;
83             }
84              
85             my $matrix = zeros($numOfVerts, $numOfVerts);
86              
87             for (my $ii=0; $ii < $numOfVerts; ++$ii)
88             {
89             my $vector = $self->_vectors->{ $verts[ $ii ] };
90             for (my $jj=0; $jj < $numOfVerts; ++$jj)
91             {
92             if (exists $vector->{ $verts[ $jj ] })
93             {
94             $matrix->set( $ii, $jj, $vector->{ $verts[ $jj ] } );
95             }
96             }
97             }
98              
99             $matrix->inplace->addLoops;
100             $matrix->inplace->makeStochastic;
101              
102             my $resultMatrix = $self->mcl( $matrix );
103              
104             my $clusters = $self->extractClusters($resultMatrix, $numOfVerts);
105              
106             return $clusters;
107             }
108              
109              
110             sub mcl {
111             my $self = shift;
112             my ( $matrix ) = @_;
113              
114             my $chaos = 1;
115             while ($chaos > 0.0001) {
116             my $mx = $matrix x $matrix;
117             my $cList = $mx->inplace->inflate;
118             $chaos = $cList->max;
119             $matrix = $mx;
120             }
121             $matrix->inplace->cleanSmall;
122              
123             return $matrix;
124             }
125              
126              
127             sub extractClusters {
128             my $self = shift;
129             my ( $resultMatrix, $numOfVerts ) = @_;
130              
131             my $clIdxs = $resultMatrix->getClustersIndex;
132              
133             my $clusters = [];
134             for ( my $ii=0; $ii < $numOfVerts; ++$ii )
135             {
136             if ($clIdxs->at( $ii ))
137             {
138             my $cluster = [];
139             push @$cluster, $self->getIdxObj( $ii );
140             for ( my $jj=0; $jj < $numOfVerts; ++$jj )
141             {
142             if ($resultMatrix->at( $ii, $jj ))
143             {
144             if ( $ii != $jj )
145             {
146             push @$cluster, $self->getIdxObj( $jj );
147             $clIdxs->set( $jj, 0 );
148             }
149             }
150             }
151             push @$clusters, $cluster
152             }
153             }
154              
155             return $clusters;
156             }
157              
158              
159             sub getIdxObj {
160             my $self = shift;
161             my ( $idx ) = @_;
162              
163             return$self->_allVerts->{$self->_orderedAllVerts->[$idx]};
164             }
165              
166              
167              
168             __PACKAGE__->meta->make_immutable();
169              
170              
171              
172              
173              
174             =pod
175              
176             =head1 NAME
177              
178             Algorithm::MCL - perl module implementing Markov Cluster Algorithm using PDL
179              
180             =head1 VERSION
181              
182             version 0.004
183              
184             =head1 SYNOPSIS
185              
186             use Algorithm::MCL;
187            
188             my $obj1 = new MyClass;
189             my $ref2 = {};
190             my $ref3 = \"abc";
191             my $ref4 = \$val1;
192             my $ref5 = [];
193            
194             my $mcl1 = Algorithm::MCL->new();
195            
196             # create graph by adding edges
197             $mcl1->addEdge($obj1, $ref2);
198             $mcl1->addEdge($obj1, $ref3);
199             $mcl1->addEdge($ref2, $ref3);
200             $mcl1->addEdge($ref3, $ref4);
201             $mcl1->addEdge($ref4, $ref5);
202              
203             # run MCL algorithm on created graph
204             my $clusters1 = $mcl1->run();
205            
206             # get clusters
207             foreach my $cluster ( @$clusters1 ) {
208             print "Cluster size: ". scalar @$cluster. "\n";
209             }
210            
211            
212             ####################################
213            
214             my $val1 = \"aaa";
215             my $val2 = \"bbb";
216             my $val3 = \"ccc";
217             my $val4 = \"ddd";
218             my $val5 = \"eee";
219            
220             my $mcl2 = Algorithm::MCL->new();
221             $mcl2->addEdge($val1, $val2);
222             $mcl2->addEdge($val1, $val3);
223             $mcl2->addEdge($val2, $val3);
224             $mcl2->addEdge($val3, $val4);
225             $mcl2->addEdge($val4, $val5);
226            
227             my $clusters2 = $mcl2->run();
228            
229             foreach my $cluster ( @$clusters2 ) {
230             print "Found Cluster\n";
231             foreach my $vertex ( @$cluster ) {
232             print " Cluster element: $$vertex \n";
233             }
234             }
235              
236             =head1 DESCRIPTION
237              
238             This module is perl implementation of Markov Cluster Algorithm (MCL) based on Perl Data Language (PDL).
239              
240             MCL is algorithm of finding clusters of vertices in graph. More information about MCL can be found at L. There is also perl script implementing MCL - minimcl L.
241              
242             This module try to solve two problems:
243              
244             =over 2
245              
246             =item *
247              
248             easy integration MCL in perl scripts and modules. Algorithm::MCL accept references as input and every reference will be found later in some cluster.
249              
250             =item *
251              
252             performance and scale. Algorithm::MCL use Perl Data Language for most of its processing and should run very fast on very big clusters. Main Algorithm::MCL procedures are written with "pdlpp".
253              
254             =back
255              
256             =head1 METHODS
257              
258             =head2 new()
259              
260             create new Algorithm::MCL object that accumulate graph edges and process data.
261              
262             =head2 addEdge($ref1, $ref2, $distance)
263              
264             add new edge to graph. first two parameters are reference to vertex objects. third parameter is "connection strength measurement" between vetices. "connection strength measurement" should be number between 0 and 1, higher number means stronger connectivity. if "connection strength measurement" is not defined it set to 1.
265              
266             =head2 run()
267              
268             apply MCL algorithm on graph. return reference to array that every element is reference to cluser array.
269              
270             =head1 AUTHOR
271              
272             Pinkhas Nisanov
273              
274             =head1 COPYRIGHT AND LICENSE
275              
276             This software is copyright (c) 2012 by Pinkhas Nisanov.
277              
278             This is free software; you can redistribute it and/or modify it under
279             the same terms as the Perl 5 programming language system itself.
280              
281             =cut
282              
283              
284             __DATA__