diff variant_effect_predictor/Bio/Tree/AlleleNode.pm @ 0:2bc9b66ada89 draft default tip

Uploaded

--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/variant_effect_predictor/Bio/Tree/AlleleNode.pm	Thu Apr 11 06:29:17 2013 -0400
@@ -0,0 +1,186 @@
+# $Id: AlleleNode.pm,v 1.4 2002/10/22 07:45:24 lapp Exp $
+#
+# BioPerl module for Bio::Tree::AlleleNode
+#
+# Cared for by Jason Stajich <[e-mail]>
+#
+# 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::Tree::AlleleNode - DESCRIPTION of Object
+
+=head1 SYNOPSIS
+
+Give standard usage here
+
+=head1 DESCRIPTION
+
+Describe the object here
+
+=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.
+
+  [e-mail]              - 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
+email or the web:
+
+  [e-mail]
+  http://bugzilla.bioperl.org/
+
+=head1 AUTHOR - Jason Stajich
+
+Email [e-mail]
+
+Describe contact details here
+
+=head1 CONTRIBUTORS
+
+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
+
+
+# Let the code begin...
+
+
+package Bio::Tree::AlleleNode;
+use vars qw(@ISA);
+use strict;
+
+use Bio::Tree::Node;
+
+@ISA = qw(Bio::Tree::Node );
+
+=head2 new
+
+ Title   : new
+ Usage   : my $obj = new Bio::Tree::AlleleNode();
+ Function: Builds a new Bio::Tree::AlleleNode object 
+ Returns : Bio::Tree::AlleleNode
+ Args    :
+
+
+=cut
+
+sub new {
+  my($class,@args) = @_;
+
+  my $self = $class->SUPER::new(@args);
+
+  my ($alleles) = $self->_rearrange([qw(ALLELES)], @args);
+  $self->{'_data'} = {};
+  if( defined $alleles ) { 
+      if( ref($alleles) !~ /HASH/i ) {
+	  $self->warn("Must specify a valid HASH reference for the -alleles value...Ignoring initializing input");
+	  
+      } else { 
+	  foreach my $mkr ( keys %{$alleles} ) { 
+	      $self->add_alleles($mkr,@{$alleles->{$mkr}});
+	  }
+      }
+  }
+  return $self;
+}
+
+=head2 add_alleles
+
+ Title   : add_alleles
+ Usage   : $node->add_alleles($mkr,@alleles);
+ Function: Adds allele(s) for $mkr, @alleles can be a single or 
+           multiple alleles. If the same marker is added more than one, the 
+           previous value will be overwritten with a warning.
+ Returns : none
+ Args    : $marker => marker name
+           @alleles => alleles for the marker
+
+
+=cut
+
+sub add_alleles{
+   my ($self,$marker,@alleles) = @_;
+   if( ! defined $marker || $marker eq '' ) { 
+       $self->warn("must specify a valid marker name for add_alleles");
+       return;
+   } 
+   if( $self->{'_data'}->{$marker} ) { 
+       $self->warn("Overwriting value of $marker");
+   }
+   $self->{'_data'}->{$marker} = []; # reset the array ref
+   foreach my $a ( sort @alleles ) { 
+       next if ! defined $a; # skip undef alleles 
+       push @{$self->{'_data'}->{$marker}},$a;
+   }
+}
+
+=head2 get_alleles
+
+ Title   : get_alleles
+ Usage   : my @alleles = $node->get_alleles($marker);
+ Function: Return the alleles for a marker $marker
+ Returns : Array of Alleles for a marker or empty array
+ Args    : $marker name
+
+=cut
+
+sub get_alleles{
+   my ($self,$marker) = @_;
+   if( defined $self->{'_data'}->{$marker} ) { 
+       return @{$self->{'_data'}->{$marker}};
+   }
+   return ();
+}
+
+=head2 get_marker_names
+
+ Title   : get_marker_names
+ Usage   : my @names =$node->get_marker_names();
+ Function: Return the names of the markers that have been added to this node
+ Returns : List of Marker Names
+ Args    : none
+
+=cut
+
+sub get_marker_names{
+   my ($self) = @_;
+   return keys %{$self->{'_data'}};
+}
+
+=head2 purge_markers
+
+ Title   : purge_markers
+ Usage   : $node->purge_markers;
+ Function: Reset the markers and alleles
+ Returns : none
+ Args    : none
+
+
+=cut
+
+sub purge_markers{
+   my ($self) = @_;
+   $self->{'_data'} = {};
+   return;
+}
+
+
+1;