Mercurial > repos > jjohnson > crest

comparison Transcript.pm @ 0:acc8d8bfeb9a

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Uploaded
author jjohnson
date Wed, 08 Feb 2012 16:59:24 -0500
parents
children
comparison
equal deleted inserted replaced
-1:000000000000 0:acc8d8bfeb9a
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;