|
0
|
1 # BioPerl module for Bio::Tools::FootPrinter
|
|
|
2 #
|
|
|
3 # Cared for by Shawn Hoon <shawnh@fugu-sg.org>
|
|
|
4 #
|
|
|
5 # Copyright Shawn Hoon
|
|
|
6 #
|
|
|
7 # You may distribute this module under the same terms as perl itself
|
|
|
8
|
|
|
9 # POD documentation - main docs before the code
|
|
|
10
|
|
|
11 =head1 NAME
|
|
|
12
|
|
|
13 Bio::Tools::FootPrinter - DESCRIPTION of Object
|
|
|
14
|
|
|
15 =head1 SYNOPSIS
|
|
|
16
|
|
|
17 use Bio::Tools::FootPrinter;
|
|
|
18
|
|
|
19 my $tool = Bio::Tools::FootPrinter->new(-file=>"footprinter.out");
|
|
|
20
|
|
|
21 while (my $result = $tool->next_feature){
|
|
|
22 foreach my $feat($result->sub_SeqFeature){
|
|
|
23 print $result->seq_id."\t".$feat->start."\t".$feat->end."\t".$feat->seq->seq."\n";
|
|
|
24 }
|
|
|
25 }
|
|
|
26
|
|
|
27 =head1 DESCRIPTION
|
|
|
28
|
|
|
29 A parser for FootPrinter output
|
|
|
30
|
|
|
31 =head1 FEEDBACK
|
|
|
32
|
|
|
33 =head2 Mailing Lists
|
|
|
34
|
|
|
35 User feedback is an integral part of the evolution of this and other
|
|
|
36 Bioperl modules. Send your comments and suggestions preferably to
|
|
|
37 the Bioperl mailing list. Your participation is much appreciated.
|
|
|
38
|
|
|
39 bioperl-l@bioperl.org - General discussion
|
|
|
40 http://bioperl.org/MailList.shtml - About the mailing lists
|
|
|
41
|
|
|
42 =head2 Reporting Bugs
|
|
|
43
|
|
|
44 Report bugs to the Bioperl bug tracking system to help us keep track
|
|
|
45 of the bugs and their resolution. Bug reports can be submitted via
|
|
|
46 email or the web:
|
|
|
47
|
|
|
48 bioperl-bugs@bioperl.org
|
|
|
49 http://bugzilla.bioperl.org/
|
|
|
50
|
|
|
51 =head1 AUTHOR - Shawn Hoon
|
|
|
52
|
|
|
53 Email shawnh@fugu-sg.org
|
|
|
54
|
|
|
55 Describe contact details here
|
|
|
56
|
|
|
57 =head1 CONTRIBUTORS
|
|
|
58
|
|
|
59 Additional contributors names and emails here
|
|
|
60
|
|
|
61 =head1 APPENDIX
|
|
|
62
|
|
|
63 The rest of the documentation details each of the object methods.
|
|
|
64 Internal methods are usually preceded with a _
|
|
|
65
|
|
|
66 =cut
|
|
|
67
|
|
|
68
|
|
|
69 # Let the code begin...
|
|
|
70
|
|
|
71
|
|
|
72 package Bio::Tools::FootPrinter;
|
|
|
73 use vars qw(@ISA);
|
|
|
74 use strict;
|
|
|
75
|
|
|
76 use Bio::Root::Root;
|
|
|
77 use Bio::SeqFeature::Generic;
|
|
|
78 use Bio::PrimarySeq;
|
|
|
79 use Bio::Root::IO;
|
|
|
80
|
|
|
81 @ISA = qw(Bio::Root::Root Bio::Root::IO );
|
|
|
82
|
|
|
83 =head2 new
|
|
|
84
|
|
|
85 Title : new
|
|
|
86 Usage : my $obj = new Bio::Tools::FootPrinter();
|
|
|
87 Function: Builds a new Bio::Tools::FootPrinter object
|
|
|
88 Returns : Bio::Tools::FootPrinter
|
|
|
89 Args : -fh/-file => $val, # for initing input, see Bio::Root::IO
|
|
|
90
|
|
|
91 =cut
|
|
|
92
|
|
|
93 sub new {
|
|
|
94 my($class,@args) = @_;
|
|
|
95
|
|
|
96 my $self = $class->SUPER::new(@args);
|
|
|
97 $self->_initialize_io(@args);
|
|
|
98
|
|
|
99 return $self;
|
|
|
100 }
|
|
|
101
|
|
|
102 =head2 next_feature
|
|
|
103
|
|
|
104 Title : next_feature
|
|
|
105 Usage : my $r = $footprint->next_feature
|
|
|
106 Function: Get the next feature from parser data
|
|
|
107 Returns : L<Bio::SeqFeature::Generic>
|
|
|
108 Args : none
|
|
|
109
|
|
|
110 =cut
|
|
|
111
|
|
|
112 sub next_feature{
|
|
|
113 my ($self) = @_;
|
|
|
114 $self->_parse_predictions() unless $self->_predictions_parsed();
|
|
|
115 return shift @{$self->{'_feature'}};
|
|
|
116
|
|
|
117 }
|
|
|
118
|
|
|
119 =head2 _add_feature
|
|
|
120
|
|
|
121 Title : _add_feature
|
|
|
122 Usage : $footprint->_add_feature($feat)
|
|
|
123 Function: Add feature to array
|
|
|
124 Returns : none
|
|
|
125 Args : none
|
|
|
126
|
|
|
127 =cut
|
|
|
128
|
|
|
129 sub _add_feature {
|
|
|
130 my ($self,$feat) = @_;
|
|
|
131 if($feat){
|
|
|
132 push @{$self->{'_feature'}},$feat;
|
|
|
133 }
|
|
|
134 }
|
|
|
135
|
|
|
136 =head2 _parse_predictions
|
|
|
137
|
|
|
138 Title : _parse_predictions
|
|
|
139 Usage : my $r = $footprint->_parse_predictions
|
|
|
140 Function: do the parsing
|
|
|
141 Returns : none
|
|
|
142 Args : none
|
|
|
143
|
|
|
144 =cut
|
|
|
145
|
|
|
146 sub _parse_predictions {
|
|
|
147 my ($self) = @_;
|
|
|
148 $/="";
|
|
|
149 my ($seq,$third,$name);
|
|
|
150 while ($_ = $self->_readline) {
|
|
|
151 chomp;
|
|
|
152 my @array = split("\n",$_);
|
|
|
153 if($#array == 3){
|
|
|
154 if($name){
|
|
|
155 $name=~s/>//;
|
|
|
156 my $feat = $self->_parse($name,$seq,$third);
|
|
|
157 $self->_add_feature($feat);
|
|
|
158 }
|
|
|
159 $name = shift @array;
|
|
|
160 $seq=$array[0];
|
|
|
161 $third=$array[2];
|
|
|
162 next;
|
|
|
163 }
|
|
|
164 $seq.=$array[0];
|
|
|
165 $third.=$array[2];
|
|
|
166 }
|
|
|
167 $name=~s/>//;
|
|
|
168 my $feat = $self->_parse($name,$seq,$third);
|
|
|
169 $self->_add_feature($feat);
|
|
|
170
|
|
|
171 $self->_predictions_parsed(1);
|
|
|
172 }
|
|
|
173
|
|
|
174 =head2 _predictions_parsed
|
|
|
175
|
|
|
176 Title : _predictions_parsed
|
|
|
177 Usage : $footprint->_predictions_parsed(1)
|
|
|
178 Function: Get/Set for whether predictions parsed
|
|
|
179 Returns : 1/0
|
|
|
180 Args : none
|
|
|
181
|
|
|
182 =cut
|
|
|
183
|
|
|
184 sub _predictions_parsed {
|
|
|
185 my ($self,$val) = @_;
|
|
|
186 if($val){
|
|
|
187 $self->{'_predictions_parsed'} = $val;
|
|
|
188 }
|
|
|
189 return $self->{'_predictions_parsed'};
|
|
|
190 }
|
|
|
191
|
|
|
192
|
|
|
193 =head2 _parse
|
|
|
194
|
|
|
195 Title : _parse
|
|
|
196 Usage : $footprint->_parse($name,$seq,$pattern)
|
|
|
197 Function: do the actual parsing
|
|
|
198 Returns : L<Bio::SeqFeature::Generic>
|
|
|
199 Args : none
|
|
|
200
|
|
|
201 =cut
|
|
|
202
|
|
|
203 sub _parse {
|
|
|
204 my ($self,$name,$seq,$pattern) = @_;
|
|
|
205 my @char = split('',$pattern);
|
|
|
206 my $prev;
|
|
|
207 my $word;
|
|
|
208 my @words;
|
|
|
209 foreach my $c(@char){
|
|
|
210 if(!$word){
|
|
|
211 $word .= $c;
|
|
|
212 $prev = $c;
|
|
|
213 next;
|
|
|
214 }
|
|
|
215 if ($c eq $prev){
|
|
|
216 $word.=$c;
|
|
|
217 $prev = $c;
|
|
|
218 }
|
|
|
219 else {
|
|
|
220 #remove words with only \s
|
|
|
221 $word=~s/\s+//g;
|
|
|
222 if ($word ne ''){
|
|
|
223 push @words, $word;
|
|
|
224 }
|
|
|
225 $word=$c;
|
|
|
226 $prev = $c;
|
|
|
227
|
|
|
228 }
|
|
|
229 }
|
|
|
230 $word=~s/\s+//g;
|
|
|
231 if($word ne ''){
|
|
|
232 push @words, $word;
|
|
|
233 }
|
|
|
234 my $last;
|
|
|
235 my $feat = new Bio::SeqFeature::Generic(-seq_id=>$name);
|
|
|
236 my $offset=0;
|
|
|
237 foreach my $w(@words){
|
|
|
238 if($w !~ /^$/){
|
|
|
239 my $index = index($pattern,$w,$offset);
|
|
|
240 $offset = $index + length($w);
|
|
|
241 my $subfeat = new Bio::SeqFeature::Generic ( -seq_id=>$name,
|
|
|
242 -start => $index+1,
|
|
|
243 -end =>$index+length($w),
|
|
|
244 -source=>"FootPrinter");
|
|
|
245 $feat->add_sub_SeqFeature($subfeat,'EXPAND');
|
|
|
246 }
|
|
|
247 }
|
|
|
248 my $priseq = Bio::PrimarySeq->new(-id=>$name,-seq=>$seq);
|
|
|
249 $feat->attach_seq($priseq);
|
|
|
250 return $feat;
|
|
|
251
|
|
|
252 }
|
|
|
253
|
|
|
254 1;
|
