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 use strict;
  87
  88 use Bio::Annotation::Collection;
  89 use Bio::Seq;
  90 use base qw(Bio::Tree::Node Bio::AnnotatableI);
  91
  92 =head2 new
  93
  94  Title   : new
  95  Usage   : my $obj = Bio::Tree::AnnotatableNode->new();
  96  Function: Builds a new Bio::Tree::AnnotatableNode object
  97  Returns : Bio::Tree::AnnotatableNode
  98  Args    : -tostring => code reference to the tostring callback function (optional)
  99
 100 =cut
 101
 102 sub new {
 103   my ($class,@args) = @_;
 104   my $self = $class->SUPER::new(@args);
 105   my $to_string_cb = $self->_rearrange([qw(TOSTRING)], @args);
 106   if ($to_string_cb) {
 107     $self->to_string_callback($to_string_cb);
 108   }
 109   return $self;
 110 }
 111
 112 sub DESTROY {
 113     my ($self) = @_;
 114     # try to insure that everything is cleaned up
 115     $self->SUPER::DESTROY();
 116 }
 117
 118 =head1 Methods for implementing Bio::AnnotatableI
 119
 120 =cut
 121
 122 =head2 annotation
 123
 124  Title   : annotation
 125  Usage   : $ann = $node->annotation or
 126            $node->annotation($ann)
 127  Function: Gets or sets the annotation
 128  Returns : Bio::AnnotationCollectionI object
 129  Args    : None or Bio::AnnotationCollectionI object
 130 See L<Bio::AnnotationCollectionI> and L<Bio::Annotation::Collection>
 131 for more information
 132
 133 =cut
 134
 135 sub annotation
 136 {
 137   my ($self,$value) = @_;
 138   if( defined $value ) {
 139     $self->throw("object of class ".ref($value)." does not implement ".
 140         "Bio::AnnotationCollectionI. Too bad.")      unless $value->isa("Bio::AnnotationCollectionI");
 141     $self->{'_annotation'} = $value;
 142   }
 143   elsif( ! defined $self->{'_annotation'})
 144   {
 145     $self->{'_annotation'} = Bio::Annotation::Collection->new();
 146   }
 147   return $self->{'_annotation'};
 148 }
 149
 150
 151 =head1 Methods for implementing tag access through Annotation::SimpleValue
 152
 153 =cut
 154
 155 =head2 add_tag_value
 156
 157  Title   : add_tag_value
 158  Usage   : $node->add_tag_value($tag,$value)
 159  Function: Adds a tag value to a node
 160  Returns : number of values stored for this tag
 161  Args    : $tag   - tag name
 162            $value - value to store for the tag
 163
 164 =cut
 165
 166 sub add_tag_value
 167 {
 168   my ($self,$tag,$value) = @_;
 169   if( ! defined $tag || ! defined $value ) {
 170     $self->warn("cannot call add_tag_value with an undefined value");
 171   }
 172   my $ac = $self->annotation();
 173   my $sv = Bio::Annotation::SimpleValue->new(-value => $value);
 174   $ac->add_Annotation($tag, $sv);
 175   return scalar $ac->get_Annotations($tag);
 176 }
 177
 178 =head2 remove_tag
 179
 180  Title   : remove_tag
 181  Usage   : $node->remove_tag($tag)
 182  Function: Remove the tag and all values for this tag
 183  Returns : boolean representing success (0 if tag does not exist)
 184  Args    : $tag - tagname to remove
 185
 186
 187 =cut
 188
 189 sub remove_tag
 190 {
 191   my ($self,$tag) = @_;
 192   my $ac = $self->annotation();
 193   if( @{$ac->get_Annotations($tag)} ) {
 194     $ac->remove_Annotations($tag);
 195     return 1;
 196   }
 197   return 0;
 198 }
 199
 200 =head2 remove_all_tags
 201
 202  Title   : remove_all_tags
 203  Usage   : $node->remove_all_tags()
 204  Function: Removes all tags
 205  Returns : None
 206  Args    : None
 207
 208 =cut
 209
 210 sub remove_all_tags
 211 {
 212   my ($self) = @_;
 213   my $ac = $self->annotation();
 214   $ac->remove_Annotations();
 215   return;
 216 }
 217
 218 =head2 get_all_tags
 219
 220  Title   : get_all_tags
 221  Usage   : my @tags = $node->get_all_tags()
 222  Function: Gets all the tag names for this Node
 223  Returns : Array of tagnames
 224  Args    : None
 225
 226 =cut
 227
 228 sub get_all_tags{
 229   my ($self) = @_;
 230   my $ac = $self->annotation();
 231   my @tags = sort $ac->get_all_annotation_keys();
 232   # how to restrict it to SimpleValues?
 233   return @tags;
 234 }
 235
 236 =head2 get_tag_values
 237
 238  Title   : get_tag_values
 239  Usage   : my @values = $node->get_tag_value($tag)
 240  Function: Gets the values for given tag ($tag)
 241  Returns : Array of values or empty list if tag does not exist
 242  Args    : $tag - tag name
 243
 244 =cut
 245
 246 sub get_tag_values{
 247   my ($self,$tag) = @_;
 248   my $ac = $self->annotation();
 249   my @values = map {$_->value()} $ac->get_Annotations($tag);
 250   return @values;
 251 }
 252
 253 =head2 has_tag
 254
 255  Title   : has_tag
 256  Usage   : $node->has_tag($tag)
 257  Function: Boolean test if tag exists in the Node
 258  Returns : Boolean
 259  Args    : $tag - tagname
 260
 261 =cut
 262
 263 sub has_tag {
 264   my ($self,$tag) = @_;
 265   my $ac = $self->annotation();
 266   return ( scalar $ac->get_Annotations($tag) > 0);
 267 }
 268
 269
 270 =head1 Methods for implementing to_string
 271
 272 =cut
 273
 274 =head2 to_string_callback
 275
 276  Title   : to_string_callback
 277  Usage   : $node->to_string_callback(\&func)
 278  Function: get/set callback for to_string
 279  Returns : code reference for the to_string callback function
 280  Args    : \&func - code reference to be set as the callback function
 281
 282 =cut
 283
 284 sub to_string_callback {
 285     # get/set callback, using $DEFAULT_CB if nothing is set
 286     my ($self, $foo) = @_;
 287     if ($foo) {
 288       # $foo is callback code ref, self as first arg (so you have access to object data)
 289       $self->{'_to_string_cb'} = $foo;
 290     }
 291     else {
 292       if (! defined $self->{'_to_string_cb'}) {
 293         $self->{'_to_string_cb'} = \&Bio::Tree::NodeI::to_string;
 294       }
 295     }
 296     return $self->{'_to_string_cb'};
 297 }
 298
 299 sub to_string {
 300   my ($self) = @_;
 301   my $cb = $self->to_string_callback();
 302   return $cb->($self);
 303 }
 304
 305 =head1 Methods for accessing Bio::Seq
 306
 307 =cut
 308
 309 =head2 sequence
 310
 311  Title   : sequence
 312  Usage   : $ann = $node->sequence or
 313            $node->sequence($seq)
 314  Function: Gets or sets the sequence
 315  Returns : array reference of Bio::SeqI objects
 316  Args    : None or Bio::SeqI object
 317 See L<Bio::SeqI> and L<Bio::Seq>
 318 for more information
 319
 320 =cut
 321
 322 sub sequence
 323 {
 324   my ($self,$value) = @_;
 325   if( defined $value ) {
 326     $self->throw("object of class ".ref($value)." does not implement ".
 327         "Bio::SeqI. Too bad.")      unless $value->isa("Bio::SeqI");
 328     push (@{$self->{'_sequence'}}, $value);
 329   }
 330   #elsif( ! defined $self->{'_sequence'})
 331   #{
 332   #  $self->{'_sequence'} = Bio::Seq->new();
 333   #}
 334   return $self->{'_sequence'};
 335 }
 336
 337 =head2 has_sequence
 338
 339  Title   : has_sequence
 340  Usage   : if( $node->has_sequence) { # do something }
 341  Function: tells if node has sequence attached
 342  Returns : Boolean for whether or not node has Bio::SeqI attached.
 343  Args    : None
 344
 345 =cut
 346
 347 sub has_sequence
 348 {
 349   my ($self) = @_;
 350   return $self->{'_sequence'} && @{$self->{'_sequence'}};
 351 }
 352
 353
 354 1;