← Back to branch summary

~ubuntu-branches/ubuntu/raring/bioperl/raring

« back to all changes in this revision

Viewing changes to Bio/Seq/SeqBuilder.pm

  • Committer: Bazaar Package Importer
  • Author(s): Charles Plessy
  • Date: 2008-03-18 14:44:57 UTC
  • mfrom: (4 hardy)
  • mto: This revision was merged to the branch mainline in revision 6.
  • Revision ID: james.westby@ubuntu.com-20080318144457-1jjoztrvqwf0gruk
http://bugs.debian.org/448890
* debian/control:
  - Removed MIA Matt Hope (dopey) from the Uploaders field.
    Thank you for your work, Matt. I hope you are doing well.
  - Downgraded some recommended package to the 'Suggests' priority,
    according to the following discussion on Upstream's mail list.
    http://bioperl.org/pipermail/bioperl-l/2008-March/027379.html
    (Closes: #448890)
* debian/copyright converted to machine-readable format.

Show diffs side-by-side

added added

removed removed

Lines of Context:
Bio/Seq/SeqBuilder.pm
1
 
# $Id: SeqBuilder.pm,v 1.6 2002/10/22 07:45:20 lapp Exp $
 
1
# $Id: SeqBuilder.pm,v 1.9.4.1 2006/10/02 23:10:27 sendu Exp $
2
2
#
3
3
# BioPerl module for Bio::Seq::SeqBuilder
4
4
#
32
32
 
33
33
   use Bio::SeqIO;
34
34
 
35
 
   # usually you won't instantiate this yourself -- a SeqIO object
36
 
   # will have one already
 
35
   # usually you won't instantiate this yourself - a SeqIO object -
 
36
   # you will have one already
37
37
   my $seqin = Bio::SeqIO->new(-fh => \*STDIN, -format => "genbank");
38
38
   my $builder = $seqin->sequence_builder();
39
39
 
69
69
easy-to-use configurator of the parsing flow.
70
70
 
71
71
Configuring the parsing process may be for you if you need much less
72
 
information, or much less sequences, than the stream actually
 
72
information, or much less sequence, than the stream actually
73
73
contains. Configuration can in both cases speed up the parsing time
74
74
considerably, because unwanted sections or the rest of unwanted
75
 
sequences are skipped over by the parser.
 
75
sequences are skipped over by the parser. This configuration could
 
76
also conserve memory if you're running out of available RAM.
76
77
 
77
78
See the methods of the class-specific implementation section for
78
79
further documentation of what can be configured.
85
86
Bioperl modules. Send your comments and suggestions preferably to
86
87
the Bioperl mailing list.  Your participation is much appreciated.
87
88
 
88
 
  bioperl-l@bioperl.org              - General discussion
89
 
  http://bioperl.org/MailList.shtml  - About the mailing lists
 
89
  bioperl-l@bioperl.org                  - General discussion
 
90
  http://bioperl.org/wiki/Mailing_lists  - About the mailing lists
90
91
 
91
92
=head2 Reporting Bugs
92
93
 
93
94
Report bugs to the Bioperl bug tracking system to help us keep track
94
95
of the bugs and their resolution. Bug reports can be submitted via
95
 
email or the web:
 
96
the web:
96
97
 
97
 
  bioperl-bugs@bioperl.org
98
 
  http://bugzilla.bioperl.org/
 
98
  http://bugzilla.open-bio.org/
99
99
 
100
100
=head1 AUTHOR - Hilmar Lapp
101
101
 
102
102
Email hlapp at gmx.net
103
103
 
104
 
=head1 CONTRIBUTORS
105
 
 
106
 
Additional contributors names and emails here
107
 
 
108
104
=head1 APPENDIX
109
105
 
110
106
The rest of the documentation details each of the object methods.
117
113
 
118
114
 
119
115
package Bio::Seq::SeqBuilder;
120
 
use vars qw(@ISA);
121
116
use strict;
122
117
 
123
118
# Object preamble - inherits from Bio::Root::Root
124
119
 
125
 
use Bio::Root::Root;
126
 
use Bio::Factory::ObjectBuilderI;
127
120
 
128
 
@ISA = qw(Bio::Root::Root Bio::Factory::ObjectBuilderI);
 
121
use base qw(Bio::Root::Root Bio::Factory::ObjectBuilderI);
129
122
 
130
123
my %slot_param_map = ("add_SeqFeature" => "features",
131
124
                      );
140
133
 Returns : an instance of Bio::Seq::SeqBuilder
141
134
 Args    :
142
135
 
143
 
 
144
136
=cut
145
137
 
146
138
sub new {
147
139
    my($class,@args) = @_;
148
 
    
 
140
 
149
141
    my $self = $class->SUPER::new(@args);
150
 
    
 
142
 
151
143
    $self->{'wanted_slots'} = [];
152
144
    $self->{'unwanted_slots'} = [];
153
145
    $self->{'object_conds'} = [];
186
178
=cut
187
179
 
188
180
sub want_slot{
189
 
    my ($self,$slot) = @_;
190
 
    my $ok = 0;
 
181
        my ($self,$slot) = @_;
 
182
        my $ok = 0;
191
183
 
192
 
    $slot = substr($slot,1) if substr($slot,0,1) eq '-';
193
 
    if($self->want_all()) {
 
184
        $slot = substr($slot,1) if substr($slot,0,1) eq '-';
 
185
        if($self->want_all()) {
194
186
        foreach ($self->get_unwanted_slots()) {
195
 
            # this always overrides in want-all mode
196
 
            return 0 if($slot eq $_);
 
187
                # this always overrides in want-all mode
 
188
                return 0 if($slot eq $_);
197
189
        }
198
190
        if(! exists($self->{'_objskel'})) {
199
 
            $self->{'_objskel'} = $self->sequence_factory->create_object();
 
191
                $self->{'_objskel'} = $self->sequence_factory->create_object();
200
192
        }
201
193
        if(exists($param_slot_map{$slot})) {
202
 
            $ok = $self->{'_objskel'}->can($param_slot_map{$slot});
 
194
                $ok = $self->{'_objskel'}->can($param_slot_map{$slot});
203
195
        } else {
204
 
            $ok = $self->{'_objskel'}->can($slot);
 
196
                $ok = $self->{'_objskel'}->can($slot);
205
197
        }
206
198
        return $ok if $ok;
207
199
        # even if the object 'cannot' do this slot, it might have been
208
200
        # added to the list of wanted slot, so carry on
209
 
    }
210
 
    foreach ($self->get_wanted_slots()) {
211
 
        if($slot eq $_) {
212
 
            $ok = 1;
213
 
            last;
 
201
}
 
202
        foreach ($self->get_wanted_slots()) {
 
203
                if($slot eq $_) {
 
204
                        $ok = 1;
 
205
                        last;
 
206
                }
214
207
        }
215
 
    }
216
 
    return $ok;
 
208
        return $ok;
217
209
}
218
210
 
219
211
=head2 add_slot_value
255
247
           starting with a dash, and each element at an odd index is
256
248
           the value of the preceding name.
257
249
 
258
 
 
259
250
=cut
260
251
 
261
252
sub add_slot_value{
262
 
    my ($self,$slot,@args) = @_;
 
253
        my ($self,$slot,@args) = @_;
263
254
 
264
 
    my $h = $self->{'_objhash'};
265
 
    return unless $h;
266
 
    # multiple named parameter variant of calling?
267
 
    if((@args > 1) && (@args % 2) && (substr($slot,0,1) eq '-')) {
268
 
        unshift(@args, $slot);
269
 
        while(@args) {
270
 
            my $key = shift(@args);
271
 
            $h->{$key} = shift(@args);
272
 
        }
273
 
    } else {
274
 
        if($slot eq 'add_SeqFeature') {
275
 
            $slot = '-'.$slot_param_map{$slot};
276
 
            $h->{$slot} = [] unless $h->{$slot};
277
 
            push(@{$h->{$slot}}, @args);
 
255
        my $h = $self->{'_objhash'};
 
256
        return unless $h;
 
257
        # multiple named parameter variant of calling?
 
258
        if((@args > 1) && (@args % 2) && (substr($slot,0,1) eq '-')) {
 
259
                unshift(@args, $slot);
 
260
                while(@args) {
 
261
                        my $key = shift(@args);
 
262
                        $h->{$key} = shift(@args);
 
263
                }
278
264
        } else {
279
 
            $slot = '-'.$slot unless substr($slot,0,1) eq '-';
280
 
            $h->{$slot} = $args[0];
 
265
                if($slot eq 'add_SeqFeature') {
 
266
                        $slot = '-'.$slot_param_map{$slot};
 
267
                        $h->{$slot} = [] unless $h->{$slot};
 
268
                        push(@{$h->{$slot}}, @args);
 
269
                } else {
 
270
                        $slot = '-'.$slot unless substr($slot,0,1) eq '-';
 
271
                        $h->{$slot} = $args[0];
 
272
                }
281
273
        }
282
 
    }
283
 
    return 1;
 
274
        return 1;
284
275
}
285
276
 
286
277
=head2 want_object
303
294
           the present object, and FALSE otherwise.
304
295
 Args    : none
305
296
 
306
 
 
307
297
=cut
308
298
 
309
299
sub want_object{
310
 
    my $self = shift;
 
300
        my $self = shift;
311
301
 
312
 
    my $ok = 1;
313
 
    foreach my $cond ($self->get_object_conditions()) {
314
 
        $ok = &$cond($self->{'_objhash'});
315
 
        last unless $ok;
316
 
    }
317
 
    delete $self->{'_objhash'} unless $ok;
318
 
    return $ok;
 
302
        my $ok = 1;
 
303
        foreach my $cond ($self->get_object_conditions()) {
 
304
                $ok = &$cond($self->{'_objhash'});
 
305
                last unless $ok;
 
306
        }
 
307
        delete $self->{'_objhash'} unless $ok;
 
308
        return $ok;
319
309
}
320
310
 
321
311
=head2 make_object
338
328
 Returns : the object that was built
339
329
 Args    : none
340
330
 
341
 
 
342
331
=cut
343
332
 
344
333
sub make_object{
345
 
    my $self = shift;
 
334
        my $self = shift;
346
335
 
347
 
    my $obj;
348
 
    if(exists($self->{'_objhash'}) && %{$self->{'_objhash'}}) {
349
 
        $obj = $self->sequence_factory->create_object(%{$self->{'_objhash'}});
350
 
    }
351
 
    $self->{'_objhash'} = {}; # reset
352
 
    return $obj;
 
336
        my $obj;
 
337
        if(exists($self->{'_objhash'}) && %{$self->{'_objhash'}}) {
 
338
                $obj = $self->sequence_factory->create_object(%{$self->{'_objhash'}});
 
339
        }
 
340
        $self->{'_objhash'} = {}; # reset
 
341
        return $obj;
353
342
}
354
343
 
355
344
=head1 Implementation specific methods
393
382
=cut
394
383
 
395
384
sub get_wanted_slots{
396
 
    my $self = shift;
 
385
        my $self = shift;
397
386
 
398
 
    return @{$self->{'wanted_slots'}};
 
387
        return @{$self->{'wanted_slots'}};
399
388
}
400
389
 
401
390
=head2 add_wanted_slot
407
396
 Returns : TRUE
408
397
 Args    : an array of slot names (strings)
409
398
 
410
 
 
411
399
=cut
412
400
 
413
401
sub add_wanted_slot{
414
 
    my ($self,@slots) = @_;
 
402
        my ($self,@slots) = @_;
415
403
 
416
 
    my $myslots = $self->{'wanted_slots'};
417
 
    foreach my $slot (@slots) {
418
 
        if(! grep { $slot eq $_; } @$myslots) {
419
 
            push(@$myslots, $slot);
 
404
        my $myslots = $self->{'wanted_slots'};
 
405
        foreach my $slot (@slots) {
 
406
                if(! grep { $slot eq $_; } @$myslots) {
 
407
                        push(@$myslots, $slot);
 
408
                }
420
409
        }
421
 
    }
422
 
    return 1;
 
410
        return 1;
423
411
}
424
412
 
425
413
=head2 remove_wanted_slots
432
420
 Returns : the previous list of wanted slot names
433
421
 Args    : none
434
422
 
435
 
 
436
423
=cut
437
424
 
438
425
sub remove_wanted_slots{
439
 
    my $self = shift;
440
 
    my @slots = $self->get_wanted_slots();
441
 
    $self->{'wanted_slots'} = [];
442
 
    return @slots;
 
426
        my $self = shift;
 
427
        my @slots = $self->get_wanted_slots();
 
428
        $self->{'wanted_slots'} = [];
 
429
        return @slots;
443
430
}
444
431
 
445
432
=head2 get_unwanted_slots
451
438
 Returns : a list of strings
452
439
 Args    : none
453
440
 
454
 
 
455
441
=cut
456
442
 
457
443
sub get_unwanted_slots{
458
 
    my $self = shift;
 
444
        my $self = shift;
459
445
 
460
 
    return @{$self->{'unwanted_slots'}};
 
446
        return @{$self->{'unwanted_slots'}};
461
447
}
462
448
 
463
449
=head2 add_unwanted_slot
469
455
 Returns : TRUE
470
456
 Args    : an array of slot names (strings)
471
457
 
472
 
 
473
458
=cut
474
459
 
475
460
sub add_unwanted_slot{
476
 
    my ($self,@slots) = @_;
 
461
        my ($self,@slots) = @_;
477
462
 
478
 
    my $myslots = $self->{'unwanted_slots'};
479
 
    foreach my $slot (@slots) {
480
 
        if(! grep { $slot eq $_; } @$myslots) {
481
 
            push(@$myslots, $slot);
 
463
        my $myslots = $self->{'unwanted_slots'};
 
464
        foreach my $slot (@slots) {
 
465
                if(! grep { $slot eq $_; } @$myslots) {
 
466
                        push(@$myslots, $slot);
 
467
                }
482
468
        }
483
 
    }
484
 
    return 1;
 
469
        return 1;
485
470
}
486
471
 
487
472
=head2 remove_unwanted_slots
494
479
 Returns : the previous list of unwanted slot names
495
480
 Args    : none
496
481
 
497
 
 
498
482
=cut
499
483
 
500
484
sub remove_unwanted_slots{
501
 
    my $self = shift;
502
 
    my @slots = $self->get_unwanted_slots();
503
 
    $self->{'unwanted_slots'} = [];
504
 
    return @slots;
 
485
        my $self = shift;
 
486
        my @slots = $self->get_unwanted_slots();
 
487
        $self->{'unwanted_slots'} = [];
 
488
        return @slots;
505
489
}
506
490
 
507
491
=head2 want_none
520
504
 Returns : TRUE
521
505
 Args    : none
522
506
 
523
 
 
524
507
=cut
525
508
 
526
509
sub want_none{
527
 
    my $self = shift;
 
510
        my $self = shift;
528
511
 
529
 
    $self->want_all(0);
530
 
    $self->remove_wanted_slots();
531
 
    $self->remove_unwanted_slots();
532
 
    return 1;
 
512
        $self->want_all(0);
 
513
        $self->remove_wanted_slots();
 
514
        $self->remove_unwanted_slots();
 
515
        return 1;
533
516
}
534
517
 
535
518
=head2 want_all
550
533
           FALSE otherwise.
551
534
 Args    : on set, new value (a scalar or undef, optional)
552
535
 
553
 
 
554
536
=cut
555
537
 
556
538
sub want_all{
557
 
    my $self = shift;
 
539
        my $self = shift;
558
540
 
559
 
    return $self->{'want_all'} = shift if @_;
560
 
    return $self->{'want_all'};
 
541
        return $self->{'want_all'} = shift if @_;
 
542
        return $self->{'want_all'};
561
543
}
562
544
 
563
545
=head2 get_object_conditions
579
561
 Returns : a list of closures
580
562
 Args    : none
581
563
 
582
 
 
583
564
=cut
584
565
 
585
566
sub get_object_conditions{
586
 
    my $self = shift;
 
567
        my $self = shift;
587
568
 
588
 
    return @{$self->{'object_conds'}};
 
569
        return @{$self->{'object_conds'}};
589
570
}
590
571
 
591
572
=head2 add_object_condition
608
589
 Returns : TRUE
609
590
 Args    : the list of conditions
610
591
 
611
 
 
612
592
=cut
613
593
 
614
594
sub add_object_condition{
615
 
    my ($self,@conds) = @_;
 
595
        my ($self,@conds) = @_;
616
596
 
617
 
    if(grep { ref($_) ne 'CODE'; } @conds) {
618
 
        $self->throw("conditions against which to validate an object ".
619
 
                     "must be anonymous code blocks");
620
 
    }
621
 
    push(@{$self->{'object_conds'}}, @conds);
622
 
    return 1;
 
597
        if(grep { ref($_) ne 'CODE'; } @conds) {
 
598
                $self->throw("conditions against which to validate an object ".
 
599
                                                 "must be anonymous code blocks");
 
600
        }
 
601
        push(@{$self->{'object_conds'}}, @conds);
 
602
        return 1;
623
603
}
624
604
 
625
605
=head2 remove_object_conditions
632
612
 Returns : The list of previously set conditions (an array of closures)
633
613
 Args    : none
634
614
 
635
 
 
636
615
=cut
637
616
 
638
617
sub remove_object_conditions{
639
 
    my $self = shift;
640
 
    my @conds = $self->get_object_conditions();
641
 
    $self->{'object_conds'} = [];
642
 
    return @conds;
 
618
        my $self = shift;
 
619
        my @conds = $self->get_object_conditions();
 
620
        $self->{'object_conds'} = [];
 
621
        return @conds;
643
622
}
644
623
 
645
624
=head1 Methods to control what type of object is built
657
636
 Args    : on set, new value (a Bio::Factory::SequenceFactoryI
658
637
           implementing object or undef, optional)
659
638
 
660
 
 
661
639
=cut
662
640
 
663
641
sub sequence_factory{
664
 
    my $self = shift;
 
642
        my $self = shift;
665
643
 
666
 
    if(@_) {
667
 
        delete $self->{'_objskel'};
668
 
        return $self->{'sequence_factory'} = shift;
669
 
    }
670
 
    return $self->{'sequence_factory'};
 
644
        if(@_) {
 
645
                delete $self->{'_objskel'};
 
646
                return $self->{'sequence_factory'} = shift;
 
647
        }
 
648
        return $self->{'sequence_factory'};
671
649
}
672
650
 
673
651
1;