|
0
|
1 # $Id: StructuredValue.pm,v 1.2 2002/10/22 07:38:26 lapp Exp $
|
|
|
2 #
|
|
|
3 # BioPerl module for Bio::Annotation::StructuredValue
|
|
|
4 #
|
|
|
5 # Cared for by Hilmar Lapp <hlapp at gmx.net>
|
|
|
6 #
|
|
|
7
|
|
|
8 #
|
|
|
9 # (c) Hilmar Lapp, hlapp at gmx.net, 2002.
|
|
|
10 # (c) GNF, Genomics Institute of the Novartis Research Foundation, 2002.
|
|
|
11 #
|
|
|
12 # You may distribute this module under the same terms as perl itself.
|
|
|
13 # Refer to the Perl Artistic License (see the license accompanying this
|
|
|
14 # software package, or see http://www.perl.com/language/misc/Artistic.html)
|
|
|
15 # for the terms under which you may use, modify, and redistribute this module.
|
|
|
16 #
|
|
|
17 # THIS PACKAGE IS PROVIDED "AS IS" AND WITHOUT ANY EXPRESS OR IMPLIED
|
|
|
18 # WARRANTIES, INCLUDING, WITHOUT LIMITATION, THE IMPLIED WARRANTIES OF
|
|
|
19 # MERCHANTIBILITY AND FITNESS FOR A PARTICULAR PURPOSE.
|
|
|
20 #
|
|
|
21
|
|
|
22 # POD documentation - main docs before the code
|
|
|
23
|
|
|
24 =head1 NAME
|
|
|
25
|
|
|
26 Bio::Annotation::StructuredValue - A scalar with embedded structured
|
|
|
27 information
|
|
|
28
|
|
|
29 =head1 SYNOPSIS
|
|
|
30
|
|
|
31 use Bio::Annotation::StructuredValue;
|
|
|
32 use Bio::Annotation::Collection;
|
|
|
33
|
|
|
34 my $col = new Bio::Annotation::Collection;
|
|
|
35 my $sv = new Bio::Annotation::StructuredValue(-value => 'someval');
|
|
|
36 $col->add_Annotation('tagname', $sv);
|
|
|
37
|
|
|
38 =head1 DESCRIPTION
|
|
|
39
|
|
|
40 Scalar value annotation object
|
|
|
41
|
|
|
42 =head1 FEEDBACK
|
|
|
43
|
|
|
44 =head2 Mailing Lists
|
|
|
45
|
|
|
46 User feedback is an integral part of the evolution of this and other
|
|
|
47 Bioperl modules. Send your comments and suggestions preferably to one
|
|
|
48 of the Bioperl mailing lists. Your participation is much appreciated.
|
|
|
49
|
|
|
50 bioperl-l@bioperl.org - General discussion
|
|
|
51 http://bio.perl.org/MailList.html - About the mailing lists
|
|
|
52
|
|
|
53 =head2 Reporting Bugs
|
|
|
54
|
|
|
55 Report bugs to the Bioperl bug tracking system to help us keep track
|
|
|
56 the bugs and their resolution. Bug reports can be submitted via email
|
|
|
57 or the web:
|
|
|
58
|
|
|
59 bioperl-bugs@bioperl.org
|
|
|
60 http://bugzilla.bioperl.org/
|
|
|
61
|
|
|
62 =head1 AUTHOR - bioperl
|
|
|
63
|
|
|
64 Email bioperl-l@bio.perl.org
|
|
|
65
|
|
|
66 Describe contact details here
|
|
|
67
|
|
|
68 =head1 APPENDIX
|
|
|
69
|
|
|
70 The rest of the documentation details each of the object methods. Internal methods are usually preceded with a _
|
|
|
71
|
|
|
72 =cut
|
|
|
73
|
|
|
74
|
|
|
75 # Let the code begin...
|
|
|
76
|
|
|
77
|
|
|
78 package Bio::Annotation::StructuredValue;
|
|
|
79 use vars qw(@ISA);
|
|
|
80 use strict;
|
|
|
81
|
|
|
82 # Object preamble - inherits from Bio::Root::Root
|
|
|
83
|
|
|
84 use Bio::AnnotationI;
|
|
|
85 use Bio::Annotation::SimpleValue;
|
|
|
86
|
|
|
87 @ISA = qw(Bio::Annotation::SimpleValue);
|
|
|
88
|
|
|
89 =head2 new
|
|
|
90
|
|
|
91 Title : new
|
|
|
92 Usage : my $sv = new Bio::Annotation::StructuredValue;
|
|
|
93 Function: Instantiate a new StructuredValue object
|
|
|
94 Returns : Bio::Annotation::StructuredValue object
|
|
|
95 Args : -value => $value to initialize the object data field [optional]
|
|
|
96 -tagname => $tag to initialize the tagname [optional]
|
|
|
97
|
|
|
98 =cut
|
|
|
99
|
|
|
100 sub new{
|
|
|
101 my ($class,@args) = @_;
|
|
|
102
|
|
|
103 my $self = $class->SUPER::new(@args);
|
|
|
104
|
|
|
105 my ($value,$tag) = $self->_rearrange([qw(VALUE TAGNAME)], @args);
|
|
|
106
|
|
|
107 $self->{'values'} = [];
|
|
|
108 defined $value && $self->value($value);
|
|
|
109 defined $tag && $self->tagname($tag);
|
|
|
110
|
|
|
111 return $self;
|
|
|
112 }
|
|
|
113
|
|
|
114
|
|
|
115 =head1 AnnotationI implementing functions
|
|
|
116
|
|
|
117 =cut
|
|
|
118
|
|
|
119 =head2 as_text
|
|
|
120
|
|
|
121 Title : as_text
|
|
|
122 Usage : my $text = $obj->as_text
|
|
|
123 Function: return the string "Value: $v" where $v is the value
|
|
|
124 Returns : string
|
|
|
125 Args : none
|
|
|
126
|
|
|
127
|
|
|
128 =cut
|
|
|
129
|
|
|
130 sub as_text{
|
|
|
131 my ($self) = @_;
|
|
|
132
|
|
|
133 return "Value: ".$self->value;
|
|
|
134 }
|
|
|
135
|
|
|
136 =head2 hash_tree
|
|
|
137
|
|
|
138 Title : hash_tree
|
|
|
139 Usage : my $hashtree = $value->hash_tree
|
|
|
140 Function: For supporting the AnnotationI interface just returns the value
|
|
|
141 as a hashref with the key 'value' pointing to the value
|
|
|
142 Returns : hashrf
|
|
|
143 Args : none
|
|
|
144
|
|
|
145
|
|
|
146 =cut
|
|
|
147
|
|
|
148 sub hash_tree{
|
|
|
149 my ($self) = @_;
|
|
|
150
|
|
|
151 my $h = {};
|
|
|
152 $h->{'value'} = $self->value;
|
|
|
153 }
|
|
|
154
|
|
|
155 =head2 tagname
|
|
|
156
|
|
|
157 Title : tagname
|
|
|
158 Usage : $obj->tagname($newval)
|
|
|
159 Function: Get/set the tagname for this annotation value.
|
|
|
160
|
|
|
161 Setting this is optional. If set, it obviates the need to provide
|
|
|
162 a tag to AnnotationCollection when adding this object.
|
|
|
163 Example :
|
|
|
164 Returns : value of tagname (a scalar)
|
|
|
165 Args : new value (a scalar, optional)
|
|
|
166
|
|
|
167
|
|
|
168 =cut
|
|
|
169
|
|
|
170 sub tagname{
|
|
|
171 my ($self,$value) = @_;
|
|
|
172 if( defined $value) {
|
|
|
173 $self->{'tagname'} = $value;
|
|
|
174 }
|
|
|
175 return $self->{'tagname'};
|
|
|
176 }
|
|
|
177
|
|
|
178
|
|
|
179 =head1 Specific accessors for StructuredValue
|
|
|
180
|
|
|
181 =cut
|
|
|
182
|
|
|
183 =head2 value
|
|
|
184
|
|
|
185 Title : value
|
|
|
186 Usage : $obj->value($newval)
|
|
|
187 Function: Get/set the value for this annotation.
|
|
|
188
|
|
|
189 Set mode is here only to retain compatibility with
|
|
|
190 SimpleValue. It is equivalent to calling
|
|
|
191 add_value([0], $newval).
|
|
|
192
|
|
|
193 In get mode, this implementation allows to pass additional
|
|
|
194 parameters that control how the structured annotation
|
|
|
195 components will be joined together to form a
|
|
|
196 string. Recognized are presently
|
|
|
197 -joins a reference to an array of join strings, the
|
|
|
198 elements at index i applying to joining
|
|
|
199 annotations at dimension i. The last element
|
|
|
200 will be re-used for dimensions higher than i.
|
|
|
201 Defaults to ['; '].
|
|
|
202 -brackets a reference to an array of two strings
|
|
|
203 denoting the opening and closing brackets for
|
|
|
204 the elements of one dimension, if there is
|
|
|
205 more than one element in the dimension.
|
|
|
206 Defaults to ['(',')'].
|
|
|
207
|
|
|
208 Returns : value of value
|
|
|
209 Args : newvalue (optional)
|
|
|
210
|
|
|
211
|
|
|
212 =cut
|
|
|
213
|
|
|
214 sub value{
|
|
|
215 my ($self,$value,@args) = @_;
|
|
|
216
|
|
|
217 # set mode?
|
|
|
218 return $self->add_value([0], $value) if defined($value) && (@args == 0);
|
|
|
219 # no, get mode
|
|
|
220 # determine joins and brackets
|
|
|
221 unshift(@args, $value);
|
|
|
222 my ($joins, $brackets) =
|
|
|
223 $self->_rearrange([qw(JOINS BRACKETS)], @args);
|
|
|
224 $joins = ['; '] unless $joins;
|
|
|
225 $brackets = ['(', ')'] unless $brackets;
|
|
|
226 my $txt = &_to_text($self->{'values'}, $joins, $brackets);
|
|
|
227 # if there's only brackets at the start and end, remove them
|
|
|
228 if((@{$self->{'values'}} == 1) &&
|
|
|
229 (length($brackets->[0]) == 1) && (length($brackets->[1]) == 1)) {
|
|
|
230 my $re = '\\'.$brackets->[0].
|
|
|
231 '([^\\'.$brackets->[1].']*)\\'.$brackets->[1];
|
|
|
232 $txt =~ s/^$re$/$1/;
|
|
|
233 }
|
|
|
234 return $txt;
|
|
|
235 }
|
|
|
236
|
|
|
237 sub _to_text{
|
|
|
238 my ($arr, $joins, $brackets, $rec_n) = @_;
|
|
|
239
|
|
|
240 $rec_n = 0 unless defined($rec_n);
|
|
|
241 my $i = $rec_n >= @$joins ? @$joins-1 : $rec_n;
|
|
|
242 my $txt = join($joins->[$i],
|
|
|
243 map {
|
|
|
244 ref($_) ?
|
|
|
245 (ref($_) eq "ARRAY" ?
|
|
|
246 &_to_text($_, $joins, $brackets, $rec_n+1) :
|
|
|
247 $_->value()) :
|
|
|
248 $_;
|
|
|
249 } @$arr);
|
|
|
250 if($rec_n && (@$arr > 1)) {
|
|
|
251 $txt = $brackets->[0] . $txt . $brackets->[1];
|
|
|
252 }
|
|
|
253 return $txt;
|
|
|
254 }
|
|
|
255
|
|
|
256 =head2 get_values
|
|
|
257
|
|
|
258 Title : get_values
|
|
|
259 Usage :
|
|
|
260 Function: Get the top-level array of values. Each of the elements will
|
|
|
261 recursively be a reference to an array or a scalar, depending
|
|
|
262 on the depth of this structured value annotation.
|
|
|
263 Example :
|
|
|
264 Returns : an array
|
|
|
265 Args : none
|
|
|
266
|
|
|
267
|
|
|
268 =cut
|
|
|
269
|
|
|
270 sub get_values{
|
|
|
271 my $self = shift;
|
|
|
272
|
|
|
273 return @{$self->{'values'}};
|
|
|
274 }
|
|
|
275
|
|
|
276 =head2 get_all_values
|
|
|
277
|
|
|
278 Title : get_all_values
|
|
|
279 Usage :
|
|
|
280 Function: Flattens all values in this structured annotation and
|
|
|
281 returns them as an array.
|
|
|
282 Example :
|
|
|
283 Returns : the (flat) array of values
|
|
|
284 Args : none
|
|
|
285
|
|
|
286
|
|
|
287 =cut
|
|
|
288
|
|
|
289 sub get_all_values{
|
|
|
290 my ($self) = @_;
|
|
|
291
|
|
|
292 # we code lazy here and just take advantage of value()
|
|
|
293 my $txt = $self->value(-joins => ['@!@'], -brackets => ['','']);
|
|
|
294 return split(/\@!\@/, $txt);
|
|
|
295 }
|
|
|
296
|
|
|
297 =head2 add_value
|
|
|
298
|
|
|
299 Title : add_value
|
|
|
300 Usage :
|
|
|
301 Function: Adds the given value to the structured annotation at the
|
|
|
302 given index.
|
|
|
303
|
|
|
304 The index is multi-dimensional, with the first dimension
|
|
|
305 applying to the first level, and so forth. If a particular
|
|
|
306 dimension or a particular index does not exist yet, it will
|
|
|
307 be created. If it does exist and adding the value would
|
|
|
308 mean replacing a scalar with an array reference, we throw
|
|
|
309 an exception to prevent unintended damage. An index of -1
|
|
|
310 at any dimension means append.
|
|
|
311
|
|
|
312 If an array of values is to be added, it will create an
|
|
|
313 additional dimension at the index specified, unless the
|
|
|
314 last index value is -1, in which case they will all be
|
|
|
315 appended to the last dimension.
|
|
|
316
|
|
|
317 Example :
|
|
|
318 Returns : none
|
|
|
319 Args : the index at which to add (a reference to an array)
|
|
|
320 the value(s) to add
|
|
|
321
|
|
|
322
|
|
|
323 =cut
|
|
|
324
|
|
|
325 sub add_value{
|
|
|
326 my ($self,$index,@values) = @_;
|
|
|
327
|
|
|
328 my $tree = $self->{'values'};
|
|
|
329 my $lastidx = pop(@$index);
|
|
|
330 foreach my $i (@$index) {
|
|
|
331 if($i < 0) {
|
|
|
332 my $subtree = [];
|
|
|
333 push(@$tree, $subtree);
|
|
|
334 $tree = $subtree;
|
|
|
335 } elsif((! $tree->[$i]) || (ref($tree->[$i]) eq "ARRAY")) {
|
|
|
336 $tree->[$i] = [] unless ref($tree->[$i]) eq "ARRAY";
|
|
|
337 $tree = $tree->[$i];
|
|
|
338 } else {
|
|
|
339 $self->throw("element $i is a scalar but not in last dimension");
|
|
|
340 }
|
|
|
341 }
|
|
|
342 if($lastidx < 0) {
|
|
|
343 push(@$tree, @values);
|
|
|
344 } elsif(@values < 2) {
|
|
|
345 $tree->[$lastidx] = shift(@values);
|
|
|
346 } else {
|
|
|
347 $tree->[$lastidx] = [@values];
|
|
|
348 }
|
|
|
349
|
|
|
350 }
|
|
|
351
|
|
|
352 1;
|
