Mercurial > repos > jjohnson > crest
diff Transcript.pm @ 0:acc8d8bfeb9a
Uploaded
author | jjohnson |
---|---|
date | Wed, 08 Feb 2012 16:59:24 -0500 |
parents | |
children |
line wrap: on
line diff
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/Transcript.pm Wed Feb 08 16:59:24 2012 -0500 @@ -0,0 +1,126 @@ +package Transcript; +use strict; +use Carp; +use Data::Dumper; + +# we are going to use a light weight Transcript model here +my @Transcript_slots; +BEGIN { + @Transcript_slots = qw(NAME REFSEQ_ID CHR START END STRAND CDS_START CDS_END EXONS TYPE); +} +use enum @Transcript_slots; + +my %attribute = ( + name => NAME, + refseq_id => REFSEQ_ID, + chr => CHR, + start => START, + end => END, + strand => STRAND, + cds_start => CDS_START, + cds_end => CDS_END, + exons => EXONS, + type => TYPE, +); + +#using an array instead of a hash for the node +sub _accessor { + my $index = shift; + return sub { + my $self = shift; + return undef unless $self; + if (@_) { + $self->[$index] = shift; + } + return $self->[$index]; + }; +} + +while(my($at, $idx) = each %attribute) { + no strict 'refs'; + *$at = _accessor($idx); +} + +sub new { + my $class = shift; + my $obj = []; + + if (@_) { + my %arg = @_; + $obj->[NAME] = $arg{-NAME} if($arg{-NAME}); + $obj->[REFSEQ_ID] = $arg{-REFSEQ_ID} if($arg{-REFSEQ_ID}); + $obj->[CHR] = $arg{-CHR} if($arg{-CHR}); + $obj->[START] = $arg{-START} if($arg{-START}); + $obj->[END] = $arg{-END} if($arg{-END}); + $obj->[STRAND] = $arg{-STRAND} if($arg{-STRAND}); + $obj->[CDS_START] = $arg{-CDS_START} if($arg{-CDS_START}); + $obj->[CDS_END] = $arg{-CDS_END} if($arg{-CDS_END}); + $obj->[EXONS] = $arg{-EXONS} if($arg{-EXONS}); + $obj->[TYPE] = $arg{-TYPE} if($arg{-TYPE}); + } + return bless $obj, $class; +} + +sub get_start { + my ($self, $pos, $ext) = @_; + my @tmp; + foreach my $e( @{$self->[EXONS]} ) { + if($e->[1] < $pos) { + push @tmp, $e; + next; + } + last; + } + my $len = 0; + while(scalar @tmp > 0) { + my $e = pop @tmp; + if($e->[1] >= $pos) { + my $l = $pos - $e->[0]; + if($l + $len < $ext) { + $len = $l; + next; + } + return $pos - $ext; + } + if($e->[1] - $e->[0] + 1 + $len < $ext) { + $len += ($e->[1] - $e->[0] + 1); + next; + } + return ($e->[1] - $ext + $len); + } + return $self->start; +} + +sub get_end { + my ($self, $pos, $ext) = @_; + my @tmp = @{$self->[EXONS]}; + my $len = 0; + while(scalar @tmp > 0) { + my $e = shift @tmp; + next if($e->[1] < $pos); + if($e->[0] <= $pos ) { + return $pos + $ext if($e->[1] - $pos >= $ext); + $len = $e->[1] - $pos; + next; + } + if($e->[1] - $e->[0] + 1 + $len < $ext) { + $len += ($e->[1] - $e->[0] + 1); + next; + } + return ($e->[0] + $ext - $len); + } + return $self->end; +} + +sub overlap { + my $self = shift; + my $range = shift; + croak "Range must be a ref of array" unless(ref($range) eq 'ARRAY'); + + foreach my $e ( @{$self->[EXONS]} ) { + return 1 if($e->[0] <= $range->[1] && $e->[1] >= $range->[0]); + } + return; +} + +1;