File Coverage

blib/lib/Bio/Coordinate/Collection.pm

Criterion	Covered	Total	%
statement	88	110	80.0
branch	28	52	53.8
condition	9	18	50.0
subroutine	15	17	88.2
pod	9	9	100.0
total	149	206	72.3

package Bio::Coordinate::Collection;
our $AUTHORITY = 'cpan:BIOPERLML';
$Bio::Coordinate::Collection::VERSION = '1.007001';
use utf8;
use strict;
use warnings;
use Bio::Coordinate::Result;
use Bio::Coordinate::Result::Gap;
use parent qw(Bio::Root::Root Bio::Coordinate::MapperI);

# ABSTRACT: Noncontinuous match between two coordinate sets.
# AUTHOR:   Heikki Lehvaslaiho
# OWNER:    Heikki Lehvaslaiho
# LICENSE:  Perl_5

# CONTRIBUTOR: Ewan Birney



sub new {
    my($class,@args) = @_;
    my $self = $class->SUPER::new(@args);

    $self->{'_mappers'} = [];

    my($in, $out, $strict, $mappers, $return_match) =
        $self->_rearrange([qw(IN
                              OUT
                              STRICT
                              MAPPERS
                              RETURN_MATCH
                             )],
                         @args);

    $in  && $self->in($in);
    $out  && $self->out($out);
    $mappers && $self->mappers($mappers);
    $return_match && $self->return_match('return_match');
    return $self; # success - we hope!
}


sub add_mapper {
  my ($self,$value) = @_;

  $self->throw("Is not a Bio::Coordinate::MapperI but a [$self]")
      unless defined $value && $value->isa('Bio::Coordinate::MapperI');

  # test pair range lengths
  $self->warn("Coordinates in pair [". $value . ":" .
              $value->in->seq_id . "/". $value->out->seq_id .
              "] are not right.")
      unless $value->test;

  $self->_is_sorted(0);
  push(@{$self->{'_mappers'}},$value);
}


sub mappers{
        my ($self,@args) = @_;

        if (@args) {
                if (@args == 1 && ref $args[0] eq 'ARRAY') {
                        @args = @{$args[0]};
                }
                $self->throw("Is not a Bio::Coordinate::MapperI but a [$self]")
                        unless defined $args[0] && $args[0]->isa('Bio::Coordinate::MapperI');
                push(@{$self->{'_mappers'}}, @args);
        }

        return @{$self->{'_mappers'}};
}


sub each_mapper{
   my ($self) = @_;
   return @{$self->{'_mappers'}};
}


sub mapper_count{
   my $self = shift;
   return scalar @{$self->{'_mappers'} || []};
}


sub swap {
   my ($self) = @_;

   $self->sort unless $self->_is_sorted;
   map {$_->swap;} @{$self->{'_mappers'}};
   ($self->{'_in_ids'}, $self->{'_out_ids'}) =
       ($self->{'_out_ids'}, $self->{'_in_ids'});
   1;
}


sub test {
   my ($self) = @_;

   my $res = 1;

   foreach my $mapper ($self->each_mapper) {
       unless( $mapper->test ) {
           $self->warn("Coordinates in pair [". $mapper . ":" .
                       $mapper->in->seq_id . "/". $mapper->out->seq_id .
                       "] are not right.");
           $res = 0;
       }
   }
   $res;
}


sub map {
   my ($self,$value) = @_;

   $self->throw("Need to pass me a value.")
       unless defined $value;
   $self->throw("I need a Bio::Location, not [$value]")
       unless $value->isa('Bio::LocationI');
   $self->throw("No coordinate mappers!")
       unless $self->each_mapper;

   $self->sort unless $self->_is_sorted;

   if ($value->isa("Bio::Location::SplitLocationI")) {

       my $result = Bio::Coordinate::Result->new();
       foreach my $loc ( $value->sub_Location(1) ) {

           my $res = $self->_map($loc);
           map { $result->add_sub_Location($_) } $res->each_Location;

       }
       return $result;

   } else {
       return $self->_map($value);
   }

}


sub _map {
   my ($self,$value) = @_;

   my $result = Bio::Coordinate::Result->new(-is_remote=>1);

IDMATCH: {

       # bail out now we if are forcing the use of an ID
       # and it is not in this collection
       last IDMATCH if defined $value->seq_id &&
           ! $self->{'_in_ids'}->{$value->seq_id};

       foreach my $pair ($self->each_mapper) {

           # if we are limiting input to a certain ID
           next if defined $value->seq_id && $value->seq_id ne $pair->in->seq_id;

           # if we haven't even reached the start, move on
           next if $pair->in->end < $value->start;
           # if we have over run, break
           last if $pair->in->start > $value->end;

           my $subres = $pair->map($value);
           $result->add_result($subres);
       }
   }

   $result->seq_id($result->match->seq_id) if $result->match;
   unless ($result->each_Location) {
       #build one gap;
       my $gap = Bio::Location::Simple->new(-start => $value->start,
                                            -end => $value->end,
                                            -strand => $value->strand,
                                            -location_type => $value->location_type
                                           );
       $gap->seq_id($value->seq_id) if defined $value->seq_id;
       bless $gap, 'Bio::Coordinate::Result::Gap';
       $result->seq_id($value->seq_id) if defined $value->seq_id;
       $result->add_sub_Location($gap);
   }
   return $result;
}


sub sort{
   my ($self) = @_;

   @{$self->{'_mappers'}} = map { $_->[0] }
                            sort { $a->[1] <=> $b->[1] }
                            map { [ $_, $_->in->start] }
                            @{$self->{'_mappers'}};

   #create hashes for sequence ids
   $self->{'_in_ids'} = ();
   $self->{'_out_ids'} = ();
   foreach ($self->each_mapper) {
       $self->{'_in_ids'}->{$_->in->seq_id} = 1;
       $self->{'_out_ids'}->{$_->out->seq_id} = 1;
   }

   $self->_is_sorted(1);
}


sub _is_sorted{
   my ($self,$value) = @_;

   $self->{'_is_sorted'} = 1 if defined $value && $value;
   return $self->{'_is_sorted'};
}

1;

__END__