view release on metacpan or  search on metacpan

lib/Bio/Grep/Backend/Vmatch.pm  view on Meta::CPAN

            $alignment_in_output = 1;
        }

        next
            if !(      $fields[$COL_LENGTH] =~ m{\A \d+ \z}xms
                    || $alignment_in_output
            );
        $skip_next_alignment = 0;

        if ( $line =~ m{\A Sbjct: \s (.*) \z}xms ) {
            $subject = $1;
        }
        if ( $line =~ m{\A Query: \s (.*) \z}xms ) {

            # updates or creates the alignment
            $self->_parser_create_alignment_obj(
                {   query     => $1,
                    subject   => $subject,
                    alignment => $tmp_aln,
                    results   => \@results
                }
            );

            next LINE;
        }
        next LINE if $alignment_in_output;

        $tmp_aln = Bio::SimpleAlign->new( -source => 'VMATCH' );

        $self->_parser_untaint_data( \@fields );

        my ( $fasta, $upstream )
            = $self->_parser_create_sequence_obj( \@fields );
        my $internal_seq_id = $fields[$COL_ID];
        if ( $s->showdesc_isset ) {
            $internal_seq_id = $fasta->id;
        }

        my $query;
        if ( $s->showdesc_isset ) {
            $query = $self->{_mapping}->{ $fields[$COL_QUERY] };
        }
        else {
            $query = $query_seqs[ $fields[$COL_QUERY] ];
        }

        my $rct = q{};
        my $rcs = $query->seq;
        if ( $s->direct_and_rev_com && $fields[$COL_STRAND] eq q{P} ) {
            $rct = ' (reverse complement)';
            $rcs = $query->revcom->seq;
        }
        my $result = Bio::Grep::SearchResult->new(
            {   sequence         => $fasta,
                begin            => $upstream,
                end              => $upstream + $fields[$COL_LENGTH],
                alignment        => Bio::SimpleAlign->new(),
                sequence_id      => $internal_seq_id,
                remark           => q{},
                evalue           => $fields[$COL_EVALUE],
                percent_identity => $fields[$COL_IDENTITY],
                query            => Bio::Seq->new(
                    -id   => $query->id,
                    -desc => $query->desc . $rct,
                    -seq  => $rcs,
                ),
            }
        );
        push @results, $result;
    }
    $self->_delete_output();
    return 0;
}

###########################################################################
# Usage      : _parser_create_sequence_obj()
# Purpose    : creates a Bio::Seq object for $res->sequence, returns true
#              upstream size (corrects upstream when available upstream
#              region too small)
# Returns    : Bio::Seq object and $upstream
# Parameters : ref to @fields array (containing the Vmatch output)

sub _parser_create_sequence_obj {
    my ( $self, $fields ) = @_;
    my $upstream = $self->settings->upstream;
    my $seq_obj;
    if ( !$self->settings->showdesc_isset ) {
        my $start = $fields->[$COL_POS] - $upstream;

        # maybe the defined upstream region is larger than available
        # so check this and store in local variables
        if ( $start < 0 ) {
            $upstream = $upstream + $start;
            $start    = 0;
        }

        my $length = $upstream + $fields->[$COL_LENGTH];
        $length += $self->settings->downstream;

        $seq_obj
            = $self->_get_subsequence( $length, $fields->[$COL_ID], $start );
    }
    else {
        my ( $seq_id, $seq_desc )
            = $fields->[$COL_ID] =~ m{\A (.+?) _ (.*) \z}xms;
        if ( !defined $seq_id ) {
            $seq_id = $fields->[$COL_ID];
        }
        $seq_desc =~ s{_}{ }gxms;
        $seq_obj = Bio::Seq->new( -id => $seq_id, -desc => $seq_desc );
    }
    return ( $seq_obj, $upstream );
}

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

    my ( $query_pos, $subject_pos );

    if ( $args->{query} =~ s{\s+ (\d+) \s* \z}{}xms ) {
        $query_pos = $1;