File Coverage

Bio/PopGen/Individual.pm
Criterion Covered Total %
statement 52 71 73.2
branch 19 32 59.3
condition 4 15 26.6
subroutine 11 14 78.5
pod 10 10 100.0
total 96 142 67.6


line stmt bran cond sub pod time code
1             #
2             # BioPerl module for Bio::PopGen::Individual
3             #
4             # Please direct questions and support issues to
5             #
6             # Cared for by Jason Stajich
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
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 4     4   3098 use vars qw($UIDCOUNTER);
  4         3  
  4         143  
81 4     4   22 use strict;
  4         5  
  4         78  
82 4     4   66 BEGIN { $UIDCOUNTER = 1 }
83              
84             # Object preamble - inherits from Bio::Root::Root
85              
86              
87 4     4   12 use base qw(Bio::Root::Root Bio::PopGen::IndividualI);
  4         5  
  4         1213  
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 1414     1414 1 2024 my($class,@args) = @_;
103              
104 1414         2484 my $self = $class->SUPER::new(@args);
105 1414         2095 $self->{'_genotypes'} = {};
106 1414         3148 my ($uid,$genotypes) = $self->_rearrange([qw(UNIQUE_ID
107             GENOTYPES)],@args);
108 1414 100       2626 unless( defined $uid ) {
109 10         11 $uid = $UIDCOUNTER++;
110             }
111 1414         1888 $self->unique_id($uid);
112 1414 100       2078 if( defined $genotypes ) {
113 1342 50       3343 if( ref($genotypes) =~ /array/i ) {
114 1342         2476 $self->add_Genotype(@$genotypes);
115             } else {
116 0         0 $self->warn("Must provide a valid array reference to set the genotypes value in the contructor");
117             }
118             }
119 1414         2430 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 72754     72754 1 57424 my ($self) = shift;
135 72754 100       84434 return $self->{'_unique_id'} = shift if @_;
136 71340         108799 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 0     0 1 0 return scalar keys %{shift->{'_genotypes'}};
  0         0  
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 0     0 1 0 my ($self, $arg) = @_;
165 0 0       0 return $self->{_annotation} unless $arg;
166 0 0 0     0 $self->throw("Bio::AnnotationCollectionI required for argument") unless
167             ref($arg) && $arg->isa('Bio::AnnotationCollectionI');
168 0         0 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 object(s) containing
178             alleles plus a marker name
179              
180             =cut
181              
182             sub add_Genotype {
183 9231     9231 1 10806 my ($self,@genotypes) = @_;
184            
185 9231         9477 foreach my $g ( @genotypes ) {
186 48656 50 33     121798 if( !ref($g) || ! $g->isa('Bio::PopGen::GenotypeI') ) {
187 0         0 $self->warn("cannot add $g as a genotype skipping");
188 0         0 next;
189             }
190 48656         53884 my $mname = $g->marker_name;
191 48656 50 33     101598 if( ! defined $mname || ! length($mname) ) {
192             # can't just say ! name b/c '0' wouldn't be valid
193 0         0 $self->warn("cannot add genotype because marker name is not defined or is an empty string");
194 0         0 next;
195             }
196 48656 50 33     55601 if( $self->verbose > 0 &&
197             defined $self->{'_genotypes'}->{$mname} ) {
198             # a warning when we have verbosity cranked up
199 0         0 $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 48656         49644 $g->individual_id($self->unique_id);
204 48656         66496 $self->{'_genotypes'}->{$mname} = $g;
205             }
206 9231         6820 return scalar keys %{$self->{'_genotypes'}};
  9231         25630  
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 9     9 1 21 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 0     0 1 0 my ($self,@mkrs) = @_;
237 0         0 foreach my $m ( @mkrs ) {
238 0         0 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 90427     90427 1 93600 my ($self,@args) = @_;
256 90427 100       109742 if( @args ) {
257 90314 100       111219 unshift @args, '-marker' if( @args == 1 ); # deal with single args
258            
259 90314         142211 my ($name) = $self->_rearrange([qw(MARKER)], @args);
260 90314 50       135921 if( ! defined($name) ) {
261 0         0 $self->warn("Only know how to process the -marker field currently");
262 0         0 return();
263             }
264 90314         96546 my $v = $self->{'_genotypes'}->{$name};
265 90314         147010 return $v;
266             }
267 113 50       129 return values %{$self->{'_genotypes'} || {}};
  113         1107  
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 9967     9967 1 6698 my ($self,$name) = @_;
284 9967 50       10532 return 0 if ! defined $name;
285              
286 9967 50 33     12374 $name = $name->name if ref($name) && $name->isa('Bio::PopGen::MarkerI');
287 9967 50       10023 if( ref($name) ) {
288 0         0 $self->warn("Passed in a ".ref($name). " to has_Marker, expecting either a string or a Bio::PopGen::MarkerI");
289 0         0 return 0;
290             }
291 9967         18927 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 1244     1244 1 822 my ($self) = @_;
307 1244         694 return keys %{$self->{'_genotypes'}};
  1244         11305  
308             }
309              
310              
311             1;