Bio/PopGen/Genotype.pm

   1 #
   2 # BioPerl module for Bio::PopGen::Genotype
   3 #
   4 # Please direct questions and support issues to <bioperl-l@bioperl.org>
   5 #
   6 # Cared for by Jason Stajich <jason-at-bioperl.org>
   7 #
   8 # Copyright Jason Stajich
   9 #
  10 # You may distribute this module under the same terms as perl itself
  11
  12 # POD documentation - main docs before the code
  13
  14 =head1 NAME
  15
  16 Bio::PopGen::Genotype - An implementation of GenotypeI which is just an allele container
  17
  18 =head1 SYNOPSIS
  19
  20   use Bio::PopGen::Genotype;
  21   my $genotype = Bio::PopGen::Genotype->new(-marker_name   => $name,
  22                                            -individual_id => $indid,
  23                                            -alleles       => \@alleles);
  24
  25 =head1 DESCRIPTION
  26
  27 This object will contain alleles for a given marker for a given
  28 individual.
  29
  30 The class variable BlankAlleles (accessible through
  31 $Bio::PopGen::Genotype::BlankAlleles = 'somepattern') can be set to a
  32 regexp pattern for identifying blank alleles which should no be
  33 counted (they are effectively missing data).  By default it set to
  34 match white space, '-', 'N' or 'n', and '?' as blank alleles which are
  35 skipped.
  36
  37 =head1 FEEDBACK
  38
  39 =head2 Mailing Lists
  40
  41 User feedback is an integral part of the evolution of this and other
  42 Bioperl modules. Send your comments and suggestions preferably to
  43 the Bioperl mailing list.  Your participation is much appreciated.
  44
  45   bioperl-l@bioperl.org                  - General discussion
  46   http://bioperl.org/wiki/Mailing_lists  - About the mailing lists
  47
  48 =head2 Support
  49
  50 Please direct usage questions or support issues to the mailing list:
  51
  52 I<bioperl-l@bioperl.org>
  53
  54 rather than to the module maintainer directly. Many experienced and
  55 reponsive experts will be able look at the problem and quickly
  56 address it. Please include a thorough description of the problem
  57 with code and data examples if at all possible.
  58
  59 =head2 Reporting Bugs
  60
  61 Report bugs to the Bioperl bug tracking system to help us keep track
  62 of the bugs and their resolution. Bug reports can be submitted via
  63 the web:
  64
  65   https://redmine.open-bio.org/projects/bioperl/
  66
  67 =head1 AUTHOR - Jason Stajich
  68
  69 Email jason-at-bioperl.org
  70
  71 =head1 CONTRIBUTORS
  72
  73 Matthew Hahn, matthew.hahn-at-duke.edu
  74
  75 =head1 APPENDIX
  76
  77 The rest of the documentation details each of the object methods.
  78 Internal methods are usually preceded with a _
  79
  80 =cut
  81
  82
  83 # Let the code begin...
  84
  85
  86 package Bio::PopGen::Genotype;
  87 use vars qw($BlankAlleles);
  88 use strict;
  89
  90 $BlankAlleles = '[\s\-Nn\?]';
  91
  92
  93 # Object preamble - inherits from Bio::Root::Root
  94
  95
  96
  97 use base qw(Bio::Root::Root Bio::PopGen::GenotypeI);
  98
  99 =head2 new
 100
 101  Title   : new
 102  Usage   : my $obj = Bio::PopGen::Genotype->new();
 103  Function: Builds a new Bio::PopGen::Genotype object
 104  Returns : an instance of Bio::PopGen::Genotype
 105  Args    : -marker_name   => string representing name of the marker
 106            -individual_id => string representing individual id (optional)
 107            -alleles       => arrayref with each item in the array being an allele
 108
 109 =cut
 110
 111 sub new {
 112   my($class,@args) = @_;
 113
 114   my $self = $class->SUPER::new(@args);
 115   my ($marker_name, $marker_type, $ind_id, $alleles) = $self->_rearrange([qw(MARKER_NAME
 116                                                                MARKER_TYPE
 117                                                                INDIVIDUAL_ID
 118                                                                ALLELES)],@args);
 119   defined $marker_name && $self->marker_name($marker_name);
 120   defined $marker_type && $self->marker_type($marker_type);
 121   defined $ind_id      && $self->individual_id($ind_id);
 122   if( defined $alleles ) {
 123       if( ref($alleles) =~ /array/i ) {
 124           $self->add_Allele(@$alleles);
 125       } else {
 126           $self->warn("Could not initialize with -alleles value, it is not an array ref");
 127       }
 128   }
 129   return $self;
 130 }
 131
 132
 133 =head2 marker_name
 134
 135  Title   : marker_name
 136  Usage   : my $name = $genotype->marker_name();
 137  Function: Get the marker name for a genotype result
 138  Returns : string
 139  Args    : [optional] marker name value to store
 140
 141
 142 =cut
 143
 144 sub marker_name{
 145     my ($self) = shift;
 146     return $self->{'_marker_name'} = shift if @_;
 147     return $self->{'_marker_name'};
 148 }
 149
 150 =head2 marker_type
 151
 152  Title   : marker_type
 153  Usage   : my $name = $genotype->marker_type();
 154  Function: Get the marker type for a genotype result
 155  Returns : M (microsatellite, or other multi-allelic
 156            locus) or S (biallelic/SNP locus)
 157  Args    : [optional] marker type value to store
 158
 159
 160 =cut
 161
 162 sub marker_type{
 163     my ($self) = shift;
 164     return $self->{'_marker_type'} = shift if @_;
 165     return $self->{'_marker_type'};
 166 }
 167
 168
 169 =head2 individual_id
 170
 171  Title   : individual_id
 172  Usage   : my $indid = $genotype->individual_id();
 173  Function: Gets the individual id associated with a genotype
 174            This is effectively a back reference since we will typically
 175            associate a genotype with an individual with an
 176            individual HAS-A genotype relationship.
 177  Returns : unique id string for an individual
 178  Args    : none
 179
 180
 181 =cut
 182
 183 sub individual_id {
 184     my ($self) = shift;
 185     return $self->{'_individual_id'} = shift if @_;
 186     return $self->{'_individual_id'};
 187 }
 188
 189 =head2 get_Alleles
 190
 191  Title   : get_Alleles
 192  Usage   : my @alleles = $genotype->get_Alleles();
 193  Function: Get the alleles for a given marker and individual
 194  Returns : array of alleles (strings in this implementation)
 195  Args    : $showblank - boolean flag to indicate return ALL alleles not
 196                         skipping the coded EMPTY alleles
 197
 198  Note    : Uses the class variable $BlankAlleles to test if alleles
 199            should be skipped or not.
 200
 201 =cut
 202
 203 sub get_Alleles{
 204     my ($self) = shift;
 205
 206      if( @_ && $_[0] ) {
 207         return @{$self->{'_alleles'} || []};
 208     } else {
 209         if( defined $self->{'_cached_noblank'} ) {
 210             return @{$self->{'_cached_noblank'}}
 211         }
 212         # one liners - woo hoo.
 213         $self->{'_cached_noblank'} = [ grep { ! /^\s*$BlankAlleles\s*$/o }
 214                                        @{$self->{'_alleles'} || []}];
 215         return @{$self->{'_cached_noblank'}};
 216     }
 217 }
 218
 219 =head2 add_Allele
 220
 221  Title   : add_Allele
 222  Usage   : $genotype->add_Allele(@alleles);
 223  Function: Add alleles to the genotype, at this point there is no
 224            verification to insure that haploid individuals only have 1
 225            allele or that diploids only have 2 - we assume that is
 226            done by the user creating these objects
 227  Returns : count of the number of alleles in genotype
 228  Args    : Array of alleles to store
 229
 230
 231 =cut
 232
 233 sub add_Allele {
 234     my ($self) = shift;
 235     $self->{'_cached_noblank'} = undef;
 236     push @{$self->{'_alleles'}}, @_;
 237     return scalar @{$self->{'_alleles'}};
 238 }
 239
 240 =head2 reset_Alleles
 241
 242  Title   : reset_Alleles
 243  Usage   : $genotype->reset_Alleles;
 244  Function: Resets the stored alleles so the list is empty
 245  Returns : None
 246  Args    : None
 247
 248
 249 =cut
 250
 251 sub reset_Alleles{
 252    my ($self,@args) = @_;
 253    $self->{'_cached_noblank'} = undef;
 254    $self->{'_alleles'} = [];
 255    return 0;
 256 }
 257
 258
 259 1;