# $Id: Node.pm,v 1.8 2004/12/08 10:48:05 heikki Exp $
#
# BioPerl module for Bio::Taxonomy::Node
#
# Cared for by Jason Stajich <jason-at-bioperl-dot-org>
#
# Copyright Jason Stajich
#
# You may distribute this module under the same terms as perl itself

# POD documentation - main docs before the code

=head1 NAME

Bio::Taxonomy::Node - A node in a represented taxonomy

=head1 SYNOPSIS

  use Bio::Taxonomy::Node;
  # typically you will get a Node from a Bio::DB::Taxonomy object
  # but here is how you initialize one
  my $node = new Bio::Taxonomy::Node(-name      => $name,
                                     -object_id => $oid,
                                     -parent_id => $pid,
                                     -rank   => $rank,
                                     -division  => $div,
                                     -dbh       => $dbh);

  my $dbh = new Bio::DB::Taxonomy(-source   => 'flatfile',
                                  -directory=> '/tmp',
                                  -nodesfile=> '/path/to/nodes.dmp',
                                  -namesfile=> '/path/to/names.dmp');
  my $hum_node = $dbh->get_Taxonomy_Node(-name => 'Homo sapiens');
  my $hum_node2= $dbh->get_Taxonomy_Node(-taxonid => '9606');

  print "rank is ", $hum_node->rank, "\n";
  print "classification is ", join(" ", $hum_node->classification),"\n"; 
  print "division is ", $node->division, "\n";

=head1 DESCRIPTION

This is the next generation (for Bioperl) of representing Taxonomy
information.  Previously all information was managed by a single
object called Bio::Species.  This new implementation allows
representation of the intermediete nodes not just the species nodes
and can relate their connections.

=head1 FEEDBACK

=head2 Mailing Lists

User feedback is an integral part of the evolution of this and other
Bioperl modules. Send your comments and suggestions preferably to
the Bioperl mailing list.  Your participation is much appreciated.

  bioperl-l@bioperl.org              - General discussion
  http://bioperl.org/MailList.shtml  - About the mailing lists

=head2 Reporting Bugs

Report bugs to the Bioperl bug tracking system to help us keep track
of the bugs and their resolution. Bug reports can be submitted via
the web:

  http://bugzilla.bioperl.org/

=head1 AUTHOR - Jason Stajich

Email jason-at-bioperl-dot-org

Describe contact details here

=head1 CONTRIBUTORS

Juguang Xiao, juguang@tll.org.sg

Additional contributors names and emails here

=head1 APPENDIX

The rest of the documentation details each of the object methods.
Internal methods are usually preceded with a _

=cut


package Bio::Taxonomy::Node;
use vars qw(@ISA);
use strict;

use Bio::Root::Root;
use Bio::IdentifiableI;
use Bio::DB::Taxonomy;

@ISA = qw(Bio::Root::Root Bio::IdentifiableI  );

=head2 new

 Title   : new
 Usage   : my $obj = new Bio::Taxonomy::Node();
 Function: Builds a new Bio::Taxonomy::Node object 
 Returns : an instance of Bio::Taxonomy::Node
 Args    : -dbh       => a reference to a Bio::DB::Taxonomy object
           -name      => a string representing the node name
           -object_id => unique identifier - typically NCBI Taxid


=cut

sub new {
  my($class,@args) = @_;
  my $self = $class->SUPER::new(@args);
  my ($name,$uniqueid,$parentid,
      $rank,$div,$dbh, 
      $factory,
      $classification, $ncbitaxid, $commonname,
      $organelle, $sub_species,$variant) = 
	  $self->_rearrange([ qw ( NAME OBJECT_ID PARENT_ID RANK DIVISION
                                   DBH 
				   FACTORY
                                   CLASSIFICATION
                                   NCBI_TAXID
			           COMMON_NAME
                                   ORGANELLE
				   SUB_SPECIES
			           VARIANT
			     )],
			@args);
  if( defined $ncbitaxid && defined $uniqueid && $ncbitaxid ne $uniqueid  ) {
      $self->warn("Only provide one of -object_id or -ncbi_taxid, using $uniqueid\n");
  } elsif( ! defined $uniqueid && defined $ncbitaxid ) { 
      $uniqueid = $ncbitaxid;
  }
$uniqueid && $self->object_id($uniqueid);

  if( defined $name && defined $commonname && $commonname ne $name ) { 
      $self->warn("Only provide one of -name or -common_name to $class, using -name value\n");
  } elsif( ! defined $name && defined $commonname ) { 
      $name = $commonname;
  }

  defined $name && $self->node_name($name);
  defined $rank && $self->rank($rank);
  defined $div  && $self->division($div);

  
#unless(defined $factory ){
   $self->db_handle($dbh || Bio::DB::Taxonomy->new(-source => 'entrez'));
#  } else { 
#      $self->factory($factory);
#  }

  defined $parentid && $self->parent_id($parentid);
  if( defined $classification ) {
      if( ref($classification) !~ /ARRAY/ ) {
	  $self->warn("Classification can only be initialize with an arrayref\n");
      }
      $self->classification(@$classification);
  }
  defined $organelle && $self->name('organelle', $organelle);
  defined $sub_species && $self->name('sub_species', $sub_species);
  defined $variant && $self->name('variant',$variant);

  return $self;
}


=head2 db_handle

 Title   : db_handle
 Usage   : $obj->db_handle($newval)
 Function: Get/Set Bio::DB::Taxonomy Handle
 Returns : value of db_handle (a scalar) (Bio::DB::Taxonomy object)
 Args    : on set, new value (a scalar or undef, optional) Bio::DB::Taxonomy object


=cut

sub db_handle {
    my $self = shift;
    if( @_ ) {
	my $v = shift;
	# until we establish some other higher level TaxonomyDB interface
	if( ! ref($v) || ! $v->isa('Bio::DB::Taxonomy') ) {
	    $self->throw("Must have provided a valid Bio::DB::Taxonomy object");
	}
	$self->{'db_handle'} = $v;
    }
    return $self->{'db_handle'};
}

=head2 factory

  Title:    factory
  Usage:    $factory->factory($newval);
  Function: Get/Set Bio::Taxonomy::FactoryI implementation
  Returns:  Bio:;Taxonomy::FactoryI
  Args:     Bio::Taxonomy::FactoryI

=cut

sub factory {
    my $self = shift;
    if(@_){
        my $v = shift;
        unless(ref($v) || $v->isa('Bio::Taxonomy::FactoryI')){
            $self->throw('A Bio::Taxonomy::FactoryI object required');
        }
        $self->{_factory} = $v;
    }
    return $self->{_factory};
}

=head2 rank

 Title   : rank
 Usage   : $obj->rank($newval)
 Function: 
 Example : 
 Returns : value of rank (a scalar)
 Args    : on set, new value (a scalar or undef, optional)


=cut

sub rank{
    my $self = shift;

    return $self->{'rank'} = shift if @_;
    return $self->{'rank'};
}

=head2 object_id

 Title   : object_id
 Usage   : $obj->object_id($newval)
 Function: 
 Example : 
 Returns : value of object_id (a scalar)
 Args    : on set, new value (a scalar or undef, optional)


=cut

sub object_id {
    my $self = shift;

    return $self->{'_object_id'} = shift if @_;
    return $self->{'_object_id'};
}

*ncbi_taxid = \&object_id;

=head2 version

 Title   : version
 Usage   : $obj->version($newval)
 Function: 
 Example : 
 Returns : value of version (a scalar)
 Args    : on set, new value (a scalar or undef, optional)


=cut

sub version{
    my $self = shift;

    return $self->{'version'} = shift if @_;
    return $self->{'version'};
}

=head2 authority

 Title   : authority
 Usage   : $obj->authority($newval)
 Function: 
 Example : 
 Returns : value of authority (a scalar)
 Args    : on set, new value (a scalar or undef, optional)


=cut

sub authority{
    my $self = shift;

    return $self->{'authority'} = shift if @_;
    return $self->{'authority'};
}


=head2 namespace

 Title   : namespace
 Usage   : $obj->namespace($newval)
 Function: 
 Example : 
 Returns : value of namespace (a scalar)
 Args    : on set, new value (a scalar or undef, optional)


=cut

sub namespace{
    my $self = shift;

    return $self->{'namespace'} = shift if @_;
    return $self->{'namespace'};
}

=head2 parent_id

 Title   : parent_id
 Usage   : $obj->parent_id($newval)
 Function: 
 Example : 
 Returns : value of parent_id (a scalar)
 Args    : on set, new value (a scalar or undef, optional)


=cut

sub parent_id{
    my $self = shift;

    return $self->{'parent_id'} = shift if @_;
    return $self->{'parent_id'};
}

=head2 get_Parent_Node

 Title   : get_Parent_Node
 Usage   : my $parentnode = $node->get_Parent_Node()
 Function: Retrieve the full Parent node from the database
 Returns : Bio::Taxonomy::Node
 Args    : none


=cut

sub get_Parent_Node {
   my ($self) = @_;

   if( ! $self->db_handle ||
       ! defined $self->parent_id ) {
       $self->warn("Cannot get the parent node for ".$self->node_name.
		   " because parent_id or db handle is not defined\n");
       return undef;
   }


   my $node = $self->db_handle->get_Taxonomy_Node(-taxonid => $self->parent_id);
   unless ( defined $node ) {
       $self->warn("Could not find node for parent id ". $self->parent_id);
       return undef;
   }
   return $node;
}


=head2 get_Children_Nodes

 Title   : get_Children_Nodes
 Usage   : my @nodes = $node->get_Children_Nodes();
 Function: Get the children of a node as L<Bio::Taxonomy::Node> objects
 Returns : Array of L<Bio::Taxonomy::Node> objects
 Args    : none


=cut

sub get_Children_Nodes{
   my ($self) = @_;
   if( ! $self->db_handle ||
       ! defined $self->parent_id ) {
       $self->warn("Cannot get the children nodes for ".$self->name('common').
		   " because the db handle is not defined\n");
       return undef;
   }
   my @nodes = $self->db_handle->get_Children_Taxids($self->object_id);
   my @children;
   for my $n ( @nodes ) {
       my $node = $self->db_handle->get_Taxonomy_Node(-taxonid => $n);
       unless( defined $node ) {
	   $self->warn("Could not find node for id $n child  of ".
		       $self->object_id);
       } else {
	   push @children, $node;
       }
   }
   return @children;
}

=head2 node_name

 Title   : node_name
 Usage   : $obj->node_name($newval)
 Function: 
 Example : 
 Returns : value of node_name (a scalar)
 Args    : on set, new value (a scalar or undef, optional)


=cut

sub node_name{
    my $self = shift;
    my @v = @{$self->name('common',@_) || []};
    return ( wantarray ) ? @v : shift @v;
}

*common_name = \&node_name;

=head2 classification

 Title   : classification
 Usage   : $self->classification(@class_array);
           @classification = $self->classification();
 Function: Fills Returns the classification list in
           the object.  The array provided must be in
           the order SPECIES, GENUS ---> KINGDOM.
           Checks are made that species is in lower case,
           and all other elements are in title case.
 Returns : Classification array
 Args    : [optional] array of vals to set classification to

=cut

sub classification {
   my ($self,@vals) = @_;
   my $p;
   if( @vals ) {
       $self->{'_classification'} = [@vals];
       return @vals;
   } elsif ( defined $self->{'_classification'} ) {
       return @{$self->{'_classification'}};
   } else { 
       if( defined($p = $self->get_Parent_Node()) &&
	   $p->object_id != 1  ) {
	   # okay this won't really work - need to do proper recursion
	   push @vals, $p->classification;
       }
       if( $self->show_all || $self->rank ne 'no rank') {
	   push @vals,$self->node_name();
       }
       $self->{'_classification'} = \@vals;
   }
   return @vals;
}


=head2 division

 Title   : division
 Usage   : $obj->division($newval)
 Function: 
 Example : 
 Returns : value of division (a scalar)
 Args    : on set, new value (a scalar or undef, optional)


=cut

sub division {
    my $self = shift;
    my @v = @{$self->name('division',@_) || []};
    return wantarray ? @v : shift @v;
}

=head2 show_all

 Title   : show_all
 Usage   : $obj->show_all($newval)
 Function: Boolean flag whether or not we should show all intermediete
           nodes that do not have actual ranks.
 Returns : value of show_all (a scalar)
 Args    : on set, new value (a scalar or undef, optional)


=cut

sub show_all{
    my $self = shift;
    return $self->{'show_all'} = shift if @_;
    return $self->{'show_all'};
}

=head2 name

  Title:    name
  Usage:    $obj->name('scientific', 'sapiens');
            $obj->name('common', 'human', 'man');
            my @names = @{$obj->name('common')};
  Function: Get and set the names
  Returns:  names (a array reference)
  Args:     Arg1 => the name_class. You can assign any text, but the words
                'scientific' and 'common' have the special meaning, as
                scientific name and common name, respectively.
            Arg2 .. => the names

=cut

sub name {
    my ($self, $name_class, @names) = @_;
    $self->throw('No name class specified') unless defined $name_class;
    # scientific name should be special, because of its uniqueness.
    return [$self->scientific_name(@names)] if $name_class =~ /scientific/i;
    $self->{'_names_hash'} = {} unless exists $self->{'_names_hash'};
    if(@names){
        $self->{'_names_hash'}->{$name_class} = [] 
            unless exists $self->{'_names_hash'}->{$name_class};
        push @{$self->{'_names_hash'}->{$name_class}}, @names;
    }
    return $self->{'_names_hash'}->{$name_class};
}

=head2 scientific_name

  Title:    scientific_name
  Usage:    my $new_val = $obj->scientific_name($newval);
  Function: Get/Set the scientific name
  Returns:  a scalar text value
  Args:     a scalar text value

=cut

sub scientific_name {
    my $self = shift;
    if( @_ ) { 
	$self->warn("Scientfic name must be set through classification");
    }
    $self->binomial;
}

=head2 parent_taxon_id

  Title   : parent_taxon_id
  Usage   : $self->parent_taxon_id($newval);
            $val = $self->parent_taxon_id;
  Function: Get/Set for parent_taxon_id
  Return  : 
  Args    :    

=cut

sub parent_taxon_id {
    my $self = shift;
    return $self->{'_parent_taxon_id'} = shift if @_;
    return $self->{'_parent_taxon_id'};
}


=head2 species

 Title   : species
 Usage   : $self->species( $species );
           $species = $self->species();
 Function: Get or set the scientific species name.  The species
           name must be in lower case.
 Example : $self->species( 'sapiens' );
 Returns : Scientific species name as string
 Args    : Scientific species name as string

=cut


sub species {
    my($self, $species) = @_;

    if (defined $species) {
        $self->validate_species_name( $species );
        $self->{'_classification'}[0] = $species;
    }
    return $self->{'_classification'}[0];
}

=head2 genus

 Title   : genus
 Usage   : $self->genus( $genus );
           $genus = $self->genus();
 Function: Get or set the scientific genus name.  The genus
           must be in title case.
 Example : $self->genus( 'Homo' );
 Returns : Scientific genus name as string
 Args    : Scientific genus name as string

=cut


sub genus {
    my($self, $genus) = @_;
    if (defined $genus) {
        $self->{'_classification'}[1] = $genus;
    }
    return $self->{'_classification'}[1];
}

=head2 sub_species

 Title   : sub_species
 Usage   : $obj->sub_species($newval)
 Function:
 Returns : value of sub_species
 Args    : newvalue (optional)


=cut

sub sub_species {
    my $self = shift;
    my @v = @{$self->name('sub_species', @_) || []};
    return wantarray ? @v : shift @v;
}

=head2 binomial

 Title   : binomial
 Usage   : $binomial = $self->binomial();
           $binomial = $self->binomial('FULL');
 Function: Returns a string "Genus species", or "Genus species subspecies",
           if the first argument is 'FULL' (and the species has a subspecies).
 Args    : Optionally the string 'FULL' to get the full name including
           the subspecies.

=cut


sub binomial {
    my( $self, $full ) = @_;

    my( $species, $genus ) = $self->classification();
    unless( defined $species) {
	$species = 'sp.';
	$self->warn("requested binomial but classification was not set");
    }
    $genus = ''   unless( defined $genus);
    my $bi = "$genus $species";
    if (defined($full) && $full =~ /full/i) { 
	my $ssp = $self->sub_species;
        $bi .= " $ssp" if $ssp;
    }
    return $bi;
}


=head2 organelle

 Title   : organelle
 Usage   : $self->organelle( $organelle );
           $organelle = $self->organelle();
 Function: Get or set the organelle name
 Example : $self->organelle('Chloroplast')
 Returns : The organelle name in a string
 Args    : String, which is the organelle name

=cut

sub organelle {
    my $self = shift;
    my @v = @{$self->name('organelle', @_) || []};
    return wantarray ? @v : shift @v;
}

=head2 variant

 Title   : variant
 Usage   : $obj->variant($newval)
 Function: Get/set variant information for this species object (strain,
           isolate, etc).
 Example : 
 Returns : value of variant (a scalar)
 Args    : new value (a scalar or undef, optional)


=cut

sub variant{
    my $self = shift;
    my @v = @{$self->name('variant',@_) || []};
    return wantarray ? @v : shift @v;
}

sub validate_species_name {
    my( $self, $string ) = @_;

    return 1 if $string eq "sp.";
    return 1 if $string =~ /^[a-z][\w\s]+$/i;
    $self->throw("Invalid species name '$string'");
}

sub validate_name {
    return 1; # checking is disabled as there is really not much we can
              # enforce HL 2002/10/03
#     my( $self, $string ) = @_;

#     return 1 if $string =~ /^[\w\s\-\,\.]+$/ or
#         $self->throw("Invalid name '$string'");
}


1;
