File Coverage

blib/lib/Bio/Coordinate/Pair.pm

Criterion	Covered	Total	%
statement	151	152	99.3
branch	40	54	74.0
condition	21	28	75.0
subroutine	15	15	100.0
pod	7	7	100.0
total	234	256	91.4

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

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



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

    my($in, $out) =
        $self->_rearrange([qw(IN
                              OUT
                             )],
                         @args);

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


sub in {
   my ($self,$value) = @_;
   if( defined $value) {
       $self->throw("Not a valid input Bio::Location [$value] ")
           unless $value->isa('Bio::LocationI');
       $self->{'_in'} = $value;
   }
   return $self->{'_in'};
}


sub out {
   my ($self,$value) = @_;
   if( defined $value) {
       $self->throw("Not a valid output coordinate Bio::Location [$value] ")
           unless $value->isa('Bio::LocationI');
       $self->{'_out'} = $value;
   }
   return $self->{'_out'};
}


sub swap {
   my ($self) = @_;
   ($self->{'_in'}, $self->{'_out'}) = ($self->{'_out'}, $self->{'_in'});
   return 1;
}


sub strand {
   my ($self) = @_;
   $self->warn("Outgoing coordinates are not defined")
       unless $self->out;
   $self->warn("Incoming coordinates are not defined")
       unless $self->in;

   return ($self->in->strand || 0) * ($self->out->strand || 0);
}


sub test {
   my ($self) = @_;
   $self->warn("Outgoing coordinates are not defined")
       unless $self->out;
   $self->warn("Incoming coordinates are not defined")
       unless $self->in;
   return ($self->in->end - $self->in->start) == ($self->out->end - $self->out->start);
}


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("Input coordinate system not set")
       unless $self->in;
   $self->throw("Output coordinate system not set")
       unless $self->out;

   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();

   my $offset = $self->in->start - $self->out->start;
   my $start  = $value->start - $offset;
   my $end    = $value->end - $offset;

   my $match = Bio::Location::Simple->new;
   $match->location_type($value->location_type);
   $match->strand($self->strand);

   #within
   #       |-------------------------|
   #            |-|
   if ($start >= $self->out->start and $end <= $self->out->end) {

       $match->seq_id($self->out->seq_id);
       $result->seq_id($self->out->seq_id);

       if ($self->strand >= 0) {
           $match->start($start);
           $match->end($end);
       } else {
           $match->start($self->out->end - $end + $self->out->start);
           $match->end($self->out->end - $start + $self->out->start);
       }
       if ($value->strand) {
           $match->strand($match->strand * $value->strand);
           $result->strand($match->strand);
       }
       bless $match, 'Bio::Coordinate::Result::Match';
       $result->add_sub_Location($match);
   }
   #out
   #       |-------------------------|
   #   |-|              or              |-|
   elsif ( ($end < $self->out->start or $start > $self->out->end ) or
           #insertions just outside the range need special settings
           ($value->location_type eq 'IN-BETWEEN' and
            ($end = $self->out->start or $start = $self->out->end)))  {

       $match->seq_id($self->in->seq_id);
       $result->seq_id($self->in->seq_id);
       $match->start($value->start);
       $match->end($value->end);
       $match->strand($value->strand);

       bless $match, 'Bio::Coordinate::Result::Gap';
       $result->add_sub_Location($match);
   }
   #partial I
   #       |-------------------------|
   #   |-----|
   elsif ($start < $self->out->start and $end <= $self->out->end ) {

       $result->seq_id($self->out->seq_id);
       if ($value->strand) {
           $match->strand($match->strand * $value->strand);
           $result->strand($match->strand);
       }
       my $gap = Bio::Location::Simple->new;
       $gap->start($value->start);
       $gap->end($self->in->start - 1);
       $gap->strand($value->strand);
       $gap->seq_id($self->in->seq_id);

       bless $gap, 'Bio::Coordinate::Result::Gap';
       $result->add_sub_Location($gap);

       # match
       $match->seq_id($self->out->seq_id);

       if ($self->strand >= 0) {
           $match->start($self->out->start);
           $match->end($end);
       } else {
           $match->start($self->out->end - $end + $self->out->start);
           $match->end($self->out->end);
       }
       bless $match, 'Bio::Coordinate::Result::Match';
       $result->add_sub_Location($match);
   }
   #partial II
   #       |-------------------------|
   #                             |------|
   elsif ($start >= $self->out->start and $end > $self->out->end ) {

       $match->seq_id($self->out->seq_id);
       $result->seq_id($self->out->seq_id);
       if ($value->strand) {
           $match->strand($match->strand * $value->strand);
           $result->strand($match->strand);
       }
       if ($self->strand >= 0) {
           $match->start($start);
           $match->end($self->out->end);
       } else {
           $match->start($self->out->start);
           $match->end($self->out->end - $start + $self->out->start);
       }
       bless $match, 'Bio::Coordinate::Result::Match';
       $result->add_sub_Location($match);

       my $gap = Bio::Location::Simple->new;
       $gap->start($self->in->end + 1);
       $gap->end($value->end);
       $gap->strand($value->strand);
       $gap->seq_id($self->in->seq_id);
       bless $gap, 'Bio::Coordinate::Result::Gap';
       $result->add_sub_Location($gap);

   }
   #enveloping
   #       |-------------------------|
   #   |---------------------------------|
   elsif ($start < $self->out->start and $end > $self->out->end ) {

       $result->seq_id($self->out->seq_id);
       if ($value->strand) {
           $match->strand($match->strand * $value->strand);
           $result->strand($match->strand);
       }
       # gap1
       my $gap1 = Bio::Location::Simple->new;
       $gap1->start($value->start);
       $gap1->end($self->in->start - 1);
       $gap1->strand($value->strand);
       $gap1->seq_id($self->in->seq_id);
       bless $gap1, 'Bio::Coordinate::Result::Gap';
       $result->add_sub_Location($gap1);

       # match
       $match->seq_id($self->out->seq_id);

       $match->start($self->out->start);
       $match->end($self->out->end);
       bless $match, 'Bio::Coordinate::Result::Match';
       $result->add_sub_Location($match);

       # gap2
       my $gap2 = Bio::Location::Simple->new;
       $gap2->start($self->in->end + 1);
       $gap2->end($value->end);
       $gap2->strand($value->strand);
       $gap2->seq_id($self->in->seq_id);
       bless $gap2, 'Bio::Coordinate::Result::Gap';
       $result->add_sub_Location($gap2);

   } else {
       $self->throw("Should not be here!");
   }
   return $result;
}

1;

__END__