Bio/Taxonomy.pm

   1 # $Id$
   2 #
   3 # BioPerl module for Bio::Taxonomy
   4 #
   5 # Cared for by Juguang Xiao
   6 #
   7 # You may distribute this module under the same terms as perl itself
   8
   9 # POD documentation - main docs before the code
  10
  11 =head1 NAME
  12
  13 Bio::Taxonomy - representing Taxonomy.
  14
  15 =head1 SYNOPSIS
  16
  17   # NB: This module is deprecated. Use Bio::Taxon in combination with
  18   # Bio::Tree::Tree methods instead.
  19
  20   use Bio::Taxonomy;
  21
  22   # CREATION: You can either create an instance by assigning it,
  23   # or fetch it through factory.
  24
  25   # Create the nodes first. See Bio::Taxonomy::Node for details.
  26   my $node_species_sapiens = Bio::Taxonomy::Node->new(
  27       -object_id => 9606, # or -ncbi_taxid. Requird tag
  28       -names => {
  29           'scientific' => ['sapiens'],
  30           'common_name' => ['human']
  31       },
  32       -rank => 'species'  # Required tag
  33   );
  34   my $node_genus_Homo = Bio::Taxonomy::Node->new(
  35       -object_id => 9605,
  36       -names => { 'scientific' => ['Homo'] },
  37       -rank => 'genus'
  38   );
  39   my $node_class_Mammalia = Bio::Taxonomy::Node->new(
  40       -object_id => 40674,
  41       -names => {
  42           'scientific' => ['Mammalia'],
  43           'common' => ['mammals']
  44       },
  45       -rank => 'class'
  46   );
  47   my $taxonomy = Bio::Taxonomy->new;
  48   $taxonomy->add_node($node_class_Mammalia);
  49   $taxonomy->add_node($node_species_sapiens);
  50   $taxonomy->add_node($node_genus_Homo);
  51
  52   # OR you can fetch it through a factory implementing
  53   # Bio::Taxonomy::FactoryI
  54   my $factory;
  55
  56   my $taxonomy = $factory->fetch_by_ncbi_taxid(40674);
  57
  58   # USAGE
  59
  60   # In this case, binomial returns a defined value.
  61   my $binomial = $taxonomy->binomial;
  62
  63   # 'common_names' refers to the lowest-rank node's common names, in
  64   # array.
  65   my @common_names = $taxonomy->common_names;
  66
  67   # 'get_node', will return undef if the rank is no defined in
  68   # taxonomy object.  It will throw error if the rank string is not
  69   # defined, say 'species lah'.
  70   my $node = $taxonomy->get_node('class');
  71   my @nodes = $taxonomy->get_all_nodes;
  72
  73   # Also, you can search for parent and children nodes, if taxonomy
  74   # comes with factory.
  75
  76   my $parent_taxonomy = $taxonomy->get_parent
  77
  78 =head1 DESCRIPTION
  79
  80 Bio::Taxonomy object represents any rank-level in taxonomy system,
  81 rather than Bio::Species which is able to represent only
  82 species-level.
  83
  84 There are two ways to create Taxonomy object, e.g.
  85 1) instantiate an object and assign all nodes on your own code; and
  86 2) fetch an object by factory.
  87
  88 =head2 Creation by instantiation
  89
  90 The abstraction of Taxonomy is actually a hash in data structure
  91 term. The keys of the hash are the rank names, such as 'genus' and
  92 'species', and the values are the instances of Bio::Taxonomy::Node.
  93
  94 =head2 Creation by Factory fetching
  95
  96 NCBI Taxonomy system is well accepted as the standard. The Taxonomy
  97 Factories in bioperl access this system, through HTTP to NCBI Entrez,
  98 dump file, and advanced biosql database.
  99
 100 Bio::Taxonomy::FactoryI defines all methods that all implementations
 101 must obey.
 102
 103 $factory-E<gt>fetch is a general method to fetch Taxonomy by either
 104 NCBI taxid or any types of names.
 105
 106 $factory-E<gt>fetch_parent($taxonomy), returns a Taxonomy that is
 107 one-step higher rank of the taxonomy specified as argument.
 108
 109 $factory-E<gt>fetch_children($taxonomy), reports an array of Taxonomy
 110 those are one-step lower rank of the taxonomy specified as the
 111 argument.
 112
 113 =head2 Usage of Taxonomy object
 114
 115 ##
 116
 117 =head1 FEEDBACK
 118
 119 =head2 Mailing Lists
 120
 121 User feedback is an integral part of the evolution of this and other
 122 Bioperl modules. Send your comments and suggestions preferably to
 123 the Bioperl mailing list.  Your participation is much appreciated.
 124
 125   bioperl-l@bioperl.org                  - General discussion
 126   http://bioperl.org/wiki/Mailing_lists  - About the mailing lists
 127
 128 =head2 Reporting Bugs
 129
 130 Report bugs to the Bioperl bug tracking system to help us keep track
 131 of the bugs and their resolution. Bug reports can be submitted via the
 132 web:
 133
 134   http://bugzilla.open-bio.org/
 135
 136 =head1 CONTACT
 137
 138 Juguang Xiao, juguang@tll.org.sg
 139
 140 =head1 APPENDIX
 141
 142 The rest of the documentation details each of the object
 143 methods. Internal methods are usually preceded with a _
 144
 145 =cut
 146
 147
 148 # code begins...
 149
 150
 151 package Bio::Taxonomy;
 152 use strict;
 153
 154
 155 use base qw(Bio::Root::Root);
 156
 157
 158 =head2 new
 159
 160  Title   : new
 161  Usage   : my $obj = Bio::Taxonomy->new();
 162  Function: Builds a new Bio::Taxonomy object
 163  Returns : Bio::Taxonomy
 164  Args    : -method  -> method used to decide classification
 165                        (none|trust|lookup)
 166            -ranks   -> what ranks are there
 167
 168 =cut
 169
 170
 171 sub new {
 172    my ($class,@args) = @_;
 173
 174    my $self = $class->SUPER::new(@args);
 175    $self->warn("Bio::Taxonomy is deprecated. Use Bio::Taxon in combination with Bio::Tree::Tree instead.");
 176
 177    $self->{'_method'}='none';
 178    $self->{'_ranks'}=[];
 179    $self->{'_rank_hash'}={};
 180     $self->{_hierarchy} = {}; # used to store the nodes, with ranks as keys.
 181    my ($method,$ranks,$order) = $self->_rearrange([qw(METHOD RANKS ORDER)], @args);
 182
 183    if ($method) {
 184       $self->method($method);
 185    }
 186
 187    if (defined $ranks &&
 188       (ref($ranks) eq "ARRAY") ) {
 189       $self->ranks(@$ranks);
 190    } else {
 191       # default ranks
 192       # I think these are in the right order, but not sure:
 193       # some parvorder|suborder and varietas|subspecies seem
 194       # to be at the same level - any taxonomists?
 195       # I don't expect that these will actually be used except as a way
 196       # to find what ranks there are in taxonomic use
 197       $self->ranks(('root',
 198         'superkingdom', 'kingdom',
 199         'superphylum', 'phylum', 'subphylum',
 200         'superclass', 'class', 'subclass', 'infraclass',
 201         'superorder', 'order', 'suborder', 'parvorder', 'infraorder',
 202         'superfamily', 'family', 'subfamily',
 203         'tribe', 'subtribe',
 204         'genus', 'subgenus',
 205         'species group', 'species subgroup', 'species', 'subspecies',
 206         'varietas', 'forma', 'no rank'));
 207    }
 208
 209    return $self;
 210 }
 211
 212
 213 =head2 method
 214
 215  Title   : method
 216  Usage   : $obj = taxonomy->method($method);
 217  Function: set or return the method used to decide classification
 218  Returns : $obj
 219  Args    : $obj
 220
 221 =cut
 222
 223
 224 sub method {
 225    my ($self,$value) = @_;
 226    if (defined $value && $value=~/none|trust|lookup/) {
 227        $self->{'_method'} = $value;
 228    }
 229    return $self->{'_method'};
 230 }
 231
 232
 233 =head2 classify
 234
 235  Title   : classify
 236  Usage   : @obj[][0-1] = taxonomy->classify($species);
 237  Function: return a ranked classification
 238  Returns : @obj of taxa and ranks as word pairs separated by "@"
 239  Args    : Bio::Species object
 240
 241 =cut
 242
 243
 244 sub classify {
 245    my ($self,$value) = @_;
 246    my @ranks;
 247
 248    if (! $value->isa('Bio::Species') ) {
 249       $self->throw("Trying to classify $value which is not a Bio::Species object");
 250    }
 251
 252    my @classes=reverse($value->classification);
 253
 254    if ($self->method eq 'none') {
 255       for (my $i=0; $i < @classes-2; $i++) {
 256          ($ranks[$i][0],$ranks[$i][1])=($classes[$i],'no rank');
 257       }
 258       push @ranks,[$classes[-2],'genus'];
 259       push @ranks,[$value->binomial,'species'];
 260    } elsif ($self->method eq 'trust') {
 261       if (scalar(@classes)==scalar($self->ranks)) {
 262          for (my $i=0; $i < @classes; $i++) {
 263             if ($self->rank_of_number($i) eq 'species') {
 264                push @ranks,[$value->binomial,$self->rank_of_number($i)];
 265             } else {
 266                push @ranks,[$classes[$i],$self->rank_of_number($i)];
 267             }
 268          }
 269       } else {
 270          $self->throw("Species object and taxonomy object cannot be reconciled");
 271       }
 272    } elsif ($self->method eq 'lookup') {
 273       # this will lookup a DB for the rank of a taxon name
 274       # I imagine that some kind of Bio::DB class will be need to
 275       # be given to the taxonomy object to act as an DB interface
 276       # (I'm not sure how useful this is though - if you have a DB of
 277       # taxonomy - why would you be doing things this way?)
 278       $self->throw_not_implemented();
 279    }
 280
 281    return @ranks;
 282 }
 283
 284
 285 =head2 level_of_rank
 286
 287  Title   : level_of_rank
 288  Usage   : $obj = taxonomy->level_of_rank($obj);
 289  Function: returns the level of a rank name
 290  Returns : $obj
 291  Args    : $obj
 292
 293 =cut
 294
 295
 296 sub level_of {
 297    my ($self,$value) = @_;
 298
 299    return $self->{'_rank_hash'}{$value};
 300 }
 301
 302
 303 =head2 rank_of_number
 304
 305  Title   : rank_of_number
 306  Usage   : $obj = taxonomy->rank_of_number($obj);
 307  Function: returns the rank name of a rank level
 308  Returns : $obj
 309  Args    : $obj
 310
 311 =cut
 312
 313
 314 sub rank_of_number {
 315    my ($self,$value) = @_;
 316
 317    return ${$self->{'_ranks'}}[$value];
 318 }
 319
 320
 321 =head2 ranks
 322
 323  Title   : ranks
 324  Usage   : @obj = taxonomy->ranks(@obj);
 325  Function: set or return all ranks
 326  Returns : @obj
 327  Args    : @obj
 328
 329 =cut
 330
 331
 332 sub ranks {
 333    my ($self,@value) = @_;
 334
 335    # currently this makes no uniqueness sanity check (this should be done)
 336    # I am think that adding a way of converting multiple 'no rank' ranks
 337    # to unique 'no rank #' ranks so that the level of a 'no rank' is
 338    # abstracted way from the user - I'm not sure of the value of this
 339
 340    if (@value) {
 341       $self->{'_ranks'}=\@value;
 342    }
 343
 344    for (my $i=0; $i <= @{$self->{'_ranks'}}-1; $i++) {
 345       $self->{'_rank_hash'}{$self->{'_ranks'}[$i]}=$i unless $self->{'_ranks'}[$i] eq 'no rank';
 346    }
 347
 348    return @{$self->{'_ranks'}};
 349 }
 350
 351 =head2 add_node
 352
 353   Title:    add_node
 354   Usage:    $obj->add_node($node[, $node2, ...]);
 355   Function: add one or more Bio::Taxonomy::Node objects
 356   Returns:  None
 357   Args:     any number of Bio::Taxonomy::Node(s)
 358
 359 =cut
 360
 361 sub add_node {
 362     my ($self, @nodes) = @_;
 363     foreach(@nodes){
 364         $self->throw("A Bio::Taxonomy::Node object needed")
 365             unless($_->isa('Bio::Taxonomy::Node'));
 366         my ($node, $rank) = ($_, $_->rank);
 367         if(exists $self->{_hierarchy}->{$rank}){
 368 #            $self->throw("$rank has been defined");
 369 #            print STDERR "RANK:$rank\n";
 370 #            return;
 371         }
 372         $self->{_hierarchy}->{$rank} = $node;
 373     }
 374 }
 375
 376 =head2 binomial
 377
 378   Title   : binomial
 379   Usage   : my $val = $obj->binomial;
 380   Function: returns the binomial name if this taxonomy reachs species level
 381   Returns : the binomial name
 382             OR undef if taxonmy does not reach species level
 383   Args    : [No arguments]
 384
 385 =cut
 386
 387 sub binomial {
 388     my $self = shift;
 389     return $self->get_node('species')->scientific_name;
 390     my $genus = $self->get_node('genus');
 391     my $species = $self->get_node('species');
 392     return ($species && $genus) ? "$species $genus" : undef;
 393 }
 394
 395 =head2 get_node
 396
 397   Title   : get_node
 398   Usage   : $node = $taxonomy->get_node('species');
 399   Function: get a Bio::Taxonomy::Node object according to rank name
 400   Returns : a Bio::Taxonomy::Node object or undef if null
 401   Args    : a vaild rank name
 402
 403 =cut
 404
 405 sub get_node {
 406     my ($self, $rank) = @_;
 407     unless(grep /$rank/, keys %{$self->{_hierarchy}}){
 408         $self->throw("'$rank' is not in the rank list");
 409     }
 410     return (exists $self->{_hierarchy}->{$rank})?
 411         $self->{_hierarchy}->{$rank} : undef;
 412 }
 413
 414 =head2 classification
 415
 416   Title   : classification
 417   Usage   : @names = $taxonomy->classification;
 418   Function: get the classification names of one taxonomy
 419   Returns : array of names
 420   Args    : [No arguments]
 421
 422 =cut
 423
 424 sub classification {
 425     my $self = shift;
 426     my %rank_hash = %{$self->{_rank_hash}};
 427     my %hierarchy = %{$self->{_hierarchy}};
 428     my @ordered_nodes = sort {
 429         ($rank_hash{$a} <=> $rank_hash{$b})
 430     } keys %hierarchy;
 431     return map {$hierarchy{$_}->scientific_name} @ordered_nodes;
 432 }
 433
 434 1;