Bio/Tree/AlleleNode.pm

   1 # $Id$
   2 #
   3 # BioPerl module for Bio::Tree::AlleleNode
   4 #
   5 # Please direct questions and support issues to <bioperl-l@bioperl.org>
   6 #
   7 # Cared for by Jason Stajich <jason@bioperl.org>
   8 #
   9 # Copyright Jason Stajich
  10 #
  11 # You may distribute this module under the same terms as perl itself
  12
  13 # POD documentation - main docs before the code
  14
  15 =head1 NAME
  16
  17 Bio::Tree::AlleleNode - A Node with Alleles attached
  18
  19 =head1 SYNOPSIS
  20
  21   use Bio::Tree::AlleleNode;
  22
  23 =head1 DESCRIPTION
  24
  25 AlleleNodes are basic L<Bio::Tree::Node>s with the added ability to
  26 add Genotypes alleles as defined by the L<Bio::PopGen::IndividualI>
  27 interface.  Genotypes are defined by the L<Bio::PopGen::GenotypeI>
  28 interface, you will probably want to use the L<Bio::PopGen::Genotype>
  29 implementation.
  30
  31 This is implemented via containment to avoid multiple inheritance
  32 problems.  Their is a L<Bio::PopGen::Individual> object which handles
  33 the L<Bio::PopGen::IndividualI> interface, and is accessible via the
  34 L<Bio::Tree::AlleleNode::individual> method.
  35
  36 =head1 FEEDBACK
  37
  38 =head2 Mailing Lists
  39
  40 User feedback is an integral part of the evolution of this and other
  41 Bioperl modules. Send your comments and suggestions preferably to
  42 the Bioperl mailing list.  Your participation is much appreciated.
  43
  44   bioperl-l@bioperl.org                  - General discussion
  45   http://bioperl.org/wiki/Mailing_lists  - About the mailing lists
  46
  47 =head2 Support
  48
  49 Please direct usage questions or support issues to the mailing list:
  50
  51 I<bioperl-l@bioperl.org>
  52
  53 rather than to the module maintainer directly. Many experienced and
  54 reponsive experts will be able look at the problem and quickly
  55 address it. Please include a thorough description of the problem
  56 with code and data examples if at all possible.
  57
  58 =head2 Reporting Bugs
  59
  60 Report bugs to the Bioperl bug tracking system to help us keep track
  61 of the bugs and their resolution. Bug reports can be submitted via the
  62 web:
  63
  64   http://bugzilla.open-bio.org/
  65
  66 =head1 AUTHOR - Jason Stajich
  67
  68 Email jason-at-bioperl-dot-org
  69
  70 =head1 APPENDIX
  71
  72 The rest of the documentation details each of the object methods.
  73 Internal methods are usually preceded with a _
  74
  75 =head1 HISTORY
  76
  77 This module was re-written to be a combination of
  78 L<Bio::PopGen::Individual> and L<Bio::Tree::Node> primarily for use in
  79 L<Bio::PopGen::Simulation::Coalescent> simulations.
  80
  81 =cut
  82
  83 # Let the code begin...
  84
  85
  86 package Bio::Tree::AlleleNode;
  87 use vars qw($UIDCOUNTER);
  88 use strict;
  89 BEGIN { $UIDCOUNTER = 1 }
  90
  91 use Bio::PopGen::Individual;
  92 use Bio::PopGen::Genotype;
  93
  94 use base qw(Bio::Tree::Node Bio::PopGen::IndividualI);
  95
  96 =head2 new
  97
  98  Title   : new
  99  Usage   : my $obj = Bio::Tree::AlleleNode->new();
 100  Function: Builds a new Bio::Tree::AlleleNode() object
 101  Returns : an instance of Bio::Tree::AlleleNode
 102  Args    : -unique_id     => $id,
 103            -genotypes     => \@genotypes
 104            -left          => pointer to Left descendent (optional)
 105            -right         => pointer to Right descenent (optional)
 106            -branch_length => branch length [integer] (optional)
 107            -bootstrap     => value   bootstrap value (string)
 108            -description   => description of node
 109            -id            => human readable (unique) id for node
 110                              Should NOT contain the characters
 111                              '();:'
 112 =cut
 113
 114 sub new {
 115     my($class,@args) = @_;
 116
 117     my $self = $class->SUPER::new(@args);
 118     $self->individual( Bio::PopGen::Individual->new(@args));
 119     return $self;
 120 }
 121
 122 =head2 individual
 123
 124  Title   : individual
 125  Usage   : $obj->individual($newval)
 126  Function: Get/Set Access to the underlying individual object
 127  Returns : L<Bio::PopGen::Individual> object
 128  Args    : on set, new value (L<Bio::PopGen::Individual>)
 129
 130
 131 =cut
 132
 133 sub individual {
 134     my ($self,$newval) = @_;
 135     if( defined $newval || ! defined $self->{'individual'} ) {
 136         $newval = Bio::PopGen::Individual->new() unless defined $newval;
 137         $self->{'individual'} = $newval;
 138     }
 139     return $self->{'individual'};
 140 }
 141
 142 =head2 Bio::PopGen::Individual methods
 143
 144 Methods required by L<Bio::PopGen::IndividualI>.
 145
 146
 147 =head2 unique_id
 148
 149  Title   : unique_id
 150  Usage   : my $id = $individual->unique_id
 151  Function: Unique Identifier
 152  Returns : string representing unique identifier
 153  Args    : string
 154
 155
 156 =cut
 157
 158 sub unique_id{
 159     my $self = shift;
 160     $self->individual->unique_id(@_);
 161 }
 162
 163 =head2 num_of_results
 164
 165  Title   : num_of_results
 166  Usage   : my $count = $person->num_results;
 167  Function: returns the count of the number of Results for a person
 168  Returns : integer
 169  Args    : none
 170
 171 =cut
 172
 173 sub num_of_results {
 174     my $self = shift;
 175     $self->individual->num_of_results(@_);
 176 }
 177
 178 =head2 add_Genotype
 179
 180  Title   : add_Genotype
 181  Usage   : $individual->add_Genotype
 182  Function: add a genotype value, only a single genotype
 183            may be associated
 184  Returns : count of the number of genotypes associated with this individual
 185  Args    : @genotypes - Bio::PopGen::GenotypeI object(s) containing
 186                         alleles plus a marker name
 187
 188 =cut
 189
 190 sub add_Genotype {
 191     my $self = shift;
 192     $self->individual->add_Genotype(@_);
 193 }
 194
 195 =head2 reset_Genotypes
 196
 197  Title   : reset_Genotypes
 198  Usage   : $individual->reset_Genotypes;
 199  Function: Reset the genotypes stored for this individual
 200  Returns : none
 201  Args    : none
 202
 203
 204 =cut
 205
 206 sub reset_Genotypes{
 207     my $self = shift;
 208     $self->individual->reset_Genotypes(@_);
 209 }
 210
 211 =head2 remove_Genotype
 212
 213  Title   : remove_Genotype
 214  Usage   : $individual->remove_Genotype(@names)
 215  Function: Removes the genotypes for the requested markers
 216  Returns : none
 217  Args    : Names of markers
 218
 219
 220 =cut
 221
 222 sub remove_Genotype{
 223     my $self = shift;
 224     $self->individual->remove_Genotype(@_);
 225 }
 226
 227 =head2 get_Genotypes
 228
 229  Title   : get_Genotypes
 230  Usage   : my @genotypes = $ind->get_Genotypes(-marker => $markername);
 231  Function: Get the genotypes for an individual, based on a criteria
 232  Returns : Array of genotypes
 233  Args    : either none (return all genotypes) or
 234            -marker => name of marker to return (exact match, case matters)
 235
 236
 237 =cut
 238
 239 sub get_Genotypes{
 240     my $self = shift;
 241     $self->individual->get_Genotypes(@_);
 242 }
 243
 244 =head2 has_Marker
 245
 246  Title   : has_Marker
 247  Usage   : if( $ind->has_Marker($name) ) {}
 248  Function: Boolean test to see if an Individual has a genotype
 249            for a specific marker
 250  Returns : Boolean (true or false)
 251  Args    : String representing a marker name
 252
 253
 254 =cut
 255
 256 sub has_Marker{
 257     my $self = shift;
 258     $self->individual->has_Marker(@_);
 259 }
 260
 261 =head2 get_marker_names
 262
 263  Title   : get_marker_names
 264  Usage   : my @names = $individual->get_marker_names;
 265  Function: Returns the list of known marker names
 266  Returns : List of strings
 267  Args    : none
 268
 269
 270 =cut
 271
 272 sub get_marker_names{
 273    my $self = shift;
 274    $self->individual->get_marker_names(@_);
 275 }
 276
 277 =head2 Bio::Tree::Node methods
 278
 279 Methods inherited from L<Bio::Tree::Node>.
 280
 281
 282 =head2 add_Descendent
 283
 284  Title   : add_Descendent
 285  Usage   : $node->add_Descendent($node);
 286  Function: Adds a descendent to a node
 287  Returns : number of current descendents for this node
 288  Args    : Bio::Node::NodeI
 289            boolean flag, true if you want to ignore the fact that you are
 290            adding a second node with the same unique id (typically memory
 291            location reference in this implementation).  default is false and
 292            will throw an error if you try and overwrite an existing node.
 293
 294
 295 =head2 each_Descendent
 296
 297  Title   : each_Descendent($sortby)
 298  Usage   : my @nodes = $node->each_Descendent;
 299  Function: all the descendents for this Node (but not their descendents
 300                                               i.e. not a recursive fetchall)
 301  Returns : Array of Bio::Tree::NodeI objects
 302  Args    : $sortby [optional] "height", "creation" or coderef to be used
 303            to sort the order of children nodes.
 304
 305
 306 =head2 remove_Descendent
 307
 308  Title   : remove_Descendent
 309  Usage   : $node->remove_Descedent($node_foo);
 310  Function: Removes a specific node from being a Descendent of this node
 311  Returns : nothing
 312  Args    : An array of Bio::Node::NodeI objects which have be previously
 313            passed to the add_Descendent call of this object.
 314
 315
 316 =head2 remove_all_Descendents
 317
 318  Title   : remove_all_Descendents
 319  Usage   : $node->remove_All_Descendents()
 320  Function: Cleanup the node's reference to descendents and reset
 321            their ancestor pointers to undef, if you don't have a reference
 322            to these objects after this call they will be cleaned up - so
 323            a get_nodes from the Tree object would be a safe thing to do first
 324  Returns : nothing
 325  Args    : none
 326
 327
 328
 329 =head2 get_all_Descendents
 330
 331  Title   : get_all_Descendents
 332  Usage   : my @nodes = $node->get_all_Descendents;
 333  Function: Recursively fetch all the nodes and their descendents
 334            *NOTE* This is different from each_Descendent
 335  Returns : Array or Bio::Tree::NodeI objects
 336  Args    : none
 337
 338 =cut
 339
 340 # implemented in the interface
 341
 342 =head2 ancestor
 343
 344  Title   : ancestor
 345  Usage   : $obj->ancestor($newval)
 346  Function: Set the Ancestor
 347  Returns : value of ancestor
 348  Args    : newvalue (optional)
 349
 350
 351 =head2 branch_length
 352
 353  Title   : branch_length
 354  Usage   : $obj->branch_length()
 355  Function: Get/Set the branch length
 356  Returns : value of branch_length
 357  Args    : newvalue (optional)
 358
 359
 360 =head2 bootstrap
 361
 362  Title   : bootstrap
 363  Usage   : $obj->bootstrap($newval)
 364  Function: Get/Set the bootstrap value
 365  Returns : value of bootstrap
 366  Args    : newvalue (optional)
 367
 368
 369 =head2 description
 370
 371  Title   : description
 372  Usage   : $obj->description($newval)
 373  Function: Get/Set the description string
 374  Returns : value of description
 375  Args    : newvalue (optional)
 376
 377
 378 =head2 id
 379
 380  Title   : id
 381  Usage   : $obj->id($newval)
 382  Function: The human readable identifier for the node
 383  Returns : value of human readable id
 384  Args    : newvalue (optional)
 385  Note    : id cannot contain the chracters '();:'
 386
 387 "A name can be any string of printable characters except blanks,
 388 colons, semicolons, parentheses, and square brackets. Because you may
 389 want to include a blank in a name, it is assumed that an underscore
 390 character ("_") stands for a blank; any of these in a name will be
 391 converted to a blank when it is read in."
 392
 393 from L<http://evolution.genetics.washington.edu/phylip/newicktree.html>
 394
 395 =cut
 396
 397 =head2 internal_id
 398
 399  Title   : internal_id
 400  Usage   : my $internalid = $node->internal_id
 401  Function: Returns the internal unique id for this Node
 402            (a monotonically increasing number for this in-memory implementation
 403             but could be a database determined unique id in other
 404             implementations)
 405  Returns : unique id
 406  Args    : none
 407
 408
 409 =head2 Bio::Node::NodeI decorated interface implemented
 410
 411 The following methods are implemented by L<Bio::Node::NodeI> decorated
 412 interface.
 413
 414 =head2 is_Leaf
 415
 416  Title   : is_Leaf
 417  Usage   : if( $node->is_Leaf )
 418  Function: Get Leaf status
 419  Returns : boolean
 420  Args    : none
 421
 422 =cut
 423
 424 =head2 to_string
 425
 426  Title   : to_string
 427  Usage   : my $str = $node->to_string()
 428  Function: For debugging, provide a node as a string
 429  Returns : string
 430  Args    : none
 431
 432 =head2 height
 433
 434  Title   : height
 435  Usage   : my $len = $node->height
 436  Function: Returns the height of the tree starting at this
 437            node.  Height is the maximum branchlength.
 438  Returns : The longest length (weighting branches with branch_length) to a leaf
 439  Args    : none
 440
 441 =head2 invalidate_height
 442
 443  Title   : invalidate_height
 444  Usage   : private helper method
 445  Function: Invalidate our cached value of the node's height in the tree
 446  Returns : nothing
 447  Args    : none
 448
 449 =cut
 450
 451 #'
 452
 453 =head2 add_tag_value
 454
 455  Title   : add_tag_value
 456  Usage   : $node->add_tag_value($tag,$value)
 457  Function: Adds a tag value to a node
 458  Returns : number of values stored for this tag
 459  Args    : $tag   - tag name
 460            $value - value to store for the tag
 461
 462
 463 =head2 remove_tag
 464
 465  Title   : remove_tag
 466  Usage   : $node->remove_tag($tag)
 467  Function: Remove the tag and all values for this tag
 468  Returns : boolean representing success (0 if tag does not exist)
 469  Args    : $tag - tagname to remove
 470
 471
 472
 473 =head2 remove_all_tags
 474
 475  Title   : remove_all_tags
 476  Usage   : $node->remove_all_tags()
 477  Function: Removes all tags
 478  Returns : None
 479  Args    : None
 480
 481
 482
 483 =head2 get_all_tags
 484
 485  Title   : get_all_tags
 486  Usage   : my @tags = $node->get_all_tags()
 487  Function: Gets all the tag names for this Node
 488  Returns : Array of tagnames
 489  Args    : None
 490
 491
 492 =head2 get_tag_values
 493
 494  Title   : get_tag_values
 495  Usage   : my @values = $node->get_tag_value($tag)
 496  Function: Gets the values for given tag ($tag)
 497  Returns : Array of values or empty list if tag does not exist
 498  Args    : $tag - tag name
 499
 500
 501 =head2 has_tag
 502
 503  Title   : has_tag
 504  Usage   : $node->has_tag($tag)
 505  Function: Boolean test if tag exists in the Node
 506  Returns : Boolean
 507  Args    : $tag - tagname
 508
 509
 510 =cut
 511
 512
 513 1;