Add tests for memory leaks and weaken for Issue #81
[bioperl-live.git] / Bio / Map / Mappable.pm
blobe2d6088b530b4d349453b352d7e587239c2c90bd
2 # BioPerl module for Bio::Map::Mappable
4 # Please direct questions and support issues to <bioperl-l@bioperl.org>
6 # Cared for by Sendu Bala <bix@sendu.me.uk>
8 # Copyright Sendu Bala
9 #
10 # You may distribute this module under the same terms as perl itself
12 # POD documentation - main docs before the code
14 =head1 NAME
16 Bio::Map::Mappable - An object representing a generic map element
17 that can have multiple locations in several maps.
19 =head1 SYNOPSIS
21 # a map element in two different positions on the same map
22 $map1 = Bio::Map::SimpleMap->new();
23 $position1 = Bio::Map::Position->new(-map => $map1, -value => 100);
24 $position2 = Bio::Map::Position->new(-map => $map1, -value => 200);
25 $mappable = Bio::Map::Mappable->new(-positions => [$position1, $position2] );
27 # add another position on a different map
28 $map2 = Bio::Map::SimpleMap->new();
29 $position3 = Bio::Map::Position->new(-map => $map2, $value => 50);
30 $mappable->add_position($position3);
32 # get all the places our map element is found, on a particular map of interest
33 foreach $pos ($mappable->get_positions($map1)) {
34 print $pos->value, "\n";
37 =head1 DESCRIPTION
39 This object handles the notion of a generic map element. Mappables are
40 entities with one or more positions on one or more maps.
42 This object is a pure perl implementation of L<Bio::Map::MappableI>. That
43 interface implements some of its own methods so check the docs there for
44 those.
46 =head1 FEEDBACK
48 =head2 Mailing Lists
50 User feedback is an integral part of the evolution of this and other
51 Bioperl modules. Send your comments and suggestions preferably to the
52 Bioperl mailing list. Your participation is much appreciated.
54 bioperl-l@bioperl.org - General discussion
55 http://bioperl.org/wiki/Mailing_lists - About the mailing lists
57 =head2 Support
59 Please direct usage questions or support issues to the mailing list:
61 I<bioperl-l@bioperl.org>
63 rather than to the module maintainer directly. Many experienced and
64 reponsive experts will be able look at the problem and quickly
65 address it. Please include a thorough description of the problem
66 with code and data examples if at all possible.
68 =head2 Reporting Bugs
70 Report bugs to the Bioperl bug tracking system to help us keep track
71 of the bugs and their resolution. Bug reports can be submitted via the
72 web:
74 https://github.com/bioperl/bioperl-live/issues
76 =head1 AUTHOR - Sendu Bala
78 Email bix@sendu.me.uk
80 =head1 APPENDIX
82 The rest of the documentation details each of the object methods.
83 Internal methods are usually preceded with a _
85 =cut
87 # Let the code begin...
89 package Bio::Map::Mappable;
90 use strict;
91 use Bio::Map::Relative;
92 use Bio::Map::Position;
94 use base qw(Bio::Root::Root Bio::Map::MappableI);
96 =head2 new
98 Title : new
99 Usage : my $mappable = Bio::Map::Mappable->new();
100 Function: Builds a new Bio::Map::Mappable object
101 Returns : Bio::Map::Mappable
102 Args : -name => string : name of the mappable element
103 -id => string : id of the mappable element
105 =cut
107 sub new {
108 my ($class, @args) = @_;
109 my $self = $class->SUPER::new(@args);
111 my ($name, $id) = $self->_rearrange([qw(NAME ID)], @args);
112 $self->name($name) if $name;
113 $self->id($id) if $id;
115 return $self;
118 =head2 name
120 Title : name
121 Usage : $mappable->name($new_name);
122 my $name = $mappable->name();
123 Function: Get/Set the name for this Mappable
124 Returns : A scalar representing the current name of this Mappable
125 Args : none to get
126 string to set
128 =cut
130 sub name {
131 my $self = shift;
132 if (@_) { $self->{_name} = shift }
133 return $self->{_name} || '';
136 =head2 id
138 Title : id
139 Usage : my $id = $mappable->id();
140 $mappable->id($new_id);
141 Function: Get/Set the id for this Mappable.
142 Returns : A scalar representing the current id of this Mappable
143 Args : none to get
144 string to set
146 =cut
148 sub id {
149 my $self = shift;
150 if (@_) { $self->{_id} = shift }
151 return $self->{_id} || return;
154 =head2 in_map
156 Title : in_map
157 Usage : if ($mappable->in_map($map)) {...}
158 Function: Tests if this mappable is found on a specific map
159 Returns : boolean
160 Args : L<Bio::Map::MapI>
162 =cut
164 sub in_map {
165 my ($self, $query_map) = @_;
166 $self->throw("Must supply an argument") unless $query_map;
167 $self->throw("This is [$query_map], not an object") unless ref($query_map);
168 $self->throw("This is [$query_map], not a Bio::Map::MapI object") unless $query_map->isa('Bio::Map::MapI');
170 foreach my $map ($self->known_maps) {
171 ($map eq $query_map) && return 1;
174 return 0;
177 =head2 Comparison methods
179 =cut
181 =head2 equals
183 Title : equals
184 Usage : if ($mappable->equals($other_mappable)) {...}
185 my @equal_positions = $mappable->equals($other_mappable);
186 Function: Finds the positions in this mappable that are equal to any
187 comparison positions.
188 Returns : array of L<Bio::Map::PositionI> objects
189 Args : arg #1 = L<Bio::Map::MappableI> OR L<Bio::Map::PositionI> to compare
190 this one to (mandatory)
191 arg #2 = optionally, one or more of the key => value pairs below
192 -map => MapI : a Bio::Map::MapI to only consider positions
193 on the given map
194 -relative => RelativeI : a Bio::Map::RelativeI to calculate in terms
195 of each Position's relative position to the
196 thing described by that Relative
198 =cut
200 sub equals {
201 my $self = shift;
202 return $self->_compare('equals', @_);
205 =head2 less_than
207 Title : less_than
208 Usage : if ($mappable->less_than($other_mappable)) {...}
209 my @lesser_positions = $mappable->less_than($other_mappable);
210 Function: Finds the positions in this mappable that are less than all
211 comparison positions.
212 Returns : array of L<Bio::Map::PositionI> objects
213 Args : arg #1 = L<Bio::Map::MappableI> OR L<Bio::Map::PositionI> to compare
214 this one to (mandatory)
215 arg #2 = optionally, one or more of the key => value pairs below
216 -map => MapI : a Bio::Map::MapI to only consider positions
217 on the given map
218 -relative => RelativeI : a Bio::Map::RelativeI to calculate in terms
219 of each Position's relative position to the
220 thing described by that Relative
222 =cut
224 sub less_than {
225 my $self = shift;
226 return $self->_compare('less_than', @_);
229 =head2 greater_than
231 Title : greater_than
232 Usage : if ($mappable->greater_than($other_mappable)) {...}
233 my @greater_positions = $mappable->greater_than($other_mappable);
234 Function: Finds the positions in this mappable that are greater than all
235 comparison positions.
236 Returns : array of L<Bio::Map::PositionI> objects
237 Args : arg #1 = L<Bio::Map::MappableI> OR L<Bio::Map::PositionI> to compare
238 this one to (mandatory)
239 arg #2 = optionally, one or more of the key => value pairs below
240 -map => MapI : a Bio::Map::MapI to only consider positions
241 on the given map
242 -relative => RelativeI : a Bio::Map::RelativeI to calculate in terms
243 of each Position's relative position to the
244 thing described by that Relative
246 =cut
248 sub greater_than {
249 my $self = shift;
250 return $self->_compare('greater_than', @_);
253 =head2 overlaps
255 Title : overlaps
256 Usage : if ($mappable->overlaps($other_mappable)) {...}
257 my @overlapping_positions = $mappable->overlaps($other_mappable);
258 Function: Finds the positions in this mappable that overlap with any
259 comparison positions.
260 Returns : array of L<Bio::Map::PositionI> objects
261 Args : arg #1 = L<Bio::Map::MappableI> OR L<Bio::Map::PositionI> to compare
262 this one to (mandatory)
263 arg #2 = optionally, one or more of the key => value pairs below
264 -map => MapI : a Bio::Map::MapI to only consider positions
265 on the given map
266 -relative => RelativeI : a Bio::Map::RelativeI to calculate in terms
267 of each Position's relative position to the
268 thing described by that Relative
270 =cut
272 sub overlaps {
273 my $self = shift;
274 return $self->_compare('overlaps', @_);
277 =head2 contains
279 Title : contains
280 Usage : if ($mappable->contains($other_mappable)) {...}
281 my @container_positions = $mappable->contains($other_mappable);
282 Function: Finds the positions in this mappable that contain any comparison
283 positions.
284 Returns : array of L<Bio::Map::PositionI> objects
285 Args : arg #1 = L<Bio::Map::MappableI> OR L<Bio::Map::PositionI> to compare
286 this one to (mandatory)
287 arg #2 = optionally, one or more of the key => value pairs below
288 -map => MapI : a Bio::Map::MapI to only consider positions
289 on the given map
290 -relative => RelativeI : a Bio::Map::RelativeI to calculate in terms
291 of each Position's relative position to the
292 thing described by that Relative
294 =cut
296 sub contains {
297 my $self = shift;
298 return $self->_compare('contains', @_);
301 =head2 overlapping_groups
303 Title : overlapping_groups
304 Usage : my @groups = $mappable->overlapping_groups($other_mappable);
305 my @groups = Bio::Map::Mappable->overlapping_groups(\@mappables);
306 Function: Look at all the positions of all the supplied mappables and group
307 them according to overlap.
308 Returns : array of array refs, each ref containing the Bio::Map::PositionI
309 objects that overlap with each other
310 Args : arg #1 = L<Bio::Map::MappableI> OR L<Bio::Map::PositionI> to compare
311 this one to, or an array ref of such objects (mandatory)
312 arg #2 = optionally, one or more of the key => value pairs below
313 -map => MapI : a Bio::Map::MapI to only consider positions
314 on the given map
315 -relative => RelativeI : a Bio::Map::RelativeI to calculate in terms
316 of each Position's relative position to the
317 thing described by that Relative
318 -min_pos_num => int : the minimum number of positions that must
319 be in a group before it will be returned
320 [default is 1]
321 -min_mappables_num => int : the minimum number of different
322 mappables represented by the
323 positions in a group before it
324 will be returned [default is 1]
325 -min_mappables_percent => number : as above, but the minimum
326 percentage of input mappables
327 [default is 0]
328 -min_map_num => int : the minimum number of different
329 maps represented by the positions
330 in a group before it will be
331 returned [default is 1]
332 -min_map_percent => number : as above, but the minimum
333 percentage of maps known by the
334 input mappables [default is 0]
335 -require_self => 1|0 : require that at least one of the
336 calling object's positions be in
337 each group [default is 1, has no
338 effect when the second usage form
339 is used]
340 -required => \@mappables : require that at least one position
341 for each mappable supplied in this
342 array ref be in each group
344 =cut
346 sub overlapping_groups {
347 my $self = shift;
348 return $self->_compare('overlapping_groups', @_);
351 =head2 disconnected_intersections
353 Title : disconnected_intersections
354 Usage : @positions = $mappable->disconnected_intersections($other_mappable);
355 @positions = Bio::Map::Mappable->disconnected_intersections(\@mappables);
356 Function: Make the positions that are at the intersection of each group of
357 overlapping positions, considering all the positions of the supplied
358 mappables.
359 Returns : new Bio::Map::Mappable who's positions on maps are the calculated
360 disconnected unions
361 Args : arg #1 = L<Bio::Map::MappableI> OR L<Bio::Map::PositionI> to compare
362 this one to, or an array ref of such objects (mandatory)
363 arg #2 = optionally, one or more of the key => value pairs below
364 -map => MapI : a Bio::Map::MapI to only consider positions
365 on the given map
366 -relative => RelativeI : a Bio::Map::RelativeI to calculate in terms
367 of each Position's relative position to the
368 thing described by that Relative
369 -min_pos_num => int : the minimum number of positions that must
370 be in a group before the intersection will
371 be calculated and returned [default is 1]
372 -min_mappables_num => int : the minimum number of different
373 mappables represented by the
374 positions in a group before the
375 intersection will be calculated
376 and returned [default is 1]
377 -min_mappables_percent => number : as above, but the minimum
378 percentage of input mappables
379 [default is 0]
380 -min_map_num => int : the minimum number of different
381 maps represented by the positions
382 in a group before the intersection
383 will be calculated and returned
384 [default is 1]
385 -min_map_percent => number : as above, but the minimum
386 percentage of maps known by the
387 input mappables [default is 0]
388 -require_self => 1|0 : require that at least one of the
389 calling object's positions be in
390 each group [default is 1, has no
391 effect when the second usage form
392 is used]
393 -required => \@mappables : require that at least one position
394 for each mappable supplied in this
395 array ref be in each group
397 =cut
399 sub disconnected_intersections {
400 my $self = shift;
401 return $self->_compare('intersection', @_);
404 =head2 disconnected_unions
406 Title : disconnected_unions
407 Usage : my @positions = $mappable->disconnected_unions($other_mappable);
408 my @positions = Bio::Map::Mappable->disconnected_unions(\@mappables);
409 Function: Make the positions that are the union of each group of overlapping
410 positions, considering all the positions of the supplied mappables.
411 Returns : new Bio::Map::Mappable who's positions on maps are the calculated
412 disconnected unions
413 Args : arg #1 = L<Bio::Map::MappableI> OR L<Bio::Map::PositionI> to compare
414 this one to, or an array ref of such objects (mandatory)
415 arg #2 = optionally, one or more of the key => value pairs below
416 -map => MapI : a Bio::Map::MapI to only consider positions
417 on the given map
418 -relative => RelativeI : a Bio::Map::RelativeI to calculate in terms
419 of each Position's relative position to the
420 thing described by that Relative
421 -min_pos_num => int : the minimum number of positions that must
422 be in a group before the union will be
423 calculated and returned [default is 1]
424 -min_mappables_num => int : the minimum number of different
425 mappables represented by the
426 positions in a group before the
427 union will be calculated and
428 returned [default is 1]
429 -min_mappables_percent => number : as above, but the minimum
430 percentage of input mappables
431 [default is 0]
432 -min_map_num => int : the minimum number of different
433 maps represented by the positions
434 in a group before the union will
435 be calculated and returned
436 [default is 1]
437 -min_map_percent => number : as above, but the minimum
438 percentage of maps known by the
439 input mappables [default is 0]
440 -require_self => 1|0 : require that at least one of the
441 calling object's positions be in
442 each group [default is 1, has no
443 effect when the second usage form
444 is used]
445 -required => \@mappables : require that at least one position
446 for each mappable supplied in this
447 array ref be in each group
449 =cut
451 sub disconnected_unions {
452 my $self = shift;
453 return $self->_compare('union', @_);
456 # do a RangeI-related comparison by calling the corresponding PositionI method
457 # on all the requested Positions of our Mappables
458 sub _compare {
459 my ($self, $method, $input, @extra_args) = @_;
460 $self->throw("Must supply an object or array ref of them") unless ref($input);
461 $self->throw("Wrong number of extra args (should be key => value pairs)") unless @extra_args % 2 == 0;
462 my @compares = ref($input) eq 'ARRAY' ? @{$input} : ($input);
464 my %args = (-map => undef, -relative => undef, -min_pos_num => 1,
465 -min_mappables_num => 1, -min_mappables_percent => 0,
466 -min_map_num => 1, -min_map_percent => 0,
467 -require_self => 0, -required => undef, -min_overlap_percent => 0, @extra_args);
468 my $map = $args{-map};
469 my $rel = $args{-relative};
470 my $overlap = $args{-min_overlap_percent};
471 my $min_pos_num = $args{-min_pos_num};
472 my $min_pables_num = $args{-min_mappables_num};
473 if ($args{-min_mappables_percent}) {
474 my $mn = (@compares + (ref($self) ? 1 : 0)) / 100 * $args{-min_mappables_percent};
475 if ($mn > $min_pables_num) {
476 $min_pables_num = $mn;
479 my $min_map_num = $args{-min_map_num};
480 if ($args{-min_map_percent}) {
481 my %known_maps;
482 foreach my $pable (@compares, ref($self) ? ($self) : ()) {
483 foreach my $known ($pable->known_maps) {
484 $known_maps{$known->unique_id} = 1;
487 my $mn = scalar(keys %known_maps) / 100 * $args{-min_map_percent};
488 if ($mn > $min_map_num) {
489 $min_map_num = $mn;
492 my %required = map { $_ => 1 } $args{-required} ? @{$args{-required}} : ();
493 my (@mine, @yours);
495 if (ref($self)) {
496 @mine = $self->get_positions($map);
497 if ($args{-require_self}) {
498 @mine > 0 or return;
499 $required{$self} = 1;
502 my @required = sort keys %required;
504 foreach my $compare (@compares) {
505 if ($compare->isa('Bio::Map::PositionI')) {
506 push(@yours, $compare);
508 elsif ($compare->isa('Bio::Map::MappableI')) {
509 push(@yours, $compare->get_positions($map));
511 else {
512 $self->throw("This is [$compare], not a Bio::Map::MappableI or Bio::Map::PositionI");
515 @yours > 0 or return;
517 my @ok;
518 SWITCH: for ($method) {
519 /equals|overlaps|contains/ && do {
520 @mine > 0 or return;
521 foreach my $my_pos (@mine) {
522 foreach my $your_pos (@yours) {
523 if ($my_pos->$method($your_pos, undef, $rel)) {
524 push(@ok, $my_pos);
525 last;
529 last SWITCH;
531 /less_than|greater_than/ && do {
532 @mine > 0 or return;
533 if ($method eq 'greater_than') {
534 @mine = map { $_->[1] }
535 sort { $b->[0] <=> $a->[0] }
536 map { [$_->end($_->absolute_relative), $_] }
537 @mine;
538 @yours = map { $_->[1] }
539 sort { $b->[0] <=> $a->[0] }
540 map { [$_->end($_->absolute_relative), $_] }
541 @yours;
543 my $test_pos = shift(@yours);
545 foreach my $my_pos (@mine) {
546 if ($my_pos->$method($test_pos, $rel)) {
547 push(@ok, $my_pos);
549 else {
550 last;
554 if ($method eq 'greater_than') {
555 @ok = map { $_->[1] }
556 sort { $a->[0] <=> $b->[0] }
557 map { [$_->sortable, $_] }
558 @ok;
561 last SWITCH;
563 /overlapping_groups|intersection|union/ && do {
564 my @positions = (@mine, @yours);
565 my $start_pos = shift(@positions);
567 my $dr_able = $start_pos->disconnected_ranges(\@positions, $rel, $overlap) || return;
568 my @disconnected_ranges = $dr_able->get_positions;
570 #print "got ", scalar(@disconnected_ranges), " disconnected_ranges, first has range ", $disconnected_ranges[0]->toString, "\n";
572 #use Benchmark qw(:all);
573 #my $t0 = new Benchmark;
575 my %all_groups;
576 my %done_ranges;
577 for my $i (0..$#disconnected_ranges) {
578 my $range = $disconnected_ranges[$i];
579 my $range_string = $range->toString;
580 next if $done_ranges{$range_string};
581 $done_ranges{$range_string} = 1;
583 foreach my $pos ($start_pos, @positions) {
584 if ($pos->overlaps($range, undef, $rel)) {
585 $all_groups{$range_string}->{$pos} = $pos;
590 #my $t1 = new Benchmark;
591 #my $td = timediff($t1, $t0);
592 #print "grouping took: ",timestr($td),"\n";
594 # purge the temporary working (not $dr_able->purge_positions since
595 # that removes the element from each position, but leaves it on
596 # the map. *** need complete purge that removes position from
597 # memory...
598 foreach my $pos (@disconnected_ranges) {
599 my $map = $pos->map || next;
600 $map->purge_positions($pos);
603 my @groups;
604 GROUPS: foreach my $group_range (sort keys %all_groups) {
605 my $group = $all_groups{$group_range};
606 my @group = sort values %{$group};
607 #print "* in group $group_range, there are ", scalar(@group), " members\n";
609 @group >= $min_pos_num or next;
610 @group >= $min_pables_num or next; # shortcut before having to work it out properly
611 @group >= $min_map_num or next; # shortcut before having to work it out properly
613 my %mappables;
614 foreach my $pos (@group) {
615 my $mappable = $pos->element || next;
616 $mappables{$mappable} = 1;
618 keys %mappables >= $min_pables_num || next;
620 my %maps;
621 foreach my $pos (@group) {
622 my $map = $pos->map || next;
623 $maps{$map->unique_id} = 1;
625 keys %maps >= $min_map_num || next;
627 foreach my $required (@required) {
628 exists $mappables{$required} or next GROUPS;
631 my @sorted = map { $_->[1] }
632 sort { $a->[0] <=> $b->[0] }
633 map { [$_->sortable, $_] }
634 @group;
635 push(@groups, \@sorted);
638 if ($method eq 'overlapping_groups') {
639 return @groups;
641 else {
642 foreach my $group (@groups) {
643 my $start_pos = shift(@{$group});
645 unless (@{$group}) {
646 # we'll consider the 'intersection' or 'union' of just
647 # one position as the position itself
648 push(@ok, Bio::Map::Position->new(-map => $start_pos->map,
649 -start => $start_pos->start,
650 -end => $start_pos->end));
652 else {
653 my @rel_arg = $method eq 'intersection' ? (undef, $rel) : ($rel);
654 my $result = $start_pos->$method($group, @rel_arg) || next;
655 push(@ok, $result->get_positions);
659 # assign all the positions to a result mappable
660 my $result = $self->new();
661 $result->add_position(@ok) if @ok; # add_position can actually take a list
663 return $result;
666 last SWITCH;
669 $self->throw("Unknown method '$method'");
672 return @ok;
675 =head2 tuple
677 Title : tuple
678 Usage : Do Not Use!
679 Function: tuple was supposed to be a private method; this method no longer
680 does anything
681 Returns : warning
682 Args : none
683 Status : deprecated, will be removed in next version
685 =cut
687 sub tuple {
688 my $self = shift;
689 $self->warn("The tuple method was supposed to be a private method, don't call it!");
692 =head2 annotation
694 Title : annotation
695 Usage : $mappable->annotation($an_col);
696 my $an_col = $mappable->annotation();
697 Function: Get the annotation collection (see Bio::AnnotationCollectionI)
698 for this annotatable object.
699 Returns : a Bio::AnnotationCollectionI implementing object, or undef
700 Args : none to get, OR
701 a Bio::AnnotationCollectionI implementing object to set
703 =cut
705 sub annotation {
706 my $self = shift;
707 if (@_) { $self->{_annotation} = shift }
708 return $self->{_annotation} || return;