Bio/PopGen/Individual.pm

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