20251125
This commit is contained in:
@@ -0,0 +1,465 @@
|
||||
|
||||
###########################
|
||||
### Class Alignment_segment
|
||||
###########################
|
||||
|
||||
=head1 NAME
|
||||
|
||||
package CDNA::Alignment_segment
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
Provides an object representation of alignment segments which are built into a single CDNA_alignment object.
|
||||
|
||||
=cut
|
||||
|
||||
|
||||
|
||||
package CDNA::Alignment_segment;
|
||||
use strict;
|
||||
use Data::Dumper;
|
||||
|
||||
|
||||
=over 4
|
||||
|
||||
=item new()
|
||||
|
||||
B<Description:> Instantiates a new Alignment_segment object.
|
||||
|
||||
B<Parameters:> $genomic_end5, $genomic_end3, $cdna_end5, $cdna_end3, $per_id
|
||||
|
||||
B<Returns:> Alignment_segment_obj
|
||||
|
||||
Alignment_segment_obj is an object of type CDNA::Alignment_object
|
||||
|
||||
Use the methods described below. In addition, the following fields are supported:
|
||||
|
||||
B<orientation> (orientation of the alignment segment)
|
||||
|
||||
B<lend> (left end of the alignment segment corresponding to the genomic sequence)
|
||||
|
||||
B<rend> (right end of the alignmetn segment corresponding to the genomic sequence)
|
||||
|
||||
note: lend <= rend in all cases; must use the B<orientation> field to determine cDNA alignment orientation for the segment.
|
||||
|
||||
B<mlend> (the cDNA coordinate corresponding to the lend alignment coordinate)
|
||||
|
||||
B<mrend> (the cDNA coordinate corresponding to the rend alignment coordinate)
|
||||
|
||||
=back
|
||||
|
||||
=cut
|
||||
|
||||
|
||||
sub new {
|
||||
my $packagename = shift;
|
||||
my ($genomic_end5, $genomic_end3, $cdna_end5, $cdna_end3, $per_id) = @_;
|
||||
my $orientation = '?'; #initialize
|
||||
my ($lend, $rend, $mlend, $mrend) = ($genomic_end5, $genomic_end3, $cdna_end5, $cdna_end3);
|
||||
|
||||
#reorient coordsets so that cdna coordinates are always in forward orientation.
|
||||
if ($cdna_end5 > $cdna_end3) { #swap coordsets
|
||||
($lend, $rend) = ($rend, $lend);
|
||||
($mlend, $mrend) = ($mrend, $mlend);
|
||||
}
|
||||
|
||||
## Check orientation and adjust lend, rend accordingly.
|
||||
if ($lend > $rend) {
|
||||
$orientation = '-';
|
||||
($lend, $rend) = ($rend, $lend);
|
||||
($mlend, $mrend) = ($mrend, $mlend);
|
||||
} elsif ($lend < $rend) { #keep coords way they are.
|
||||
$orientation = '+';
|
||||
}
|
||||
|
||||
my $self = {
|
||||
orientation=>$orientation, ## should be [+-]
|
||||
lend=>$lend,
|
||||
rend=>$rend,
|
||||
mlend=>$mlend, ## cDNA coordinate that maps to lend of alignment.
|
||||
mrend=>$mrend,
|
||||
per_id => $per_id,
|
||||
type=>undef(), # [first|last|internal|single]
|
||||
has_left_splice_junction=>0, #flag indicating whether the consensus is present.
|
||||
has_right_splice_junction=>0,
|
||||
left_splice_site_chars=>undef(), #store the two characters at that splice junction.
|
||||
right_splice_site_chars=>undef()
|
||||
};
|
||||
bless ($self, $packagename);
|
||||
return ($self);
|
||||
}
|
||||
|
||||
sub set_coords {
|
||||
my $self = shift;
|
||||
my ($c1, $c2) = @_;
|
||||
($c1, $c2) = sort {$a<=>$b} ($c1, $c2);
|
||||
$self->{lend} = $c1;
|
||||
$self->{rend} = $c2;
|
||||
}
|
||||
|
||||
|
||||
####
|
||||
sub get_aligned_orientation {
|
||||
my $self = shift;
|
||||
return ($self->{orientation});
|
||||
}
|
||||
|
||||
|
||||
|
||||
=over 4
|
||||
|
||||
=item get_coords()
|
||||
|
||||
B<Description:> Retrieves the lend, rend for the alignment segment.
|
||||
|
||||
B<Parameters:> none.
|
||||
|
||||
B<Returns:> ($lend, $rend)
|
||||
|
||||
=back
|
||||
|
||||
=cut
|
||||
|
||||
|
||||
sub get_coords {
|
||||
my $self = shift;
|
||||
return ($self->{lend}, $self->{rend});
|
||||
}
|
||||
|
||||
# private.
|
||||
sub set_mcoords () {
|
||||
my $self = shift;
|
||||
my ($mlend, $mrend) = @_;
|
||||
$self->{mlend} = $mlend;
|
||||
$self->{mrend} = $mrend;
|
||||
}
|
||||
|
||||
=over 4
|
||||
|
||||
=item get_mcoords()
|
||||
|
||||
B<Description:> Retrieves the mlend, mrend for the cDNA coordinates.
|
||||
|
||||
B<Parameters:> none
|
||||
|
||||
B<Returns:> ($mlend, $mrend)
|
||||
|
||||
=back
|
||||
|
||||
=cut
|
||||
|
||||
sub get_mcoords () {
|
||||
my $self = shift;
|
||||
return ($self->{mlend}, $self->{mrend});
|
||||
}
|
||||
|
||||
|
||||
=over 4
|
||||
|
||||
=item get_per_id()
|
||||
|
||||
B<Description:> Retrieves the per_id for the alignment segment
|
||||
|
||||
B<Parameters:> none
|
||||
|
||||
B<Returns:> $per_id
|
||||
|
||||
=back
|
||||
|
||||
=cut
|
||||
|
||||
sub get_per_id {
|
||||
my $self = shift;
|
||||
return ($self->{per_id});
|
||||
}
|
||||
|
||||
|
||||
|
||||
#private
|
||||
sub set_orientation {
|
||||
my $self = shift;
|
||||
my $orientation = shift;
|
||||
$self->{orientation} = $orientation;
|
||||
}
|
||||
|
||||
=over 4
|
||||
|
||||
=item get_orientation()
|
||||
|
||||
B<Description:> Retrieves the orientation for an alignment segment.
|
||||
|
||||
B<Parameters:> none
|
||||
|
||||
B<Returns:> [+|-]
|
||||
|
||||
=back
|
||||
|
||||
=cut
|
||||
|
||||
sub get_orientation {
|
||||
my $self = shift;
|
||||
return ($self->{orientation});
|
||||
}
|
||||
|
||||
sub set_type {
|
||||
my $self = shift;
|
||||
my $type = shift;
|
||||
unless ($type =~ /first|last|internal|single/) {
|
||||
die "Incompatible segment type provided: $type\n";
|
||||
}
|
||||
$self->{type} = $type;
|
||||
}
|
||||
|
||||
|
||||
=over 4
|
||||
|
||||
=item get_type()
|
||||
|
||||
B<Description:>Retrieves the classification of the alignment segment
|
||||
|
||||
B<Parameters:> none
|
||||
|
||||
B<Returns:> [first|last|internal|single]
|
||||
|
||||
=back
|
||||
|
||||
=cut
|
||||
|
||||
sub get_type {
|
||||
my $self = shift;
|
||||
return ($self->{type});
|
||||
}
|
||||
|
||||
sub is_first {
|
||||
my $self = shift;
|
||||
return ($self->{type} eq "first") ;
|
||||
}
|
||||
|
||||
sub is_internal {
|
||||
my $self = shift;
|
||||
return ($self->{type} eq "internal");
|
||||
}
|
||||
|
||||
sub is_last {
|
||||
my $self = shift;
|
||||
return ($self->{type} eq "last");
|
||||
}
|
||||
|
||||
sub is_single_segment {
|
||||
my $self = shift;
|
||||
return ($self->{type} eq "single");
|
||||
}
|
||||
|
||||
sub set_left_splice_junction {
|
||||
my $self = shift;
|
||||
my $value = shift;
|
||||
$self->{has_left_splice_junction} = $value;
|
||||
}
|
||||
|
||||
=over 4
|
||||
|
||||
=item has_left_splice_junction()
|
||||
|
||||
B<Description:> Provides result of a left splice junction test.
|
||||
|
||||
B<Parameters:> none
|
||||
|
||||
B<Returns:> [1|0]
|
||||
|
||||
1=true
|
||||
|
||||
0=false
|
||||
|
||||
=back
|
||||
|
||||
=cut
|
||||
|
||||
|
||||
sub has_left_splice_junction {
|
||||
my $self = shift;
|
||||
return ($self->{has_left_splice_junction});
|
||||
}
|
||||
|
||||
sub set_right_splice_junction {
|
||||
my $self = shift;
|
||||
my $value = shift;
|
||||
$self->{has_right_splice_junction} = $value;
|
||||
}
|
||||
|
||||
=over 4
|
||||
|
||||
=item has_right_splice_junction()
|
||||
|
||||
B<Description:> Provides the result of a right splice junction test.
|
||||
|
||||
B<Parameters:> none
|
||||
|
||||
B<Returns:> [1|0]
|
||||
|
||||
=back
|
||||
|
||||
=cut
|
||||
|
||||
|
||||
sub has_right_splice_junction {
|
||||
my $self = shift;
|
||||
return ($self->{has_right_splice_junction});
|
||||
}
|
||||
|
||||
sub set_left_splice_site_chars () {
|
||||
my $self = shift;
|
||||
my $chars = shift;
|
||||
$self->{left_splice_site_chars} = $chars;
|
||||
}
|
||||
|
||||
|
||||
=over 4
|
||||
|
||||
=item get_left_splice_site_chars()
|
||||
|
||||
B<Description:> Retrieves the two characters representing the left splice site
|
||||
|
||||
B<Parameters:> none.
|
||||
|
||||
B<Returns:> $twochars
|
||||
|
||||
ie. Typically, this will return AG or AC depending on the spliced orientation.
|
||||
|
||||
=back
|
||||
|
||||
=cut
|
||||
|
||||
sub get_left_splice_site_chars () {
|
||||
my $self = shift;
|
||||
return ($self->{left_splice_site_chars});
|
||||
}
|
||||
|
||||
|
||||
sub set_right_splice_site_chars() {
|
||||
my $self = shift;
|
||||
my $chars = shift;
|
||||
$self->{right_splice_site_chars} = $chars;
|
||||
}
|
||||
|
||||
=over 4
|
||||
|
||||
=item get_right_splice_chars()
|
||||
|
||||
B<Description:> Retrieves the two characters representing the right splice site
|
||||
|
||||
B<Parameters:> none.
|
||||
|
||||
B<Returns:> $two_chars
|
||||
|
||||
ie. typcially returns GT or CT depending on the spliced orientation.
|
||||
|
||||
=back
|
||||
|
||||
=cut
|
||||
|
||||
|
||||
sub get_right_splice_site_chars() {
|
||||
my $self = shift;
|
||||
return ($self->{right_splice_site_chars});
|
||||
}
|
||||
|
||||
sub toString() {
|
||||
my $self = shift;
|
||||
return( "segment\* orient: " . $self->{orientation} . " coords: " . $self->{lend} . "-" . $self->{rend} . " type: " . $self->{type}
|
||||
. " lsplice: " . $self->has_left_splice_junction() . " rsplice: " . $self->has_right_splice_junction() . "\n");
|
||||
|
||||
}
|
||||
|
||||
sub toToken() {
|
||||
my $segment = shift;
|
||||
my $token = "";
|
||||
my $type = $segment->get_type();
|
||||
my ($lend, $rend) = $segment->get_coords();
|
||||
my ($mlend, $mrend) = $segment->get_mcoords();
|
||||
if ($type =~ /internal|last/) {
|
||||
# check splice site
|
||||
my $left_splice = $segment->get_left_splice_site_chars();
|
||||
if ($segment->has_left_splice_junction()) {
|
||||
$left_splice = uc $left_splice;
|
||||
} else {
|
||||
$left_splice = lc $left_splice;
|
||||
}
|
||||
$token .= $left_splice . "<";
|
||||
}
|
||||
$token .= $lend;
|
||||
if ($mlend) {
|
||||
$token .= "($mlend)";
|
||||
}
|
||||
$token .= "-$rend";
|
||||
if ($rend) {
|
||||
$token .= "($mrend)";
|
||||
}
|
||||
if ($type =~ /internal|first/) {
|
||||
# check splice site
|
||||
my $right_splice = $segment->get_right_splice_site_chars();
|
||||
if ($segment->has_right_splice_junction()) {
|
||||
$right_splice = uc $right_splice;
|
||||
} else {
|
||||
$right_splice = lc $right_splice;
|
||||
}
|
||||
$token .= ">$right_splice";
|
||||
}
|
||||
return ($token);
|
||||
}
|
||||
|
||||
|
||||
|
||||
=over 4
|
||||
|
||||
=item clone()
|
||||
|
||||
B<Description:> Clones an Alignment_segment object into a new Alignment_segment object with the same attribute values.
|
||||
|
||||
B<Parameters:> none
|
||||
|
||||
B<Returns:> new CDNA::Alignment_segment
|
||||
|
||||
=back
|
||||
|
||||
=cut
|
||||
|
||||
|
||||
sub clone {
|
||||
my $self = shift;
|
||||
my $packagename = ref $self;
|
||||
my $clone = {};
|
||||
foreach my $key (keys %$self) {
|
||||
$clone->{$key} = $self->{$key};
|
||||
}
|
||||
bless ($clone, $packagename);
|
||||
return ($clone);
|
||||
}
|
||||
|
||||
|
||||
=over 4
|
||||
|
||||
=item get_length()
|
||||
|
||||
B<Description:> Calculates the length of the alignment segment.
|
||||
|
||||
B<Parameters:> none
|
||||
|
||||
B<Returns:> int
|
||||
|
||||
=back
|
||||
|
||||
=cut
|
||||
|
||||
|
||||
|
||||
sub get_length {
|
||||
my $self = shift;
|
||||
my ($lend, $rend) = $self->get_coords();
|
||||
my $length = abs ($rend - $lend) + 1;
|
||||
return ($length);
|
||||
}
|
||||
|
||||
|
||||
|
||||
|
||||
1; #EOM
|
||||
File diff suppressed because it is too large
Load Diff
File diff suppressed because it is too large
Load Diff
@@ -0,0 +1,289 @@
|
||||
package main;
|
||||
our $SEE;
|
||||
|
||||
package CDNA::CDNA_stitcher;
|
||||
use strict;
|
||||
use CDNA::CDNA_alignment;
|
||||
use CDNA::Gene_obj_alignment_assembler; #used for converting gene_obj to alignment.
|
||||
use Carp;
|
||||
|
||||
my $FUZZDIST = 20; #allow FUZZDIST nt extension beyond splice site.
|
||||
|
||||
sub new {
|
||||
my $packagename = shift;
|
||||
my $self = {
|
||||
fuzzlength=>$FUZZDIST #default setting.
|
||||
};
|
||||
bless ($self, $packagename);
|
||||
return ($self);
|
||||
}
|
||||
|
||||
|
||||
sub set_fuzzlength {
|
||||
my $self = shift;
|
||||
my $fuzzdist = shift;
|
||||
$self->{fuzzlength} = $fuzzdist;
|
||||
}
|
||||
|
||||
sub stitch_alignments {
|
||||
my $self = shift;
|
||||
my ($template_alignment, $thread_alignment) = @_;
|
||||
|
||||
my $template_acc = $template_alignment->get_acc();
|
||||
my $thread_acc = $thread_alignment->get_acc();
|
||||
|
||||
print "Stitching Template:\n$template_acc: " . $template_alignment->toToken()
|
||||
. "\nby\n$thread_acc: " . $thread_alignment->toToken() . "\n\n" if $main::SEE;
|
||||
|
||||
## don't even think about stitching alignments of opposite spliced orienatations!!!
|
||||
|
||||
my $template_spliced_orient = $template_alignment->get_spliced_orientation();
|
||||
my $thread_spliced_orient = $thread_alignment->get_spliced_orientation();
|
||||
|
||||
if ($template_spliced_orient ne '?' && $thread_spliced_orient ne '?') {
|
||||
## both have assigned transcribed orients
|
||||
if ($template_spliced_orient ne $thread_spliced_orient) {
|
||||
confess "Error, trying to stitch together oppositely transcribed alignments. That's impossible. ";
|
||||
}
|
||||
}
|
||||
|
||||
|
||||
my $spliced_orient = ($thread_spliced_orient ne '?') ? $thread_spliced_orient : $template_spliced_orient;
|
||||
|
||||
my $fuzzlength = $self->{fuzzlength};
|
||||
|
||||
## Algorithm
|
||||
## -anchor the first thread segment to the template alignment
|
||||
## -determine the boundaries of the matching anchor and first threaded segment
|
||||
## -add all preceding template segments to the stitched alignment if splice compatible.
|
||||
## -add internal cdna alignment segments
|
||||
## -add terminal template alignment segments if splice compatible.
|
||||
|
||||
my @template_segments = $template_alignment->get_alignment_segments();
|
||||
my @threaded_segments = $thread_alignment->get_alignment_segments();
|
||||
|
||||
my $single_threaded_segment = ($#threaded_segments == 0) ? 1:0; #indicate only a single segment exists.
|
||||
|
||||
my @stitched_segments;
|
||||
## Anchor first threaded segment to the template alignment:
|
||||
my ($thread_lend, $thread_rend) = $threaded_segments[0]->get_coords();
|
||||
my $anchor_pos = -1;
|
||||
for (my $i = 0; $i <= $#template_segments; $i++) {
|
||||
my ($lend, $rend) = $template_segments[$i]->get_coords();
|
||||
if ($lend < $thread_rend && $rend > $thread_lend) { #overlap
|
||||
$anchor_pos = $i;
|
||||
last;
|
||||
}
|
||||
}
|
||||
print "Anchoring first cDNA segment. Anchor point: $anchor_pos\n" if $SEE;
|
||||
if ($anchor_pos > -1) { #found an anchor point in template alignment.
|
||||
|
||||
|
||||
## add stitched segment
|
||||
my $anchor_segment = $template_segments[$anchor_pos];
|
||||
my ($anchor_lend, $anchor_rend) = $anchor_segment->get_coords();
|
||||
my $first_threaded_segment = $threaded_segments[0];
|
||||
my ($thread_lend, $thread_rend) = $first_threaded_segment->get_coords();
|
||||
# initialize to largest spread
|
||||
my ($new_lend) = ($anchor_lend < $thread_lend) ? $anchor_lend : $thread_lend;
|
||||
my ($new_rend) = ($anchor_rend > $thread_rend) ? $anchor_rend : $thread_rend;
|
||||
# adjust based on splice boundaries
|
||||
my ($has_left_splice_junction, $has_right_splice_junction);
|
||||
$has_left_splice_junction = $anchor_segment->has_left_splice_junction(); #initialize.
|
||||
if ($anchor_segment->has_left_splice_junction() && ($anchor_lend - $thread_lend <= $fuzzlength)) {
|
||||
$new_lend = $anchor_lend;
|
||||
} elsif ($thread_lend < $anchor_lend) {
|
||||
#using threaded segment as initial stitched segment
|
||||
$has_left_splice_junction = $first_threaded_segment->has_left_splice_junction();
|
||||
}
|
||||
|
||||
$has_right_splice_junction = $first_threaded_segment->has_right_splice_junction();
|
||||
if ($first_threaded_segment->has_right_splice_junction()) {
|
||||
$new_rend = $thread_rend;
|
||||
} elsif ($anchor_segment->has_right_splice_junction() && ($thread_rend - $anchor_rend <= $fuzzlength)) {
|
||||
$new_rend = $anchor_rend;
|
||||
$has_right_splice_junction = $anchor_segment->has_right_splice_junction();
|
||||
}
|
||||
|
||||
## Add preceding template segments if current segment is left-splice compatible.
|
||||
if ($has_left_splice_junction) {
|
||||
print "Adding all template segments before position $anchor_pos.\n" if $SEE;
|
||||
## add all template segments to the stitched alignment preceding the anchor point:
|
||||
for (my $i = 0; $i < $anchor_pos; $i++) {
|
||||
push (@stitched_segments, $template_segments[$i]->clone());
|
||||
}
|
||||
}
|
||||
|
||||
## add the current segment.
|
||||
my $newsegment = $anchor_segment->clone();
|
||||
$newsegment->set_coords($new_lend, $new_rend);
|
||||
$newsegment->set_left_splice_junction($has_left_splice_junction);
|
||||
$newsegment->set_right_splice_junction($has_right_splice_junction);
|
||||
print "adding current segment: lsplice: $has_left_splice_junction, rsplice: $has_right_splice_junction\n" if $SEE;
|
||||
push (@stitched_segments, $newsegment);
|
||||
|
||||
} else { #no anchor pos, simply add the first threaded segment:
|
||||
print "No anchor position, simply adding the first threaded segment.\n" if $SEE;
|
||||
push (@stitched_segments, $threaded_segments[0]->clone());
|
||||
}
|
||||
|
||||
## Add all but last threaded segments to the stitched alignment:
|
||||
|
||||
for (my $i = 1; $i < $#threaded_segments; $i++) {
|
||||
print "Adding internal cDNA alignment segment, index: $i\n" if $SEE;
|
||||
push (@stitched_segments, $threaded_segments[$i]->clone());
|
||||
}
|
||||
|
||||
## Anchor the last threaded segment to a segment within the template model:
|
||||
print "Anchoring the terminal segment.\n" if $SEE;
|
||||
$anchor_pos = -1;
|
||||
my $last_threaded_segment = $threaded_segments[$#threaded_segments];
|
||||
($thread_lend, $thread_rend) = $last_threaded_segment->get_coords();
|
||||
# find last template segment overlapping last cdna segment
|
||||
for (my $i = $#template_segments; $i >= 0; $i--) {
|
||||
my ($lend, $rend) = $template_segments[$i]->get_coords();
|
||||
if ($lend < $thread_rend && $rend > $thread_lend) { #overlap
|
||||
$anchor_pos = $i;
|
||||
last;
|
||||
}
|
||||
}
|
||||
print "Terminal anchor position: $anchor_pos\n" if $SEE;
|
||||
if ($anchor_pos > -1) {
|
||||
#build composite segment
|
||||
my $anchor_segment = $template_segments[$anchor_pos];
|
||||
my $has_left_splice_junction = $last_threaded_segment->has_left_splice_junction(); #initialize.
|
||||
my $has_right_splice_junction = $anchor_segment->has_right_splice_junction();
|
||||
my ($anchor_lend, $anchor_rend) = $anchor_segment->get_coords();
|
||||
my $new_lend = ($anchor_lend < $thread_lend) ? $anchor_lend : $thread_lend;
|
||||
my $new_rend = ($anchor_rend > $thread_rend) ? $anchor_rend : $thread_rend;
|
||||
if ($last_threaded_segment->has_left_splice_junction()) {
|
||||
$new_lend = $thread_lend;
|
||||
} elsif ($anchor_segment->has_left_splice_junction() && ($anchor_lend - $thread_lend <= $fuzzlength)) {
|
||||
$new_lend = $anchor_lend;
|
||||
$has_left_splice_junction = $anchor_segment->has_left_splice_junction();
|
||||
}
|
||||
if ($anchor_segment->has_right_splice_junction() && ($thread_rend - $anchor_rend <= $fuzzlength)) {
|
||||
$new_rend = $anchor_rend;
|
||||
} else {
|
||||
$has_right_splice_junction = $last_threaded_segment->has_right_splice_junction();
|
||||
}
|
||||
if ($single_threaded_segment) { #only one segment (first == last)
|
||||
#just update existing status:
|
||||
print "Only one threaded segment, updating it's rend coord and status.\n" if $SEE;
|
||||
my $last_stitched_segment = $stitched_segments[$#stitched_segments];
|
||||
my ($curr_lend, $curr_rend) = $last_stitched_segment->get_coords();
|
||||
$last_stitched_segment->set_coords($curr_lend, $new_rend);
|
||||
$last_stitched_segment->set_right_splice_junction($has_right_splice_junction);
|
||||
} else {
|
||||
my $newsegment = $anchor_segment->clone();
|
||||
$newsegment->set_coords($new_lend, $new_rend);
|
||||
$newsegment->set_left_splice_junction($has_left_splice_junction);
|
||||
$newsegment->set_right_splice_junction($has_right_splice_junction);
|
||||
print "adding composite terminal segment. Lsplice: $has_left_splice_junction, Rsplice: $has_right_splice_junction.\n" if $SEE;
|
||||
push (@stitched_segments, $newsegment);
|
||||
}
|
||||
} else {
|
||||
print "No matching terminal exon in template.\n" if $SEE;
|
||||
if ($single_threaded_segment) {
|
||||
print "Single threaded segment remains unchanged.\n" if $SEE;
|
||||
} else {
|
||||
|
||||
print "Adding last cDNA exon.\n" if $SEE;
|
||||
push (@stitched_segments, $last_threaded_segment->clone());
|
||||
}
|
||||
}
|
||||
|
||||
|
||||
## Add terminal template segments if the last stitched segment contains a splice junction
|
||||
|
||||
my $last_stitched_segment = $stitched_segments[$#stitched_segments];
|
||||
if ($last_stitched_segment->has_right_splice_junction()) {
|
||||
print "Adding terminal template segments:\n" if $SEE;
|
||||
my ($last_lend, $last_rend) = $last_stitched_segment->get_coords();
|
||||
$anchor_pos = -1;
|
||||
for (my $i = $#template_segments; $i >= 0; $i--) {
|
||||
my ($anchor_lend, $anchor_rend) = $template_segments[$i]->get_coords();
|
||||
if ($anchor_rend > $last_lend && $anchor_lend < $last_rend) { #overlap
|
||||
$anchor_pos = $i;
|
||||
last;
|
||||
}
|
||||
}
|
||||
print "Last overlapping alignment segment in index found at: $anchor_pos\n" if $SEE;
|
||||
if ($anchor_pos > -1) {
|
||||
for (my $i = $anchor_pos + 1; $i <= $#template_segments; $i++) {
|
||||
print "\tadding terminal template segment index: $i\n" if $SEE;
|
||||
push (@stitched_segments, $template_segments[$i]->clone());
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
|
||||
## Done stitching segments together. Create new alignment:
|
||||
my $cdna_length = 0;
|
||||
foreach my $segment (@stitched_segments) {
|
||||
my $length = $segment->get_length();
|
||||
$cdna_length += $length;
|
||||
}
|
||||
|
||||
my $seq_ref = $template_alignment->get_genomic_seq_ref();
|
||||
|
||||
my $stitched_alignment = new CDNA::CDNA_alignment ($cdna_length, \@stitched_segments, $seq_ref); #aligned orientation auto assigned.
|
||||
|
||||
$stitched_alignment->set_spliced_orientation($spliced_orient);
|
||||
$stitched_alignment->set_acc($template_alignment->get_acc());
|
||||
|
||||
print "Stitched alignment: " . $stitched_alignment->toToken() . "\n" if $SEE;
|
||||
|
||||
return ($stitched_alignment);
|
||||
}
|
||||
|
||||
|
||||
|
||||
sub stitch_alignment_into_gene {
|
||||
my $self = shift;
|
||||
my ($gene_obj, $cdna_obj, $sequence_ref) = @_;
|
||||
|
||||
my $gene_obj_assembler = new CDNA::Gene_obj_alignment_assembler($sequence_ref);
|
||||
my $gene_based_cdna_obj = $gene_obj_assembler->gene_obj_to_cdna_alignment($gene_obj);
|
||||
|
||||
my $stitched_alignment = $self->stitch_alignments($gene_based_cdna_obj, $cdna_obj);
|
||||
$stitched_alignment->set_fli(1);
|
||||
|
||||
my $partials_href = $self->_analyze_partial_status($gene_obj);
|
||||
my $stitched_gene_obj = $stitched_alignment->get_gene_obj_via_alignment($partials_href);
|
||||
|
||||
return ($stitched_gene_obj);
|
||||
|
||||
}
|
||||
|
||||
|
||||
####
|
||||
sub _analyze_partial_status {
|
||||
my $self = shift;
|
||||
my ($gene_obj) = shift;
|
||||
my %partials;
|
||||
if ($gene_obj->is_5prime_partial()) {
|
||||
$partials{"5prime"} = 1;
|
||||
}
|
||||
if ($gene_obj->is_3prime_partial()) {
|
||||
$partials{"3prime"} = 1;
|
||||
}
|
||||
return (\%partials);
|
||||
}
|
||||
|
||||
|
||||
|
||||
|
||||
1; #EOM
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
@@ -0,0 +1,140 @@
|
||||
package main;
|
||||
our $SEE;
|
||||
|
||||
=head1 NAME
|
||||
|
||||
CDNA::Gene_obj_alignment_assembler;
|
||||
|
||||
=cut
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
This package assembles multiple gene objs by assembling compatible sets of coordinates. This module inherits from the CDNA::Genome_based_cDNA_assembler module. Please see this inherited module for additional methods available.
|
||||
|
||||
=cut
|
||||
|
||||
package CDNA::Gene_obj_alignment_assembler;
|
||||
use strict;
|
||||
use base qw (CDNA::PASA_alignment_assembler);
|
||||
use CDNA::CDNA_alignment;
|
||||
|
||||
|
||||
=item new()
|
||||
|
||||
=over 4
|
||||
|
||||
B<Description:> Instantiate a new CDNA::Gene_obj_alignment_assembler object.
|
||||
|
||||
B<Parameters:> $seq_ref
|
||||
|
||||
$seq_ref is a scalar reference to the genomic sequence string.
|
||||
|
||||
B<Returns:> obj_ref
|
||||
|
||||
=back
|
||||
|
||||
=cut
|
||||
|
||||
|
||||
sub new {
|
||||
my $packagename = shift;
|
||||
my $seqref = shift;
|
||||
my $self = $packagename->SUPER::new();
|
||||
$self->{sequence_ref} = $seqref;
|
||||
bless ($self, $packagename);
|
||||
|
||||
return ($self);
|
||||
}
|
||||
|
||||
|
||||
|
||||
=item assemble_genes()
|
||||
|
||||
=over 4
|
||||
|
||||
B<Description:> assembles a list of Gene_obj(s). Each of the Gene_objs
|
||||
|
||||
B<Parameters:> @Gene_obj
|
||||
|
||||
@Gene_obj is an array of gene objects created via the Gene_obj.pm module.
|
||||
|
||||
B<Returns:> @CDNA_alignments
|
||||
|
||||
The @CDNA_alignments array contains the list of CDNA::CDNA_alignment objects created based on the gene objects.
|
||||
|
||||
The CDNA_alignment accession is set to the Model_feat_name of the gene_obj. Retrieving the cDNA acc using the get_acc() method will allow a mapping back to the gene object. Also, the newly created CDNA_alignment objects that are returned should be in the same order as the inputed gene objects, so indexing should provide mapping info as well.
|
||||
|
||||
use the get_assemblies() function to fetch the merged genes.
|
||||
|
||||
=back
|
||||
|
||||
=cut
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
sub assemble_genes {
|
||||
my $self = shift;
|
||||
my @gene_objs = @_;
|
||||
my @cDNA_alignments;
|
||||
foreach my $gene_obj (@gene_objs) {
|
||||
my $alignment_obj = $self->gene_obj_to_cdna_alignment($gene_obj);
|
||||
push (@cDNA_alignments, $alignment_obj);
|
||||
}
|
||||
$self->assemble_alignments(@cDNA_alignments);
|
||||
return (@cDNA_alignments);
|
||||
}
|
||||
|
||||
|
||||
|
||||
=item gene_obj_to_cdna_alignment()
|
||||
|
||||
=over 4
|
||||
|
||||
B<Description:> method converts a Gene_obj to a CDNA::CDNA_alignment obj.
|
||||
|
||||
B<Parameters:> Gene_obj
|
||||
|
||||
B<Returns:> CDNA::CDNA_alignment
|
||||
|
||||
=back
|
||||
|
||||
=cut
|
||||
|
||||
sub gene_obj_to_cdna_alignment {
|
||||
my $self = shift;
|
||||
my $gene_obj = shift;
|
||||
my @exons = $gene_obj->get_exons();
|
||||
my %coords;
|
||||
my @alignment_segments;
|
||||
my $cdna_length = 0;
|
||||
foreach my $exon (@exons) {
|
||||
my ($end5, $end3) = $exon->get_coords();
|
||||
my $alignment_seg = new CDNA::Alignment_segment($end5, $end3);
|
||||
push (@alignment_segments, $alignment_seg);
|
||||
$cdna_length += abs ($end3 - $end5) + 1;
|
||||
}
|
||||
my $alignment_obj = new CDNA::CDNA_alignment($cdna_length, \@alignment_segments, $self->{sequence_ref});
|
||||
my $feat_name = $gene_obj->{Model_feat_name};
|
||||
print "Gene has the following model feat_name: $feat_name\n" if $SEE;
|
||||
$alignment_obj->set_acc($feat_name);
|
||||
$alignment_obj->set_title($gene_obj->{com_name});
|
||||
$alignment_obj->set_fli_status(1); #treat like a fli cdna
|
||||
my $align_orient = $alignment_obj->get_spliced_orientation();
|
||||
## Make sure strand is set correctly (should only matter for single exon genes).
|
||||
if ($align_orient ne $gene_obj->{strand}) {
|
||||
$alignment_obj->set_orientation($gene_obj->{strand});
|
||||
$alignment_obj->set_spliced_orientation($gene_obj->{strand});
|
||||
}
|
||||
$alignment_obj->remap_cdna_segment_coords();
|
||||
print $alignment_obj->toToken() ." " . $alignment_obj->get_acc() . "\n" if $SEE;
|
||||
return ($alignment_obj);
|
||||
}
|
||||
|
||||
|
||||
1; #EOM
|
||||
|
||||
|
||||
|
||||
|
||||
@@ -0,0 +1,630 @@
|
||||
#!/usr/local/bin/perl
|
||||
|
||||
package main;
|
||||
our $SEE;
|
||||
|
||||
|
||||
package CDNA::Genome_based_cDNA_assembler;
|
||||
|
||||
=head1 NAME
|
||||
|
||||
CDNA::Genome_based_cdna_assembler
|
||||
|
||||
=cut
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
This module is used to assemble compatible cDNA alignments. The algorithm is as follows:
|
||||
must describe this here.
|
||||
|
||||
=cut
|
||||
|
||||
use strict;
|
||||
use CDNA::CDNA_alignment;
|
||||
use Data::Dumper;
|
||||
|
||||
my $DELIMETER = "$;,";
|
||||
my $FUZZLENGTH = 20;
|
||||
|
||||
|
||||
=item new()
|
||||
|
||||
=over 4
|
||||
|
||||
B<Description:> instantiates a new cDNA assembler obj.
|
||||
|
||||
B<Parameters:> $sequence_sref
|
||||
|
||||
$sequence_sref is a reference to a scalar containing the genomic sequence string.
|
||||
|
||||
B<Returns:> $obj_href
|
||||
|
||||
$obj_href is the object reference newly instantiated by this new method.
|
||||
|
||||
=back
|
||||
|
||||
=cut
|
||||
|
||||
sub new () {
|
||||
my $package_name = shift;
|
||||
my $self = {};
|
||||
bless ($self, $package_name);
|
||||
$self->_init(@_);
|
||||
return ($self);
|
||||
}
|
||||
|
||||
|
||||
sub _init {
|
||||
my $self = shift;
|
||||
my ($sequence_ref) = @_;
|
||||
$self->{incoming_alignments} = []; #these are the alignments to be assembled.
|
||||
$self->{assemblies} = []; #contains list of all singletons and assemblies.
|
||||
$self->{sequence_ref} = $sequence_ref;
|
||||
$self->{fuzzlength} = $FUZZLENGTH; #default setting.
|
||||
}
|
||||
|
||||
|
||||
=item assemble_alignments()
|
||||
|
||||
=over 4
|
||||
|
||||
B<DESCRIPTION:> assembles a series of cDNA aligmnments into one or more cDNA assemblies
|
||||
|
||||
B<Parameters:> @alignments
|
||||
|
||||
@alignments is an array of CDNA::CDNA_alignment objects
|
||||
|
||||
B<Returns:> none.
|
||||
|
||||
=back
|
||||
|
||||
=cut
|
||||
|
||||
sub assemble_alignments {
|
||||
my $self = shift;
|
||||
my @alignments = @_;
|
||||
@alignments = reverse sort {$a->{length}<=>$b->{length}} @alignments; #keep in order of decreasing alignment length.
|
||||
$self->{incoming_alignments} = [@alignments];
|
||||
#return;
|
||||
|
||||
## Algorithm: given cdna, merge with rest of cDNAs iteratively until merging complete.
|
||||
## find unmerged cDNA, merge it if possible with all individual cdna entries.
|
||||
## continue until all cDNAs have merged products, if possible.
|
||||
|
||||
my $num_alignments = $#alignments + 1;
|
||||
for (my $i = 0; $i < $num_alignments; $i++) {
|
||||
my $seed_alignment = $alignments[$i];
|
||||
if ($seed_alignment->{merged}) {next;}
|
||||
print "Checking seed $i\n" if $SEE;
|
||||
my $merged_alignment = $seed_alignment; #initialize to seed alignment.
|
||||
my $merged_flag = 1;
|
||||
my $round = 0;
|
||||
while ($merged_flag) {
|
||||
$merged_flag = 0;
|
||||
$round++;
|
||||
print "Merging round $round\n" if $SEE;
|
||||
for (my $j=0; $j < $num_alignments; $j++) {
|
||||
if ($i == $j) {next;} #no self comparisons.
|
||||
my $other_alignment = $alignments[$j];
|
||||
if ($self->already_contains($merged_alignment, $other_alignment)) { next;}
|
||||
if ($self->can_merge($merged_alignment, $other_alignment)) {
|
||||
my $initial_merged_fli_status = $merged_alignment->is_fli();
|
||||
my $initial_merged_orient = $merged_alignment->get_orientation();
|
||||
$merged_alignment = $self->merge_alignments($merged_alignment, $other_alignment);
|
||||
$alignments[$i]->{merged} = 1; #set seed alignment merge flag.
|
||||
$alignments[$j]->{merged} = 1; #set other alignment merge flag.
|
||||
$merged_flag = 1; #indicates something actually merged this round.
|
||||
|
||||
$merged_alignment->remap_cdna_segment_coords();
|
||||
print "merged: " . $merged_alignment->toToken() . "\n" if $SEE;
|
||||
|
||||
}
|
||||
}
|
||||
}
|
||||
push (@{$self->{assemblies}}, $merged_alignment); #either an assembled product, or something that won't ever merge.
|
||||
}
|
||||
}
|
||||
|
||||
=item get_assemblies()
|
||||
|
||||
=over 4
|
||||
|
||||
B<Description:> returns all the alignment assemblies resulting from the assembly procedure.
|
||||
|
||||
B<Parameters:> none.
|
||||
|
||||
B<Returns:> @assemblies
|
||||
|
||||
@assemblies is an array of CDNA::CDNA_alignment objects.
|
||||
|
||||
use the get_acc() method of the alignment object to retrieve all the accessions of the cDNAs that were merged into the assembly.
|
||||
|
||||
=back
|
||||
|
||||
=cut
|
||||
|
||||
|
||||
sub get_assemblies {
|
||||
my $self = shift;
|
||||
return (@{$self->{assemblies}});
|
||||
}
|
||||
|
||||
|
||||
# private method. Determines if two alignments are compatible with one another.
|
||||
sub can_merge () {
|
||||
my $self = shift;
|
||||
my ($a1, $a2) = @_;
|
||||
print "Checking to see if can merge: " . $a1->get_acc() . ", " . $a2->get_acc() . "\n" if $::SEE;
|
||||
## See if the coord spans overlap
|
||||
my ($a1_lend, $a1_rend) = $a1->get_coords();
|
||||
my ($a2_lend, $a2_rend) = $a2->get_coords();
|
||||
unless (&overlap($a1_lend, $a1_rend, $a2_lend, $a2_rend)) {
|
||||
print "failed merge: No overlap between alignment spans. ($a1_lend, $a1_rend) vs. ($a2_lend, $a2_rend)\n" if $::SEE;
|
||||
return(0);
|
||||
}
|
||||
|
||||
## Make sure the spliced orientation is equivalent if appropriate
|
||||
my $a1_num_segs = $a1->get_num_segments();
|
||||
my $a2_num_segs = $a2->get_num_segments();
|
||||
my $a1_spliced_orientation = $a1->get_spliced_orientation();
|
||||
my $a2_spliced_orientation = $a2->get_spliced_orientation();
|
||||
my $a1_is_fli = $a1->is_fli();
|
||||
my $a2_is_fli = $a2->is_fli();
|
||||
|
||||
my $fuzzlength = $self->{fuzzlength};
|
||||
|
||||
if ($a1_num_segs > 1 && $a2_num_segs > 1) { #if more than one segment, then spliced orientation is relevant.
|
||||
if ($a1_spliced_orientation ne $a2_spliced_orientation) {
|
||||
print "failed merge: $a1_num_segs segments vs. $a2_num_segs and opposite spliced orientations.\n" if $::SEE;
|
||||
return (0);
|
||||
}
|
||||
}
|
||||
|
||||
if ($a1_is_fli && $a2_is_fli && ($a1_spliced_orientation ne $a2_spliced_orientation)) { #fli's must have same orient.
|
||||
print "failed merge: (a1-fli: $a1_is_fli, a2-fli: $a2_is_fli) and opposite orientations.\n" if $SEE;
|
||||
return (0);
|
||||
}
|
||||
|
||||
## Check all overlapping segments to ensure non-conflicting segments.
|
||||
my @a1_segments = $a1->get_alignment_segments();
|
||||
my @a2_segments = $a2->get_alignment_segments();
|
||||
|
||||
|
||||
## align segment orders between a1 and a2
|
||||
my ($starting_a1, $starting_a2);
|
||||
for (my $i = 0; $i <= $#a1_segments; $i++) {
|
||||
my $a1_seg = $a1_segments[$i];
|
||||
my ($a1_lend, $a1_rend) = $a1_seg->get_coords();
|
||||
for (my $j = 0; $j <= $#a2_segments; $j++) {
|
||||
my $a2_seg = $a2_segments[$j];
|
||||
my ($a2_lend, $a2_rend) = $a2_seg->get_coords();
|
||||
if (&overlap($a1_lend, $a1_rend, $a2_lend, $a2_rend)) {
|
||||
$starting_a1 = $i;
|
||||
$starting_a2 = $j;
|
||||
last;
|
||||
}
|
||||
}
|
||||
if (defined ($starting_a1) && defined ($starting_a2)) {
|
||||
last;
|
||||
}
|
||||
}
|
||||
|
||||
unless (defined ($starting_a1) && defined ($starting_a2)) {
|
||||
print "failed merge: can't align two segments between overlapping alignments.\n" if $::SEE;
|
||||
return (0);
|
||||
}
|
||||
|
||||
unless ($starting_a1 == 0 || $starting_a2 == 0) {
|
||||
print "failed merge: segment alignment doesn't begin at either cDNA terminus.\n" if $::SEE;
|
||||
return (0);
|
||||
}
|
||||
|
||||
while ($starting_a1 <= $#a1_segments && $starting_a2 <= $#a2_segments) {
|
||||
my $a1_segment = $a1_segments[$starting_a1];
|
||||
my $a2_segment = $a2_segments[$starting_a2];
|
||||
|
||||
my ($a1_lend, $a1_rend) = $a1_segment->get_coords();
|
||||
my ($a2_lend, $a2_rend) = $a2_segment->get_coords();
|
||||
|
||||
if (&overlap($a1_lend, $a1_rend, $a2_lend, $a2_rend)) {
|
||||
## See if have splice sites, do they exist and are they identical
|
||||
if ($a1_segment->has_left_splice_junction() || $a2_segment->has_left_splice_junction()) {
|
||||
if ($a1_segment->has_left_splice_junction() && $a2_segment->has_left_splice_junction() && $a1_lend != $a2_lend) {
|
||||
print "failed merge:\tboth left splice, but unequal coords: L1 ($a1_lend), L2 ($a2_lend)\n" if $::SEE;
|
||||
return (0);
|
||||
} elsif ($a1_segment->has_left_splice_junction() && ($a2_lend + $fuzzlength < $a1_lend)) { #alignment extends beyond a splice junction.
|
||||
print "failed merge:\tL1 left splice, L2 ($a2_lend) < L1 ($a1_lend)\n" if $::SEE;
|
||||
return (0);
|
||||
} elsif ($a2_segment->has_left_splice_junction() && ($a1_lend + $fuzzlength < $a2_lend)) {
|
||||
print "failed merge:\tL2 left splice, L1 ($a1_lend) < L2 ($a2_lend)\n" if $::SEE;
|
||||
return (0);
|
||||
}
|
||||
|
||||
}
|
||||
if ($a1_segment->has_right_splice_junction() || $a2_segment->has_right_splice_junction()) {
|
||||
if ($a1_segment->has_right_splice_junction() && $a2_segment->has_right_splice_junction() && $a1_rend != $a2_rend) {
|
||||
print "failed merge:\tboth right splice, but unequal coords: R1($a1_rend), R2($a2_rend)\n" if $::SEE;
|
||||
return (0);
|
||||
} elsif ($a1_segment->has_right_splice_junction() && ($a2_rend - $fuzzlength > $a1_rend)) {
|
||||
print "failed merge:\tR1 right splice, R2($a2_rend) > R1 ($a1_rend)\n" if $::SEE;
|
||||
return (0);
|
||||
} elsif ($a2_segment->has_right_splice_junction() && ($a1_rend - $fuzzlength > $a2_rend)) {
|
||||
print "failed merge:\tR2 right splice, R1 ($a1_rend) > R2 ($a2_rend)\n" if $::SEE;
|
||||
return (0);
|
||||
}
|
||||
}
|
||||
} else {
|
||||
print "failed merge: Two ordered segments don't overlap. ($a1_lend, $a1_rend) , ($a2_lend, $a2_rend)\n" if $::SEE;
|
||||
return (0);
|
||||
}
|
||||
$starting_a1++;
|
||||
$starting_a2++;
|
||||
|
||||
}
|
||||
|
||||
## Passed all tests
|
||||
print "Merge tests PASSED.\n" if $::SEE;
|
||||
return (1);
|
||||
|
||||
}
|
||||
|
||||
|
||||
|
||||
# private method
|
||||
# merges two alignment objects together into an assembly.
|
||||
sub merge_alignments () {
|
||||
my ($self, $a1, $a2) = @_;
|
||||
print "Merging <" . $a1->get_acc() . ">, <" . $a2->get_acc() . ">\n" if $::SEE;
|
||||
my $a1_fli = $a1->is_fli();
|
||||
my $a2_fli = $a2->is_fli();
|
||||
print "a1_fli: $a1_fli, a2_fli: $a2_fli\n" if $SEE;
|
||||
## Determine fli status for merged product.
|
||||
my $merged_fli_status = ($a1_fli || $a2_fli);
|
||||
|
||||
my $merged_orientation = $self->determine_merged_orientation($a1, $a2);
|
||||
|
||||
#get a1 segment cooridnates;
|
||||
my %leftsplicecoords; #preferrentially use splice coords over Fuzzlength extensions.
|
||||
my %rightsplicecoords;
|
||||
my %a1_coords;
|
||||
my @a1_segments = $a1->get_alignment_segments();
|
||||
foreach my $seg (@a1_segments) {
|
||||
my ($lend, $rend) = $seg->get_coords();
|
||||
$a1_coords{$lend} = $rend;
|
||||
if ($seg->has_left_splice_junction()) {
|
||||
$leftsplicecoords{$lend} = 1;
|
||||
}
|
||||
if ($seg->has_right_splice_junction()) {
|
||||
$rightsplicecoords{$rend} = 1;
|
||||
}
|
||||
}
|
||||
|
||||
# get a2 segment coordinates:
|
||||
my %a2_coords;
|
||||
my @a2_segments = $a2->get_alignment_segments();
|
||||
foreach my $seg (@a2_segments) {
|
||||
my ($lend, $rend) = $seg->get_coords();
|
||||
$a2_coords{$lend} = $rend;
|
||||
if ($seg->has_left_splice_junction()) {
|
||||
$leftsplicecoords{$lend} = 1;
|
||||
}
|
||||
if ($seg->has_right_splice_junction()) {
|
||||
$rightsplicecoords{$rend} = 1;
|
||||
}
|
||||
}
|
||||
|
||||
my %merged_coords;
|
||||
|
||||
#print "Coord dumps:\n" . Dumper (\%a1_coords) . Dumper (\%a2_coords) . "\n";
|
||||
|
||||
#print "\n\nBEGIN\n";
|
||||
## merge the overlapping coordinate sets between a1 and a2 alignments.
|
||||
foreach my $a1_lend (keys %a1_coords) {
|
||||
my $a1_rend = $a1_coords{$a1_lend};
|
||||
my ($merged_lend, $merged_rend);
|
||||
foreach my $a2_lend (keys %a2_coords) {
|
||||
my $a2_rend = $a2_coords{$a2_lend};
|
||||
if (&overlap($a1_lend, $a1_rend, $a2_lend, $a2_rend)) { #overlap
|
||||
## Determine merged lend;
|
||||
if ($leftsplicecoords{$a1_lend}) {
|
||||
$merged_lend = $a1_lend;
|
||||
} elsif ($leftsplicecoords{$a2_lend}) {
|
||||
$merged_lend = $a2_lend;
|
||||
} else {
|
||||
$merged_lend = min ($a1_lend, $a2_lend);
|
||||
}
|
||||
# Determine merged rend
|
||||
if ($rightsplicecoords{$a1_rend}) {
|
||||
$merged_rend = $a1_rend;
|
||||
} elsif ($rightsplicecoords{$a2_rend}) {
|
||||
$merged_rend = $a2_rend;
|
||||
} else {
|
||||
$merged_rend = max ($a1_rend, $a2_rend);
|
||||
}
|
||||
last;
|
||||
}
|
||||
}
|
||||
if ($merged_lend && $merged_rend) {
|
||||
#print "Adding overlapped \$merged_coords{$merged_lend} = $merged_rend\n";
|
||||
$merged_coords{$merged_lend} = $merged_rend;
|
||||
} else { #must not have been any overlap; keep a1 coordset
|
||||
#print "Keeping a1 coords: \$merged_coords{$a1_lend} = $a1_rend\n";
|
||||
$merged_coords{$a1_lend} = $a1_rend;
|
||||
}
|
||||
}
|
||||
#print "adding unconsumed a2 coords:\n";
|
||||
## add non-overlapping a2-segments
|
||||
foreach my $a2_lend (keys %a2_coords) {
|
||||
my $overlap = 0;
|
||||
my $a2_rend = $a2_coords{$a2_lend};
|
||||
foreach my $m_lend (keys %merged_coords) {
|
||||
my $m_rend = $merged_coords{$m_lend};
|
||||
if (&overlap($a2_lend, $a2_rend, $m_lend, $m_rend)) {
|
||||
$overlap = 1;
|
||||
last;
|
||||
}
|
||||
}
|
||||
if (!$overlap) {
|
||||
#print "Consuming a2 non-overlapping coords.\n";
|
||||
$merged_coords{$a2_lend} = $a2_rend; #added a2 non-overlapping coordset
|
||||
} else {
|
||||
#print "coords overlapped, not consuming.\n";
|
||||
}
|
||||
}
|
||||
print Dumper (\%merged_coords) if $::SEE;
|
||||
## Create a new alignment based on a1 and a2
|
||||
my @alignment_segments;
|
||||
my $merged_length = 0;
|
||||
foreach my $end5 (keys %merged_coords) {
|
||||
my $end3 = $merged_coords{$end5};
|
||||
my $alignment_seg = new CDNA::Alignment_segment($end5, $end3);
|
||||
push (@alignment_segments, $alignment_seg);
|
||||
$merged_length += abs ($end3 - $end5) + 1;
|
||||
}
|
||||
my $new_alignment = new CDNA::CDNA_alignment($merged_length, \@alignment_segments, $self->{sequence_ref});
|
||||
my $new_acc = $self->merge_accs($a1->get_acc(), $a2->get_acc());
|
||||
$new_alignment->set_acc($new_acc);
|
||||
$new_alignment->set_fli_status($merged_fli_status);
|
||||
$new_alignment->force_spliced_validation($merged_orientation);
|
||||
#print "END.\n\n";
|
||||
return ($new_alignment);
|
||||
}
|
||||
|
||||
|
||||
#private method
|
||||
# returns the minimum of an array of numerical values.
|
||||
sub min {
|
||||
my @x = @_;
|
||||
@x = sort {$a<=>$b} @x;
|
||||
my $y = shift @x;
|
||||
return ($y);
|
||||
}
|
||||
|
||||
|
||||
#private method
|
||||
# returns the maximum of an array of numerical values.
|
||||
sub max {
|
||||
my @x = @_;
|
||||
@x = sort {$a<=>$b} @x;
|
||||
my $y = pop @x;
|
||||
return ($y);
|
||||
}
|
||||
|
||||
|
||||
|
||||
#private method
|
||||
# returns true/false, determines whether two coordinate sets overlap each other.
|
||||
sub overlap {
|
||||
my ($a1_lend, $a1_rend, $a2_lend, $a2_rend) = @_;
|
||||
#print "Checking overlap @_\t";
|
||||
if ($a2_rend >= $a1_lend && $a2_lend <= $a1_rend) { #overlap
|
||||
#print "YES\n";
|
||||
return (1);
|
||||
} else {
|
||||
#print "NO\n";
|
||||
return (0);
|
||||
}
|
||||
}
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
=item toAlignIllustration()
|
||||
|
||||
=over 4
|
||||
|
||||
B<Description:> illustrates the individual cDNAs to be assembled along with the final products.
|
||||
|
||||
B<Parameters:> $max_line_chars(optional)
|
||||
|
||||
$max_line_chars is an integer representing the maximum number of characters in a single line of output to the terminal. The default is 100.
|
||||
|
||||
B<Returns:> $alignment_illustration_text
|
||||
|
||||
$alignment_illustration_text is a string containing a paragraph of text which illustrates the alignments and assemblies. An example is below:
|
||||
|
||||
---> <--> <-----> <---> <---------------- (+)gi|1199466
|
||||
|
||||
---> <--> <-----> <---> <------------ (+)gi|1209702
|
||||
|
||||
----> <--> <---- (+)AV827070
|
||||
|
||||
----> <--> <--- (+)AV828861
|
||||
|
||||
----> <--> <--- (+)AV830936
|
||||
|
||||
---> <--> <- (+)H36350
|
||||
|
||||
ASSEMBLIES: (1)
|
||||
|
||||
----> <--> <-----> <---> <---------------- (+) gi|1199466, gi|1209702, AV827070, AV828861, AV830936, H36350
|
||||
|
||||
|
||||
|
||||
|
||||
=back
|
||||
|
||||
=cut
|
||||
|
||||
|
||||
sub toAlignIllustration () {
|
||||
my $self = shift;
|
||||
my $max_line_chars = shift;
|
||||
$max_line_chars = ($max_line_chars) ? $max_line_chars : 100; #if not specified, 100 chars / line is default.
|
||||
|
||||
## Get minimum coord for relative positioning.
|
||||
my @coords;
|
||||
my @alignments = @{$self->{incoming_alignments}};
|
||||
foreach my $alignment (@alignments) {
|
||||
my @c = $alignment->get_coords();
|
||||
push (@coords, @c);
|
||||
}
|
||||
@coords = sort {$a<=>$b} @coords;
|
||||
print "coords: @coords\n" if $::SEE;
|
||||
my $min_coord = shift @coords;
|
||||
my $max_coord = pop @coords;
|
||||
my $rel_max = $max_coord - $min_coord;
|
||||
my $alignment_text = "";
|
||||
## print each alignment followed by assemblies:
|
||||
my $num_alignments = $#alignments + 1;
|
||||
$alignment_text .= "Individual Alignments: ($num_alignments)\n";
|
||||
my $i = 0;
|
||||
foreach my $alignment (@alignments) {
|
||||
$alignment_text .= (sprintf ("%3d ", $i)) . $alignment->toAlignIllustration($min_coord, $rel_max, $max_line_chars) . "\n";
|
||||
$i++;
|
||||
}
|
||||
|
||||
my @assemblies = @{$self->{assemblies}};
|
||||
my $num_assemblies = $#assemblies + 1;
|
||||
$alignment_text .= "\n\nASSEMBLIES: ($num_assemblies)\n";
|
||||
foreach my $assembly (@assemblies) {
|
||||
$alignment_text .= " " . $assembly->toAlignIllustration($min_coord, $rel_max, $max_line_chars) . "\n";
|
||||
}
|
||||
|
||||
return ($alignment_text);
|
||||
}
|
||||
|
||||
|
||||
|
||||
=over 4
|
||||
|
||||
=item set_fuzzlength()
|
||||
|
||||
B<Description:> Sets the fuzzlength parameter.
|
||||
|
||||
B<Parameters:> int
|
||||
|
||||
B<Returns:> none.
|
||||
|
||||
The fuzzlength is the length allowed to be fuzzy at the terminus of all alignments when compared to overlapping exons containining nearby splice sites.
|
||||
|
||||
=back
|
||||
|
||||
=cut
|
||||
|
||||
sub set_fuzzlength {
|
||||
my $self = shift;
|
||||
my $fuzzlength = shift;
|
||||
|
||||
$self->{fuzzlength} = $fuzzlength;
|
||||
}
|
||||
|
||||
|
||||
|
||||
#private method
|
||||
# determines if two assemblies have the same accessions.
|
||||
sub composition_same () {
|
||||
my ($name1, $name2) = @_;
|
||||
if ($name1 eq $name2) {
|
||||
return (1);
|
||||
} else {
|
||||
return (0);
|
||||
}
|
||||
}
|
||||
|
||||
#private method
|
||||
# creates a new name based on the accessions composing two assemblies.
|
||||
sub merge_accs () {
|
||||
my $self = shift;
|
||||
my @names = @_;
|
||||
my @nameaccs;
|
||||
foreach my $name (@names) {
|
||||
my @nameacclist = split (/$DELIMETER/, $name);
|
||||
push (@nameaccs, @nameacclist);
|
||||
}
|
||||
my %unique;
|
||||
foreach my $acc (@nameaccs) {
|
||||
$unique{$acc} = 1;
|
||||
}
|
||||
my @accs = sort {$a cmp $b} keys %unique;
|
||||
my $combo = join ($DELIMETER, @accs);
|
||||
return ($combo);
|
||||
}
|
||||
|
||||
#private method
|
||||
# checks to see if an assembly already contains all the accessions built into a second assembly.
|
||||
sub already_contains () {
|
||||
## Checks to see if a1 contains all accessions of a2
|
||||
my $self = shift;
|
||||
my ($a1, $a2) = @_;
|
||||
my $a1_acc = $a1->get_acc();
|
||||
my $a2_acc = $a2->get_acc();
|
||||
my @a1_accs = split (/$DELIMETER/, $a1_acc);
|
||||
my @a2_accs = split (/$DELIMETER/, $a2_acc);
|
||||
my %a1_acc_hash;
|
||||
foreach my $acc (@a1_accs) {
|
||||
$a1_acc_hash{$acc} = 1;
|
||||
}
|
||||
my %a2_acc_hash;
|
||||
foreach my $acc (@a2_accs) {
|
||||
$a2_acc_hash{$acc} = 1;
|
||||
}
|
||||
|
||||
foreach my $acc (keys %a2_acc_hash) {
|
||||
unless ($a1_acc_hash{$acc}) {
|
||||
return (0);
|
||||
}
|
||||
}
|
||||
## if still here, then must have all a2 accs in a1.
|
||||
return (1);
|
||||
}
|
||||
|
||||
|
||||
#private
|
||||
sub determine_merged_orientation {
|
||||
my ($self, $a1, $a2) = @_;
|
||||
## Determine the orientation of the merged product.
|
||||
my $num_a1_segments = $a1->get_num_segments();
|
||||
my $num_a2_segments = $a2->get_num_segments();
|
||||
my $a1_spliced_orientation = $a1->get_spliced_orientation();
|
||||
my $a2_spliced_orientation = $a2->get_spliced_orientation();
|
||||
print "a1_spliced_orient: $a1_spliced_orientation, a2_spliced_orient: $a2_spliced_orientation\n" if $SEE;
|
||||
my $merged_orientation = '+'; #initialize to a default.
|
||||
if ($a1_spliced_orientation eq $a2_spliced_orientation) {
|
||||
$merged_orientation = $a1_spliced_orientation;
|
||||
print "Same spliced orientation: $merged_orientation\n" if $SEE;
|
||||
} elsif ($a1->is_fli() || $a2->is_fli()) {
|
||||
$merged_orientation = ($a1->is_fli()) ? $a1_spliced_orientation : $a2_spliced_orientation;
|
||||
print "a1 is fli, using a1 orient: $merged_orientation\n" if ($a1->is_fli() && $SEE);
|
||||
print "a2 is fli, using a2 orient: $merged_orientation\n" if ($a2->is_fli() && $SEE);
|
||||
|
||||
} elsif ($num_a1_segments > 1 || $num_a2_segments > 1) {
|
||||
$merged_orientation = ($num_a1_segments > 1) ? $a1_spliced_orientation : $a2_spliced_orientation;
|
||||
print "a1 has multiple segments, using a1 orient: $merged_orientation\n" if ($num_a1_segments > 1 && $SEE);
|
||||
print "a2 has multiple segments, using a2 orient: $merged_orientation\n" if ($num_a2_segments > 1 && $SEE);
|
||||
|
||||
} else {
|
||||
print "Can't predict the orientation of the merged alignments ($a1_spliced_orientation vs. $a2_spliced_orientation). Using default '+'\n" if $SEE;
|
||||
}
|
||||
return ($merged_orientation);
|
||||
}
|
||||
|
||||
|
||||
|
||||
1; #EOM
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
@@ -0,0 +1,671 @@
|
||||
#!/usr/local/bin/perl
|
||||
|
||||
package main;
|
||||
our $SEE;
|
||||
|
||||
|
||||
package CDNA::Genome_based_cDNA_graph_assembler;
|
||||
|
||||
=head1 NAME
|
||||
|
||||
CDNA::Genome_based_cdna_assembler
|
||||
|
||||
=cut
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
This module is used to assemble compatible cDNA alignments. The algorithm is as follows:
|
||||
must describe this here.
|
||||
|
||||
=cut
|
||||
|
||||
use strict;
|
||||
use CDNA::CDNA_alignment;
|
||||
use Data::Dumper;
|
||||
use base ("CDNA::Genome_based_cDNA_assembler");
|
||||
|
||||
=item new()
|
||||
|
||||
=over 4
|
||||
|
||||
B<Description:> instantiates a new cDNA assembler obj.
|
||||
|
||||
B<Parameters:> $sequence_sref
|
||||
|
||||
$sequence_sref is a reference to a scalar containing the genomic sequence string.
|
||||
|
||||
B<Returns:> $obj_href
|
||||
|
||||
$obj_href is the object reference newly instantiated by this new method.
|
||||
|
||||
=back
|
||||
|
||||
=cut
|
||||
|
||||
sub new () {
|
||||
my $package_name = shift;
|
||||
my $self = {};
|
||||
bless ($self, $package_name);
|
||||
$self->_init(@_);
|
||||
return ($self);
|
||||
}
|
||||
|
||||
|
||||
sub _init {
|
||||
my $self = shift;
|
||||
$self->CDNA::Genome_based_cDNA_assembler::_init(@_);
|
||||
$self->{show_matrix} = 0;
|
||||
$self->{compatibilities} = []; #retains results of compatibility comparisons:
|
||||
$self->{incapsulations} = [];
|
||||
$self->{LobjsForient} = []; #non-fli single-segment alignments forced in forward orientation.
|
||||
$self->{LobjsRorient} = []; #non-fli single segment alignments forced in reverse orientation.
|
||||
$self->{indices_included} = []; #remember what indices are built into assemblies.
|
||||
}
|
||||
|
||||
|
||||
=item assemble_alignments()
|
||||
|
||||
=over 4
|
||||
|
||||
B<DESCRIPTION:> assembles a series of cDNA aligmnments into one or more cDNA assemblies using a directed acyclic graph.
|
||||
|
||||
B<Parameters:> @alignments
|
||||
|
||||
@alignments is an array of CDNA::CDNA_alignment objects
|
||||
|
||||
B<Returns:> none.
|
||||
|
||||
=back
|
||||
|
||||
=cut
|
||||
|
||||
|
||||
sub assemble_alignments {
|
||||
my $self = shift;
|
||||
my @alignments = @_;
|
||||
@alignments = sort {$a->{lend}<=>$b->{lend}} @alignments; #keep in order of lend across genomic sequence to provide a layout.
|
||||
$self->{incoming_alignments} = [@alignments];
|
||||
|
||||
my $num_alignments = $#alignments + 1;
|
||||
|
||||
## Initialize globals.
|
||||
$self->{incapsulations} = []; #initialize.
|
||||
$self->{compatibilities} = {}; #initialize.
|
||||
$self->{indices_included} = []; #initialize
|
||||
|
||||
$self->{assemblies} = []; #initialize
|
||||
|
||||
#precompute compatible alignment pairs and full encapsulations.
|
||||
$self->determine_compatibilities_and_encapsulations();
|
||||
|
||||
######################################
|
||||
# Do Forward Scan Dynamic Programming.
|
||||
my $LobjsForient = $self->{LobjsForient} = [];
|
||||
my $LobjsRorient = $self->{LobjsRorient} = [];
|
||||
$self->force_flexorient('+');
|
||||
$self->do_full_Fscan($LobjsForient);
|
||||
$self->force_flexorient('-');
|
||||
$self->do_full_Fscan($LobjsRorient);
|
||||
|
||||
&Describe_containment($LobjsForient, $LobjsRorient) if $SEE;
|
||||
|
||||
## Get the highest scoring Lobj
|
||||
|
||||
my $struct = $self->get_top_alignment_indices();
|
||||
|
||||
## Create the highest scoring assembly.
|
||||
my $assembly = $self->create_assembly($struct);
|
||||
my $num_cdnas_included = $struct->{num_cdnas};
|
||||
|
||||
if ( $num_cdnas_included == $num_alignments) { return();}
|
||||
|
||||
|
||||
#######################################
|
||||
## Do Reverse Scan Dynamic Programming (if cDNAs exist and not included in assembly above).
|
||||
$self->force_flexorient('+');
|
||||
$self->do_full_Rscan($LobjsForient);
|
||||
$self->force_flexorient('-');
|
||||
$self->do_full_Rscan($LobjsRorient);
|
||||
## Create assemblies for each cDNA not included yet.
|
||||
my @asmbl_sets;
|
||||
my %seen;
|
||||
for (my $i = 0; $i < $num_alignments; $i++) {
|
||||
unless ($self->{indices_included}->[$i]) {
|
||||
print "Not Included: $i, Doing Back trace starting at $i.\n" if $SEE;
|
||||
my $struct = $self->get_top_alignment_indices_starting_index($i);
|
||||
push (@asmbl_sets, $struct);
|
||||
}
|
||||
}
|
||||
@asmbl_sets = reverse sort {$a->{num_cdnas}<=>$b->{num_cdnas}} @asmbl_sets;
|
||||
my $all_included_flag = 0;
|
||||
while ((!$all_included_flag) && @asmbl_sets) {
|
||||
my $asmbl_set = shift @asmbl_sets;
|
||||
$all_included_flag = $self->test_and_add_asmbl($asmbl_set);
|
||||
}
|
||||
unless ($all_included_flag) {
|
||||
die "FATAL: All assemblies not included!!\n";
|
||||
}
|
||||
|
||||
}
|
||||
|
||||
# private.
|
||||
sub do_full_Fscan {
|
||||
my $self = shift;
|
||||
my $Lobjs = shift;
|
||||
|
||||
print "\n# Doing full Fscan\n" if $SEE;
|
||||
my $alignments_aref = $self->{incoming_alignments};
|
||||
my $num_alignments = $#{$alignments_aref} + 1;
|
||||
|
||||
for (my $i = 0; $i < $num_alignments; $i++) {
|
||||
my $Lobj = Lobject->new($i, $self);
|
||||
if ($i != 0) { #first cDNA, base case.
|
||||
## Must compare to previous alignments:
|
||||
my $top_score = 0;
|
||||
my $top_scoring_index = -1;
|
||||
my $i_alignment = $alignments_aref->[$i];
|
||||
for (my $j = $i - 1; $j >= 0; $j--) {
|
||||
my $j_alignment = $alignments_aref->[$j];
|
||||
my $prevLobj = $Lobjs->[$j];
|
||||
print "Comparing $i to $j\n" if $SEE;
|
||||
my $compatibility = $self->{compatibilities}->{$i}->{$j};
|
||||
my $j_contains_i = $prevLobj->{contained_cdna_indices}->{$i};
|
||||
my $i_contains_j = $Lobj->{contained_cdna_indices}->{$j};
|
||||
print "\tcompat: $compatibility\tj_contains_i: $j_contains_i\n" if $SEE;
|
||||
if ($compatibility && (!($j_contains_i||$i_contains_j))) {
|
||||
unless (&runtime_compatible($i_alignment, $j_alignment)) {next;}
|
||||
my $curr_Lscore = $Lobjs->[$j]->{LscoreF};
|
||||
my $Cscore = &get_Cscore($Lobj, $prevLobj);
|
||||
my $curr_total_score = $curr_Lscore + $Cscore;
|
||||
|
||||
print "\tFSCAN score: ($i,$j) = $curr_total_score\n" if $SEE;
|
||||
if ($curr_total_score > $top_score) {
|
||||
$top_scoring_index = $j;
|
||||
$top_score = $curr_total_score;
|
||||
print "\t*making topscore.\n" if $SEE;
|
||||
|
||||
}
|
||||
}
|
||||
}
|
||||
if ($top_scoring_index > -1) {
|
||||
my $topLobj = $Lobjs->[$top_scoring_index];
|
||||
$Lobj->{fromLptr} = $topLobj;
|
||||
$Lobj->{LscoreF} = $top_score;
|
||||
|
||||
}
|
||||
|
||||
}
|
||||
$Lobjs->[$i] = $Lobj;
|
||||
}
|
||||
}
|
||||
|
||||
# private.
|
||||
sub do_full_Rscan {
|
||||
my $self = shift;
|
||||
my $Lobjs = shift;
|
||||
|
||||
|
||||
print "\n# Doing full Rscan\n" if $SEE;
|
||||
my $alignments_aref = $self->{incoming_alignments};
|
||||
my $num_alignments = $#{$alignments_aref} + 1;
|
||||
|
||||
for (my $i = $num_alignments - 2; $i >= 0; $i--) {
|
||||
my $Lobj = $Lobjs->[$i];
|
||||
my $i_alignment = $alignments_aref->[$i];
|
||||
## Must compare to previous alignments:
|
||||
my $top_score = 0;
|
||||
my $top_scoring_index = -1;
|
||||
for (my $j = $i + 1; $j < $num_alignments; $j++) {
|
||||
my $j_alignment = $alignments_aref->[$j];
|
||||
my $nextLobj = $Lobjs->[$j];
|
||||
print "Comparing $i to $j\n" if $SEE;
|
||||
my $compatibility = $self->{compatibilities}->{$i}->{$j};
|
||||
my $j_contains_i = $nextLobj->{contained_cdna_indices}->{$i};
|
||||
my $i_contains_j = $Lobj->{contained_cdna_indices}->{$j};
|
||||
print "\tcompat: $compatibility\tj_contains_i: $j_contains_i\n" if $SEE;
|
||||
if ($compatibility && (!($j_contains_i||$i_contains_j))) {
|
||||
unless (&runtime_compatible($i_alignment, $j_alignment)) { next;}
|
||||
my $curr_Lscore = $Lobjs->[$j]->{LscoreR};
|
||||
my $Cscore = &get_Cscore($Lobj, $nextLobj);
|
||||
my $curr_total_score = $curr_Lscore + $Cscore;
|
||||
|
||||
print "\tRSCAN score: ($i,$j) = $curr_total_score\n" if $SEE;
|
||||
if ($curr_total_score > $top_score) {
|
||||
$top_scoring_index = $j;
|
||||
$top_score = $curr_total_score;
|
||||
print "\t*making topscore.\n" if $SEE;
|
||||
|
||||
}
|
||||
}
|
||||
}
|
||||
if ($top_scoring_index > -1) {
|
||||
my $topLobj = $Lobjs->[$top_scoring_index];
|
||||
$Lobj->{toLptr} = $topLobj;
|
||||
$Lobj->{LscoreR} = $top_score;
|
||||
}
|
||||
|
||||
}
|
||||
}
|
||||
|
||||
|
||||
# private.
|
||||
sub get_Cscore {
|
||||
## Cscore is the number of cdnas contained in a but not in b including a itself
|
||||
my ($a, $b) = @_;
|
||||
my $score = 0;
|
||||
my $a_container_ref = $a->{contained_cdna_indices};
|
||||
my $b_container_ref = $b->{contained_cdna_indices};
|
||||
foreach my $a_index (keys %$a_container_ref) {
|
||||
unless ($b_container_ref->{$a_index}) {
|
||||
$score++;
|
||||
}
|
||||
}
|
||||
return ($score);
|
||||
}
|
||||
|
||||
|
||||
=over 4
|
||||
|
||||
=item encapsulates()
|
||||
|
||||
B<Description:> Returns true (1) if alignment A encapsulates the span of alignment B
|
||||
|
||||
B<Parameters:> ($alignment_A, $alignment_B)
|
||||
|
||||
Alignments A and B are of type CDNA::CDNA_alignment
|
||||
|
||||
B<Returns:> [1|0]
|
||||
|
||||
=back
|
||||
|
||||
=cut
|
||||
|
||||
|
||||
sub encapsulates {
|
||||
my $self = shift;
|
||||
my ($alignmentA, $alignmentB) = @_;
|
||||
my ($alend, $arend) = $alignmentA->get_coords();
|
||||
my ($blend, $brend) = $alignmentB->get_coords();
|
||||
|
||||
if ($blend >= $alend && $brend <= $arend) {
|
||||
return (1);
|
||||
} else {
|
||||
return (0);
|
||||
}
|
||||
}
|
||||
|
||||
|
||||
sub determine_compatibilities_and_encapsulations {
|
||||
my $self = shift;
|
||||
|
||||
my $alignments_aref = $self->{incoming_alignments};
|
||||
my $num_alignments = $#{$alignments_aref} + 1;
|
||||
|
||||
|
||||
#initialize incapsulations list
|
||||
for (my $i = 0; $i < $num_alignments; $i++) {
|
||||
$self->{incapsulations}->[$i] = [];
|
||||
}
|
||||
|
||||
#compare each downstream alignment to the upstream alignment for compatiblity and encapsulation:
|
||||
for (my $i = 0; $i < $num_alignments; $i++) {
|
||||
for (my $j = $i + 1; $j < $num_alignments; $j++) {
|
||||
|
||||
my $alignment_i = $alignments_aref->[$i];
|
||||
my $alignment_j = $alignments_aref->[$j];
|
||||
|
||||
|
||||
my $can_merge = 0;
|
||||
if ($self->can_merge($alignment_i, $alignment_j)) {
|
||||
$can_merge = 1;
|
||||
# set compatibility flags.
|
||||
$self->{compatibilities}->{$j}->{$i} = 1;
|
||||
$self->{compatibilities}->{$i}->{$j} = 1;
|
||||
}
|
||||
|
||||
my $align_i_single_seg = ($alignment_i->get_num_segments() == 1) ? 1:0;
|
||||
my $align_j_single_seg = ($alignment_j->get_num_segments() == 1) ? 1:0;
|
||||
|
||||
|
||||
## Analyze compatible alignments for containment. Single segment alignments may conflict if in opposite orientations and fli-status, so should check these incompatible alignments for containment as well to avoid multiple identical assemblies from being generated.
|
||||
|
||||
if ($can_merge || ($align_i_single_seg && $align_j_single_seg)) {
|
||||
|
||||
## Check for encapsulation:
|
||||
if ($self->encapsulates($alignment_j, $alignment_i)) {
|
||||
push (@{$self->{incapsulations}->[$j]}, $i);
|
||||
print "$j contains $i\n" if $SEE;
|
||||
}
|
||||
if ($self->encapsulates($alignment_i, $alignment_j)) {
|
||||
push (@{$self->{incapsulations}->[$i]}, $j);
|
||||
print "$i contains $j\n" if $SEE;
|
||||
}
|
||||
|
||||
}
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
sub force_flexorient {
|
||||
my $self = shift;
|
||||
my $orient = shift;
|
||||
my $alignments_aref = $self->{incoming_alignments};
|
||||
my $num_alignments = $#{$alignments_aref} + 1;
|
||||
## Fix orientations of fli and multi-segment alignments:
|
||||
for (my $i = 0; $i < $num_alignments; $i++) {
|
||||
my $alignment = $alignments_aref->[$i];
|
||||
my $num_segments = $alignment->get_num_segments();
|
||||
my $spliced_orientation = $alignment->get_spliced_orientation();
|
||||
|
||||
if ($spliced_orientation =~ /^[+-]$/) { # set specifically
|
||||
$alignment->{fixed_orient} = $spliced_orientation; ## adding tag, using only in this module.
|
||||
} else {
|
||||
print "Setting $i to flex orient: $orient.\n" if $SEE;
|
||||
$alignment->{fixed_orient} = $orient;
|
||||
}
|
||||
}
|
||||
|
||||
}
|
||||
|
||||
|
||||
sub back_trace {
|
||||
my $self = shift;
|
||||
my $top_scoring_index = shift;
|
||||
my $Lobjs = shift;
|
||||
|
||||
print "Back_trace: " if $SEE;
|
||||
my $Lobj = $Lobjs->[$top_scoring_index];
|
||||
## Traverse the fromLptrs
|
||||
|
||||
my %unique_indices;
|
||||
my @trace_indices;
|
||||
while ($Lobj != 0) {
|
||||
my $index = $Lobj->{myIndex};
|
||||
print "$index " if $SEE;
|
||||
push (@trace_indices, $index);
|
||||
# get composed accs:
|
||||
foreach my $contained_index ($Lobj->get_contained_indices()) {
|
||||
$unique_indices{$contained_index} = 1;
|
||||
}
|
||||
$Lobj = $Lobj->{fromLptr};
|
||||
}
|
||||
print "\n" if $SEE;
|
||||
my @unique = keys %unique_indices;
|
||||
my $num_cdnas_included = $#unique + 1;
|
||||
my $struct = {trace_indices=>\@trace_indices,
|
||||
num_cdnas=>$num_cdnas_included,
|
||||
all_indices=>\@unique};
|
||||
return ($struct);
|
||||
}
|
||||
|
||||
|
||||
sub forward_trace {
|
||||
my $self = shift;
|
||||
my $index = shift;
|
||||
my $Lobjs = shift;
|
||||
|
||||
print "Forward_trace: " if $SEE;
|
||||
my $Lobj = $Lobjs->[$index];
|
||||
## Traverse the fromLptrs
|
||||
my @trace_indices;
|
||||
my %unique_indices;
|
||||
while ($Lobj != 0) {
|
||||
my $index = $Lobj->{myIndex};
|
||||
print " $index" if $SEE;
|
||||
push (@trace_indices, $index);
|
||||
# get composed accs:
|
||||
foreach my $contained_index ($Lobj->get_contained_indices()) {
|
||||
$unique_indices{$contained_index} = 1;
|
||||
}
|
||||
$Lobj = $Lobj->{toLptr};
|
||||
}
|
||||
|
||||
|
||||
print "\n" if $SEE;
|
||||
my @unique = keys %unique_indices;
|
||||
my $num_cdnas_included = $#unique + 1;
|
||||
my $struct = {trace_indices=>\@trace_indices,
|
||||
num_cdnas=>$num_cdnas_included,
|
||||
all_indices=>\@unique};
|
||||
|
||||
return ($struct);
|
||||
}
|
||||
|
||||
|
||||
sub create_assembly {
|
||||
my $self = shift;
|
||||
my $struct = shift;
|
||||
my $indices_aref = $struct->{trace_indices};
|
||||
my $alignments_aref = $self->{incoming_alignments};
|
||||
my @indices = sort {$a<=>$b} @$indices_aref;
|
||||
my $all_indices_ref = $struct->{all_indices};
|
||||
my @all_indices = sort {$a<=>$b} @$all_indices_ref;
|
||||
print "Creating assembly: @indices\n" if $SEE;
|
||||
|
||||
my $first_index = shift @indices;
|
||||
my $alignment = $alignments_aref->[$first_index];
|
||||
$self->{indices_included}->[$first_index] = 1;
|
||||
print "Index: $first_index\t" . $alignment->toToken() . "\n" if $SEE;
|
||||
my $assembly = $alignment->clone();
|
||||
|
||||
my @alignments_to_assemble;
|
||||
# first index already included in assembly; ...now, include the others.
|
||||
foreach my $index (@indices) {
|
||||
my $alignment = $alignments_aref->[$index];
|
||||
print "Index: $index\t" . $alignment->toToken() . "\n" if $SEE;
|
||||
$assembly = $self->merge_alignments($assembly, $alignment);
|
||||
}
|
||||
print "assembly contains: @all_indices\n" if $SEE;
|
||||
my @all_accs;
|
||||
|
||||
foreach my $index (@all_indices) {
|
||||
$self->{indices_included}->[$index] = 1;
|
||||
my $acc = $alignments_aref->[$index]->get_acc();
|
||||
push (@all_accs, $acc);
|
||||
}
|
||||
my $acc = $self->merge_accs(@all_accs);
|
||||
$assembly->set_acc($acc);
|
||||
|
||||
push (@{$self->{assemblies}}, $assembly);;
|
||||
|
||||
return ($assembly);
|
||||
}
|
||||
|
||||
sub runtime_compatible {
|
||||
my ($a, $b) = @_;
|
||||
my $a_fixed_orient = $a->{fixed_orient};
|
||||
my $b_fixed_orient = $b->{fixed_orient};
|
||||
print "a($a_fixed_orient) vs. b($b_fixed_orient)\n" if $SEE;
|
||||
if ($a_fixed_orient eq $b_fixed_orient) {
|
||||
print "runtime compatible.\n" if $SEE;
|
||||
return (1);
|
||||
} else {
|
||||
print "NOT runtime compatible\n" if $SEE;
|
||||
return (0);
|
||||
}
|
||||
}
|
||||
|
||||
|
||||
sub get_top_alignment_indices {
|
||||
my $self = shift;
|
||||
my $LobjsForient = $self->{LobjsForient};
|
||||
my $LobjsRorient = $self->{LobjsRorient};
|
||||
|
||||
## Process Forient (singletons forced Forward orient)
|
||||
my $top_Forient_index = $self->top_scoring_index_from_Lobjs($LobjsForient, 'LscoreF');
|
||||
my $ForientStruct = $self->back_trace($top_Forient_index, $LobjsForient);
|
||||
|
||||
## Process Rorient (singletons forced Reverse orient)
|
||||
my $top_Rorient_index = $self->top_scoring_index_from_Lobjs($LobjsRorient, 'LscoreF');
|
||||
my $RorientStruct = $self->back_trace($top_Rorient_index, $LobjsRorient);
|
||||
if ($ForientStruct->{num_cdnas} >= $RorientStruct->{num_cdnas}) {
|
||||
return ($ForientStruct);
|
||||
} else {
|
||||
return ($RorientStruct);
|
||||
}
|
||||
}
|
||||
|
||||
sub get_top_alignment_indices_starting_index {
|
||||
my $self = shift;
|
||||
my $index = shift;
|
||||
my $LobjsForient = $self->{LobjsForient};
|
||||
my $LobjsRorient = $self->{LobjsRorient};
|
||||
my $LobjsForient_num_contained = $LobjsForient->[$index]->get_contained_indices();
|
||||
my $LobjsRorient_num_contained = $LobjsRorient->[$index]->get_contained_indices();
|
||||
|
||||
## Process Forient (singletons forced forward orient)
|
||||
my $ForientBtraceStruct = $self->back_trace($index, $LobjsForient);
|
||||
my $ForientFtraceStruct = $self->forward_trace($index, $LobjsForient);
|
||||
my $ForientNumCdnas = $ForientBtraceStruct->{num_cdnas} + $ForientFtraceStruct->{num_cdnas} -$LobjsForient_num_contained;
|
||||
|
||||
## Process Rorient (singletons forced reverse orient)
|
||||
my $RorientBtraceStruct = $self->back_trace($index, $LobjsRorient);
|
||||
my $RorientFtraceStruct = $self->forward_trace($index, $LobjsRorient);
|
||||
my $RorientNumCdnas = $RorientBtraceStruct->{num_cdnas} + $RorientFtraceStruct->{num_cdnas} - $LobjsRorient_num_contained;
|
||||
|
||||
my ($Ftrace, $Btrace,$total_cdnas);
|
||||
if ($ForientNumCdnas > $RorientNumCdnas) {
|
||||
($Ftrace, $Btrace) = ($ForientFtraceStruct, $ForientBtraceStruct);
|
||||
$total_cdnas = $ForientNumCdnas;
|
||||
} else {
|
||||
($Ftrace, $Btrace) = ($RorientFtraceStruct, $RorientBtraceStruct);
|
||||
$total_cdnas = $RorientNumCdnas;
|
||||
}
|
||||
|
||||
## Create new struct
|
||||
my @unique_trace = &unique_entries(@{$Ftrace->{trace_indices}}, @{$Btrace->{trace_indices}});
|
||||
my @all_indices = &unique_entries (@{$Ftrace->{all_indices}}, @{$Btrace->{all_indices}});
|
||||
if ($#all_indices +1 != $total_cdnas) {
|
||||
die "Error: total number of alignments not calculated correctly.\n";
|
||||
}
|
||||
print "FnB trace from index[$index] yields assembly containing indices [@all_indices]\n" if $SEE;
|
||||
my $struct = {trace_indices=>\@unique_trace,
|
||||
num_cdnas=>$total_cdnas,
|
||||
all_indices=>\@all_indices};
|
||||
return ($struct);
|
||||
}
|
||||
|
||||
|
||||
|
||||
|
||||
sub unique_entries {
|
||||
my @x = @_;
|
||||
my %z;
|
||||
foreach my $y (@x) {
|
||||
$z{$y}=1;
|
||||
}
|
||||
return (keys %z);
|
||||
}
|
||||
|
||||
|
||||
sub top_scoring_index_from_Lobjs {
|
||||
my $self = shift;
|
||||
my $Lobjs = shift;
|
||||
my $score_type = shift;
|
||||
|
||||
my $alignments_aref = $self->{incoming_alignments};
|
||||
my $num_alignments = $#{$alignments_aref} + 1;
|
||||
my $top_scoring_index = -1;
|
||||
my $top_score = -1;
|
||||
|
||||
for (my $i = 0; $i < $num_alignments; $i++) {
|
||||
my $Lscore = $Lobjs->[$i]->{$score_type};
|
||||
if ($Lscore > $top_score) {
|
||||
$top_scoring_index = $i;
|
||||
$top_score = $Lscore;
|
||||
}
|
||||
}
|
||||
return ($top_scoring_index);
|
||||
}
|
||||
|
||||
|
||||
sub test_and_add_asmbl {
|
||||
my $self = shift;
|
||||
my $asmbl_set = shift;
|
||||
my $all_indices_ref = $asmbl_set->{all_indices};
|
||||
my $indices_included_ref = $self->{indices_included};
|
||||
## If the asmbl_set contains a cDNA missing from an assembly inclusion, then add it.
|
||||
|
||||
|
||||
my $num_alignments = $#{$self->{incoming_alignments}} + 1;
|
||||
my $contains_unincorporated = 0;
|
||||
foreach my $index (@$all_indices_ref) {
|
||||
if (! $indices_included_ref->[$index]) {
|
||||
$contains_unincorporated = 1;
|
||||
last;
|
||||
}
|
||||
}
|
||||
if ($contains_unincorporated) {
|
||||
$self->create_assembly($asmbl_set);
|
||||
}
|
||||
|
||||
## Test to see if all cDNAs are accounted for in assemblies.
|
||||
my $all_included_flag = 1;
|
||||
|
||||
for (my $i =0; $i < $num_alignments; $i++) {
|
||||
if (! $indices_included_ref->[$i]) {
|
||||
print "$i not included!\n" if $SEE;
|
||||
$all_included_flag = 0;
|
||||
}
|
||||
}
|
||||
return ($all_included_flag);
|
||||
}
|
||||
|
||||
sub Describe_containment {
|
||||
my ($LobjsForient, $LobjsRorient) = @_;
|
||||
for (my $i = 0; $i <= $#$LobjsForient; $i++) {
|
||||
print "Fixed Forient: index $i contains: " . join (" ", $LobjsForient->[$i]->get_contained_indices()) . "\n";
|
||||
print "Fixed Rorient: index $i contains: " . join (" ", $LobjsRorient->[$i]->get_contained_indices()) . "\n";
|
||||
}
|
||||
print "Lscores:\n";
|
||||
for (my $i = 0; $i <= $#$LobjsForient; $i++) {
|
||||
print "$i: F-forced singleton orient Lscores: F: " . $LobjsForient->[$i]->{LscoreF} . " R: " . $LobjsForient->[$i]->{LscoreR} . "\n";
|
||||
print "$i: R-forced singleton orient Lscores: F: " . $LobjsRorient->[$i]->{LscoreF} . " R: " . $LobjsRorient->[$i]->{LscoreR} . "\n";
|
||||
}
|
||||
}
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
#######################
|
||||
package Lobject;
|
||||
|
||||
sub new {
|
||||
my $packagename = shift;
|
||||
my $index = shift;
|
||||
my $assembler_ref = shift;
|
||||
my $self = {
|
||||
contained_cdna_indices =>{ $index => 1 #include as containing itself.
|
||||
},
|
||||
myIndex => $index, #remember Lobj position.
|
||||
LscoreF => 1, #Forward scan Lscore.
|
||||
LscoreR => 1, #Reverse scan Lscore.
|
||||
toLPtr => 0, # used in Rscan for forward tracking.
|
||||
fromLPtr => 0 # used in Fscan for backtracking
|
||||
};
|
||||
|
||||
## populate list of contained entries.
|
||||
my @contained_indices = @{$assembler_ref->{incapsulations}->[$index]};
|
||||
foreach my $contained_index (@contained_indices) {
|
||||
$self->{contained_cdna_indices}->{$contained_index} = 1;
|
||||
$self->{LscoreF}++;
|
||||
$self->{LscoreR}++;
|
||||
}
|
||||
|
||||
bless ($self, $packagename);
|
||||
return ($self);
|
||||
}
|
||||
|
||||
sub get_contained_indices {
|
||||
my $self = shift;
|
||||
return (keys %{$self->{contained_cdna_indices}});
|
||||
}
|
||||
|
||||
|
||||
1; #EOM
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
@@ -0,0 +1,119 @@
|
||||
package main;
|
||||
our $SEE = 0;
|
||||
|
||||
|
||||
package CDNA::Overlap_assembler;
|
||||
|
||||
use strict;
|
||||
|
||||
sub new {
|
||||
my $packagename = shift;
|
||||
my $self = {
|
||||
node_list => []
|
||||
};
|
||||
bless ($self, $packagename);
|
||||
return ($self);
|
||||
}
|
||||
|
||||
sub add_cDNA {
|
||||
my $self = shift;
|
||||
my ($cdna_acc, $end5, $end3) = @_;
|
||||
my ($cdna_start, $cdna_stop) = sort {$a<=>$b} ($end5, $end3);
|
||||
my $node = Cdna_node->new($cdna_acc, $cdna_start, $cdna_stop);
|
||||
push (@{$self->{node_list}}, $node);
|
||||
}
|
||||
|
||||
|
||||
####
|
||||
sub build_clusters {
|
||||
my $self = shift;
|
||||
my $node_list_aref = $self->{node_list};
|
||||
@{$node_list_aref} = sort {$a->{lend}<=>$b->{lend}} @{$node_list_aref}; #sort by lend coord.
|
||||
## set indices
|
||||
for (my $i = 0; $i <= $#{$node_list_aref}; $i++) {
|
||||
$node_list_aref->[$i]->{myIndex} = $i;
|
||||
}
|
||||
|
||||
my @clusters;
|
||||
my $first_node = $node_list_aref->[0];
|
||||
my $start_pos = 0;
|
||||
my ($exp_left, $exp_right) = ($first_node->{lend}, $first_node->{rend});
|
||||
print $first_node->{acc} . " ($exp_left, $exp_right)\n" if $SEE;
|
||||
for (my $i = 1; $i <= $#{$node_list_aref}; $i++) {
|
||||
my $curr_node = $node_list_aref->[$i];
|
||||
my ($lend, $rend) = ($curr_node->{lend}, $curr_node->{rend});
|
||||
print $curr_node->{acc} . " ($lend, $rend)\n" if $SEE;
|
||||
if ($exp_left <= $rend && $exp_right >= $lend) { #overlap
|
||||
$exp_left = &min($exp_left, $lend);
|
||||
$exp_right = &max($exp_right, $rend);
|
||||
print "overlap. New expanded coords: ($exp_left, $exp_right)\n" if $SEE;
|
||||
} else {
|
||||
print "No overlap; Creating cluster: " if $SEE;
|
||||
my @cluster;
|
||||
for (my $j=$start_pos; $j < $i; $j++) {
|
||||
my $acc = $node_list_aref->[$j]->{acc};
|
||||
push (@cluster, $acc);
|
||||
print "$acc, " if $SEE;
|
||||
}
|
||||
push (@clusters, [@cluster]);
|
||||
$start_pos = $i;
|
||||
($exp_left, $exp_right) = ($lend, $rend);
|
||||
print "\nResetting expanded coords: ($lend, $rend)\n" if $SEE;
|
||||
}
|
||||
}
|
||||
|
||||
print "# Adding final cluster.\n" if $SEE;
|
||||
if ($start_pos != $#{$node_list_aref}) {
|
||||
print "final cluster: " if $SEE;
|
||||
my @cluster;
|
||||
for (my $j = $start_pos; $j <= $#{$node_list_aref}; $j++) {
|
||||
my $acc = $node_list_aref->[$j]->{acc};
|
||||
print "$acc, " if $SEE;
|
||||
push (@cluster, $acc);
|
||||
}
|
||||
push (@clusters, [@cluster]);
|
||||
print "\n" if $SEE;
|
||||
} else {
|
||||
my $acc = $node_list_aref->[$start_pos]->{acc};
|
||||
push (@clusters, [$acc]);
|
||||
print "adding final $acc.\n" if $SEE;
|
||||
}
|
||||
return (@clusters);
|
||||
}
|
||||
|
||||
sub min {
|
||||
my (@x) = @_;
|
||||
@x = sort {$a<=>$b} @x;
|
||||
my $min = shift @x;
|
||||
return ($min);
|
||||
}
|
||||
|
||||
sub max {
|
||||
my @x = @_;
|
||||
@x = sort {$a<=>$b} @x;
|
||||
my $max = pop @x;
|
||||
return ($max);
|
||||
}
|
||||
|
||||
#################################################################
|
||||
package Cdna_node;
|
||||
use strict;
|
||||
|
||||
sub new {
|
||||
my $packagename = shift;
|
||||
my ($acc, $lend, $rend) = @_;
|
||||
my $self = { acc=>$acc,
|
||||
lend=>$lend,
|
||||
rend=>$rend,
|
||||
myIndex=>undef(),
|
||||
overlapping_indices=>[]
|
||||
};
|
||||
bless ($self, $packagename);
|
||||
return ($self);
|
||||
}
|
||||
|
||||
1; #EOM
|
||||
|
||||
|
||||
|
||||
|
||||
@@ -0,0 +1,437 @@
|
||||
#!/usr/local/bin/perl
|
||||
|
||||
package main;
|
||||
our $SEE;
|
||||
|
||||
|
||||
package CDNA::PASA_alignment_assembler;
|
||||
|
||||
=head1 NAME
|
||||
|
||||
CDNA::PASA_alignment_assembler
|
||||
|
||||
=cut
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
This module is used to assemble compatible cDNA alignments. The algorithm is as follows:
|
||||
must describe this here.
|
||||
|
||||
=cut
|
||||
|
||||
use strict;
|
||||
use CDNA::CDNA_alignment;
|
||||
use Data::Dumper;
|
||||
use Carp;
|
||||
|
||||
## File scoped globals:
|
||||
my $DELIMETER = "$;,";
|
||||
our $FUZZLENGTH = 20;
|
||||
|
||||
|
||||
=item new()
|
||||
|
||||
=over 4
|
||||
|
||||
B<Description:> instantiates a new cDNA assembler obj.
|
||||
|
||||
B<Parameters:> none
|
||||
|
||||
B<Returns:> $obj_href
|
||||
|
||||
$obj_href is the object reference newly instantiated by this new method.
|
||||
|
||||
=back
|
||||
|
||||
=cut
|
||||
|
||||
sub new {
|
||||
my $package_name = shift;
|
||||
my $self = {};
|
||||
bless ($self, $package_name);
|
||||
$self->_init(@_);
|
||||
return ($self);
|
||||
}
|
||||
|
||||
|
||||
sub _init {
|
||||
my $self = shift;
|
||||
$self->{incoming_alignments} = []; #these are the alignments to be assembled.
|
||||
$self->{assemblies} = []; #contains list of all singletons and assemblies.
|
||||
$self->{fuzzlength} = $FUZZLENGTH; #default setting.
|
||||
|
||||
my $pasa_bin = `sh -c "command -v pasa"`;
|
||||
$pasa_bin =~ s/\s//g;
|
||||
|
||||
unless (-x $pasa_bin) {
|
||||
confess "Error, pasa binary [$pasa_bin] isn't executable or couldn't be found.";
|
||||
}
|
||||
|
||||
$self->{pasa_bin} = $pasa_bin;
|
||||
|
||||
}
|
||||
|
||||
|
||||
=item assemble_alignments()
|
||||
|
||||
=over 4
|
||||
|
||||
B<DESCRIPTION:> assembles a series of cDNA aligmnments into one or more cDNA assemblies using a directed acyclic graph.
|
||||
|
||||
B<Parameters:> @alignments
|
||||
|
||||
@alignments is an array of CDNA::CDNA_alignment objects
|
||||
|
||||
B<Returns:> none.
|
||||
|
||||
=back
|
||||
|
||||
=cut
|
||||
|
||||
|
||||
sub assemble_alignments {
|
||||
my $self = shift;
|
||||
my @alignments = @_;
|
||||
@alignments = sort {$a->{lend}<=>$b->{lend}} @alignments; #keep in order of lend across genomic sequence to provide a layout.
|
||||
$self->{incoming_alignments} = [@alignments];
|
||||
my %accs;
|
||||
my %spliced_orientations; # track so can set later in each assembly based on content.
|
||||
my %aligned_orientations;
|
||||
my %FL_accs;
|
||||
|
||||
foreach my $alignment (@alignments) {
|
||||
my $acc = $alignment->get_acc();
|
||||
$accs{$acc} = 0;
|
||||
my $spliced_orient = $alignment->get_spliced_orientation();
|
||||
$spliced_orientations{$acc} = $spliced_orient;
|
||||
my $aligned_orient = $alignment->get_orientation();
|
||||
$aligned_orientations{$acc} = $aligned_orient;
|
||||
$FL_accs{$acc} = $alignment->is_fli();
|
||||
}
|
||||
$self->{accs_in_assemblies} = \%accs;
|
||||
|
||||
my $num_alignments = $#alignments + 1;
|
||||
|
||||
$self->force_flexorient('+');
|
||||
my @assemblies = $self->pasa_cpp_assemblies('+');
|
||||
$self->force_flexorient('-');
|
||||
push (@assemblies, $self->pasa_cpp_assemblies('-'));
|
||||
|
||||
# sort in order of decreasing score
|
||||
@assemblies = reverse sort {$a->{num_contained_aligns}<=>$b->{num_contained_aligns}} @assemblies;
|
||||
|
||||
if ($SEE) {
|
||||
print "\n\nScore summary for all assemblies (nr set unchosen):\n\n";
|
||||
foreach my $assembly (@assemblies) {
|
||||
print "score: " . $assembly->{num_contained_aligns} . ", " . $assembly->toToken . "\n";
|
||||
}
|
||||
print "\n\n";
|
||||
}
|
||||
my @report_assemblies;
|
||||
my $still_missing = 1;
|
||||
foreach my $assembly (@assemblies) {
|
||||
print "\nAnalyzing assembly.\n" if $SEE;
|
||||
my $contained_aligns_aref = $assembly->{contained_aligns};
|
||||
my $have_unseen = 0;
|
||||
my $spliced_orient = '?';
|
||||
my $is_fli = 0;
|
||||
my %aligned_orient_counts;
|
||||
|
||||
foreach my $acc (@$contained_aligns_aref) {
|
||||
print "got: $acc\n" if $SEE;
|
||||
# check to see if we've encountered this one yet.
|
||||
unless ($accs{$acc}) {
|
||||
$have_unseen = 1;
|
||||
}
|
||||
$accs{$acc} = 1;
|
||||
my $curr_spliced_orient = $spliced_orientations{$acc};
|
||||
print "curr_spliced_orient: $curr_spliced_orient\n" if $SEE;
|
||||
if ($curr_spliced_orient ne '?') {
|
||||
if ($spliced_orient ne '?' && $spliced_orient ne $curr_spliced_orient) {
|
||||
## cannot have conflicting spliced orientations in the assembly: corruption.
|
||||
die "Fatal: conflicting spliced orientations in current PASA assembly results (spliced_orient: $spliced_orient, $acc has $curr_spliced_orient).\n";
|
||||
}
|
||||
$spliced_orient = $curr_spliced_orient; ## retain original spliced orientation.
|
||||
}
|
||||
if ( (!$is_fli) && $FL_accs{$acc}) {
|
||||
$is_fli = 1;
|
||||
}
|
||||
## track aligned orientation
|
||||
$aligned_orient_counts{ $aligned_orientations{$acc} } ++;
|
||||
|
||||
}
|
||||
|
||||
## set assembly orientation
|
||||
$assembly->set_spliced_orientation($spliced_orient);
|
||||
if ($spliced_orient eq '?') {
|
||||
## set aligned orientation based on a majority vote
|
||||
my @orients = reverse sort { $aligned_orient_counts{$a} <=> $aligned_orient_counts{$b} } keys %aligned_orient_counts;
|
||||
my $winning_aligned_orient = shift @orients;
|
||||
$assembly->set_orientation($winning_aligned_orient);
|
||||
}
|
||||
else {
|
||||
# got spliced orientation, use it for aligned orientation too.
|
||||
$assembly->set_orientation($spliced_orient);
|
||||
}
|
||||
|
||||
$assembly->set_fli_status($is_fli);
|
||||
|
||||
if ($have_unseen) {
|
||||
print $assembly->toToken . "\n" if $SEE;
|
||||
push (@report_assemblies, $assembly);
|
||||
}
|
||||
$still_missing = 0;
|
||||
foreach my $key (keys %accs) {
|
||||
if (! $accs{$key}) {
|
||||
$still_missing = 1;
|
||||
print "still missing: $key\n" if $SEE;
|
||||
}
|
||||
}
|
||||
if (! $still_missing) {
|
||||
last; #got them all.
|
||||
}
|
||||
}
|
||||
|
||||
$self->{assemblies} = \@report_assemblies;
|
||||
|
||||
if ($still_missing) {
|
||||
die "Didn't obtain assemblies describing all maximal assemblies.\n";
|
||||
}
|
||||
|
||||
|
||||
}
|
||||
|
||||
|
||||
sub pasa_cpp_assemblies {
|
||||
my $self = shift;
|
||||
my $forced_orient = shift;
|
||||
|
||||
my $prev_input_sep = $/;
|
||||
$/ = "\n";
|
||||
|
||||
my $sequence_ref;
|
||||
my $incoming_alignments_aref = $self->{incoming_alignments};
|
||||
# create input file for pasa-cpp implementation:
|
||||
my $pasa_input = "pasa.$$.$forced_orient.in";
|
||||
my $pasa_output = "pasa.$$.$forced_orient.out";
|
||||
my @assemblies;
|
||||
|
||||
open (TMPIN, ">$pasa_input") or die "Can't open file $pasa_input";
|
||||
foreach my $alignment (@$incoming_alignments_aref) {
|
||||
my $acc = $alignment->get_acc();
|
||||
## commas not allowed in acc name:
|
||||
if ($acc =~ /,/) {
|
||||
die "ERROR, $acc accession contains comma(s). This is not allowed.\n";
|
||||
}
|
||||
my $orient = $alignment->{fixed_orient};
|
||||
my $alignText = "$acc,$orient";
|
||||
unless (ref $sequence_ref) {
|
||||
$sequence_ref = $alignment->get_genomic_seq_ref();
|
||||
}
|
||||
foreach my $seg ($alignment->get_alignment_segments()) {
|
||||
my ($lend, $rend) = $seg->get_coords();
|
||||
$alignText .= ",$lend-$rend";
|
||||
}
|
||||
print TMPIN $alignText . "\n";
|
||||
}
|
||||
close TMPIN;
|
||||
|
||||
if ($SEE) {
|
||||
print "PASA_INPUT ($forced_orient):\n====\n";
|
||||
system "cat $pasa_input";
|
||||
print "====\n";
|
||||
}
|
||||
my $cmd = $self->{pasa_bin} . " $pasa_input > $pasa_output";
|
||||
my $ret = system $cmd;
|
||||
if ($ret) {
|
||||
system "mv $pasa_input pasa_killer.input";
|
||||
print STDERR "PASA died on input file. See pasa_killer.input";
|
||||
die;
|
||||
} else {
|
||||
|
||||
# process the output.
|
||||
open (TMPOUT, $pasa_output) or die "Can't open $pasa_output";
|
||||
while (<TMPOUT>) {
|
||||
if (/assembly:\s\(\d+\)\scontains\salignments:\s\[([^\]]+)\]\swith\sstructure\s\[([^\]]+)\]/) {
|
||||
print "Extracting assembly output: $_" if $SEE;
|
||||
my $acclist = $1;
|
||||
my $aligndescript = $2;
|
||||
my @x = split (/,/, $aligndescript);
|
||||
|
||||
shift @x;
|
||||
my $orient = shift @x;
|
||||
my @alignSegs;
|
||||
my $length = 0;
|
||||
foreach my $coordset (@x) {
|
||||
my ($lend, $rend) = sort {$a<=>$b} split (/-/, $coordset);
|
||||
my $seg = new CDNA::Alignment_segment($lend, $rend);
|
||||
$length += ($rend - $lend) + 1;
|
||||
push (@alignSegs, $seg);
|
||||
}
|
||||
my $assembly = new CDNA::CDNA_alignment($length, \@alignSegs, $sequence_ref);
|
||||
|
||||
my @accs = split (/,/, $acclist);
|
||||
my $num_accs = $#accs + 1;
|
||||
$assembly->{contained_aligns} = [@accs];
|
||||
$assembly->{num_contained_aligns} = $num_accs;
|
||||
|
||||
$acclist =~ s/,/\//g; #convert list of accessions into a new accession representing a single entry (unity)
|
||||
# if we keep the commas, use of this assembly in future PASA runs will break the assembler
|
||||
# because of the input file requirements.
|
||||
$assembly->set_acc($acclist);
|
||||
|
||||
push (@assemblies, $assembly);
|
||||
}
|
||||
|
||||
}
|
||||
close TMPOUT;
|
||||
|
||||
if ($SEE) {
|
||||
print "PASA_OUTPUT ($forced_orient):\n####\n";
|
||||
system "cat $pasa_output";
|
||||
print "####\n";
|
||||
}
|
||||
unlink ($pasa_input, $pasa_output) unless $SEE;
|
||||
|
||||
}
|
||||
|
||||
$/ = $prev_input_sep; ## restore
|
||||
|
||||
return (@assemblies);
|
||||
}
|
||||
|
||||
|
||||
sub force_flexorient {
|
||||
my $self = shift;
|
||||
my $orient = shift;
|
||||
my $alignments_aref = $self->{incoming_alignments};
|
||||
my $num_alignments = $#{$alignments_aref} + 1;
|
||||
## Fix orientations of fli and multi-segment alignments:
|
||||
for (my $i = 0; $i < $num_alignments; $i++) {
|
||||
my $alignment = $alignments_aref->[$i];
|
||||
my $num_segments = $alignment->get_num_segments();
|
||||
my $spliced_orientation = $alignment->get_spliced_orientation();
|
||||
|
||||
if ($spliced_orientation =~ /^[+-]$/) { # set specifically
|
||||
$alignment->{fixed_orient} = $spliced_orientation; ## adding tag, using only in this module.
|
||||
} else {
|
||||
print "Setting $i to flex orient: $orient.\n" if $SEE;
|
||||
$alignment->{fixed_orient} = $orient;
|
||||
}
|
||||
}
|
||||
|
||||
}
|
||||
|
||||
|
||||
sub unique_entries {
|
||||
my @x = @_;
|
||||
my %z;
|
||||
foreach my $y (@x) {
|
||||
$z{$y}=1;
|
||||
}
|
||||
return (keys %z);
|
||||
}
|
||||
|
||||
|
||||
=item get_assemblies()
|
||||
|
||||
=over 4
|
||||
|
||||
B<Description:> returns all the alignment assemblies resulting from the assembly procedure.
|
||||
|
||||
B<Parameters:> none.
|
||||
|
||||
B<Returns:> @assemblies
|
||||
|
||||
@assemblies is an array of CDNA::CDNA_alignment objects.
|
||||
|
||||
use the get_acc() method of the alignment object to retrieve all the accessions of the cDNAs that were merged into the assembly.
|
||||
|
||||
=back
|
||||
|
||||
=cut
|
||||
|
||||
|
||||
sub get_assemblies {
|
||||
my $self = shift;
|
||||
return (@{$self->{assemblies}});
|
||||
}
|
||||
|
||||
=item toAlignIllustration()
|
||||
|
||||
=over 4
|
||||
|
||||
B<Description:> illustrates the individual cDNAs to be assembled along with the final products.
|
||||
|
||||
B<Parameters:> $max_line_chars(optional)
|
||||
|
||||
$max_line_chars is an integer representing the maximum number of characters in a single line of output to the terminal. The default is 100.
|
||||
|
||||
B<Returns:> $alignment_illustration_text
|
||||
|
||||
$alignment_illustration_text is a string containing a paragraph of text which illustrates the alignments and assemblies. An example is below:
|
||||
|
||||
---> <--> <-----> <---> <---------------- (+)gi|1199466
|
||||
|
||||
---> <--> <-----> <---> <------------ (+)gi|1209702
|
||||
|
||||
----> <--> <---- (+)AV827070
|
||||
|
||||
----> <--> <--- (+)AV828861
|
||||
|
||||
----> <--> <--- (+)AV830936
|
||||
|
||||
---> <--> <- (+)H36350
|
||||
|
||||
ASSEMBLIES: (1)
|
||||
|
||||
----> <--> <-----> <---> <---------------- (+) gi|1199466, gi|1209702, AV827070, AV828861, AV830936, H36350
|
||||
|
||||
|
||||
|
||||
|
||||
=back
|
||||
|
||||
=cut
|
||||
|
||||
;
|
||||
|
||||
sub toAlignIllustration () {
|
||||
my $self = shift;
|
||||
my $max_line_chars = shift;
|
||||
$max_line_chars = ($max_line_chars) ? $max_line_chars : 100; #if not specified, 100 chars / line is default.
|
||||
|
||||
## Get minimum coord for relative positioning.
|
||||
my @coords;
|
||||
my @alignments = @{$self->{incoming_alignments}};
|
||||
foreach my $alignment (@alignments) {
|
||||
my @c = $alignment->get_coords();
|
||||
push (@coords, @c);
|
||||
}
|
||||
@coords = sort {$a<=>$b} @coords;
|
||||
print "coords: @coords\n" if $::SEE;
|
||||
my $min_coord = shift @coords;
|
||||
my $max_coord = pop @coords;
|
||||
my $rel_max = $max_coord - $min_coord;
|
||||
my $alignment_text = "";
|
||||
## print each alignment followed by assemblies:
|
||||
my $num_alignments = $#alignments + 1;
|
||||
$alignment_text .= "Individual Alignments: ($num_alignments)\n";
|
||||
my $i = 0;
|
||||
foreach my $alignment (@alignments) {
|
||||
$alignment_text .= (sprintf ("%3d ", $i)) . $alignment->toAlignIllustration($min_coord, $rel_max, $max_line_chars) . "\n";
|
||||
$i++;
|
||||
}
|
||||
|
||||
my @assemblies = @{$self->{assemblies}};
|
||||
my $num_assemblies = $#assemblies + 1;
|
||||
$alignment_text .= "\n\nASSEMBLIES: ($num_assemblies)\n";
|
||||
foreach my $assembly (@assemblies) {
|
||||
$alignment_text .= " " . $assembly->toAlignIllustration($min_coord, $rel_max, $max_line_chars) . "\n";
|
||||
}
|
||||
|
||||
return ($alignment_text);
|
||||
}
|
||||
|
||||
|
||||
1;
|
||||
File diff suppressed because it is too large
Load Diff
Reference in New Issue
Block a user