Bio/Taxon.pm

   1 #
   2 # BioPerl module for Bio::Taxon
   3 #
   4 # Please direct questions and support issues to <bioperl-l@bioperl.org>
   5 #
   6 # Cared for by Sendu Bala <bix@sendu.me.uk>
   7 #
   8 # Copyright Sendu Bala, based heavily on a module by Jason Stajich
   9 #
  10 # You may distribute this module under the same terms as perl itself
  11
  12 # POD documentation - main docs before the code
  13
  14 =head1 NAME
  15
  16 Bio::Taxon - A node in a represented taxonomy
  17
  18 =head1 SYNOPSIS
  19
  20   use Bio::Taxon;
  21
  22   # Typically you will get a Taxon from a Bio::DB::Taxonomy object
  23   # but here is how you initialize one
  24   my $taxon = Bio::Taxon->new(-name      => $name,
  25                               -id        => $id,
  26                               -rank      => $rank,
  27                               -division  => $div);
  28
  29   # Get one from a database
  30   my $dbh = Bio::DB::Taxonomy->new(-source   => 'flatfile',
  31                                    -directory=> '/tmp',
  32                                    -nodesfile=> '/path/to/nodes.dmp',
  33                                    -namesfile=> '/path/to/names.dmp');
  34   my $human = $dbh->get_taxon(-name => 'Homo sapiens');
  35   $human = $dbh->get_taxon(-taxonid => '9606');
  36
  37   print "id is ", $human->id, "\n"; # 9606
  38   print "rank is ", $human->rank, "\n"; # species
  39   print "scientific name is ", $human->scientific_name, "\n"; # Homo sapiens
  40   print "division is ", $human->division, "\n"; # Primates
  41
  42   my $mouse = $dbh->get_taxon(-name => 'Mus musculus');
  43
  44   # You can quickly make your own lineages with the list database
  45   my @ranks = qw(superkingdom class genus species);
  46   my @h_lineage = ('Eukaryota', 'Mammalia', 'Homo', 'Homo sapiens');
  47   my $list_dbh = Bio::DB::Taxonomy->new(-source => 'list', -names => \@h_lineage,
  48                                                            -ranks => \@ranks);
  49   $human = $list_dbh->get_taxon(-name => 'Homo sapiens');
  50   my @names = $human->common_names; # @names is empty
  51   $human->common_names('woman');
  52   @names = $human->common_names; # @names contains woman
  53
  54   # You can switch to another database when you need more information
  55   my $entrez_dbh = Bio::DB::Taxonomy->new(-source => 'entrez');
  56   $human->db_handle($entrez_dbh);
  57   @names = $human->common_names; # @names contains woman, human, man
  58
  59   # Since Bio::Taxon implements Bio::Tree::NodeI, we have access to those
  60   # methods (and can manually create our own taxa and taxonomy without the use
  61   # of any database)
  62   my $homo = $human->ancestor;
  63
  64   # Though be careful with each_Descendent - unless you add_Descendent()
  65   # yourself, you won't get an answer because unlike for ancestor(), Bio::Taxon
  66   # does not ask the database for the answer. You can ask the database yourself
  67   # using the same method:
  68   ($human) = $homo->db_handle->each_Descendent($homo);
  69
  70   # We can also take advantage of Bio::Tree::Tree* methods:
  71   # a) some methods are available with just an empty tree object
  72   use Bio::Tree::Tree;
  73   my $tree_functions = Bio::Tree::Tree->new();
  74   my @lineage = $tree_functions->get_lineage_nodes($human);
  75   my $lineage = $tree_functions->get_lineage_string($human);
  76   my $lca = $tree_functions->get_lca($human, $mouse);
  77
  78   # b) for other methods, create a tree using your Taxon object
  79   my $tree = Bio::Tree::Tree->new(-node => $human);
  80   my @taxa = $tree->get_nodes;
  81   $homo = $tree->find_node(-rank => 'genus');
  82
  83   # Normally you can't get the lca of a list-database derived Taxon and an
  84   # entrez or flatfile-derived one because the two different databases might
  85   # have different roots and different numbers of ranks between the root and the
  86   # taxa of interest. To solve this, make a tree of the Taxon with the more
  87   # detailed lineage and splice out all the taxa that won't be in the lineage of
  88   # your other Taxon:
  89   my $entrez_mouse = $entrez_dbh->get_taxon(-name => 'Mus musculus');
  90   my $list_human = $list_dbh->get_taxon(-name => 'Homo sapiens');
  91   my $mouse_tree = Bio::Tree::Tree->new(-node => $entrez_mouse);
  92   $mouse_tree->splice(-keep_rank => \@ranks);
  93   $lca = $mouse_tree->get_lca($entrez_mouse, $list_human);
  94
  95 =head1 DESCRIPTION
  96
  97 This is the next generation (for Bioperl) of representing Taxonomy
  98 information. Previously all information was managed by a single
  99 object called Bio::Species. This new implementation allows
 100 representation of the intermediate nodes not just the species nodes
 101 and can relate their connections.
 102
 103 =head1 FEEDBACK
 104
 105 =head2 Mailing Lists
 106
 107 User feedback is an integral part of the evolution of this and other
 108 Bioperl modules. Send your comments and suggestions preferably to
 109 the Bioperl mailing list.  Your participation is much appreciated.
 110
 111   bioperl-l@bioperl.org                  - General discussion
 112   http://bioperl.org/wiki/Mailing_lists  - About the mailing lists
 113
 114 =head2 Support
 115
 116 Please direct usage questions or support issues to the mailing list:
 117
 118 I<bioperl-l@bioperl.org>
 119
 120 rather than to the module maintainer directly. Many experienced and
 121 reponsive experts will be able look at the problem and quickly
 122 address it. Please include a thorough description of the problem
 123 with code and data examples if at all possible.
 124
 125 =head2 Reporting Bugs
 126
 127 Report bugs to the Bioperl bug tracking system to help us keep track
 128 of the bugs and their resolution. Bug reports can be submitted via
 129 the web:
 130
 131   https://github.com/bioperl/bioperl-live/issues
 132
 133 =head1 AUTHOR - Sendu Bala
 134
 135 Email bix@sendu.me.uk
 136
 137 =head1 CONTRIBUTORS
 138
 139 Jason Stajich,    jason-at-bioperl-dot-org (original Bio::Taxonomy::Node)
 140 Juguang Xiao,     juguang@tll.org.sg
 141 Gabriel Valiente, valiente@lsi.upc.edu
 142
 143 =head1 APPENDIX
 144
 145 The rest of the documentation details each of the object methods.
 146 Internal methods are usually preceded with a _
 147
 148 =cut
 149
 150
 151 package Bio::Taxon;
 152 use strict;
 153 use Scalar::Util qw(blessed);
 154
 155 use Bio::DB::Taxonomy;
 156
 157 use base qw(Bio::Tree::Node Bio::IdentifiableI);
 158
 159
 160 =head2 new
 161
 162  Title   : new
 163  Usage   : my $obj = Bio::Taxonomy::Node->new();
 164  Function: Builds a new Bio::Taxonomy::Node object
 165  Returns : an instance of Bio::Taxonomy::Node
 166  Args    : -dbh               => a reference to a Bio::DB::Taxonomy object
 167                                  [no default]
 168            -name              => a string representing the taxon name
 169                                  (scientific name)
 170            -id                => human readable id - typically NCBI taxid
 171            -ncbi_taxid        => same as -id, but explicitly say that it is an
 172                                  NCBI taxid
 173            -rank              => node rank (one of 'species', 'genus', etc)
 174            -common_names      => array ref of all common names
 175            -division          => 'Primates', 'Rodents', etc
 176            -genetic_code      => genetic code table number
 177            -mito_genetic_code => mitochondrial genetic code table number
 178            -create_date       => date created in database
 179            -update_date       => date last updated in database
 180            -pub_date          => date published in database
 181
 182 =cut
 183
 184 sub new {
 185     my ($class, @args) = @_;
 186     my $self = $class->SUPER::new(@args);
 187     my ($name, $id, $objid, $rank, $div, $dbh, $ncbitaxid, $commonname,
 188         $commonnames, $gcode, $mitocode, $createdate, $updatedate, $pubdate,
 189         $parent_id) = $self->_rearrange([qw(NAME ID OBJECT_ID RANK DIVISION DBH
 190                                             NCBI_TAXID COMMON_NAME COMMON_NAMES
 191                                             GENETIC_CODE MITO_GENETIC_CODE
 192                                             CREATE_DATE UPDATE_DATE PUB_DATE
 193                                             PARENT_ID)], @args);
 194
 195     if (defined $id && (defined $ncbitaxid && $ncbitaxid ne $id || defined $objid && $objid ne $id)) {
 196         $self->warn("Only provide one of -id, -object_id or -ncbi_taxid, using $id\n");
 197     }
 198     elsif(!defined $id) {
 199         $id = $objid || $ncbitaxid;
 200     }
 201     defined $id && $self->id($id);
 202     $self->{_ncbi_tax_id_provided} = 1 if $ncbitaxid;
 203
 204     defined $rank && $self->rank($rank);
 205     defined $name && $self->node_name($name);
 206
 207     my @common_names;
 208     if ($commonnames) {
 209         $self->throw("-common_names takes only an array reference") unless $commonnames
 210             && ref($commonnames) eq 'ARRAY';
 211         @common_names = @{$commonnames};
 212     }
 213     if ($commonname) {
 214         my %c_names = map { $_ => 1 } @common_names;
 215         unless (exists $c_names{$commonname}) {
 216             unshift(@common_names, $commonname);
 217         }
 218     }
 219     @common_names > 0 && $self->common_names(@common_names);
 220
 221     defined $gcode      && $self->genetic_code($gcode);
 222     defined $mitocode   && $self->mitochondrial_genetic_code($mitocode);
 223     defined $createdate && $self->create_date($createdate);
 224     defined $updatedate && $self->update_date($updatedate);
 225     defined $pubdate    && $self->pub_date($pubdate);
 226     defined $div        && $self->division($div);
 227     defined $dbh        && $self->db_handle($dbh);
 228
 229     # Making an administrative decision to override this behavior, particularly
 230     # for optimization reasons (if it works to cache it up front, why not?
 231     # Please trust your implementations to get it right)
 232
 233     # Original note:
 234     # deprecated and will issue a warning when method called,
 235     # eventually to be removed completely as option
 236     defined $parent_id  && $self->parent_id($parent_id);
 237
 238     # some things want to freeze/thaw Bio::Species objects, but
 239     # _root_cleanup_methods contains a CODE ref, delete it.
 240     delete $self->{_root_cleanup_methods};
 241
 242     return $self;
 243 }
 244
 245
 246 =head1 Bio::IdentifiableI interface
 247
 248 Also see L<Bio::IdentifiableI>
 249
 250 =head2 version
 251
 252  Title   : version
 253  Usage   : $taxon->version($newval)
 254  Returns : value of version (a scalar)
 255  Args    : on set, new value (a scalar or undef, optional)
 256
 257 =cut
 258
 259 sub version {
 260     my $self = shift;
 261     return $self->{'version'} = shift if @_;
 262     return $self->{'version'};
 263 }
 264
 265
 266 =head2 authority
 267
 268  Title   : authority
 269  Usage   : $taxon->authority($newval)
 270  Returns : value of authority (a scalar)
 271  Args    : on set, new value (a scalar or undef, optional)
 272
 273 =cut
 274
 275 sub authority {
 276     my $self = shift;
 277     return $self->{'authority'} = shift if @_;
 278     return $self->{'authority'};
 279 }
 280
 281
 282 =head2 namespace
 283
 284  Title   : namespace
 285  Usage   : $taxon->namespace($newval)
 286  Returns : value of namespace (a scalar)
 287  Args    : on set, new value (a scalar or undef, optional)
 288
 289 =cut
 290
 291 sub namespace {
 292     my $self = shift;
 293     return $self->{'namespace'} = shift if @_;
 294     return $self->{'namespace'};
 295 }
 296
 297
 298 =head1 Bio::Taxonomy::Node implementation
 299
 300 =head2 db_handle
 301
 302  Title   : db_handle
 303  Usage   : $taxon->db_handle($newval)
 304  Function: Get/Set Bio::DB::Taxonomy Handle
 305  Returns : value of db_handle (a scalar) (Bio::DB::Taxonomy object)
 306  Args    : on set, new value (a scalar, optional) Bio::DB::Taxonomy object
 307
 308 Also see L<Bio::DB::Taxonomy>
 309
 310 =cut
 311
 312 sub db_handle {
 313     my $self = shift;
 314     if (@_) {
 315         my $db = shift;
 316
 317         if (! ref($db) || ! $db->isa('Bio::DB::Taxonomy')) {
 318             $self->throw("Must provide a valid Bio::DB::Taxonomy object to db_handle()");
 319         }
 320         if (!$self->{'db_handle'} || ($self->{'db_handle'} && $self->{'db_handle'} ne $db)) {
 321             my $new_self = $self->_get_similar_taxon_from_db($self, $db);
 322             $self->_merge_taxa($new_self) if $new_self;
 323         }
 324
 325         # NB: The Bio::DB::Taxonomy modules access this data member directly
 326         # to avoid calling this method and going infinite
 327         $self->{'db_handle'} = $db;
 328     }
 329     return $self->{'db_handle'};
 330 }
 331
 332
 333 =head2 rank
 334
 335  Title   : rank
 336  Usage   : $taxon->rank($newval)
 337  Function: Get/set rank of this Taxon, 'species', 'genus', 'order', etc...
 338  Returns : value of rank (a scalar)
 339  Args    : on set, new value (a scalar or undef, optional)
 340
 341 =cut
 342
 343 sub rank {
 344     my $self = shift;
 345     return $self->{'rank'} = shift if @_;
 346     return $self->{'rank'};
 347 }
 348
 349
 350 =head2 id
 351
 352  Title   : id
 353  Usage   : $taxon->id($newval)
 354  Function: Get/Set id (NCBI Taxonomy ID in most cases); object_id() and
 355            ncbi_taxid() are synonyms of this method.
 356  Returns : id (a scalar)
 357  Args    : none to get, OR scalar to set
 358
 359 =cut
 360
 361 sub id {
 362     my $self = shift;
 363     return $self->SUPER::id(@_);
 364 }
 365
 366 *object_id = \&id;
 367
 368
 369 =head2 ncbi_taxid
 370
 371  Title   : ncbi_taxid
 372  Usage   : $taxon->ncbi_taxid($newval)
 373  Function: Get/Set the NCBI Taxonomy ID; This actually sets the id() but only
 374            returns an id when ncbi_taxid has been explictely set with this
 375            method.
 376  Returns : id (a scalar)
 377  Args    : none to get, OR scalar to set
 378
 379 =cut
 380
 381 sub ncbi_taxid {
 382     my ($self, $id) = @_;
 383
 384     if ($id) {
 385         $self->{_ncbi_tax_id_provided} = 1;
 386         return $self->SUPER::id($id);
 387     }
 388
 389     if ($self->{_ncbi_tax_id_provided}) {
 390         return $self->SUPER::id;
 391     }
 392     return;
 393 }
 394
 395
 396 =head2 parent_id
 397
 398  Title   : parent_id
 399  Usage   : $taxon->parent_id()
 400  Function: Get parent ID, (NCBI Taxonomy ID in most cases);
 401            parent_taxon_id() is a synonym of this method.
 402  Returns : value of parent_id (a scalar)
 403  Args    : none
 404
 405 =cut
 406
 407 sub parent_id {
 408     my $self = shift;
 409     if (@_) {
 410         $self->{parent_id} = shift;
 411     }
 412     if (defined $self->{parent_id}) {
 413         return $self->{parent_id}
 414     }
 415     my $ancestor = $self->ancestor() || return;
 416     return $ancestor->id;
 417 }
 418
 419 *parent_taxon_id = \&parent_id;
 420
 421 =head2 trusted_parent_id
 422
 423  Title   : trusted_parent_id
 424  Usage   : $taxon->trusted_parent_id()
 425  Function: If the parent_id is explicitly set, trust it
 426  Returns : simple boolean value (whether or not it has been set)
 427  Args    : none
 428
 429 =cut
 430
 431 sub trusted_parent_id {
 432     return defined $_[0]->{parent_id};
 433 }
 434
 435 =head2 genetic_code
 436
 437  Title   : genetic_code
 438  Usage   : $taxon->genetic_code($newval)
 439  Function: Get/set genetic code table
 440  Returns : value of genetic_code (a scalar)
 441  Args    : on set, new value (a scalar or undef, optional)
 442
 443 =cut
 444
 445 sub genetic_code {
 446     my $self = shift;
 447     return $self->{'genetic_code'} = shift if @_;
 448     return $self->{'genetic_code'};
 449 }
 450
 451
 452 =head2 mitochondrial_genetic_code
 453
 454  Title   : mitochondrial_genetic_code
 455  Usage   : $taxon->mitochondrial_genetic_code($newval)
 456  Function: Get/set mitochondrial genetic code table
 457  Returns : value of mitochondrial_genetic_code (a scalar)
 458  Args    : on set, new value (a scalar or undef, optional)
 459
 460 =cut
 461
 462 sub mitochondrial_genetic_code {
 463     my $self = shift;
 464     return $self->{'mitochondrial_genetic_code'} = shift if @_;
 465     return $self->{'mitochondrial_genetic_code'};
 466 }
 467
 468
 469 =head2 create_date
 470
 471  Title   : create_date
 472  Usage   : $taxon->create_date($newval)
 473  Function: Get/Set Date this node was created (in the database)
 474  Returns : value of create_date (a scalar)
 475  Args    : on set, new value (a scalar or undef, optional)
 476
 477 =cut
 478
 479 sub create_date {
 480     my $self = shift;
 481     return $self->{'create_date'} = shift if @_;
 482     return $self->{'create_date'};
 483 }
 484
 485
 486 =head2 update_date
 487
 488  Title   : update_date
 489  Usage   : $taxon->update_date($newval)
 490  Function: Get/Set Date this node was updated (in the database)
 491  Returns : value of update_date (a scalar)
 492  Args    : on set, new value (a scalar or undef, optional)
 493
 494 =cut
 495
 496 sub update_date {
 497     my $self = shift;
 498     return $self->{'update_date'} = shift if @_;
 499     return $self->{'update_date'};
 500 }
 501
 502
 503 =head2 pub_date
 504
 505  Title   : pub_date
 506  Usage   : $taxon->pub_date($newval)
 507  Function: Get/Set Date this node was published (in the database)
 508  Returns : value of pub_date (a scalar)
 509  Args    : on set, new value (a scalar or undef, optional)
 510
 511 =cut
 512
 513 sub pub_date {
 514     my $self = shift;
 515     return $self->{'pub_date'} = shift if @_;
 516     return $self->{'pub_date'};
 517 }
 518
 519
 520 =head2 ancestor
 521
 522  Title   : ancestor
 523  Usage   : my $ancestor_taxon = $taxon->ancestor()
 524  Function: Retrieve the ancestor taxon. Normally the database is asked what the
 525            ancestor is.
 526
 527            If you manually set the ancestor (or you make a Bio::Tree::Tree with
 528            this object as an argument to new()), the database (if any) will not
 529            be used for the purposes of this method.
 530
 531            To restore normal database behaviour, call ancestor(undef) (which
 532            would remove this object from the tree), or request this taxon again
 533            as a new Taxon object from the database.
 534
 535  Returns : Bio::Taxon
 536  Args    : none
 537
 538 =cut
 539
 540 sub ancestor {
 541     my $self = shift;
 542     my $ancestor = $self->SUPER::ancestor(@_);
 543     if ($ancestor) {
 544         return $ancestor;
 545     }
 546     my $dbh = $self->db_handle;
 547     #*** could avoid the db lookup if we knew our current id was definitely
 548     #    information from the db...
 549
 550     # TODO: you must trust your implementation to get it right.
 551     # If there is a parent_id set, trust it. If not, fall back to calling this
 552     # method
 553     my $definitely_from_dbh = $self->_get_similar_taxon_from_db($self);
 554     return $dbh->ancestor($definitely_from_dbh);
 555 }
 556
 557
 558 =head2 get_Parent_Node
 559
 560  Title   : get_Parent_Node
 561  Function: Synonym of ancestor()
 562  Status  : deprecated
 563
 564 =cut
 565
 566 sub get_Parent_Node {
 567     my $self = shift;
 568     $self->warn("get_Parent_Node is deprecated, use ancestor() instead");
 569     return $self->ancestor(@_);
 570 }
 571
 572
 573 =head2 each_Descendent
 574
 575  Title   : each_Descendent
 576  Usage   : my @taxa = $taxon->each_Descendent();
 577  Function: Get all the descendents for this Taxon (but not their descendents,
 578            ie. not a recursive fetchall). get_Children_Nodes() is a synonym of
 579            this method.
 580
 581            Note that this method never asks the database for the descendents;
 582            it will only return objects you have manually set with
 583            add_Descendent(), or where this was done for you by making a
 584            Bio::Tree::Tree with this object as an argument to new().
 585
 586            To get the database descendents use
 587            $taxon->db_handle->each_Descendent($taxon).
 588
 589  Returns : Array of Bio::Taxon objects
 590  Args    : optionally, when you have set your own descendents, the string
 591            "height", "creation", "alpha", "revalpha", or coderef to be used to
 592            sort the order of children nodes.
 593
 594 =cut
 595
 596
 597 # implemented by Bio::Tree::Node
 598
 599 =head2 get_Children_Nodes
 600
 601  Title   : get_Children_Nodes
 602  Function: Synonym of each_Descendent()
 603  Status  : deprecated
 604
 605 =cut
 606
 607 sub get_Children_Nodes {
 608     my $self = shift;
 609     $self->warn("get_Children_Nodes is deprecated, use each_Descendent() instead");
 610     return $self->each_Descendent(@_);
 611 }
 612
 613
 614 =head2 name
 615
 616   Title:    name
 617   Usage:    $taxon->name('scientific', 'Homo sapiens');
 618             $taxon->name('common', 'human', 'man');
 619             my @names = @{$taxon->name('common')};
 620   Function: Get/set the names. node_name(), scientific_name() and common_names()
 621             are shorthands to name('scientific'), name('scientific') and
 622             name('common') respectively.
 623   Returns:  names (a array reference)
 624   Args:     Arg1 => the name_class. You can assign any text, but the words
 625                 'scientific' and 'common' have the special meaning, as
 626                 scientific name and common name, respectively. 'scientific' and
 627                 'division' are treated specially, allowing only the first value
 628                 in the Arg2 list to be set.
 629             Arg2 ... => list of names
 630
 631 =cut
 632
 633 sub name {
 634     my ($self, $name_class, @names) = @_;
 635     $self->throw('No name class specified') unless defined $name_class;
 636
 637     if (@names) {
 638         if ($name_class =~ /scientific|division/i) {
 639             delete $self->{'_names_hash'}->{$name_class};
 640             @names = (shift(@names));
 641         }
 642         push @{$self->{'_names_hash'}->{$name_class}}, @names;
 643     }
 644     return $self->{'_names_hash'}->{$name_class} || return;
 645 }
 646
 647
 648 =head2 node_name
 649
 650  Title   : node_name
 651  Usage   : $taxon->node_name($newval)
 652  Function: Get/set the name of this taxon (node), typically the scientific name
 653            of the taxon, eg. 'Primate' or 'Homo'; scientific_name() is a synonym
 654            of this method.
 655  Returns : value of node_name (a scalar)
 656  Args    : on set, new value (a scalar or undef, optional)
 657
 658 =cut
 659
 660 sub node_name {
 661     my $self = shift;
 662     my @v = @{$self->name('scientific', @_) || []};
 663     return pop @v;
 664 }
 665
 666 *scientific_name = \&node_name;
 667
 668
 669 =head2 common_names
 670
 671  Title   : common_names
 672  Usage   : $taxon->common_names($newval)
 673  Function: Get/add the other names of this taxon, typically the genbank common
 674            name and others, eg. 'Human' and 'man'. common_name() is a synonym
 675            of this method.
 676  Returns : array of names in list context, one of those names in scalar context
 677  Args    : on add, new list of names (scalars, optional)
 678
 679 =cut
 680
 681 sub common_names {
 682     my $self = shift;
 683     my @v = @{$self->name('common', @_) || []};
 684     return ( wantarray ) ? @v : pop @v;
 685 }
 686
 687 *common_name = \&common_names;
 688
 689
 690 =head2 division
 691
 692  Title   : division
 693  Usage   : $taxon->division($newval)
 694  Function: Get/set the division this taxon belongs to, eg. 'Primates' or
 695            'Bacteria'.
 696  Returns : value of division (a scalar)
 697  Args    : on set, new value (a scalar or undef, optional)
 698
 699 =cut
 700
 701 sub division {
 702     my $self = shift;
 703     my @v = @{$self->name('division',@_) || []};
 704     return pop @v;
 705 }
 706
 707
 708 # get a node from the database that is like the supplied node
 709 sub _get_similar_taxon_from_db {
 710     #*** not really happy with this having to be called so much; there must be
 711     #    a better way...
 712     my ($self, $taxon, $db) = @_;
 713     $self->throw("Must supply a Bio::Taxon") unless ref($taxon) && $taxon->isa("Bio::Taxon");
 714     ($self->id || $self->node_name) || return;
 715     $db ||= $self->db_handle || return;
 716     if (!blessed($db) || !$db->isa('Bio::DB::Taxonomy')) {
 717         $self->throw("DB handle is not a Bio::DB::Taxonomy: got $db in node ".$self->node_name)
 718     }
 719     my $db_taxon = $db->get_taxon(-taxonid => $taxon->id) if $taxon->id;
 720     unless ($db_taxon) {
 721         my @try_ids = $db->get_taxonids($taxon->node_name) if $taxon->node_name;
 722
 723         my $own_rank = $taxon->rank || 'no rank';
 724         foreach my $try_id (@try_ids) {
 725             my $try = $db->get_taxon(-taxonid => $try_id);
 726             my $try_rank = $try->rank || 'no rank';
 727             if ($own_rank eq 'no rank' || $try_rank eq 'no rank' || $own_rank eq $try_rank) {
 728                 $db_taxon = $try;
 729                 last;
 730             }
 731         }
 732     }
 733
 734     return $db_taxon;
 735 }
 736
 737
 738 # merge data from supplied Taxon into self
 739 sub _merge_taxa {
 740     my ($self, $taxon) = @_;
 741     $self->throw("Must supply a Bio::Taxon object") unless ref($taxon) && $taxon->isa('Bio::Taxon');
 742     return if ($taxon eq $self);
 743
 744     foreach my $attrib (qw(scientific_name version authority namespace genetic_code mitochondrial_genetic_code create_date update_date pub_date division id)) {
 745         my $own = $self->$attrib();
 746         my $his = $taxon->$attrib();
 747         if (!$own && $his) {
 748             $self->$attrib($his);
 749         }
 750     }
 751
 752     my $own = $self->rank || 'no rank';
 753     my $his = $taxon->rank || 'no rank';
 754     if ($own eq 'no rank' && $his ne 'no rank') {
 755         $self->rank($his);
 756     }
 757
 758     my %own_cnames = map { $_ => 1 } $self->common_names;
 759     my %his_cnames = map { $_ => 1 } $taxon->common_names;
 760     foreach (keys %his_cnames) {
 761         unless (exists $own_cnames{$_}) {
 762             $self->common_names($_);
 763         }
 764     }
 765
 766     #*** haven't merged the other things in names() hash, could do above much easier with direct access to object data
 767 }
 768
 769
 770 =head2 remove_Descendent
 771
 772  Title   : remove_Descendent
 773  Usage   : $node->remove_Descedent($node_foo);
 774  Function: Removes a specific node from being a Descendent of this node
 775  Returns : nothing
 776  Args    : An array of Bio::Node::NodeI objects which have been previously
 777            passed to the add_Descendent call of this object.
 778
 779 =cut
 780
 781 sub remove_Descendent {
 782     # need to override this method from Bio::Tree::Node since it casually
 783     # throws away nodes if they don't branch
 784     my ($self,@nodes) = @_;
 785     my $c= 0;
 786     foreach my $n ( @nodes ) {
 787         if ($self->{'_desc'}->{$n->internal_id}) {
 788             $self->{_removing_descendent} = 1;
 789             $n->ancestor(undef);
 790             $self->{_removing_descendent} = 0;
 791             $self->{'_desc'}->{$n->internal_id}->ancestor(undef);
 792             delete $self->{'_desc'}->{$n->internal_id};
 793             $c++;
 794         }
 795     }
 796     return $c;
 797 }
 798
 799
 800 1;