lib/Bio/Tree/AnnotatableNode.pm

   1 # BioPerl module for Bio::Tree::AnnotatableNode
   2 #
   3 # Please direct questions and support issues to <bioperl-l@bioperl.org>
   4 #
   5 # Cared for by Mira Han <mirhan@indiana.edu>
   6 #
   7 # Copyright Mira Han
   8 #
   9 # You may distribute this module under the same terms as perl itself
  10
  11 # POD documentation - main docs before the code
  12
  13 =head1 NAME
  14
  15 Bio::Tree::AnnotatableNode - A Tree Node with support for annotation
  16
  17 =head1 SYNOPSIS
  18
  19     use Bio::Tree::AnnotatableNode;
  20     my $nodeA = Bio::Tree::AnnotatableNode->new();
  21     my $nodeL = Bio::Tree::AnnotatableNode->new();
  22     my $nodeR = Bio::Tree::AnnotatableNode->new();
  23
  24     my $node = Bio::Tree::AnnotatableNode->new();
  25     $node->add_Descendents($nodeL);
  26     $node->add_Descendents($nodeR);
  27
  28     print "node is not a leaf \n" if( $node->is_leaf);
  29
  30     # $node is-a Bio::AnnotatableI, hence:
  31     my $ann_coll = $node->annotation();
  32     # $ann_coll is-a Bio::AnnotationCollectionI, hence:
  33     my @all_anns = $ann_coll->get_Annotations();
  34     # do something with the annotation objects
  35
  36 =head1 DESCRIPTION
  37
  38 Makes a Tree Node with Annotations, suitable for building a Tree.  See
  39 L<Bio::Tree::Node> for a full list of functionality.
  40
  41 =head1 FEEDBACK
  42
  43 =head2 Mailing Lists
  44
  45 User feedback is an integral part of the evolution of this and other
  46 Bioperl modules. Send your comments and suggestions preferably to
  47 the Bioperl mailing list.  Your participation is much appreciated.
  48
  49   bioperl-l@bioperl.org                  - General discussion
  50   http://bioperl.org/wiki/Mailing_lists  - About the mailing lists
  51
  52 =head2 Support
  53
  54 Please direct usage questions or support issues to the mailing list:
  55
  56 I<bioperl-l@bioperl.org>
  57
  58 rather than to the module maintainer directly. Many experienced and
  59 reponsive experts will be able look at the problem and quickly
  60 address it. Please include a thorough description of the problem
  61 with code and data examples if at all possible.
  62
  63 =head2 Reporting Bugs
  64
  65 Report bugs to the Bioperl bug tracking system to help us keep track
  66 of the bugs and their resolution. Bug reports can be submitted via
  67 the web:
  68
  69   https://github.com/bioperl/bioperl-live/issues
  70
  71 =head1 AUTHOR - Mira Han
  72
  73 Email mirhan@indiana.edu
  74
  75 =head1 APPENDIX
  76
  77 The rest of the documentation details each of the object methods.
  78 Internal methods are usually preceded with a _
  79
  80 =cut
  81
  82
  83 # Let the code begin...
  84
  85 package Bio::Tree::AnnotatableNode;
  86
  87 use strict;
  88
  89 use Bio::Annotation::Collection;
  90 use Bio::Seq;
  91 use base qw(Bio::Tree::Node Bio::AnnotatableI);
  92
  93 =head2 new
  94
  95  Title   : new
  96  Usage   : my $obj = Bio::Tree::AnnotatableNode->new();
  97  Function: Builds a new Bio::Tree::AnnotatableNode object
  98  Returns : Bio::Tree::AnnotatableNode
  99  Args    : -tostring => code reference to the tostring callback function (optional)
 100
 101 =cut
 102
 103 sub new {
 104   my ($class,@args) = @_;
 105   my $self = $class->SUPER::new(@args);
 106   my $to_string_cb = $self->_rearrange([qw(TOSTRING)], @args);
 107   if ($to_string_cb) {
 108     $self->to_string_callback($to_string_cb);
 109   }
 110   return $self;
 111 }
 112
 113 sub DESTROY {
 114     my ($self) = @_;
 115     # try to insure that everything is cleaned up
 116     $self->SUPER::DESTROY();
 117 }
 118
 119 =head1 Methods for implementing Bio::AnnotatableI
 120
 121 =cut
 122
 123 =head2 annotation
 124
 125  Title   : annotation
 126  Usage   : $ann = $node->annotation or
 127            $node->annotation($ann)
 128  Function: Gets or sets the annotation
 129  Returns : Bio::AnnotationCollectionI object
 130  Args    : None or Bio::AnnotationCollectionI object
 131 See L<Bio::AnnotationCollectionI> and L<Bio::Annotation::Collection>
 132 for more information
 133
 134 =cut
 135
 136 sub annotation
 137 {
 138   my ($self,$value) = @_;
 139   if( defined $value ) {
 140     $self->throw("object of class ".ref($value)." does not implement ".
 141         "Bio::AnnotationCollectionI. Too bad.")      unless $value->isa("Bio::AnnotationCollectionI");
 142     $self->{'_annotation'} = $value;
 143   }
 144   elsif( ! defined $self->{'_annotation'})
 145   {
 146     $self->{'_annotation'} = Bio::Annotation::Collection->new();
 147   }
 148   return $self->{'_annotation'};
 149 }
 150
 151
 152 =head1 Methods for implementing tag access through Annotation::SimpleValue
 153
 154 =cut
 155
 156 =head2 add_tag_value
 157
 158  Title   : add_tag_value
 159  Usage   : $node->add_tag_value($tag,$value)
 160  Function: Adds a tag value to a node
 161  Returns : number of values stored for this tag
 162  Args    : $tag   - tag name
 163            $value - value to store for the tag
 164
 165 =cut
 166
 167 sub add_tag_value
 168 {
 169   my ($self,$tag,$value) = @_;
 170   if( ! defined $tag || ! defined $value ) {
 171     $self->warn("cannot call add_tag_value with an undefined value");
 172   }
 173   my $ac = $self->annotation();
 174   my $sv = Bio::Annotation::SimpleValue->new(-value => $value);
 175   $ac->add_Annotation($tag, $sv);
 176   return scalar $ac->get_Annotations($tag);
 177 }
 178
 179 =head2 remove_tag
 180
 181  Title   : remove_tag
 182  Usage   : $node->remove_tag($tag)
 183  Function: Remove the tag and all values for this tag
 184  Returns : boolean representing success (0 if tag does not exist)
 185  Args    : $tag - tagname to remove
 186
 187
 188 =cut
 189
 190 sub remove_tag
 191 {
 192   my ($self,$tag) = @_;
 193   my $ac = $self->annotation();
 194   if( @{$ac->get_Annotations($tag)} ) {
 195     $ac->remove_Annotations($tag);
 196     return 1;
 197   }
 198   return 0;
 199 }
 200
 201 =head2 remove_all_tags
 202
 203  Title   : remove_all_tags
 204  Usage   : $node->remove_all_tags()
 205  Function: Removes all tags
 206  Returns : None
 207  Args    : None
 208
 209 =cut
 210
 211 sub remove_all_tags
 212 {
 213   my ($self) = @_;
 214   my $ac = $self->annotation();
 215   $ac->remove_Annotations();
 216   return;
 217 }
 218
 219 =head2 get_all_tags
 220
 221  Title   : get_all_tags
 222  Usage   : my @tags = $node->get_all_tags()
 223  Function: Gets all the tag names for this Node
 224  Returns : Array of tagnames
 225  Args    : None
 226
 227 =cut
 228
 229 sub get_all_tags{
 230   my ($self) = @_;
 231   my $ac = $self->annotation();
 232   my @tags = sort $ac->get_all_annotation_keys();
 233   # how to restrict it to SimpleValues?
 234   return @tags;
 235 }
 236
 237 =head2 get_tag_values
 238
 239  Title   : get_tag_values
 240  Usage   : my @values = $node->get_tag_value($tag)
 241  Function: Gets the values for given tag ($tag)
 242  Returns : Array of values or empty list if tag does not exist
 243  Args    : $tag - tag name
 244
 245 =cut
 246
 247 sub get_tag_values{
 248   my ($self,$tag) = @_;
 249   my $ac = $self->annotation();
 250   my @values = map {$_->value()} $ac->get_Annotations($tag);
 251   return @values;
 252 }
 253
 254 =head2 has_tag
 255
 256  Title   : has_tag
 257  Usage   : $node->has_tag($tag)
 258  Function: Boolean test if tag exists in the Node
 259  Returns : Boolean
 260  Args    : $tag - tagname
 261
 262 =cut
 263
 264 sub has_tag {
 265   my ($self,$tag) = @_;
 266   my $ac = $self->annotation();
 267   return ( scalar $ac->get_Annotations($tag) > 0);
 268 }
 269
 270
 271 =head1 Methods for implementing to_string
 272
 273 =cut
 274
 275 =head2 to_string_callback
 276
 277  Title   : to_string_callback
 278  Usage   : $node->to_string_callback(\&func)
 279  Function: get/set callback for to_string
 280  Returns : code reference for the to_string callback function
 281  Args    : \&func - code reference to be set as the callback function
 282
 283 =cut
 284
 285 sub to_string_callback {
 286     # get/set callback, using $DEFAULT_CB if nothing is set
 287     my ($self, $foo) = @_;
 288     if ($foo) {
 289       # $foo is callback code ref, self as first arg (so you have access to object data)
 290       $self->{'_to_string_cb'} = $foo;
 291     }
 292     else {
 293       if (! defined $self->{'_to_string_cb'}) {
 294         $self->{'_to_string_cb'} = \&Bio::Tree::NodeI::to_string;
 295       }
 296     }
 297     return $self->{'_to_string_cb'};
 298 }
 299
 300 sub to_string {
 301   my ($self) = @_;
 302   my $cb = $self->to_string_callback();
 303   return $cb->($self);
 304 }
 305
 306 =head1 Methods for accessing Bio::Seq
 307
 308 =cut
 309
 310 =head2 sequence
 311
 312  Title   : sequence
 313  Usage   : $ann = $node->sequence or
 314            $node->sequence($seq)
 315  Function: Gets or sets the sequence
 316  Returns : array reference of Bio::SeqI objects
 317  Args    : None or Bio::SeqI object
 318 See L<Bio::SeqI> and L<Bio::Seq>
 319 for more information
 320
 321 =cut
 322
 323 sub sequence
 324 {
 325   my ($self,$value) = @_;
 326   if( defined $value ) {
 327     $self->throw("object of class ".ref($value)." does not implement ".
 328         "Bio::SeqI. Too bad.")      unless $value->isa("Bio::SeqI");
 329     push (@{$self->{'_sequence'}}, $value);
 330   }
 331   #elsif( ! defined $self->{'_sequence'})
 332   #{
 333   #  $self->{'_sequence'} = Bio::Seq->new();
 334   #}
 335   return $self->{'_sequence'};
 336 }
 337
 338 =head2 has_sequence
 339
 340  Title   : has_sequence
 341  Usage   : if( $node->has_sequence) { # do something }
 342  Function: tells if node has sequence attached
 343  Returns : Boolean for whether or not node has Bio::SeqI attached.
 344  Args    : None
 345
 346 =cut
 347
 348 sub has_sequence
 349 {
 350   my ($self) = @_;
 351   return $self->{'_sequence'} && @{$self->{'_sequence'}};
 352 }
 353
 354
 355 1;