← Back to branch summary

~ubuntu-branches/ubuntu/saucy/bioperl/saucy-proposed

« back to all changes in this revision

Viewing changes to Bio/SeqEvolution/Factory.pm

  • Committer: Bazaar Package Importer
  • Author(s): Charles Plessy
  • Date: 2009-03-10 07:19:11 UTC
  • mfrom: (1.2.3 upstream)
  • Revision ID: james.westby@ubuntu.com-20090310071911-fukqzw54pyb1f0bd
Tags: 1.6.0-2
https://launchpad.net/bugs/324001
* Removed patch system (not used):
  - removed instuctions in debian/rules;
  - removed quilt from Build-Depends in debian/control.
* Re-enabled tests:
  - uncommented test command in debian/rules;
  - uncommented previously missing build-dependencies in debian/control.
  - Re-enabled tests and uncommented build-dependencies accordingly.
* Removed libmodule-build-perl and libtest-harness-perl from
  Build-Depends-Indep (provided by perl-modules).
* Better cleaning of empty directories using find -type d -empty -delete
  instead of rmdir in debian/rules (LP: #324001).

Show diffs side-by-side

added added

removed removed

Lines of Context:
Bio/SeqEvolution/Factory.pm
 
1
# $Id: Factory.pm 11480 2007-06-14 14:16:21Z sendu $
 
2
#
 
3
# BioPerl module for Bio::SeqEvolution::Factory
 
4
#
 
5
# Cared for by Heikki Lehvaslaiho <heikki at bioperl dot org>
 
6
#
 
7
# Copyright Heikki Lehvaslaiho
 
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::SeqEvolution::Factory - Factory object to instantiate sequence evolving classes
 
16
 
 
17
=head1 SYNOPSIS
 
18
 
 
19
    # not an instantiable class
 
20
 
 
21
=head1 DESCRIPTION
 
22
 
 
23
This is the factory class that can be used to call for a specific
 
24
model to mutate a sequence.
 
25
 
 
26
Bio::SeqEvolution::DNAPoint is the default for nucleotide sequences
 
27
and the only implementation at this point.
 
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/MailList.shtml  - 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 the
 
44
web:
 
45
 
 
46
  http://bugzilla.bioperl.org/
 
47
 
 
48
=head1 AUTHOR
 
49
 
 
50
  Heikki Lehvaslaiho E<lt>heikki at bioperl dot orgE<gt>
 
51
 
 
52
=head1 CONTRIBUTORS
 
53
 
 
54
Additional contributor's names and emails here
 
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::SeqEvolution::Factory;
 
68
use strict;
 
69
use Bio::Root::Root;
 
70
use Bio::SeqEvolution::EvolutionI;
 
71
use base qw(Bio::Root::Root Bio::SeqEvolution::EvolutionI);
 
72
 
 
73
=head2 new
 
74
 
 
75
  Title   : new
 
76
  Usage   : my $obj = Bio::SeqEvolution::Factory->new();
 
77
  Function: Builds a new Bio:SeqEvolution::EvolutionI object
 
78
  Returns : Bio:SeqEvolution::EvolutionI object
 
79
  Args    : -type           => class name
 
80
 
 
81
See L<Bio:SeqEvolution::EvolutionI>
 
82
 
 
83
=cut
 
84
 
 
85
sub new {
 
86
    my($caller,@args) = @_;
 
87
    my $class = ref($caller) || $caller;
 
88
 
 
89
    my %param = @args;
 
90
    @param{ map { lc $_ } keys %param } = values %param; # lowercase keys
 
91
 
 
92
    if ( $class eq 'Bio::SeqEvolution::Factory') {
 
93
        #my %param = @args;
 
94
        #@param{ map { lc $_ } keys %param } = values %param; # lowercase keys
 
95
 
 
96
        if (exists $param{'-type'}) {
 
97
#            $self->type($param{'-type'});
 
98
        } else {
 
99
            $param{'-type'} = 'Bio::SeqEvolution::DNAPoint';
 
100
            #$self->type('Bio::SeqEvolution::DNAPoint'} unless $seq->alphabet == 'protein'
 
101
        }
 
102
        my $type = $param{'-type'};
 
103
        return unless( $class->_load_format_module($param{'-type'}) );
 
104
        return $type->new(%param);
 
105
    } else {
 
106
        my ($self) = $class->SUPER::new(%param);
 
107
        $self->_initialize(%param);
 
108
        return $self;
 
109
    }
 
110
}
 
111
 
 
112
sub _initialize {
 
113
    my($self, @args) = @_;
 
114
 
 
115
    $self->SUPER::_initialize(@args);
 
116
    my %param = @args;
 
117
    @param{ map { lc $_ } keys %param } = values %param; # lowercase keys
 
118
 
 
119
    exists $param{'-seq'} && $self->seq($param{'-seq'});
 
120
    exists $param{'-set_mutated_seq'} && $self->set_mutated_seq($param{'-set_mutated_seq'});
 
121
    exists $param{'-identity'} && $self->identity($param{'-identity'});
 
122
    exists $param{'-pam'} && $self->pam($param{'-pam'});
 
123
    exists $param{'-mutation_count'} && $self->mutation_count($param{'-mutation_count'});
 
124
 
 
125
}
 
126
 
 
127
 
 
128
=head2 _load_format_module
 
129
 
 
130
 Title   : _load_format_module
 
131
 Usage   : *INTERNAL SeqIO stuff*
 
132
 Function: Loads up (like use) a module at run time on demand
 
133
 Example :
 
134
 Returns :
 
135
 Args    :
 
136
 
 
137
=cut
 
138
 
 
139
sub _load_format_module {
 
140
        my ($self, $format) = @_;
 
141
        my $module =  $format;
 
142
        my $ok;
 
143
 
 
144
        eval {
 
145
                $ok = $self->_load_module($module);
 
146
        };
 
147
        if ( $@ ) {
 
148
                print STDERR <<END;
 
149
$self: $format cannot be found
 
150
Exception $@
 
151
END
 
152
                ;
 
153
        }
 
154
        return $ok;
 
155
}
 
156
 
 
157
 
 
158
=head2 type
 
159
 
 
160
 Title   : type
 
161
 Usage   : $obj->type($newval)
 
162
 Function: Set used evolution model. It is set by giving a
 
163
           valid Bio::SeqEvolution::* class name 
 
164
 Returns : value of type
 
165
 Args    : newvalue (optional)
 
166
 
 
167
Defaults to Bio::SeqEvolution::DNAPoint.
 
168
 
 
169
=cut
 
170
 
 
171
sub type{
 
172
   my $self = shift;
 
173
   if (@_) {
 
174
       $self->{'_type'} = shift @_;
 
175
       $self->_load_module($self->{'_type'});
 
176
   }
 
177
   return $self->{'_type'} || 'Bio::SeqEvolution::DNAPoint';
 
178
}
 
179
 
 
180
=head1 mutation counters
 
181
 
 
182
The next three methods set a value to limit the number of mutations
 
183
introduced the the input sequence.
 
184
 
 
185
=cut
 
186
 
 
187
=head2 identity
 
188
 
 
189
 Title   : identity
 
190
 Usage   : $obj->identity($newval)
 
191
 Function: Set the desired identity between original and mutated sequence
 
192
 Returns : value of identity
 
193
 Args    : newvalue (optional)
 
194
 
 
195
=cut
 
196
 
 
197
sub identity{
 
198
   my $self = shift;
 
199
   $self->{'_identity'} = shift @_ if @_;
 
200
   return $self->{'_identity'};
 
201
}
 
202
 
 
203
 
 
204
=head2 pam
 
205
 
 
206
 Title   : pam
 
207
 Usage   : $obj->pam($newval)
 
208
 Function: Set the wanted Percentage of Accepted Mutations, PAM
 
209
 Returns : value of PAM
 
210
 Args    : newvalue (optional)
 
211
 
 
212
When you are measuring sequence divergence, PAM needs to be
 
213
estimated. When you are generating sequences, PAM is simply the count
 
214
of mutations introduced to the reference sequence normalised to the
 
215
original sequence lenght.
 
216
 
 
217
=cut
 
218
 
 
219
sub pam{
 
220
   my $self = shift;
 
221
   $self->{'_pam'} = shift @_ if @_;
 
222
   return $self->{'_pam'};
 
223
}
 
224
 
 
225
=head2 mutation_count
 
226
 
 
227
 Title   : mutation_count
 
228
 Usage   : $obj->mutation_count($newval)
 
229
 Function: Set the number of wanted mutations to the sequence 
 
230
 Returns : value of mutation_count
 
231
 Args    : newvalue (optional)
 
232
 
 
233
=cut
 
234
 
 
235
sub mutation_count{
 
236
   my $self = shift;
 
237
   $self->{'_mutation_count'} = shift @_ if @_;
 
238
   return $self->{'_mutation_count'};
 
239
}
 
240
 
 
241
 
 
242
 
 
243
=head2 seq
 
244
 
 
245
 Title   : seq
 
246
 Usage   : $obj->seq($newval)
 
247
 Function: Set the sequence object for the original sequence
 
248
 Returns : The sequence object
 
249
 Args    : newvalue (optional)
 
250
 
 
251
Setting this will reset mutation and generated mutation counters.
 
252
 
 
253
=cut
 
254
 
 
255
sub seq {
 
256
   my $self = shift;
 
257
   if (@_) {
 
258
       $self->{'_seq'} = shift @_ ;
 
259
       return $self->{'_seq'};
 
260
       $self->reset_mutation_counter;
 
261
       $self->reset_sequence_counter;
 
262
   }
 
263
   return $self->{'_seq'};
 
264
}
 
265
 
 
266
=head2 seq_type
 
267
 
 
268
 Title   : seq_type
 
269
 Usage   : $obj->seq_type($newval)
 
270
 Function: Set the returned seq_type to one needed
 
271
 Returns : value of seq_type
 
272
 Args    : newvalue (optional)
 
273
 
 
274
Defaults to Bio::PrimarySeq.
 
275
 
 
276
=cut
 
277
 
 
278
sub seq_type{
 
279
   my $self = shift;
 
280
   if (@_) {
 
281
       $self->{'_seq_type'} = shift @_;
 
282
       $self->_load_module($self->{'_seq_type'});
 
283
   }
 
284
   return $self->{'_seq_type'} || 'Bio::PrimarySeq';
 
285
}
 
286
 
 
287
 
 
288
=head2 get_mutation_counter
 
289
 
 
290
 Title   : get_mutation_counter
 
291
 Usage   : $obj->get_mutation_counter()
 
292
 Function: Get the count of sequences created
 
293
 Returns : value of counter
 
294
 Args    : -
 
295
 
 
296
=cut
 
297
 
 
298
sub get_mutation_counter{
 
299
   return shift->{'_mutation_counter'};
 
300
}
 
301
 
 
302
 
 
303
=head2 reset_mutation_counter
 
304
 
 
305
 Title   : reset_mutation_counter
 
306
 Usage   : $obj->reset_mutation_counter()
 
307
 Function: Resert the counter of mutations
 
308
 Returns : value of counter
 
309
 Args    : -
 
310
 
 
311
=cut
 
312
 
 
313
sub reset_mutation_counter{
 
314
   shift->{'_mutation_counter'} = 0;
 
315
   return 1;
 
316
}
 
317
 
 
318
 
 
319
=head2 get_sequence_counter
 
320
 
 
321
 Title   : get_sequence_counter
 
322
 Usage   : $obj->get_sequence_counter()
 
323
 Function: Get the count of sequences created
 
324
 Returns : value of counter
 
325
 Args    : -
 
326
 
 
327
=cut
 
328
 
 
329
sub get_sequence_counter{
 
330
   return shift->{'_sequence_counter'};
 
331
}
 
332
 
 
333
=head2 reset_sequence_counter
 
334
 
 
335
 Title   : reset_sequence_counter
 
336
 Usage   : $obj->reset_sequence_counter()
 
337
 Function: Resert the counter of sequences created
 
338
 Returns : value of counter
 
339
 Args    : -
 
340
 
 
341
This is called when ever mutated sequences are reassigned new values
 
342
using methods seq() and mutated_seq().  As a side affect, this method
 
343
also recreates the intermal alignment that is used to calculate the
 
344
sequence identity.
 
345
 
 
346
=cut
 
347
 
 
348
sub reset_sequence_counter{
 
349
   my $self = shift;
 
350
   $self->{'_sequence_counter'} = 0;
 
351
   $self->_init_alignment;
 
352
   return 1;
 
353
}
 
354
 
 
355
 
 
356
 
 
357
=head2 each_seq
 
358
 
 
359
 Title   : each_seq
 
360
 Usage   : $obj->each_seq($int)
 
361
 Function:
 
362
 Returns : an array of sequences mutated from the reference sequence
 
363
           according to evolutionary parameters given
 
364
 Args    : -
 
365
 
 
366
=cut
 
367
 
 
368
sub each_seq{
 
369
   my $self = shift;
 
370
   my $number = shift;
 
371
 
 
372
   $self->throw("[$number] ". ' should be a positive integer')
 
373
       unless $number =~ /^[+\d]+$/;
 
374
 
 
375
   my @array;
 
376
   for (my $count=1; $count<$number; $count++) {
 
377
       push @array, $self->next_seq();
 
378
 
 
379
   }
 
380
   return @array;
 
381
}
 
382
 
 
383
 
 
384
 
 
385
=head2 each_mutation
 
386
 
 
387
  Title   : each_mutation
 
388
  Usage   : $obj->each_mutation
 
389
  Function: return the mutations leading to the last generated 
 
390
            sequence in objects 
 
391
  Returns : an array of Bio::Variation::DNAMutation objects
 
392
  Args    : optional argument to return an array of  stringified names
 
393
 
 
394
=cut
 
395
 
 
396
sub each_mutation {
 
397
    my $self = shift;
 
398
    my $string = shift;
 
399
 
 
400
    return @{$self->{'_mutations'}} if $string;
 
401
 
 
402
    return map {
 
403
        /(\d+)(\w*)>(\w*)/;
 
404
#        print;
 
405
        my $dnamut = Bio::Variation::DNAMutation->new
 
406
            ('-start'         => $1,
 
407
             '-end'           => $1,
 
408
             '-length'        => 1,
 
409
             '-isMutation'    => 1
 
410
            );
 
411
        $dnamut->allele_ori( Bio::Variation::Allele->new(-seq => $2,
 
412
                                                         -alphabet => 'dna') );
 
413
        $dnamut->add_Allele( Bio::Variation::Allele->new(-seq => $3,
 
414
                                                         -alphabet => 'dna') );
 
415
        $dnamut;
 
416
    } @{$self->{'_mutations'}}
 
417
}
 
418
 
 
419
 
 
420
sub get_alignment_identity  {
 
421
    my $self = shift;
 
422
    return $self->{'_align'}->overall_percentage_identity;
 
423
}
 
424
 
 
425
 
 
426
sub get_alignmet {
 
427
   my $self = shift;
 
428
   return $self->{'_align'}->remove_gaps('-', 'all-gaps');
 
429
}
 
430
 
 
431
 
 
432
=head1 Internal methods
 
433
 
 
434
=cut
 
435
 
 
436
 
 
437
=head2 _increase_mutation_counter
 
438
 
 
439
 Title   : _increase_mutation_counter
 
440
 Usage   : $obj->_increase_mutation_counter()
 
441
 Function: Internal method to increase the counter of mutations performed
 
442
 Returns : value of counter
 
443
 Args    : -
 
444
 
 
445
=cut
 
446
 
 
447
sub _increase_mutation_counter{
 
448
   return shift->{'_mutation_counter'}++;
 
449
}
 
450
 
 
451
 
 
452
 
 
453
=head2 _increase_sequence_counter
 
454
 
 
455
 Title   : _increase_sequence_counter
 
456
 Usage   : $obj->_increase_sequence_counter()
 
457
 Function: Internal method to increase the counter of sequences created
 
458
 Returns : value of counter
 
459
 Args    : -
 
460
 
 
461
=cut
 
462
 
 
463
sub _increase_sequence_counter{
 
464
   return shift->{'_sequence_counter'}++;
 
465
}
 
466
 
 
467
 
 
468
1;
 
469