Bio/PopGen/Marker.pm

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