File Coverage

Bio/Annotation/TagTree.pm
Criterion Covered Total %
statement 62 108 57.4
branch 32 50 64.0
condition 7 17 41.1
subroutine 13 30 43.3
pod 27 27 100.0
total 141 232 60.7


line stmt bran cond sub pod time code
1             # $Id: TagTree.pm 11693 2007-09-17 20:54:04Z cjfields $
2             #
3             # BioPerl module for Bio::Annotation::TagTree
4             #
5             # Cared for Chris Fields
6             #
7             # You may distribute this module under the same terms as perl itself.
8             # Refer to the Perl Artistic License (see the license accompanying this
9             # software package, or see http://www.perl.com/language/misc/Artistic.html)
10             # for the terms under which you may use, modify, and redistribute this module.
11             #
12             # THIS PACKAGE IS PROVIDED "AS IS" AND WITHOUT ANY EXPRESS OR IMPLIED
13             # WARRANTIES, INCLUDING, WITHOUT LIMITATION, THE IMPLIED WARRANTIES OF
14             # MERCHANTIBILITY AND FITNESS FOR A PARTICULAR PURPOSE.
15             #
16             # POD documentation - main docs before the code
17              
18             =head1 NAME
19              
20             Bio::Annotation::TagTree - AnnotationI with tree-like hierarchal key-value
21             relationships ('structured tags') that can be represented as simple text.
22              
23             =head1 SYNOPSIS
24              
25             use Bio::Annotation::TagTree;
26             use Bio::Annotation::Collection;
27              
28             my $col = Bio::Annotation::Collection->new();
29              
30             # data structure can be an array reference with a data structure
31             # corresponding to that defined by Data::Stag:
32              
33             my $sv = Bio::Annotation::TagTree->new(-tagname => 'mytag1',
34             -value => $data_structure);
35             $col->add_Annotation($sv);
36              
37             # regular text passed is parsed based on the tagformat().
38             my $sv2 = Bio::Annotation::TagTree->new(-tagname => 'mytag2',
39             -tagformat => 'xml',
40             -value => $xmltext);
41             $col->add_Annotation($sv2);
42              
43             =head1 DESCRIPTION
44              
45             This takes tagged data values and stores them in a hierarchal structured
46             element-value hierarchy (complements of Chris Mungall's Data::Stag module). Data
47             can then be represented as text using a variety of output formats (indention,
48             itext, xml, spxr). Furthermore, the data structure can be queried using various
49             means. See L for details.
50              
51             Data passed in using value() or the '-value' parameter upon instantiation
52             can either be:
53              
54             1) an array reference corresponding to the data structure for Data::Stag;
55              
56             2) a text string in 'xml', 'itext', 'spxr', or 'indent' format. The default
57             format is 'xml'; this can be changed using tagformat() prior to using value() or
58             by passing in the proper format using '-tagformat' upon instantiation;
59              
60             3) another Bio::Annotation::TagTree or Data::Stag node instance. In both cases
61             a deep copy (duplicate) of the instance is generated.
62              
63             Beyond checking for an array reference no format guessing occurs (so, for
64             roundtrip tests ensure that the IO formats correspond). For now, we recommend
65             when using text input to set tagformat() to one of these formats prior to data
66             loading to ensure the proper Data::Stag parser is selected. After data loading,
67             the tagformat() can be changed to change the text string format returned by
68             value(). (this may be rectified in the future)
69              
70             This Annotation type is fully BioSQL compatible and could be considered a
71             temporary replacement for nested Bio::Annotation::Collections, at least until
72             BioSQL and bioperl-db can support nested annotation collections.
73              
74             =head1 FEEDBACK
75              
76             =head2 Mailing Lists
77              
78             User feedback is an integral part of the evolution of this and other
79             Bioperl modules. Send your comments and suggestions preferably to one
80             of the Bioperl mailing lists. Your participation is much appreciated.
81              
82             bioperl-l@bioperl.org - General discussion
83             http://bioperl.org/wiki/Mailing_lists - About the mailing lists
84              
85             =head2 Support
86              
87             Please direct usage questions or support issues to the mailing list:
88              
89             I
90              
91             rather than to the module maintainer directly. Many experienced and
92             reponsive experts will be able look at the problem and quickly
93             address it. Please include a thorough description of the problem
94             with code and data examples if at all possible.
95              
96             =head2 Reporting Bugs
97              
98             Report bugs to the Bioperl bug tracking system to help us keep track
99             the bugs and their resolution. Bug reports can be submitted via
100             or the web:
101              
102             https://github.com/bioperl/bioperl-live/issues
103              
104             =head1 AUTHOR
105              
106             Chris Fields
107              
108             =head1 APPENDIX
109              
110             The rest of the documentation details each of the object methods. Internal
111             methods are usually preceded with a _
112              
113             =cut
114              
115             # Let the code begin...
116              
117             package Bio::Annotation::TagTree;
118 8     8   612 use strict;
  8         10  
  8         218  
119              
120             # Object preamble - inherits from Bio::Root::Root
121              
122 8     8   26 use base qw(Bio::Annotation::SimpleValue);
  8         128  
  8         523  
123 8     8   30 use Data::Stag;
  8         9  
  8         8803  
124              
125             =head2 new
126              
127             Title : new
128             Usage : my $sv = Bio::Annotation::TagTree->new();
129             Function: Instantiate a new TagTree object
130             Returns : Bio::Annotation::TagTree object
131             Args : -value => $value to initialize the object data field [optional]
132             -tagname => $tag to initialize the tagname [optional]
133             -tagformat => format for output [optional]
134             (types 'xml', 'itext', 'sxpr', 'indent', default = 'itext')
135             -node => Data::Stag node or Bio::Annotation::TagTree instance
136              
137             =cut
138              
139             sub new {
140 60     60 1 2940 my ( $class, @args ) = @_;
141 60         324 my $self = $class->SUPER::new();
142 60         206 my ( $node, $value, $tag, $format, $verbose ) = $self->_rearrange(
143             [
144             qw(
145             NODE
146             VALUE
147             TAGNAME
148             TAGFORMAT
149             VERBOSE)
150             ],
151             @args
152             );
153 60 50 33     232 $self->throw("Cant use both node and value; mutually exclusive")
154             if defined $node && defined $value;
155 60 100       239 defined $tag && $self->tagname($tag);
156 60   50     223 $format ||= 'itext';
157 60         159 $self->tagformat($format);
158 60 100       218 defined $value && $self->value($value);
159 60 50       48193 defined $node && $self->node($node);
160 60 100       175 defined $verbose && $self->verbose($verbose);
161 60         182 return $self;
162             }
163              
164             =head1 AnnotationI implementing functions
165              
166             =cut
167              
168             =head2 as_text
169              
170             Title : as_text
171             Usage : my $text = $obj->as_text
172             Function: return the string "Value: $v" where $v is the value
173             Returns : string
174             Args : none
175              
176             =cut
177              
178             sub as_text {
179 0     0 1 0 my ($self) = @_;
180 0         0 return "TagTree: " . $self->value;
181             }
182              
183             =head2 display_text
184              
185             Title : display_text
186             Usage : my $str = $ann->display_text();
187             Function: returns a string. Unlike as_text(), this method returns a string
188             formatted as would be expected for the specific implementation.
189              
190             One can pass a callback as an argument which allows custom text
191             generation; the callback is passed the current instance and any text
192             returned
193             Example :
194             Returns : a string
195             Args : [optional] callback
196              
197             =cut
198              
199             {
200             my $DEFAULT_CB = sub { $_[0]->value || '' };
201              
202             sub display_text {
203 0     0 1 0 my ( $self, $cb ) = @_;
204 0   0     0 $cb ||= $DEFAULT_CB;
205 0 0       0 $self->throw("Callback must be a code reference") if ref $cb ne 'CODE';
206 0         0 return $cb->($self);
207             }
208              
209             }
210              
211             =head2 hash_tree
212              
213             Title : hash_tree
214             Usage : my $hashtree = $value->hash_tree
215             Function: For supporting the AnnotationI interface just returns the value
216             as a hashref with the key 'value' pointing to the value
217             Maybe reimplement using Data::Stag::hash()?
218             Returns : hashrf
219             Args : none
220              
221             =cut
222              
223             sub hash_tree {
224 0     0 1 0 my ($self) = @_;
225 0         0 my $h = {};
226 0         0 $h->{'value'} = $self->value;
227             }
228              
229             =head2 tagname
230              
231             Title : tagname
232             Usage : $obj->tagname($newval)
233             Function: Get/set the tagname for this annotation value.
234              
235             Setting this is optional. If set, it obviates the need to provide
236             a tag to AnnotationCollection when adding this object.
237             Example :
238             Returns : value of tagname (a scalar)
239             Args : new value (a scalar, optional)
240              
241             =cut
242              
243             sub tagname {
244 78     78 1 106 my ( $self, $value ) = @_;
245 78 100       175 if ( defined $value ) {
246 58         148 $self->{'tagname'} = $value;
247             }
248 78         162 return $self->{'tagname'};
249             }
250              
251             =head1 Specific accessors for TagTree
252              
253             =cut
254              
255             =head2 value
256              
257             Title : value
258             Usage : $obj->value($newval)
259             Function: Get/set the value for this annotation.
260             Returns : value of value
261             Args : newvalue (optional)
262              
263             =cut
264              
265             sub value {
266 81     81 1 6995 my ( $self, $value ) = @_;
267              
268             # set mode? This resets the entire tagged database
269 81         156 my $format = $self->tagformat;
270 81 100       178 if ($value) {
271 58 100       145 if ( ref $value ) {
272 57 100       173 if ( ref $value eq 'ARRAY' ) {
273              
274             # note the tagname() is not used here; it is only used for
275             # storing this AnnotationI in the annotation collection
276 53         92 eval { $self->{db} = Data::Stag->nodify($value) };
  53         696  
277             }
278             else {
279              
280             # assuming this is blessed; passing on to node() and copy
281 4         11 $self->node( $value, 'copy' );
282             }
283             }
284             else {
285              
286             # not trying to guess here for now; we go by the tagformat() setting
287 1         19 my $h = Data::Stag->getformathandler($format);
288 1         137 eval { $self->{db} = Data::Stag->from( $format . 'str', $value ) };
  1         8  
289             }
290 58 50       10081 $self->throw("Data::Stag error:\n$@") if $@;
291             }
292              
293             # get mode?
294             # How do we return a data structure?
295             # for now, we use the output (if there is a Data::Stag node present)
296             # may need to run an eval {} to catch Data::Stag output errors
297 81         489 $self->node->$format;
298             }
299              
300             =head2 tagformat
301              
302             Title : tagformat
303             Usage : $obj->tagformat($newval)
304             Function: Get/set the output tag format for this annotation.
305             Returns : value of tagformat
306             Args : newvalue (optional) - format for the data passed into value
307             must be of values 'xml', 'indent', 'sxpr', 'itext', 'perl'
308              
309             =cut
310              
311             my %IS_VALID_FORMAT = map { $_ => 1 } qw(xml indent sxpr itext);
312              
313             sub tagformat {
314 144     144 1 10783 my ( $self, $value ) = @_;
315 144 100       276 if ( defined $value ) {
316             $self->throw( "$value is not a valid format; valid format types:\n"
317 0         0 . join( ',', map { "'$_'" } keys %IS_VALID_FORMAT ) )
318 63 50       181 if !exists $IS_VALID_FORMAT{$value};
319 63         124 $self->{'tagformat'} = $value;
320             }
321 144         210 return $self->{'tagformat'};
322             }
323              
324             =head2 node
325              
326             Title : node
327             Usage : $obj->node()
328             Function: Get/set the topmost Data::Stag node used for this annotation.
329             Returns : Data::Stag node implementation
330             (default is Data::Stag::StagImpl)
331             Args : (optional) Data::Stag node implementation
332             (optional)'copy' => flag to create a copy of the node
333              
334             =cut
335              
336             sub node {
337 120     120 1 5288 my ( $self, $value, $copy ) = @_;
338 120 100 66     330 if ( defined $value && ref $value ) {
339 6 100 66     64 $self->{'db'} =
    50 33        
    50          
    100          
340             $value->isa('Data::Stag::StagI')
341             ? ( $copy && $copy eq 'copy' ? $value->duplicate : $value )
342             : $value->isa('Bio::Annotation::TagTree') ? ( $copy
343             && $copy eq 'copy' ? $value->node->duplicate : $value->node )
344             : $self->throw(
345             'Object must be Data::Stag::StagI or Bio::Annotation::TagTree');
346             }
347            
348             # lazily create Data::Stag instance if not present
349 120 100       1979 if (!$self->{'db'}) {
350 4         16 $self->{'db'} = Data::Stag->new();
351             }
352 120         641 return $self->{'db'};
353             }
354              
355             =head2 Data::Stag convenience methods
356              
357             Because Data::Stag uses blessed arrays and the core Bioperl class uses blessed
358             hashes, TagTree uses an internal instance of a Data::Stag node for data storage.
359             Therefore the following methods actually delegate to the Data:::Stag internal
360             instance.
361              
362             For consistency (since one could recursively check child nodes), methods retain
363             the same names as Data::Stag. Also, no 'magic' (AUTOLOAD'ed) methods are
364             employed, simply b/c full-fledged Data::Stag functionality can be attained by
365             grabbing the Data::Stag instance using node().
366              
367             =head2 element
368              
369             Title : element
370             Usage :
371             Function: Returns the element name (key name) for this node
372             Example :
373             Returns : scalar
374             Args : none
375              
376             =cut
377              
378             sub element {
379 0     0 1 0 my $self = shift;
380 0         0 return $self->node->element;
381             }
382              
383             =head2 data
384              
385             Title : data
386             Usage :
387             Function: Returns the data structure (array ref) for this node
388             Example :
389             Returns : array ref
390             Args : none
391              
392             =cut
393              
394             sub data {
395 0     0 1 0 my $self = shift;
396 0         0 return $self->node->data;
397             }
398              
399             =head2 children
400              
401             Title : children
402             Usage :
403             Function: Get the top-level array of Data::Stag nodes or (if the top level is
404             a terminal node) a scalar value.
405              
406             This is similar to StructuredValue's get_values() method, with the
407             key difference being instead of array refs and scalars you get either
408             Data::Stag nodes or the value for this particular node.
409              
410             For consistency (since one could recursively check nodes),
411             we use the same method name as Data::Stag children().
412             Example :
413             Returns : an array
414             Args : none
415              
416             =cut
417              
418             sub children {
419 6     6 1 4958 my $self = shift;
420 6         21 return $self->node->children;
421             }
422              
423             =head2 subnodes
424              
425             Title : subnodes
426             Usage :
427             Function: Get the top-level array of Data::Stag nodes. Unlike children(),
428             this only returns an array of nodes (if this is a terminal node,
429             no value is returned)
430             Example :
431             Returns : an array of nodes
432             Args : none
433              
434             =cut
435              
436             sub subnodes {
437 0     0 1 0 my $self = shift;
438 0         0 return $self->node->subnodes;
439             }
440              
441             =head2 get
442              
443             Title : get
444             Usage :
445             Function: Returns the nodes or value for the named element or path
446             Example :
447             Returns : returns array of nodes or a scalar (if node is terminal)
448             dependent on wantarray
449             Args : none
450              
451             =cut
452              
453             sub get {
454 0     0 1 0 my ( $self, @vals ) = @_;
455 0         0 return $self->node->get(@vals);
456             }
457              
458             =head2 find
459              
460             Title : find
461             Usage :
462             Function: Recursively searches for and returns the nodes or values for the
463             named element or path
464             Example :
465             Returns : returns array of nodes or scalars (for terminal nodes)
466             Args : none
467              
468             =cut
469              
470             sub find {
471 0     0 1 0 my ( $self, @vals ) = @_;
472 0         0 return $self->node->find(@vals);
473             }
474              
475             =head2 findnode
476              
477             Title : findnode
478             Usage :
479             Function: Recursively searches for and returns a list of nodes
480             of the given element path
481             Example :
482             Returns : returns array of nodes
483             Args : none
484              
485             =cut
486              
487             sub findnode {
488 6     6 1 2059 my ( $self, @vals ) = @_;
489 6         19 return $self->node->findnode(@vals);
490             }
491              
492             =head2 findval
493              
494             Title : findval
495             Usage :
496             Function:
497             Example :
498             Returns : returns array of nodes or values
499             Args : none
500              
501             =cut
502              
503             sub findval {
504 4     4 1 751 my ( $self, @vals ) = @_;
505 4         12 return $self->node->findval(@vals);
506             }
507              
508             =head2 addchild
509              
510             Title : addchild
511             Usage : $struct->addchild(['name' => [['foo'=> 'bar1']]]);
512             Function: add new child node to the current node. One can pass in a node, TagTree,
513             or data structure; for instance, in the above, this would translate
514             to (in XML):
515              
516            
517             bar1
518            
519              
520             Returns : node
521             Args : first arg = element name
522             all other args are added as tag-value pairs
523              
524             =cut
525              
526             sub addchild {
527 0     0 1 0 my ( $self, @vals ) = @_;
528              
529             # check for element tag first (if no element, must be empty Data::Stag node)
530 0 0       0 if ( !$self->element ) {
    0          
531              
532             # try to do the right thing; if more than one element, wrap in array ref
533 0 0       0 @vals > 1 ? $self->value( \@vals ) : $self->value( $vals[0] );
534 0         0 return $self->{db};
535             }
536             elsif ( !$self->node->ntnodes ) {
537              
538             # if this is a terminal node, can't add to it (use set?)
539 0         0 $self->throw("Can't add child to node; only terminal node is present!");
540             }
541             else {
542 0         0 return $self->node->addchild(@vals);
543             }
544             }
545              
546             =head2 add
547              
548             Title : add
549             Usage : $struct->add('foo', 'bar1', 'bar2', 'bar3');
550             Function: add tag-value nodes to the current node. In the above, this would
551             translate to (in XML):
552             bar1
553             bar2
554             bar3
555             Returns :
556             Args : first arg = element name
557             all other args are added as tag-value pairs
558              
559             =cut
560              
561             sub add {
562 0     0 1 0 my ( $self, @vals ) = @_;
563              
564             # check for empty object and die for now
565 0 0       0 if ( !$self->node->element ) {
566 0         0 $self->throw("Can't add to terminal element!");
567             }
568 0         0 return $self->node->add(@vals);
569             }
570              
571             =head2 set
572              
573             Title : set
574             Usage : $struct->set('foo','bar');
575             Function: sets a single tag-value pair in the current node. Note this
576             differs from add() in that this replaces any data already present
577             Returns : node
578             Args : first arg = element name
579             all other args are added as tag-value pairs
580              
581             =cut
582              
583             sub set {
584 0     0 1 0 my ( $self, @vals ) = @_;
585              
586             # check for empty object
587 0 0       0 if ( !$self->node->element ) {
588 0         0 $self->throw("Can't add to tree; empty tree!");
589             }
590 0         0 return $self->node->set(@vals);
591             }
592              
593             =head2 unset
594              
595             Title : unset
596             Usage : $struct->unset('foo');
597             Function: unsets all key-value pairs of the passed element from the
598             current node
599             Returns : node
600             Args : element name
601              
602             =cut
603              
604             sub unset {
605 0     0 1 0 my ( $self, @vals ) = @_;
606 0         0 return $self->node->unset(@vals);
607             }
608              
609             =head2 free
610              
611             Title : free
612             Usage : $struct->free
613             Function: removes all data from the current node
614             Returns :
615             Args :
616              
617             =cut
618              
619             sub free {
620 0     0 1 0 my ($self) = @_;
621 0         0 return $self->node->free;
622             }
623              
624             =head2 hash
625              
626             Title : hash
627             Usage : $struct->hash;
628             Function: turns the tag-value tree into a hash, all data values are array refs
629             Returns : hash
630             Args : first arg = element name
631             all other args are added as tag-value pairs
632              
633             =cut
634              
635             sub hash {
636 0     0 1 0 my ($self) = @_;
637 0         0 return $self->node->hash;
638             }
639              
640             =head2 pairs
641              
642             Title : pairs
643             Usage : $struct->pairs;
644             Function: turns the tag-value tree into a hash, all data values are scalar
645             Returns : hash
646             Args : first arg = element name
647             all other args are added as tag-value pairs, note that duplicates
648             will be lost
649              
650             =cut
651              
652             sub pairs {
653 4     4 1 313 my ($self) = @_;
654 4         6 return $self->node->pairs;
655             }
656              
657             =head2 qmatch
658              
659             Title : qmatch
660             Usage : @persons = $s->qmatch('person', ('name'=>'fred'));
661             Function : returns all elements in the node tree which match the
662             element name and the key-value pair
663             Returns : Array of nodes
664             Args : return-element str, match-element str, match-value str
665              
666             =cut
667              
668             sub qmatch {
669 0     0 1 0 my ( $self, @vals ) = @_;
670 0         0 return $self->node->qmatch(@vals);
671             }
672              
673             =head2 tnodes
674              
675             Title : tnodes
676             Usage : @termini = $s->tnodes;
677             Function : returns all terminal nodes below this node
678             Returns : Array of nodes
679             Args : return-element str, match-element str, match-value str
680              
681             =cut
682              
683             sub tnodes {
684 0     0 1 0 my ($self) = @_;
685 0         0 return $self->node->tnodes;
686             }
687              
688             =head2 ntnodes
689              
690             Title : ntnodes
691             Usage : @termini = $s->ntnodes;
692             Function : returns all nonterminal nodes below this node
693             Returns : Array of nodes
694             Args : return-element str, match-element str, match-value str
695              
696             =cut
697              
698             sub ntnodes {
699 0     0 1 0 my ($self) = @_;
700 0         0 return $self->node->ntnodes;
701             }
702              
703             =head2 StructureValue-like methods
704              
705             =cut
706              
707             =head2 get_all_values
708              
709             Title : get_all_values
710             Usage : @termini = $s->get_all_values;
711             Function : returns all terminal node values
712             Returns : Array of values
713             Args : return-element str, match-element str, match-value str
714              
715             This is meant to emulate the values one would get from StructureValue's
716             get_all_values() method. Note, however, using this method dissociates the
717             tag-value relationship (i.e. you only get the value list, no elements)
718              
719             =cut
720              
721             sub get_all_values {
722 4     4 1 27 my $self = shift;
723 4         15 my @kids = $self->children;
724 4         96 my @vals;
725 4         16 while ( my $val = shift @kids ) {
726 92 100       474 ( ref $val ) ? push @kids, $val->children : push @vals, $val;
727             }
728 4         20 return @vals;
729             }
730              
731             1;