File Coverage

blib/lib/Bio/Phylo/ListableRole.pm
Criterion Covered Total %
statement 120 179 67.0
branch 51 80 63.7
condition 33 42 78.5
subroutine 15 18 83.3
pod 12 12 100.0
total 231 331 69.7


line stmt bran cond sub pod time code
1             package Bio::Phylo::ListableRole;
2 51     51   283 use strict;
  51         94  
  51         1289  
3 51     51   1243 use Bio::Phylo::Util::MOP;
  51         114  
  51         329  
4 51     51   218 use base 'Bio::Phylo::NeXML::Writable';
  51         89  
  51         17092  
5 51     51   348 use Scalar::Util qw'blessed';
  51         102  
  51         2648  
6 51     51   282 use Bio::Phylo::Util::Exceptions 'throw';
  51         98  
  51         1930  
7 51     51   282 use Bio::Phylo::Util::CONSTANT qw':all';
  51         92  
  51         87427  
8              
9             {
10             my $logger = __PACKAGE__->get_logger;
11             my ( $DATUM, $NODE, $MATRIX, $TREE ) =
12             ( _DATUM_, _NODE_, _MATRIX_, _TREE_ );
13              
14             =head1 NAME
15              
16             Bio::Phylo::ListableRole - Extra functionality for things that are lists
17              
18             =head1 SYNOPSIS
19              
20             No direct usage, parent class. Methods documented here
21             are available for all objects that inherit from it.
22              
23             =head1 DESCRIPTION
24              
25             A listable object is an object that contains multiple smaller objects of the
26             same type. For example: a tree contains nodes, so it's a listable object.
27              
28             This class contains methods that are useful for all listable objects: Matrices
29             (i.e. sets of matrix objects), individual Matrix objects, Datum objects (i.e.
30             character state sequences), Taxa, Forest, Tree and Node objects.
31              
32             =head1 METHODS
33              
34             =head2 ARRAY METHODS
35              
36             =over
37              
38             =item prune_entities()
39              
40             Prunes the container's contents specified by an array reference of indices.
41              
42             Type : Mutator
43             Title : prune_entities
44             Usage : $list->prune_entities([9,7,7,6]);
45             Function: Prunes a subset of contents
46             Returns : A Bio::Phylo::Listable object.
47             Args : An array reference of indices
48              
49             =cut
50              
51             sub prune_entities {
52 0     0 1 0 my ( $self, @indices ) = @_;
53 0         0 my %indices = map { $_ => 1 } @indices;
  0         0  
54 0         0 my $last_index = $self->last_index;
55 0         0 my @keep;
56 0         0 for my $i ( 0 .. $last_index ) {
57 0 0       0 push @keep, $i if not exists $indices{$i};
58             }
59 0         0 return $self->keep_entities( \@keep );
60             }
61              
62             =item get_index_of()
63              
64             Returns the index of the argument in the list,
65             or undef if the list doesn't contain the argument
66              
67             Type : Accessor
68             Title : get_index_of
69             Usage : my $i = $listable->get_index_of($obj)
70             Function: Returns the index of the argument in the list,
71             or undef if the list doesn't contain the argument
72             Returns : An index or undef
73             Args : A contained object
74              
75             =cut
76              
77             sub get_index_of {
78 68     68 1 105 my ( $self, $obj ) = @_;
79 68         142 my $id = $obj->get_id;
80 68         103 my $i = 0;
81 68         81 for my $ent ( @{ $self->get_entities } ) {
  68         127  
82 148 100       238 return $i if $ent->get_id == $id;
83 80         111 $i++;
84             }
85 0         0 return;
86             }
87              
88             =item get_by_index()
89              
90             Gets element at index from container.
91              
92             Type : Accessor
93             Title : get_by_index
94             Usage : my $contained_obj = $obj->get_by_index($i);
95             Function: Retrieves the i'th entity
96             from a listable object.
97             Returns : An entity stored by a listable
98             object (or array ref for slices).
99             Args : An index or range. This works
100             the way you dereference any perl
101             array including through slices,
102             i.e. $obj->get_by_index(0 .. 10)>
103             $obj->get_by_index(0, -1)
104             and so on.
105             Comments: Throws if out-of-bounds
106              
107             =cut
108              
109             sub get_by_index {
110 123     123 1 4898 my $self = shift;
111 123         252 my $entities = $self->get_entities;
112 123         218 my @range = @_;
113 123 50       257 if ( scalar @range > 1 ) {
114 0         0 my @returnvalue;
115 0         0 eval { @returnvalue = @{$entities}[@range] };
  0         0  
  0         0  
116 0 0       0 if ($@) {
117 0         0 throw 'OutOfBounds' => 'index out of bounds';
118             }
119 0         0 return \@returnvalue;
120             }
121             else {
122 123         139 my $returnvalue;
123 123         152 eval { $returnvalue = $entities->[ $range[0] ] };
  123         205  
124 123 50       244 if ($@) {
125 0         0 throw 'OutOfBounds' => 'index out of bounds';
126             }
127 123         362 return $returnvalue;
128             }
129             }
130              
131             =item get_by_regular_expression()
132              
133             Gets elements that match regular expression from container.
134              
135             Type : Accessor
136             Title : get_by_regular_expression
137             Usage : my @objects = @{
138             $obj->get_by_regular_expression(
139             -value => $method,
140             -match => $re
141             ) };
142             Function: Retrieves the data in the
143             current Bio::Phylo::Listable
144             object whose $method output
145             matches $re
146             Returns : A list of Bio::Phylo::* objects.
147             Args : -value => any of the string
148             datum props (e.g. 'get_type')
149             -match => a compiled regular
150             expression (e.g. qr/^[D|R]NA$/)
151              
152             =cut
153              
154             sub get_by_regular_expression {
155 17     17 1 4093 my $self = shift;
156 17         89 my %o = looks_like_hash @_;
157 17         45 my @matches;
158 17         34 for my $e ( @{ $self->get_entities } ) {
  17         74  
159 175 100 66     844 if ( $o{-match} && looks_like_instance( $o{-match}, 'Regexp' ) ) {
160 174 100 100     621 if ( $e->get( $o{-value} )
161             && $e->get( $o{-value} ) =~ $o{-match} )
162             {
163 13         58 push @matches, $e;
164             }
165             }
166             else {
167 1         4 throw 'BadArgs' => 'need a regular expression to evaluate';
168             }
169             }
170 15         90 return \@matches;
171             }
172              
173             =item get_by_value()
174              
175             Gets elements that meet numerical rule from container.
176              
177             Type : Accessor
178             Title : get_by_value
179             Usage : my @objects = @{ $obj->get_by_value(
180             -value => $method,
181             -ge => $number
182             ) };
183             Function: Iterates through all objects
184             contained by $obj and returns
185             those for which the output of
186             $method (e.g. get_tree_length)
187             is less than (-lt), less than
188             or equal to (-le), equal to
189             (-eq), greater than or equal to
190             (-ge), or greater than (-gt) $number.
191             Returns : A reference to an array of objects
192             Args : -value => any of the numerical
193             obj data (e.g. tree length)
194             -lt => less than
195             -le => less than or equals
196             -eq => equals
197             -ge => greater than or equals
198             -gt => greater than
199              
200             =cut
201              
202             sub get_by_value {
203 28     28 1 53 my $self = shift;
204 28         72 my %o = looks_like_hash @_;
205 28         49 my @results;
206 28         37 for my $e ( @{ $self->get_entities } ) {
  28         64  
207 116 100       193 if ( $o{-eq} ) {
208 22 100 100     49 if ( $e->get( $o{-value} )
209             && $e->get( $o{-value} ) == $o{-eq} )
210             {
211 3         8 push @results, $e;
212             }
213             }
214 115 100       177 if ( $o{-le} ) {
215 22 100 100     50 if ( $e->get( $o{-value} )
216             && $e->get( $o{-value} ) <= $o{-le} )
217             {
218 5         12 push @results, $e;
219             }
220             }
221 114 100       176 if ( $o{-lt} ) {
222 24 100 100     126 if ( $e->get( $o{-value} )
223             && $e->get( $o{-value} ) < $o{-lt} )
224             {
225 6         13 push @results, $e;
226             }
227             }
228 113 100       174 if ( $o{-ge} ) {
229 24 100 100     50 if ( $e->get( $o{-value} )
230             && $e->get( $o{-value} ) >= $o{-ge} )
231             {
232 18         34 push @results, $e;
233             }
234             }
235 112 100       220 if ( $o{-gt} ) {
236 24 100 100     58 if ( $e->get( $o{-value} )
237             && $e->get( $o{-value} ) > $o{-gt} )
238             {
239 17         38 push @results, $e;
240             }
241             }
242             }
243 23         113 return \@results;
244             }
245              
246             =item get_by_name()
247              
248             Gets first element that has argument name
249              
250             Type : Accessor
251             Title : get_by_name
252             Usage : my $found = $obj->get_by_name('foo');
253             Function: Retrieves the first contained object
254             in the current Bio::Phylo::Listable
255             object whose name is 'foo'
256             Returns : A Bio::Phylo::* object.
257             Args : A name (string)
258              
259             =cut
260              
261             sub get_by_name {
262 173     173 1 4636 my ( $self, $name ) = @_;
263 173 50 33     766 if ( not defined $name or ref $name ) {
264 0         0 throw 'BadString' => "Can't search on name '$name'";
265             }
266 173         280 for my $obj ( @{ $self->get_entities } ) {
  173         424  
267 608         1322 my $obj_name = $obj->get_name;
268 608 100 100     2022 if ( $obj_name and $name eq $obj_name ) {
269 173         635 return $obj;
270             }
271             }
272 0         0 return;
273             }
274              
275             =back
276              
277             =head2 VISITOR METHODS
278              
279             =over
280              
281             =item visit()
282              
283             Iterates over objects contained by container, executes argument
284             code reference on each.
285              
286             Type : Visitor predicate
287             Title : visit
288             Usage : $obj->visit(
289             sub{ print $_[0]->get_name, "\n" }
290             );
291             Function: Implements visitor pattern
292             using code reference.
293             Returns : The container, possibly modified.
294             Args : a CODE reference.
295              
296             =cut
297              
298             sub visit {
299 193     193 1 932 my ( $self, $code ) = @_;
300 193 50       586 if ( looks_like_instance( $code, 'CODE' ) ) {
301 193         440 for ( @{ $self->get_entities } ) {
  193         560  
302 1109         3325 $code->($_);
303             }
304             }
305             else {
306 0         0 throw 'BadArgs' => "\"$code\" is not a CODE reference!";
307             }
308 193         976 return $self;
309             }
310              
311             =back
312              
313             =head2 TESTS
314              
315             =over
316              
317             =item contains()
318              
319             Tests whether the container object contains the argument object.
320              
321             Type : Test
322             Title : contains
323             Usage : if ( $obj->contains( $other_obj ) ) {
324             # do something
325             }
326             Function: Tests whether the container object
327             contains the argument object
328             Returns : BOOLEAN
329             Args : A Bio::Phylo::* object
330              
331             =cut
332              
333             sub contains {
334 17436     17436 1 25183 my ( $self, $obj ) = @_;
335 17436 50       37832 if ( blessed $obj ) {
336 17436         29276 my $id = $obj->get_id;
337 17436         23516 for my $ent ( @{ $self->get_entities } ) {
  17436         31790  
338 871004 50       1230739 next if not $ent;
339 871004 100       1283952 return 1 if $ent->get_id == $id;
340             }
341 6         17 return 0;
342             }
343             else {
344 0         0 for my $ent ( @{ $self->get_entities } ) {
  0         0  
345 0 0       0 next if not $ent;
346 0 0       0 return 1 if $ent eq $obj;
347             }
348             }
349             }
350              
351             =item can_contain()
352              
353             Tests if argument can be inserted in container.
354              
355             Type : Test
356             Title : can_contain
357             Usage : &do_something if $listable->can_contain( $obj );
358             Function: Tests if $obj can be inserted in $listable
359             Returns : BOOL
360             Args : An $obj to test
361              
362             =cut
363              
364             sub can_contain {
365 17981     17981 1 28090 my ( $self, @obj ) = @_;
366 17981         25614 for my $obj (@obj) {
367 18284         22959 my ( $self_type, $obj_container );
368 18284         23768 eval {
369 18284         36566 $self_type = $self->_type;
370 18284         35265 $obj_container = $obj->_container;
371             };
372 18284 100 100     56073 if ( $@ or $self_type != $obj_container ) {
373 5 100       28 if ( not $@ ) {
374 1         7 $logger->info(" $self $self_type != $obj $obj_container");
375             }
376             else {
377 4         30 $logger->info($@);
378             }
379 5         34 return 0;
380             }
381             }
382 17976         40042 return 1;
383             }
384              
385             =back
386              
387             =head2 UTILITY METHODS
388              
389             =over
390              
391             =item cross_reference()
392              
393             The cross_reference method links node and datum objects to the taxa they apply
394             to. After crossreferencing a matrix with a taxa object, every datum object has
395             a reference to a taxon object stored in its C<$datum-Eget_taxon> field, and
396             every taxon object has a list of references to datum objects stored in its
397             C<$taxon-Eget_data> field.
398              
399             Type : Generic method
400             Title : cross_reference
401             Usage : $obj->cross_reference($taxa);
402             Function: Crossreferences the entities
403             in the container with names
404             in $taxa
405             Returns : string
406             Args : A Bio::Phylo::Taxa object
407             Comments:
408              
409             =cut
410              
411             sub cross_reference {
412 5     5 1 26 my ( $self, $taxa ) = @_;
413 5         13 my ( $selfref, $taxref ) = ( ref $self, ref $taxa );
414 5 100       16 if ( looks_like_implementor( $taxa, 'get_entities' ) ) {
415 4         12 my $ents = $self->get_entities;
416 4 100 66     12 if ( $ents && @{$ents} ) {
  4         13  
417 3         10 foreach ( @{$ents} ) {
  3         6  
418 4 100 66     11 if ( looks_like_implementor( $_, 'get_name' )
419             && looks_like_implementor( $_, 'set_taxon' ) )
420             {
421 2         5 my $tax = $taxa->get_entities;
422 2 50 33     5 if ( $tax && @{$tax} ) {
  2         7  
423 2         2 foreach my $taxon ( @{$tax} ) {
  2         4  
424 4 50 33     52 if ( not $taxon->get_name or not $_->get_name )
425             {
426 4         9 next;
427             }
428 0 0       0 if ( $taxon->get_name eq $_->get_name ) {
429 0         0 $_->set_taxon($taxon);
430 0 0       0 if ( $_->_type == $DATUM ) {
431 0         0 $taxon->set_data($_);
432             }
433 0 0       0 if ( $_->_type == $NODE ) {
434 0         0 $taxon->set_nodes($_);
435             }
436             }
437             }
438             }
439             }
440             else {
441 2         9 throw 'ObjectMismatch' =>
442             "$selfref can't link to $taxref";
443             }
444             }
445             }
446 2 100       8 if ( $self->_type == $TREE ) {
    50          
447 1         7 $self->_get_container->set_taxa($taxa);
448             }
449             elsif ( $self->_type == $MATRIX ) {
450 1         13 $self->set_taxa($taxa);
451             }
452 2         10 return $self;
453             }
454             else {
455 1         7 throw 'ObjectMismatch' => "$taxref does not contain taxa";
456             }
457             }
458              
459             =item alphabetize()
460              
461             Sorts the contents alphabetically by their name.
462              
463             Type : Generic method
464             Title : alphabetize
465             Usage : $obj->alphabetize;
466             Function: Sorts the contents alphabetically by their name.
467             Returns : $self
468             Args : None
469             Comments:
470              
471             =cut
472            
473             sub alphabetize {
474 0     0 1   my $self = shift;
475 0           my @sorted = map { $_->[0] }
476 0           sort { $_->[1] cmp $_->[1] }
477 0           map { [ $_, $_->get_internal_name ] }
478 0           @{ $self->get_entities };
  0            
479 0           $self->clear;
480 0           $self->insert($_) for @sorted;
481 0           return $self;
482             }
483            
484             =back
485              
486             =head2 SETS MANAGEMENT
487              
488             Many Bio::Phylo objects are segmented, i.e. they contain one or more subparts
489             of the same type. For example, a matrix contains multiple rows; each row
490             contains multiple cells; a tree contains nodes, and so on. (Segmented objects
491             all inherit from Bio::Phylo::Listable, i.e. the class whose documentation you're
492             reading here.) In many cases it is useful to be able to define subsets of the
493             contents of segmented objects, for example sets of taxon objects inside a taxa
494             block. The Bio::Phylo::Listable object allows this through a number of methods
495             (add_set, remove_set, add_to_set, remove_from_set etc.). Those methods delegate
496             the actual management of the set contents to the L object.
497             Consult the documentation for L for a code sample.
498              
499             =over
500              
501             =item sets_to_xml()
502              
503             Returns string representation of sets
504              
505             Type : Accessor
506             Title : sets_to_xml
507             Usage : my $str = $obj->sets_to_xml;
508             Function: Gets xml string
509             Returns : Scalar
510             Args : None
511              
512             =cut
513              
514             sub sets_to_xml {
515 0     0 1   my $self = shift;
516 0           my $xml = '';
517 0 0         if ( $self->can('get_sets') ) {
518 0           for my $set ( @{ $self->get_sets } ) {
  0            
519 0           my %contents;
520 0           for my $ent ( @{ $self->get_entities } ) {
  0            
521 0 0         if ( $self->is_in_set($ent,$set) ) {
522 0           my $tag = $ent->get_tag;
523 0 0         $contents{$tag} = [] if not $contents{$tag};
524 0           push @{ $contents{$tag} }, $ent->get_xml_id;
  0            
525             }
526             }
527 0           for my $key ( keys %contents ) {
528 0           my @ids = @{ $contents{$key} };
  0            
529 0           $contents{$key} = join ' ', @ids;
530             }
531 0           $set->set_attributes(%contents);
532 0           $xml .= "\n" . $set->to_xml;
533             }
534             }
535 0           return $xml;
536             }
537              
538             =back
539              
540             =cut
541              
542             # podinherit_insert_token
543              
544             =head1 SEE ALSO
545              
546             There is a mailing list at L
547             for any user or developer questions and discussions.
548              
549             Also see the manual: L and L.
550              
551             =head2 Objects inheriting from Bio::Phylo::Listable
552              
553             =over
554              
555             =item L
556              
557             Iterate over a set of trees.
558              
559             =item L
560              
561             Iterate over nodes in a tree.
562              
563             =item L
564              
565             Iterate of children of a node.
566              
567             =item L
568              
569             Iterate over a set of matrices.
570              
571             =item L
572              
573             Iterate over the datum objects in a matrix.
574              
575             =item L
576              
577             Iterate over the characters in a datum.
578              
579             =item L
580              
581             Iterate over a set of taxa.
582              
583             =back
584              
585             =head2 Superclasses
586              
587             =over
588              
589             =item L
590              
591             This object inherits from L, so methods
592             defined there are also applicable here.
593              
594             =back
595              
596             =head1 CITATION
597              
598             If you use Bio::Phylo in published research, please cite it:
599              
600             B, B, B, B
601             and B, 2011. Bio::Phylo - phyloinformatic analysis using Perl.
602             I B<12>:63.
603             L
604              
605             =cut
606              
607             }
608             1;