|
0
|
1 package Transcript;
|
|
|
2 use strict;
|
|
|
3 use Carp;
|
|
|
4 use Data::Dumper;
|
|
|
5
|
|
|
6 # we are going to use a light weight Transcript model here
|
|
|
7 my @Transcript_slots;
|
|
|
8 BEGIN {
|
|
|
9 @Transcript_slots = qw(NAME REFSEQ_ID CHR START END STRAND CDS_START CDS_END EXONS TYPE);
|
|
|
10 }
|
|
|
11 use enum @Transcript_slots;
|
|
|
12
|
|
|
13 my %attribute = (
|
|
|
14 name => NAME,
|
|
|
15 refseq_id => REFSEQ_ID,
|
|
|
16 chr => CHR,
|
|
|
17 start => START,
|
|
|
18 end => END,
|
|
|
19 strand => STRAND,
|
|
|
20 cds_start => CDS_START,
|
|
|
21 cds_end => CDS_END,
|
|
|
22 exons => EXONS,
|
|
|
23 type => TYPE,
|
|
|
24 );
|
|
|
25
|
|
|
26 #using an array instead of a hash for the node
|
|
|
27 sub _accessor {
|
|
|
28 my $index = shift;
|
|
|
29 return sub {
|
|
|
30 my $self = shift;
|
|
|
31 return undef unless $self;
|
|
|
32 if (@_) {
|
|
|
33 $self->[$index] = shift;
|
|
|
34 }
|
|
|
35 return $self->[$index];
|
|
|
36 };
|
|
|
37 }
|
|
|
38
|
|
|
39 while(my($at, $idx) = each %attribute) {
|
|
|
40 no strict 'refs';
|
|
|
41 *$at = _accessor($idx);
|
|
|
42 }
|
|
|
43
|
|
|
44 sub new {
|
|
|
45 my $class = shift;
|
|
|
46 my $obj = [];
|
|
|
47
|
|
|
48 if (@_) {
|
|
|
49 my %arg = @_;
|
|
|
50 $obj->[NAME] = $arg{-NAME} if($arg{-NAME});
|
|
|
51 $obj->[REFSEQ_ID] = $arg{-REFSEQ_ID} if($arg{-REFSEQ_ID});
|
|
|
52 $obj->[CHR] = $arg{-CHR} if($arg{-CHR});
|
|
|
53 $obj->[START] = $arg{-START} if($arg{-START});
|
|
|
54 $obj->[END] = $arg{-END} if($arg{-END});
|
|
|
55 $obj->[STRAND] = $arg{-STRAND} if($arg{-STRAND});
|
|
|
56 $obj->[CDS_START] = $arg{-CDS_START} if($arg{-CDS_START});
|
|
|
57 $obj->[CDS_END] = $arg{-CDS_END} if($arg{-CDS_END});
|
|
|
58 $obj->[EXONS] = $arg{-EXONS} if($arg{-EXONS});
|
|
|
59 $obj->[TYPE] = $arg{-TYPE} if($arg{-TYPE});
|
|
|
60 }
|
|
|
61 return bless $obj, $class;
|
|
|
62 }
|
|
|
63
|
|
|
64 sub get_start {
|
|
|
65 my ($self, $pos, $ext) = @_;
|
|
|
66 my @tmp;
|
|
|
67 foreach my $e( @{$self->[EXONS]} ) {
|
|
|
68 if($e->[1] < $pos) {
|
|
|
69 push @tmp, $e;
|
|
|
70 next;
|
|
|
71 }
|
|
|
72 last;
|
|
|
73 }
|
|
|
74 my $len = 0;
|
|
|
75 while(scalar @tmp > 0) {
|
|
|
76 my $e = pop @tmp;
|
|
|
77 if($e->[1] >= $pos) {
|
|
|
78 my $l = $pos - $e->[0];
|
|
|
79 if($l + $len < $ext) {
|
|
|
80 $len = $l;
|
|
|
81 next;
|
|
|
82 }
|
|
|
83 return $pos - $ext;
|
|
|
84 }
|
|
|
85 if($e->[1] - $e->[0] + 1 + $len < $ext) {
|
|
|
86 $len += ($e->[1] - $e->[0] + 1);
|
|
|
87 next;
|
|
|
88 }
|
|
|
89 return ($e->[1] - $ext + $len);
|
|
|
90 }
|
|
|
91 return $self->start;
|
|
|
92 }
|
|
|
93
|
|
|
94 sub get_end {
|
|
|
95 my ($self, $pos, $ext) = @_;
|
|
|
96 my @tmp = @{$self->[EXONS]};
|
|
|
97 my $len = 0;
|
|
|
98 while(scalar @tmp > 0) {
|
|
|
99 my $e = shift @tmp;
|
|
|
100 next if($e->[1] < $pos);
|
|
|
101 if($e->[0] <= $pos ) {
|
|
|
102 return $pos + $ext if($e->[1] - $pos >= $ext);
|
|
|
103 $len = $e->[1] - $pos;
|
|
|
104 next;
|
|
|
105 }
|
|
|
106 if($e->[1] - $e->[0] + 1 + $len < $ext) {
|
|
|
107 $len += ($e->[1] - $e->[0] + 1);
|
|
|
108 next;
|
|
|
109 }
|
|
|
110 return ($e->[0] + $ext - $len);
|
|
|
111 }
|
|
|
112 return $self->end;
|
|
|
113 }
|
|
|
114
|
|
|
115 sub overlap {
|
|
|
116 my $self = shift;
|
|
|
117 my $range = shift;
|
|
|
118 croak "Range must be a ref of array" unless(ref($range) eq 'ARRAY');
|
|
|
119
|
|
|
120 foreach my $e ( @{$self->[EXONS]} ) {
|
|
|
121 return 1 if($e->[0] <= $range->[1] && $e->[1] >= $range->[0]);
|
|
|
122 }
|
|
|
123 return;
|
|
|
124 }
|
|
|
125
|
|
|
126 1;
|
