Bio/PopGen/Marker.pm

   1 # $Id$
   2 #
   3 # BioPerl module for Bio::PopGen::Marker
   4 #
   5 # Please direct questions and support issues to <bioperl-l@bioperl.org>
   6 #
   7 # Cared for by Jason Stajich <jason@bioperl.org>
   8 #
   9 # Copyright Jason Stajich
  10 #
  11 # You may distribute this module under the same terms as perl itself
  12
  13 # POD documentation - main docs before the code
  14
  15 =head1 NAME
  16
  17 Bio::PopGen::Marker - A genetic marker which one uses to generate genotypes
  18
  19 =head1 SYNOPSIS
  20
  21   my $name = $marker->name();            # marker name
  22   my $description = $marker->description(); # description
  23   my $type = $marker->type();            # coded type of the marker
  24   my $unique_id = $marker->unique_id;    # optional unique ID
  25   my @alleles = $marker->get_Alleles();  # the known alleles
  26   my %allele_freqs = $marker->get_Allele_Frequencies(); # keys are marker names
  27                                          # vals are frequencies
  28                                          # may change to handle multiple populations
  29
  30 =head1 DESCRIPTION
  31
  32 This object will not contain genotype information pertaining to an
  33 individual, but rather population level statistics and descriptive
  34 information about a marker.
  35
  36 =head1 FEEDBACK
  37
  38 =head2 Mailing Lists
  39
  40 User feedback is an integral part of the evolution of this and other
  41 Bioperl modules. Send your comments and suggestions preferably to
  42 the Bioperl mailing list.  Your participation is much appreciated.
  43
  44   bioperl-l@bioperl.org                  - General discussion
  45   http://bioperl.org/wiki/Mailing_lists  - About the mailing lists
  46
  47 =head2 Support
  48
  49 Please direct usage questions or support issues to the mailing list:
  50
  51 L<bioperl-l@bioperl.org>
  52
  53 rather than to the module maintainer directly. Many experienced and
  54 reponsive experts will be able look at the problem and quickly
  55 address it. Please include a thorough description of the problem
  56 with code and data examples if at all possible.
  57
  58 =head2 Reporting Bugs
  59
  60 Report bugs to the Bioperl bug tracking system to help us keep track
  61 of the bugs and their resolution. Bug reports can be submitted via
  62 the web:
  63
  64   http://bugzilla.open-bio.org/
  65
  66 =head1 AUTHOR - Jason Stajich
  67
  68 Email jason-at-bioperl.org
  69
  70 =head1 CONTRIBUTORS
  71
  72 Matthew Hahn, matthew.hahn-at-duke.edu
  73
  74 =head1 APPENDIX
  75
  76 The rest of the documentation details each of the object methods.
  77 Internal methods are usually preceded with a _
  78
  79 =cut
  80
  81
  82 # Let the code begin...
  83
  84
  85 package Bio::PopGen::Marker;
  86 use strict;
  87
  88 # Object preamble - inherits from Bio::Root::Root
  89
  90
  91 use vars qw($UniqueCounter);
  92
  93 $UniqueCounter = 0;
  94
  95 use base qw(Bio::Root::Root Bio::PopGen::MarkerI);
  96
  97 =head2 new
  98
  99  Title   : new
 100  Usage   : my $obj = Bio::PopGen::Marker->new();
 101  Function: Builds a new Bio::PopGen::Marker object
 102  Returns : an instance of Bio::PopGen::Marker
 103  Args    : -name          => [string] marker name
 104            -description   => [string] marker description
 105            -type          => [string] marker type
 106            -unique_id     => [string/int] unique id
 107            -allele_freq   => [hash ref] allele frequencies
 108
 109 =cut
 110
 111 sub new {
 112   my($class,@args) = @_;
 113
 114   my $self = $class->SUPER::new(@args);
 115   my ($name,$desc,$type,$uid,$af) = $self->_rearrange([qw(NAME
 116                                                           DESCRIPTION
 117                                                           TYPE
 118                                                           UNIQUE_ID
 119                                                           ALLELE_FREQ)],@args);
 120   $self->{'_allele_freqs'} = {};
 121   if( ! defined $uid ) {
 122       $uid = $UniqueCounter++;
 123   }
 124   if( defined $name) {
 125       $self->name($name);
 126   } else {
 127       $self->throw("Must provide a name when initializing a Marker");
 128   }
 129   defined $desc && $self->description($desc);
 130   defined $type && $self->type($type);
 131   $self->unique_id($uid);
 132   if( defined $af) {
 133       if( ref($af) !~ /HASH/i ) {
 134           $self->warn("Must provide valid Hash reference for allele_freq method");
 135       } else {
 136           foreach my $allele ( keys %$af ) {
 137               $self->add_Allele_Frequency($allele, $af->{$allele});
 138           }
 139       }
 140   }
 141   return $self;
 142 }
 143
 144 =head2 name
 145
 146  Title   : name
 147  Usage   : my $name = $marker->name();
 148  Function: Get the name of the marker
 149  Returns : string representing the name of the marker
 150  Args    : [optional] name
 151
 152
 153 =cut
 154
 155 sub name{
 156     my $self = shift;
 157
 158     return $self->{'_name'} = shift if @_;
 159     return $self->{'_name'};
 160 }
 161
 162
 163 =head2 description
 164
 165  Title   : description
 166  Usage   : my $desc = $marker->description
 167  Function: Get the marker description free text
 168  Returns : string
 169  Args    : [optional] string
 170
 171
 172 =cut
 173
 174 sub description{
 175     my $self = shift;
 176
 177     return $self->{'_description'} = shift if @_;
 178     return $self->{'_description'};
 179 }
 180
 181 =head2 type
 182
 183  Title   : type
 184  Usage   : my $type = $marker->type;
 185  Function: Get coded string for marker type
 186  Returns : string
 187  Args    : [optional] string
 188
 189
 190 =cut
 191
 192 sub type{
 193     my $self = shift;
 194
 195     return $self->{'_type'} = shift if @_;
 196     return $self->{'_type'};
 197 }
 198
 199
 200 =head2 unique_id
 201
 202  Title   : unique_id
 203  Usage   : my $id = $marker->unique_id;
 204  Function: Get the unique marker ID
 205  Returns : unique ID string
 206  Args    : [optional ] string
 207
 208
 209 =cut
 210
 211 sub unique_id{
 212     my $self = shift;
 213
 214     return $self->{'_uniqueid'} = shift if @_;
 215     return $self->{'_uniqueid'};
 216 }
 217
 218 =head2 get_Alleles
 219
 220  Title   : get_Alleles
 221  Usage   : my @alleles = $marker->get_Alleles();
 222  Function: Get the available marker alleles
 223  Returns : Array of strings
 224  Args    : none
 225
 226 =cut
 227
 228 sub get_Alleles{
 229     my $self = shift;
 230     my (@numeric,@alpha);
 231
 232     for ( keys %{$self->{'_allele_freqs'}} ) {
 233         if( /[^\d\.\-e]/ ) { push @alpha, $_ }
 234         else { push @numeric, $_ }
 235     }
 236     @numeric = sort { $b <=> $a } @numeric;
 237     @alpha   = sort { $b cmp $a } @alpha;
 238     return @numeric,@alpha;
 239 }
 240
 241
 242 =head2 get_Allele_Frequencies
 243
 244  Title   : get_Allele_Frequencies
 245  Usage   : my %allele_freqs = $marker->get_Allele_Frequencies;
 246  Function: Get the alleles and their frequency (set relative to
 247            a given population - you may want to create different
 248            markers with the same name for different populations
 249            with this current implementation
 250  Returns : Associative array where keys are the names of the alleles
 251  Args    : none
 252
 253
 254 =cut
 255
 256 sub get_Allele_Frequencies{
 257    return %{$_[0]->{'_allele_freqs'}};
 258 }
 259
 260 =head2 add_Allele_Frequency
 261
 262  Title   : add_Allele_Frequency
 263  Usage   : $marker->add_Allele_Frequency($allele,$freq)
 264  Function: Adds an allele frequency
 265  Returns : None
 266  Args    : $allele - allele name
 267            $freq   - frequency value
 268
 269
 270 =cut
 271
 272 sub add_Allele_Frequency{
 273    my ($self,$allele,$freq) = @_;
 274    $self->{'_allele_freqs'}->{$allele} = $freq;
 275 }
 276
 277 =head2 reset_alleles
 278
 279  Title   : reset_alleles
 280  Usage   : $marker->reset_alleles();
 281  Function: Reset the alleles for a marker
 282  Returns : None
 283  Args    : None
 284
 285
 286 =cut
 287
 288 sub reset_alleles{
 289    my ($self) = @_;
 290    $self->{'_allele_freqs'} = {};
 291 }
 292
 293
 294
 295 1;