Bio/PopGen/Individual.pm

   1 # $Id$
   2 #
   3 # BioPerl module for Bio::PopGen::Individual
   4 #
   5 # Cared for by Jason Stajich <jason-at-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::Individual - An implementation of an Individual who has
  16 Genotype or Sequence Results
  17
  18 =head1 SYNOPSIS
  19
  20   use Bio::PopGen::Individual;
  21
  22   my $ind = Bio::PopGen::Individual->new(-unique_id => $id,
  23                                         -genotypes => \@genotypes);
  24
  25 =head1 DESCRIPTION
  26
  27 This object is a container for genotypes.
  28
  29 =head1 FEEDBACK
  30
  31 =head2 Mailing Lists
  32
  33 User feedback is an integral part of the evolution of this and other
  34 Bioperl modules. Send your comments and suggestions preferably to
  35 the Bioperl mailing list.  Your participation is much appreciated.
  36
  37   bioperl-l@bioperl.org                  - General discussion
  38   http://bioperl.org/wiki/Mailing_lists  - About the mailing lists
  39
  40 =head2 Reporting Bugs
  41
  42 Report bugs to the Bioperl bug tracking system to help us keep track
  43 of the bugs and their resolution. Bug reports can be submitted via
  44 the web:
  45
  46   http://bugzilla.open-bio.org/
  47
  48 =head1 AUTHOR - Jason Stajich
  49
  50 Email jason-at-bioperl.org
  51
  52 =head1 CONTRIBUTORS
  53
  54 Matthew Hahn, matthew.hahn-at-duke.edu
  55
  56 =head1 APPENDIX
  57
  58 The rest of the documentation details each of the object methods.
  59 Internal methods are usually preceded with a _
  60
  61 =cut
  62
  63
  64 # Let the code begin...
  65
  66
  67 package Bio::PopGen::Individual;
  68 use vars qw($UIDCOUNTER);
  69 use strict;
  70 BEGIN { $UIDCOUNTER = 1 }
  71
  72 # Object preamble - inherits from Bio::Root::Root
  73
  74
  75 use base qw(Bio::Root::Root Bio::PopGen::IndividualI);
  76
  77 =head2 new
  78
  79  Title   : new
  80  Usage   : my $obj = Bio::PopGen::Individual->new();
  81  Function: Builds a new Bio::PopGen::Individual object
  82  Returns : an instance of Bio::PopGen::Individual
  83  Args    : -unique_id => $id,
  84            -genotypes => \@genotypes
  85
  86
  87 =cut
  88
  89 sub new {
  90   my($class,@args) = @_;
  91
  92   my $self = $class->SUPER::new(@args);
  93   $self->{'_genotypes'} = {};
  94   my ($uid,$genotypes) = $self->_rearrange([qw(UNIQUE_ID
  95                                                GENOTYPES)],@args);
  96   unless( defined $uid ) {
  97       $uid = $UIDCOUNTER++;
  98   }
  99   $self->unique_id($uid);
 100   if( defined $genotypes ) {
 101       if( ref($genotypes) =~ /array/i ) {
 102           $self->add_Genotype(@$genotypes);
 103       } else {
 104           $self->warn("Must provide a valid array reference to set the genotypes value in the contructor");
 105       }
 106   }
 107   return $self;
 108 }
 109
 110 =head2 unique_id
 111
 112  Title   : unique_id
 113  Usage   : my $id = $individual->unique_id
 114  Function: Unique Identifier
 115  Returns : string representing unique identifier
 116  Args    : string
 117
 118
 119 =cut
 120
 121 sub unique_id{
 122    my ($self) = shift;
 123    return $self->{'_unique_id'} = shift if @_;
 124    return $self->{'_unique_id'};
 125 }
 126
 127 =head2 num_of_results
 128
 129  Title   : num_of_results
 130  Usage   : my $count = $person->num_results;
 131  Function: returns the count of the number of Results for a person
 132  Returns : integer
 133  Args    : none
 134
 135 =cut
 136
 137 sub num_of_results {
 138     return scalar keys %{shift->{'_genotypes'}};
 139 }
 140
 141
 142 =head2 add_Genotype
 143
 144  Title   : add_Genotype
 145  Usage   : $individual->add_Genotype
 146  Function: add a genotype value
 147  Returns : count of the number of genotypes associated with this individual
 148  Args    : @genotypes - L<Bio::PopGen::GenotypeI> object(s) containing
 149                         alleles plus a marker name
 150
 151 =cut
 152
 153 sub add_Genotype {
 154    my ($self,@genotypes) = @_;
 155
 156    foreach my $g ( @genotypes ) {
 157        if( !ref($g) || ! $g->isa('Bio::PopGen::GenotypeI') ) {
 158            $self->warn("cannot add $g as a genotype skipping");
 159            next;
 160        }
 161        my $mname = $g->marker_name;
 162        if( ! defined $mname || ! length($mname) ) {
 163          # can't just say ! name b/c '0' wouldn't be valid
 164            $self->warn("cannot add genotype because marker name is not defined or is an empty string");
 165            next;
 166        }
 167        if( $self->verbose > 0 &&
 168            defined $self->{'_genotypes'}->{$mname} ) {
 169            # a warning when we have verbosity cranked up
 170            $self->debug("Overwriting the previous value for $mname for this individual");
 171        }
 172        # this will force Genotype individual_id to be set to
 173        # the Individual it has been added for
 174        $g->individual_id($self->unique_id);
 175        $self->{'_genotypes'}->{$mname} = $g;
 176    }
 177    return scalar keys %{$self->{'_genotypes'}};
 178 }
 179
 180 =head2 reset_Genotypes
 181
 182  Title   : reset_Genotypes
 183  Usage   : $individual->reset_Genotypes;
 184  Function: Reset the genotypes stored for this individual
 185  Returns : none
 186  Args    : none
 187
 188
 189 =cut
 190
 191 sub reset_Genotypes{
 192     shift->{'_genotypes'} = {};
 193 }
 194
 195 =head2 remove_Genotype
 196
 197  Title   : remove_Genotype
 198  Usage   : $individual->remove_Genotype(@names)
 199  Function: Removes the genotypes for the requested markers
 200  Returns : none
 201  Args    : Names of markers
 202
 203
 204 =cut
 205
 206 sub remove_Genotype{
 207    my ($self,@mkrs) = @_;
 208    foreach my $m ( @mkrs ) {
 209        delete($self->{'_genotypes'}->{$m});
 210    }
 211 }
 212
 213 =head2 get_Genotypes
 214
 215  Title   : get_Genotypes
 216  Usage   : my @genotypes = $ind->get_Genotypes(-marker => $markername);
 217  Function: Get the genotypes for an individual, based on a criteria
 218  Returns : Array of genotypes
 219  Args    : either none (return all genotypes) or
 220            -marker => name of marker to return (exact match, case matters)
 221
 222
 223 =cut
 224
 225 sub get_Genotypes{
 226    my ($self,@args) = @_;
 227    if( @args ) {
 228        unshift @args, '-marker' if( @args == 1 );  # deal with single args
 229
 230        my ($name) = $self->_rearrange([qw(MARKER)], @args);
 231        if( ! $name ) {
 232            $self->warn("Only know how to process the -marker field currently");
 233            return();
 234        }
 235        my $v = $self->{'_genotypes'}->{$name};
 236        return $v;
 237    }
 238    return values %{$self->{'_genotypes'} || {}};
 239 }
 240
 241 =head2 has_Marker
 242
 243  Title   : has_Marker
 244  Usage   : if( $ind->has_Marker($name) ) {}
 245  Function: Boolean test to see if an Individual has a genotype
 246            for a specific marker
 247  Returns : Boolean (true or false)
 248  Args    : String representing a marker name
 249
 250
 251 =cut
 252
 253 sub has_Marker{
 254    my ($self,$name) = @_;
 255    return 0 if ! defined $name;
 256
 257    $name = $name->name if ref($name) && $name->isa('Bio::PopGen::MarkerI');
 258    if( ref($name) ) {
 259        $self->warn("Passed in a ".ref($name). " to has_Marker, expecting either a string or a Bio::PopGen::MarkerI");
 260        return 0;
 261    }
 262    return defined $self->{'_genotypes'}->{$name};
 263 }
 264
 265 =head2 get_marker_names
 266
 267  Title   : get_marker_names
 268  Usage   : my @names = $individual->get_marker_names;
 269  Function: Returns the list of known marker names
 270  Returns : List of strings
 271  Args    : none
 272
 273
 274 =cut
 275
 276 sub get_marker_names{
 277    my ($self) = @_;
 278    return keys %{$self->{'_genotypes'}};
 279 }
 280
 281
 282 1;