File Coverage

Bio/Taxon.pm
Criterion Covered Total %
statement 147 178 82.5
branch 72 114 63.1
condition 29 62 46.7
subroutine 25 29 86.2
pod 23 23 100.0
total 296 406 72.9


line stmt bran cond sub pod time code
1             #
2             # BioPerl module for Bio::Taxon
3             #
4             # Please direct questions and support issues to
5             #
6             # Cared for by Sendu Bala
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
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 44     44   151 use strict;
  44         58  
  44         1284  
153 44     44   156 use Scalar::Util qw(blessed);
  44         61  
  44         2111  
154              
155 44     44   170 use Bio::DB::Taxonomy;
  44         52  
  44         943  
156              
157 44     44   141 use base qw(Bio::Tree::Node Bio::IdentifiableI);
  44         57  
  44         15801  
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 7122     7122 1 10719 my ($class, @args) = @_;
186 7122         12654 my $self = $class->SUPER::new(@args);
187 7122         25049 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 7122 50 0     33194 if (defined $id && (defined $ncbitaxid && $ncbitaxid ne $id || defined $objid && $objid ne $id)) {
    50 33        
196 0         0 $self->warn("Only provide one of -id, -object_id or -ncbi_taxid, using $id\n");
197             }
198             elsif(!defined $id) {
199 7122   100     12382 $id = $objid || $ncbitaxid;
200             }
201 7122 100       16239 defined $id && $self->id($id);
202 7122 100       10516 $self->{_ncbi_tax_id_provided} = 1 if $ncbitaxid;
203            
204 7122 50       9831 defined $rank && $self->rank($rank);
205 7122 100       14683 defined $name && $self->node_name($name);
206            
207 7122         5769 my @common_names;
208 7122 50       10175 if ($commonnames) {
209 0 0 0     0 $self->throw("-common_names takes only an array reference") unless $commonnames
210             && ref($commonnames) eq 'ARRAY';
211 0         0 @common_names = @{$commonnames};
  0         0  
212             }
213 7122 100       9408 if ($commonname) {
214 2         4 my %c_names = map { $_ => 1 } @common_names;
  0         0  
215 2 50       5 unless (exists $c_names{$commonname}) {
216 2         4 unshift(@common_names, $commonname);
217             }
218             }
219 7122 100       10679 @common_names > 0 && $self->common_names(@common_names);
220            
221 7122 50       9650 defined $gcode && $self->genetic_code($gcode);
222 7122 50       9636 defined $mitocode && $self->mitochondrial_genetic_code($mitocode);
223 7122 50       8817 defined $createdate && $self->create_date($createdate);
224 7122 50       10089 defined $updatedate && $self->update_date($updatedate);
225 7122 50       8830 defined $pubdate && $self->pub_date($pubdate);
226 7122 50       8626 defined $div && $self->division($div);
227 7122 50       8722 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 7122 50       8246 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 7122         9788 delete $self->{_root_cleanup_methods};
241            
242 7122         15591 return $self;
243             }
244              
245              
246             =head1 Bio::IdentifiableI interface
247              
248             Also see L
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 500     500 1 750 my $self = shift;
261 500 50       898 return $self->{'version'} = shift if @_;
262 500         647 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 500     500 1 454 my $self = shift;
277 500 50       832 return $self->{'authority'} = shift if @_;
278 500         575 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 500     500 1 440 my $self = shift;
293 500 50       767 return $self->{'namespace'} = shift if @_;
294 500         516 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
309              
310             =cut
311              
312             sub db_handle {
313 26413     26413 1 19237 my $self = shift;
314 26413 100       33878 if (@_) {
315 250         299 my $db = shift;
316            
317 250 50 33     1541 if (! ref($db) || ! $db->isa('Bio::DB::Taxonomy')) {
318 0         0 $self->throw("Must provide a valid Bio::DB::Taxonomy object to db_handle()");
319             }
320 250 50 33     827 if (!$self->{'db_handle'} || ($self->{'db_handle'} && $self->{'db_handle'} ne $db)) {
      66        
321 250         827 my $new_self = $self->_get_similar_taxon_from_db($self, $db);
322 250 50       909 $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 250         372 $self->{'db_handle'} = $db;
328             }
329 26413         55100 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 9348     9348 1 7400 my $self = shift;
345 9348 100       13751 return $self->{'rank'} = shift if @_;
346 9047         27303 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 32928     32928 1 24610 my $self = shift;
363 32928         48553 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 363     363 1 632 my ($self, $id) = @_;
383            
384 363 100       715 if ($id) {
385 190         401 $self->{_ncbi_tax_id_provided} = 1;
386 190         623 return $self->SUPER::id($id);
387             }
388            
389 173 100       394 if ($self->{_ncbi_tax_id_provided}) {
390 57         160 return $self->SUPER::id;
391             }
392 116         458 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 2     2 1 3 my $self = shift;
409 2 50       6 if (@_) {
410 0         0 $self->{parent_id} = shift;
411             }
412 2 50       4 if (defined $self->{parent_id}) {
413             return $self->{parent_id}
414 0         0 }
415 2   50     4 my $ancestor = $self->ancestor() || return;
416 2         4 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             Notes : Previously, the parent_id method was to be deprecated in favor of
429             using ancestor(). However this removes one key optimization point,
430             namely when an implementation has direct access to the taxon's
431             parent ID when retrieving the information for the taxon ID. This
432             method is in place so implementations can choose to (1) check whether
433             the parent_id is set and (2) trust that the implementation (whether
434             it is self or another implementation) set the parent_id correctly.
435              
436             =cut
437              
438             sub trusted_parent_id {
439 0     0 1 0 return defined $_[0]->{parent_id};
440             }
441              
442             =head2 genetic_code
443              
444             Title : genetic_code
445             Usage : $taxon->genetic_code($newval)
446             Function: Get/set genetic code table
447             Returns : value of genetic_code (a scalar)
448             Args : on set, new value (a scalar or undef, optional)
449              
450             =cut
451              
452             sub genetic_code {
453 502     502 1 497 my $self = shift;
454 502 50       800 return $self->{'genetic_code'} = shift if @_;
455 502         588 return $self->{'genetic_code'};
456             }
457              
458              
459             =head2 mitochondrial_genetic_code
460              
461             Title : mitochondrial_genetic_code
462             Usage : $taxon->mitochondrial_genetic_code($newval)
463             Function: Get/set mitochondrial genetic code table
464             Returns : value of mitochondrial_genetic_code (a scalar)
465             Args : on set, new value (a scalar or undef, optional)
466              
467             =cut
468              
469             sub mitochondrial_genetic_code {
470 502     502 1 480 my $self = shift;
471 502 50       815 return $self->{'mitochondrial_genetic_code'} = shift if @_;
472 502         509 return $self->{'mitochondrial_genetic_code'};
473             }
474              
475              
476             =head2 create_date
477              
478             Title : create_date
479             Usage : $taxon->create_date($newval)
480             Function: Get/Set Date this node was created (in the database)
481             Returns : value of create_date (a scalar)
482             Args : on set, new value (a scalar or undef, optional)
483              
484             =cut
485              
486             sub create_date {
487 500     500 1 474 my $self = shift;
488 500 50       1001 return $self->{'create_date'} = shift if @_;
489 500         541 return $self->{'create_date'};
490             }
491              
492              
493             =head2 update_date
494              
495             Title : update_date
496             Usage : $taxon->update_date($newval)
497             Function: Get/Set Date this node was updated (in the database)
498             Returns : value of update_date (a scalar)
499             Args : on set, new value (a scalar or undef, optional)
500              
501             =cut
502              
503             sub update_date {
504 500     500 1 544 my $self = shift;
505 500 50       839 return $self->{'update_date'} = shift if @_;
506 500         532 return $self->{'update_date'};
507             }
508              
509              
510             =head2 pub_date
511              
512             Title : pub_date
513             Usage : $taxon->pub_date($newval)
514             Function: Get/Set Date this node was published (in the database)
515             Returns : value of pub_date (a scalar)
516             Args : on set, new value (a scalar or undef, optional)
517              
518             =cut
519              
520             sub pub_date {
521 500     500 1 434 my $self = shift;
522 500 50       959 return $self->{'pub_date'} = shift if @_;
523 500         578 return $self->{'pub_date'};
524             }
525              
526              
527             =head2 ancestor
528              
529             Title : ancestor
530             Usage : my $ancestor_taxon = $taxon->ancestor()
531             Function: Retrieve the ancestor taxon. Normally the database is asked what the
532             ancestor is.
533              
534             If you manually set the ancestor (or you make a Bio::Tree::Tree with
535             this object as an argument to new()), the database (if any) will not
536             be used for the purposes of this method.
537              
538             To restore normal database behaviour, call ancestor(undef) (which
539             would remove this object from the tree), or request this taxon again
540             as a new Taxon object from the database.
541              
542             Returns : Bio::Taxon
543             Args : none
544              
545             =cut
546              
547             sub ancestor {
548 30024     30024 1 20964 my $self = shift;
549 30024         36434 my $ancestor = $self->SUPER::ancestor(@_);
550 30024 100       37517 if ($ancestor) {
551 25548         40299 return $ancestor;
552             }
553 4476         6417 my $dbh = $self->db_handle;
554             #*** could avoid the db lookup if we knew our current id was definitely
555             # information from the db...
556              
557 4476         6699 my $definitely_from_dbh = $self->_get_similar_taxon_from_db($self);
558 4476         8080 return $dbh->ancestor($definitely_from_dbh);
559             }
560              
561              
562             =head2 get_Parent_Node
563              
564             Title : get_Parent_Node
565             Function: Synonym of ancestor()
566             Status : deprecated
567              
568             =cut
569              
570             sub get_Parent_Node {
571 0     0 1 0 my $self = shift;
572 0         0 $self->warn("get_Parent_Node is deprecated, use ancestor() instead");
573 0         0 return $self->ancestor(@_);
574             }
575              
576              
577             =head2 each_Descendent
578              
579             Title : each_Descendent
580             Usage : my @taxa = $taxon->each_Descendent();
581             Function: Get all the descendents for this Taxon (but not their descendents,
582             ie. not a recursive fetchall). get_Children_Nodes() is a synonym of
583             this method.
584              
585             Note that this method never asks the database for the descendents;
586             it will only return objects you have manually set with
587             add_Descendent(), or where this was done for you by making a
588             Bio::Tree::Tree with this object as an argument to new().
589              
590             To get the database descendents use
591             $taxon->db_handle->each_Descendent($taxon).
592              
593             Returns : Array of Bio::Taxon objects
594             Args : optionally, when you have set your own descendents, the string
595             "height", "creation", "alpha", "revalpha", or coderef to be used to
596             sort the order of children nodes.
597              
598             =cut
599              
600              
601             # implemented by Bio::Tree::Node
602              
603             =head2 get_Children_Nodes
604              
605             Title : get_Children_Nodes
606             Function: Synonym of each_Descendent()
607             Status : deprecated
608              
609             =cut
610              
611             sub get_Children_Nodes {
612 0     0 1 0 my $self = shift;
613 0         0 $self->warn("get_Children_Nodes is deprecated, use each_Descendent() instead");
614 0         0 return $self->each_Descendent(@_);
615             }
616              
617              
618             =head2 name
619              
620             Title: name
621             Usage: $taxon->name('scientific', 'Homo sapiens');
622             $taxon->name('common', 'human', 'man');
623             my @names = @{$taxon->name('common')};
624             Function: Get/set the names. node_name(), scientific_name() and common_names()
625             are shorthands to name('scientific'), name('scientific') and
626             name('common') respectively.
627             Returns: names (a array reference)
628             Args: Arg1 => the name_class. You can assign any text, but the words
629             'scientific' and 'common' have the special meaning, as
630             scientific name and common name, respectively. 'scientific' and
631             'division' are treated specially, allowing only the first value
632             in the Arg2 list to be set.
633             Arg2 ... => list of names
634              
635             =cut
636              
637             sub name {
638 20142     20142 1 22087 my ($self, $name_class, @names) = @_;
639 20142 50       26720 $self->throw('No name class specified') unless defined $name_class;
640            
641 20142 100       27783 if (@names) {
642 7357 100       30645 if ($name_class =~ /scientific|division/i) {
643 7121         8819 delete $self->{'_names_hash'}->{$name_class};
644 7121         10368 @names = (shift(@names));
645             }
646 7357         6676 push @{$self->{'_names_hash'}->{$name_class}}, @names;
  7357         17453  
647             }
648 20142   100     66827 return $self->{'_names_hash'}->{$name_class} || return;
649             }
650              
651              
652             =head2 node_name
653              
654             Title : node_name
655             Usage : $taxon->node_name($newval)
656             Function: Get/set the name of this taxon (node), typically the scientific name
657             of the taxon, eg. 'Primate' or 'Homo'; scientific_name() is a synonym
658             of this method.
659             Returns : value of node_name (a scalar)
660             Args : on set, new value (a scalar or undef, optional)
661              
662             =cut
663              
664             sub node_name {
665 18793     18793 1 14058 my $self = shift;
666 18793 100       12907 my @v = @{$self->name('scientific', @_) || []};
  18793         24012  
667 18793         31000 return pop @v;
668             }
669              
670             *scientific_name = \&node_name;
671              
672              
673             =head2 common_names
674              
675             Title : common_names
676             Usage : $taxon->common_names($newval)
677             Function: Get/add the other names of this taxon, typically the genbank common
678             name and others, eg. 'Human' and 'man'. common_name() is a synonym
679             of this method.
680             Returns : array of names in list context, one of those names in scalar context
681             Args : on add, new list of names (scalars, optional)
682              
683             =cut
684              
685             sub common_names {
686 632     632 1 644 my $self = shift;
687 632 100       591 my @v = @{$self->name('common', @_) || []};
  632         986  
688 632 100       1821 return ( wantarray ) ? @v : pop @v;
689             }
690              
691             *common_name = \&common_names;
692              
693              
694             =head2 division
695              
696             Title : division
697             Usage : $taxon->division($newval)
698             Function: Get/set the division this taxon belongs to, eg. 'Primates' or
699             'Bacteria'.
700             Returns : value of division (a scalar)
701             Args : on set, new value (a scalar or undef, optional)
702              
703             =cut
704              
705             sub division {
706 502     502 1 1295 my $self = shift;
707 502 50       592 my @v = @{$self->name('division',@_) || []};
  502         748  
708 502         690 return pop @v;
709             }
710              
711              
712             # get a node from the database that is like the supplied node
713             sub _get_similar_taxon_from_db {
714             #*** not really happy with this having to be called so much; there must be
715             # a better way...
716 4726     4726   4738 my ($self, $taxon, $db) = @_;
717 4726 50 33     20719 $self->throw("Must supply a Bio::Taxon") unless ref($taxon) && $taxon->isa("Bio::Taxon");
718 4726 50 66     6176 ($self->id || $self->node_name) || return;
719 4726   50     10850 $db ||= $self->db_handle || return;
      66        
720 4726 50 33     21836 if (!blessed($db) || !$db->isa('Bio::DB::Taxonomy')) {
721 0         0 $self->throw("DB handle is not a Bio::DB::Taxonomy: got $db in node ".$self->node_name)
722             }
723 4726 100       6530 my $db_taxon = $db->get_taxon(-taxonid => $taxon->id) if $taxon->id;
724 4726 100       8541 unless ($db_taxon) {
725 250 50       450 my @try_ids = $db->get_taxonids($taxon->node_name) if $taxon->node_name;
726            
727 250   50     549 my $own_rank = $taxon->rank || 'no rank';
728 250         492 foreach my $try_id (@try_ids) {
729 250         939 my $try = $db->get_taxon(-taxonid => $try_id);
730 250   50     537 my $try_rank = $try->rank || 'no rank';
731 250 50 33     1382 if ($own_rank eq 'no rank' || $try_rank eq 'no rank' || $own_rank eq $try_rank) {
      33        
732 250         296 $db_taxon = $try;
733 250         499 last;
734             }
735             }
736             }
737            
738 4726         5339 return $db_taxon;
739             }
740              
741              
742             # merge data from supplied Taxon into self
743             sub _merge_taxa {
744 250     250   359 my ($self, $taxon) = @_;
745 250 50 33     1394 $self->throw("Must supply a Bio::Taxon object") unless ref($taxon) && $taxon->isa('Bio::Taxon');
746 250 50       817 return if ($taxon eq $self);
747            
748 250         568 foreach my $attrib (qw(scientific_name version authority namespace genetic_code mitochondrial_genetic_code create_date update_date pub_date division id)) {
749 2750         5490 my $own = $self->$attrib();
750 2750         3482 my $his = $taxon->$attrib();
751 2750 100 100     8290 if (!$own && $his) {
752 246         484 $self->$attrib($his);
753             }
754             }
755            
756 250   50     573 my $own = $self->rank || 'no rank';
757 250   50     513 my $his = $taxon->rank || 'no rank';
758 250 50 33     828 if ($own eq 'no rank' && $his ne 'no rank') {
759 0         0 $self->rank($his);
760             }
761            
762 250         730 my %own_cnames = map { $_ => 1 } $self->common_names;
  1         3  
763 250         567 my %his_cnames = map { $_ => 1 } $taxon->common_names;
  0         0  
764 250         964 foreach (keys %his_cnames) {
765 0 0         unless (exists $own_cnames{$_}) {
766 0           $self->common_names($_);
767             }
768             }
769            
770             #*** haven't merged the other things in names() hash, could do above much easier with direct access to object data
771             }
772              
773              
774             =head2 remove_Descendent
775              
776             Title : remove_Descendent
777             Usage : $node->remove_Descedent($node_foo);
778             Function: Removes a specific node from being a Descendent of this node
779             Returns : nothing
780             Args : An array of Bio::Node::NodeI objects which have been previously
781             passed to the add_Descendent call of this object.
782              
783             =cut
784              
785             sub remove_Descendent {
786             # need to override this method from Bio::Tree::Node since it casually
787             # throws away nodes if they don't branch
788 0     0 1   my ($self,@nodes) = @_;
789 0           my $c= 0;
790 0           foreach my $n ( @nodes ) {
791 0 0         if ($self->{'_desc'}->{$n->internal_id}) {
792 0           $self->{_removing_descendent} = 1;
793 0           $n->ancestor(undef);
794 0           $self->{_removing_descendent} = 0;
795 0           $self->{'_desc'}->{$n->internal_id}->ancestor(undef);
796 0           delete $self->{'_desc'}->{$n->internal_id};
797 0           $c++;
798             }
799             }
800 0           return $c;
801             }
802              
803              
804             1;