Algorithm-NeedlemanWunsch

 view release on metacpan or  search on metacpan

lib/Algorithm/NeedlemanWunsch.pm  view on Meta::CPAN

my $from_left_idx = 2;

sub _curry_callback {
    my ($univ_cb, $spec_name) = @_;

    my $cb;
    if ($spec_name eq 'align') {
        $cb = sub {
	    my $arg = { align => [ @_ ] };
	    my $rv = &$univ_cb($arg);
	    croak "select_align callback returned invalid selection $rv."
	        unless $rv eq 'align';
	};
    } else {
        $cb = sub {
	    my $arg = { $spec_name => $_[0] };
	    my $rv = &$univ_cb($arg);
	    croak "select_align callback returned invalid selection $rv."
	        unless $rv eq $spec_name;
	};
    }

    return $cb;
}

sub _canonicalize_callbacks {
    my $cb;
    if (@_) {
        $cb = $_[0];
    } else {
        $cb = { };
    }

    if (exists($cb->{select_align})) {
        my @cn = qw(align shift_a shift_b);
	foreach (@cn) {
	    if (!exists($cb->{$_})) {
	        $cb->{$_} = _curry_callback($cb->{select_align}, $_);
	    }
	}
    }

    return $cb;
}

sub new {
    my $class = shift;
    my $score_sub = shift;

lib/Algorithm/NeedlemanWunsch.pm  view on Meta::CPAN

	    $arg->{shift_a} = $cur->[1] - 1;
	} elsif ($m eq 'shift_b') {
	    $arg->{shift_b} = $cur->[0] - 1;
	} else {
	    die "internal error";
	}
    }

    my $move;
    my $cb = $self->{callbacks};
    if (exists($cb->{select_align})) {
        $move = &{$cb->{select_align}}($arg);
	if (!exists($arg->{$move})) {
	    die "select_align callback returned invalid selection $move.";
	}
    } else {
        my @cn = qw(align shift_a shift_b);
	foreach my $m (@cn) {
	    if (exists($arg->{$m})) {
	        $move = $m;
		last;
	    }
	}

lib/Algorithm/NeedlemanWunsch.pm  view on Meta::CPAN

	return ($_[0] eq $_[1]) ? 1 : -1;
    }

    my $matcher = Algorithm::NeedlemanWunsch->new(\&score_sub);
    my $score = $matcher->align(
               \@a,
               \@b,
               {   align     => \&on_align,
                   shift_a => \&on_shift_a,
                   shift_b => \&on_shift_b,
		   select_align => \&on_select_align
               });

=head1 DESCRIPTION

Sequence alignment is a way to find commonalities in two (or more)
similar sequences or strings of some items or characters. Standard
motivating example is the comparison of DNA sequences and their
functional and evolutionary similarities and differences, but the
problem has much wider applicability - for example finding the longest
common subsequence (that is, C<diff>) is a special case of sequence

lib/Algorithm/NeedlemanWunsch.pm  view on Meta::CPAN

Aligns an item of the first sequence with a gap in the second
sequence. The callback is called with 1 argument, which is the
position of the item in C<\@a>.

=item shift_b

Aligns a gap in the first sequence with an item of the second
sequence. The callback is called with 1 argument, which is the
position of the item in C<\@b>.

=item select_align

Called when there's more than one way to construct the optimal
alignment, with 1 argument which is a hashref enumerating the
possibilities. The hash may contain the following keys:

=over

=item align

If this key exists, the optimal alignment may align two sequence

lib/Algorithm/NeedlemanWunsch.pm  view on Meta::CPAN

=item shift_b

If this key exists, the optimal alignment may align a gap in the first
sequence with an item of the second sequence. The key's value is
the position of the item in C<\@b>.

=back

All keys are optional, but the hash will always have at least one. The
callback must select one of the possibilities by returning one of the
keys.

=back

All callbacks are optional. When there is just one way to make the
optimal alignment, the C<Algorithm::NeedlemanWunsch> object prefers
calling the specific callbacks, but will call C<select_align> if it's
defined and the specific callback isn't.

Note that C<select_align> is called I<instead> of the specific
callbacks, not in addition to them - users defining both
C<select_align> and other callbacks should probably call the specific
callback explicitly from their C<select_align>, once it decides which
one to prefer.

Also note that the passed positions move backwards, from the sequence
ends to zero - if you're building the alignment in your callbacks, add
items to the front.

=head2 Extensions

In addition to the standard Needleman-Wunsch algorithm, this module
also implements two popular extensions: local alignment and affine

t/pub.t  view on Meta::CPAN

}

$simple->local(0);

@alignment = ();
$score = $simple->align(\@a, \@b,
			   {
			    align => \&prepend_align,
			    shift_a => \&prepend_first_only,
			    shift_b => \&prepend_second_only,
			    select_align => \&postpone_gap
			   });
is($score, -1);
is_deeply(\@alignment,
	  [ [ 'A', 'A' ], [ 'T', 'T' ], [ 'G', 'G' ], [ 'G', 'A' ],
	    [ 'C', undef ], [ 'G', 'G' ], [ 'T', 'T' ] ]);

$simple->local(1);

@alignment = ();
$score = $simple->align(\@a, \@b,
			   {
			    align => \&prepend_align,
			    shift_a => \&prepend_first_only,
			    shift_b => \&prepend_second_only,
			    select_align => \&postpone_gap
			   });
is($score, 0);
is_deeply(\@alignment,
	  [ [ 'A', 'A' ], [ 'T', 'T' ], [ 'G', 'G' ], [ 'G', 'A' ],
	    [ 'C', 'G' ], [ 'G', 'T' ], [ 'T', undef ] ]);

my $evo = Algorithm::NeedlemanWunsch->new(\&evo_scheme);

@alignment = ();
$score = $evo->align(\@a, \@b,

t/pub.t  view on Meta::CPAN

			    align => \&prepend_align2,
			    shift_a => \&prepend_first_only2,
			    shift_b => \&prepend_second_only2
			   });
is($score, 31);
is($oa, '--AGACTAGTTAC');
is($ob, 'CGAGAC--GT---');

$evo->local(0);

sub select_align2 {
    my $arg = shift;

    if (exists($arg->{align})) {
        prepend_align2(@{$arg->{align}});
	return 'align';
    } elsif (exists($arg->{shift_a})) {
        prepend_first_only2($arg->{shift_a});
	return 'shift_a';
    } else {
        prepend_second_only2($arg->{shift_b});
	return 'shift_b';
    }
}

$oa = '';
$ob = '';
@a = qw(A A G T A G A G);
@b = qw(T A C C G A T A T T A T);
$score = $evo->align(\@a, \@b, { select_align => \&select_align2 });
is($score, 16);
is($oa, '-A-AG-TA-GAG');
is($ob, 'TACCGATATTAT');

$score = $evo->align(\@a, \@b, { });
is($score, 16);

$oa = '';
$ob = '';
@a = qw(T A G C A C A C A A C);

t/simple.t  view on Meta::CPAN

is($score, 3);

my @alignment;

sub check_align {
    my ($i, $j) = @_;

    unshift @alignment, [$i, $j];
}

sub check_select_align {
    my $arg = shift;

    die "alignment not an option" unless exists($arg->{align});
    unshift @alignment, $arg->{align};
    return 'align';
}

@alignment = ();
$lcs->align(\@same_a, \@same_b, { align => \&check_align });
is_deeply(\@alignment, [ [0, 0], [1, 1], [2, 2] ]);

@alignment = ();
$lcs->align(\@same_a, \@same_b, { select_align => \&check_select_align });
is_deeply(\@alignment, [ [0, 0], [1, 1], [2, 2] ]);