Bio/PopGen/Individual.pm

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