view release on metacpan or  search on metacpan

lib/Bio/Tools/Primer3Redux/Result.pm  view on Meta::CPAN

        map {$self->{feature_data}{$_}{$it_type}} sort {$a <=> $b} keys %{$self->{feature_data}};
    my $ct = 0;

    # for attaching the features
    my $seq = $self->get_seq;

    return ($it_type eq 'PAIR') ?
        sub {
            my $instance = shift;
            my $ft = shift @feat_data;
            return unless $ft;
            # return cached features if previously generated and seq already attached
            return $ft->{PAIR} if (blessed $ft->{PAIR} && $ft->{PAIR}->isa('Bio::SeqFeature::Generic')
                && !$self->{reattach_sf});

            # carry over persistent data
            for my $fkey (keys %{$ft}) {
                $ft->{$fkey}{rank} = $ct;
                $ft->{$fkey}{type} = lc $fkey;
                for my $pkey (keys %{$persistent_data}) {
                    $ft->{$fkey}{$pkey} = $persistent_data->{$pkey};
                }
            }
            my $sf = $mth->($ft,$seq,$instance);
            # run caching here
            $ct++;
            $sf;
        } :
        sub {
            my $instance = shift;
            # these are tags
            my $ft = shift @feat_data;
            return unless $ft;
            # return cached features if previously generated and seq already attached
            if (blessed $ft && $ft->isa('Bio::SeqFeature::Generic') && !$self->{reattach_sf}) {
                $ct++;
                return $ft;
            }

            # carry over persistent data
            for my $key (keys %{$persistent_data}) {
                $ft->{$key} = $persistent_data->{$key};
            }

            $ft->{rank} = $ct;
            $ft->{type} = lc $it_type;
            my $sf = $mth->($ft, $seq, $instance);
            $ct++;
            $sf;
        }
}

}

sub _generate_primer {
    my ($ft, $seq, $instance) = @_;
    my ($type, $loc) = (delete($ft->{type}), delete($ft->{location}));

    # TODO: There is data showing up here that doesn't have locations, traceback
    if (!defined($loc)) {
        #print STDERR (caller(1))[3].":".Dumper $ft;
        return ;
    }

    my $rank = $ft->{rank};
    my $strand = $type eq 'right' ? -1 : 1;
    my ($start, $len) = split(',', $loc);
    # coordinates for Primer3 may be zero-based, may need conversion to 1-based
    if (!$instance->run_parameter('PRIMER_FIRST_BASE_INDEX')) {
        $start++
    }
    my $end = ($strand == 1) ? $start + $len -1 : $start - $len + 1;
    ($start, $end) = ($end, $start) if $strand == -1;
    my $primary = $type eq 'internal' ? 'ss_oligo'       :
                  $type eq 'left'     ? 'forward_primer' :
                  'reverse_primer' ;
    my $sf = Bio::Tools::Primer3Redux::Primer->new(-start       => $start,
                                                  -end          => $end,
                                                  -strand       => $strand,
                                                  -display_name => $type.'_'.$rank,
                                                  -primary_tag  => $primary,
                                                  -tag          => $ft);
    $seq->add_SeqFeature($sf) if ($seq && blessed $seq && $seq->isa('Bio::SeqI'));

    # cache Primer
    $instance->{feature_data}{$rank}{uc $type} = $sf;
    $sf;
}

sub _generate_pair {
    my ($ft, $seq, $instance) = @_;
    # some combinations of parameters do not return proper pairings,
    # so punt and return
    return if (!exists $ft->{PAIR} ||
               !exists $ft->{PAIR}->{num_returned} ||
               $ft->{PAIR}->{num_returned} == 0);

    my $pair = delete $ft->{PAIR};
    my $rank = $pair->{rank};

    $pair = Bio::Tools::Primer3Redux::PrimerPair->new(-tag => $pair);

    for my $type (sort keys %$ft) {
        my $sf = _generate_primer($ft->{$type}, $seq, $instance);
        $pair->add_SeqFeature($sf, 'EXPAND');
    }
    $seq->add_SeqFeature($pair) if ($seq && blessed $seq && $seq->isa('Bio::SeqI'));
    # cache PrimerPair
    $instance->{feature_data}{$rank}{PAIR} = $pair;
    return $pair;
}

# a fallback Bio::SeqI in case the parser is called directly (not from the
# wrapper)
# This is also needed to construct a "dummy" sequence in case there is no
# SEQUENCE_TEMPLATE, which is legal when running a "check_priemrs" task.
# In this case, we make a dummy sequence that contains the given primers
# separated with Ns to match the product length.
sub _create_default_seq {
    my $self = shift;