File Coverage

blib/lib/Bio/Coordinate/Utils.pm

Criterion	Covered	Total	%
statement	40	62	64.5
branch	3	12	25.0
condition	1	2	50.0
subroutine	8	9	88.8
pod	2	2	100.0
total	54	87	62.0

package Bio::Coordinate::Utils;
our $AUTHORITY = 'cpan:BIOPERLML';
$Bio::Coordinate::Utils::VERSION = '1.007001';
use utf8;
use strict;
use warnings;
use Bio::Location::Simple;
use Bio::Coordinate::Pair;
use Bio::Coordinate::Collection;
use parent qw(Bio::Root::Root);

# ABSTRACT: Additional methods to create Bio::Coordinate objects.
# AUTHOR:   Heikki Lehvaslaiho
# AUTHOR:   Jason Stajich
# OWNER:    Heikki Lehvaslaiho
# OWNER:    Jason Stajich
# LICENSE:  Perl_5




sub from_align {
   my ($self, $aln, $ref ) = @_;

   $aln->isa('Bio::Align::AlignI') ||
       $self->throw('Not a Bio::Align::AlignI object but ['. ref($aln). ']');

   # default reference sequence to the first sequence
   $ref ||= 1;

   my $collection = Bio::Coordinate::Collection->new(-return_match=>1);

   # this works only for pairs, so split the MSA
   # take the ref
   #foreach remaining seq in aln, do:
   $aln->map_chars('\.','-');
   my $cs = $aln->gap_line;
   my $seq1 = $aln->get_seq_by_pos(1);
   my $seq2 = $aln->get_seq_by_pos(2);
   while ( $cs =~ /([^\-]+)/g) {
       # alignment coordinates
       my $lenmatch = length($1);
       my $start = pos($cs) - $lenmatch +1;
       my $end   = $start + $lenmatch -1;
       my $match1 = Bio::Location::Simple->new
           (-seq_id => $seq1->id,
            -start  => $seq1->location_from_column($start)->start,
            -end    => $seq1->location_from_column($end)->start,
            -strand => $seq1->strand );

       my $match2 = Bio::Location::Simple->new
           (-seq_id => $seq2->id,
            -start  => $seq2->location_from_column($start)->start,
            -end    => $seq2->location_from_column($end)->start,
            -strand => $seq2->strand );

       my $pair = Bio::Coordinate::Pair->new
           (-in  => $match1,
            -out => $match2
            );
       unless( $pair->test ) {
           $self->warn(join("",
                            "pair align did not pass test ($start..$end):\n",
                            "\tm1=",$match1->to_FTstring(), " len=",
                            $match1->length,
                            " m2=", $match2->to_FTstring()," len=",
                            $match2->length,"\n"));
       }
       $collection->add_mapper($pair);
   }
   return ($collection->each_mapper)[0] if $collection->mapper_count == 1;
   return $collection;

}


sub from_seq_to_alignmentpos {
    my ($self, $aln ) = @_;

    $aln->isa('Bio::Align::AlignI') ||
        $self->throw('Not a Bio::Align::AlignI object but ['. ref($aln). ']');

    # default reference sequence to the first sequence
    my @mappers;
    $aln->map_chars('\.','-');
    for my $seq ( $aln->each_seq ) {
        my $collection = Bio::Coordinate::Collection->new(-return_match=>1);
        my $cs = $seq->seq();
        # do we change this over to use index and substr for speed?
        while ( $cs =~ /([^\-]+)/g) {
            # alignment coordinates
            my $lenmatch = length($1);
            my $start = pos($cs) - $lenmatch +1;
            my $end   = $start + $lenmatch -1;

            my $match1 = Bio::Location::Simple->new
                (-seq_id => $seq->id,
                 -start  => $seq->location_from_column($start)->start,
                 -end    => $seq->location_from_column($end)->start,
                 -strand => $seq->strand );

            my $match2 = Bio::Location::Simple->new
                (-seq_id => 'alignment',
                 -start  => $start,
                 -end    => $end,
                 -strand => 0 );

            my $pair = Bio::Coordinate::Pair->new
                (-in  => $match1,
                 -out => $match2
                 );
            unless ( $pair->test ) {
                $self->warn(join("",
                                 "pair align did not pass test ($start..$end):\n",
                                 "\tm1=",$match1->to_FTstring(), " len=",
                                 $match1->length,
                                 " m2=", $match2->to_FTstring()," len=",
                                 $match2->length,"\n"));
            }
            $collection->add_mapper($pair);
        }
        if( $collection->mapper_count == 1) {
            push @mappers, ($collection->each_mapper)[0];
        } else {
            push @mappers, $collection;
        }
    }
    return @mappers;
}

1;

__END__