← Back to branch summary

~ubuntu-branches/ubuntu/trusty/bioperl/trusty

« back to all changes in this revision

Viewing changes to Bio/DB/SeqFeature/Store/memory.pm

  • Committer: Bazaar Package Importer
  • Author(s): Charles Plessy
  • Date: 2011-06-17 13:51:18 UTC
  • mfrom: (3.1.6 sid)
  • Revision ID: james.westby@ubuntu.com-20110617135118-hncy38e0134j8oi5
Tags: 1.6.901-1
* New upstream release.
* Point debian/watch to search.cpan.org.
* Build using dh and overrides:
  - Use Debhelper 8 (debian/rules, debian/control).
  - Simplified debian/rules.
* Split into libbio-perl-perl, as discussed with the Debian Perl team.
  (debian/control, debian/bioperl.install, debian libbio-perl-perl.install)
* debian/control:
  - Incremented Standards-Version to reflect conformance with Policy 3.9.2.
    No other changes needed.
  - Vcs-Browser URL made redirectable to viewvc.
  - Removed useless ‘svn’ in the Vcs-Svn URL.

Show diffs side-by-side

added added

removed removed

Lines of Context:
Bio/DB/SeqFeature/Store/memory.pm
11
11
  # Open the sequence database
12
12
  my $db      = Bio::DB::SeqFeature::Store->new( -adaptor => 'memory',
13
13
                                                 -dsn     => '/var/databases/test');
14
 
 
15
14
  # search... by id
16
15
  my @features = $db->fetch_many(@list_of_ids);
17
16
 
22
21
  @features = $db->get_features_by_alias('sma-3');
23
22
 
24
23
  # ...by type
25
 
  @features = $db->get_features_by_name('gene');
 
24
  @features = $db->get_features_by_type('gene');
26
25
 
27
26
  # ...by location
28
27
  @features = $db->get_features_by_location(-seq_id=>'Chr1',-start=>4000,-end=>600000);
83
82
 
84
83
Before using the memory adaptor, populate a readable-directory on the
85
84
file system with annotation and/or sequence files. The annotation
86
 
files must be in GFF3 format, and shold end in the extension .gff or
 
85
files must be in GFF3 format, and sholud end in the extension .gff or
87
86
.gff3. They may be compressed with "compress", "gzip" or "bzip2" (in
88
87
which case the appropriate compression extension must be present as
89
88
well.)
109
108
  $db  = Bio::DB::SeqFeature::Store->new( -adaptor => 'memory',
110
109
                                          -dsn     => '/usr/annotations/worm.gff3.gz');
111
110
 
112
 
For compatibility with the Bio::DB::GFF memory adapter, -gff is
 
111
For compatibility with the Bio::DB::GFF memory adaptor, -gff is
113
112
recognized as an alias for -dsn.
114
113
 
115
114
See L<Bio::DB::SeqFeature::Store> for all the access methods supported
120
119
 
121
120
=cut
122
121
 
123
 
# $Id: memory.pm 15635 2009-04-14 19:11:13Z cjfields $
124
122
use strict;
125
123
use base 'Bio::DB::SeqFeature::Store';
126
124
use Bio::DB::SeqFeature::Store::GFF3Loader;
136
134
# object initialization
137
135
#
138
136
sub init {
139
 
  my $self          = shift;
140
 
  my $args          = shift;
 
137
  my ($self, $args) = @_;
141
138
  $self->SUPER::init($args);
142
 
  $self->{_data}     = [];
 
139
  $self->{_data}     = {};
143
140
  $self->{_children} = {};
144
141
  $self->{_index}    = {};
145
142
  $self;
156
153
  my @argv;
157
154
  if (-d $file_or_dir) {
158
155
    @argv = (
 
156
             bsd_glob("$file_or_dir/*.size*"),
159
157
             bsd_glob("$file_or_dir/*.gff"),            bsd_glob("$file_or_dir/*.gff3"),
160
158
             bsd_glob("$file_or_dir/*.gff.{gz,Z,bz2}"), bsd_glob("$file_or_dir/*.gff3.{gz,Z,bz2}")
161
159
             );
164
162
  }
165
163
  local $self->{file_or_dir} = $file_or_dir;
166
164
  $loader->load(@argv);
 
165
  warn $@ if $@;
167
166
}
168
167
 
169
168
sub commit { # reindex fasta files
170
169
  my $self = shift;
171
170
 
 
171
  my $db;
172
172
  if (my $fh = $self->{fasta_fh}) {
173
173
      $fh->close;
174
 
      $self->{fasta_db} = Bio::DB::Fasta->new($self->{fasta_file});
 
174
      $db = Bio::DB::Fasta->new($self->{fasta_file});
175
175
  } elsif (exists $self->{file_or_dir} && -d $self->{file_or_dir}) {
176
 
      $self->{fasta_db} = Bio::DB::Fasta->new($self->{file_or_dir});
 
176
      $db = Bio::DB::Fasta->new($self->{file_or_dir});
177
177
  }
 
178
  $self->{fasta_db} = $db if $db;
178
179
}
179
180
 
180
181
sub can_store_parentage { 1 }
181
182
 
182
 
# return an array ref in which each index is primary id
 
183
# return a hash ref in which each key is primary id
183
184
sub data {
184
185
  shift->{_data};
185
186
}
189
190
sub _store {
190
191
  my $self    = shift;
191
192
  my $indexed = shift;
192
 
  my $data    = $self->data;
 
193
  my @objs    = @_;
 
194
  my $data = $self->data;
193
195
  my $count = 0;
194
 
  for my $obj (@_) {
195
 
    my $primary_id = $obj->primary_id;
196
 
    $primary_id    = 1 + @{$data} unless $primary_id;  # primary id of 0 causes a downstream bug
197
 
    $self->data->[$primary_id] = $obj;
 
196
  for my $obj (@objs) {
 
197
    # Add unique ID to feature if needed
 
198
    my $primary_id = $self->_autoid($obj);
 
199
    # Store feature (overwriting any existing feature with the same primary ID
 
200
    # as required by Bio::DB::SF::Store)
 
201
    $data->{$primary_id} = $obj;
 
202
    if ($indexed) {
 
203
      $self->{_index}{ids}{$primary_id} = undef;
 
204
      $self->_update_indexes($obj);
 
205
    }
 
206
    $count++;
 
207
  }
 
208
  return $count;
 
209
}
 
210
 
 
211
 
 
212
sub _autoid {
 
213
  # If a feature has no ID, assign it a unique ID
 
214
  my ($self, $obj) = @_;
 
215
  my $data = $self->data;
 
216
  my $primary_id = $obj->primary_id;
 
217
  if (not defined $primary_id) {
 
218
    # Create a unique ID
 
219
    $primary_id = 1 + scalar keys %{$data};
 
220
    while (exists $data->{$primary_id}) {
 
221
      $primary_id++;
 
222
    }
198
223
    $obj->primary_id($primary_id);
199
 
    $self->{_index}{ids}{$primary_id} = undef if $indexed;
200
 
    $self->_update_indexes($obj) if $indexed;
201
 
    $count++;
202
 
  }
203
 
  $count;
 
224
  }
 
225
  return $primary_id;
 
226
}
 
227
 
 
228
 
 
229
sub _deleteid {
 
230
  my ($self, $id) = @_;
 
231
  if (exists $self->{_index}{ids}{$id}) {
 
232
    # $indexed was true
 
233
    $self->_update_indexes( $self->fetch($id), 1 );
 
234
    delete $self->{_index}{ids}{$id};
 
235
  }
 
236
  delete $self->data->{$id};
 
237
  return 1;
204
238
}
205
239
 
206
240
sub _fetch {
207
 
  my $self = shift;
208
 
  my $id   = shift;
209
 
  my $data = $self->data;
210
 
  return $data->[$id];
 
241
  my ($self, $id) = @_;
 
242
  return $self->data->{$id};
211
243
}
212
244
 
213
245
sub _add_SeqFeature {
214
 
  my $self = shift;
215
 
  my $parent   = shift;
216
 
  my @children = @_;
217
 
  my $parent_id = (ref $parent ? $parent->primary_id : $parent);
218
 
  defined $parent_id or $self->throw("$parent should have a primary_id");
 
246
  my ($self, $parent, @children) = @_;
 
247
  my $count = 0;
 
248
  my $parent_id = ref $parent ? $parent->primary_id : $parent;
 
249
  defined $parent_id or $self->throw("Parent $parent should have a primary ID");
219
250
  for my $child (@children) {
220
251
    my $child_id = ref $child ? $child->primary_id : $child;
221
 
    defined $child_id or $self->throw("no primary ID known for $child");
 
252
    defined $child_id or $self->throw("Child $child should have a primary ID");
222
253
    $self->{_children}{$parent_id}{$child_id}++;
 
254
    $count++;
223
255
  }
 
256
  return $count;
224
257
}
225
258
 
226
259
sub _fetch_SeqFeatures {
227
 
  my $self   = shift;
228
 
  my $parent = shift;
229
 
  my @types  = @_;
 
260
  my ($self, $parent, @types) = @_;
230
261
  my $parent_id = $parent->primary_id;
231
 
  defined $parent_id or $self->throw("$parent should have a primary_id");
 
262
  defined $parent_id or $self->throw("Parent $parent should have a primary ID");
232
263
  my @children_ids  = keys %{$self->{_children}{$parent_id}};
233
264
  my @children      = map {$self->fetch($_)} @children_ids;
234
 
 
 
265
  
235
266
  if (@types) {
236
 
    my $regexp = join '|',map {quotemeta($_)} $self->find_types(@types);
237
 
    return grep {($_->primary_tag.':'.$_->source_tag) =~ /^$regexp$/i} @children;
238
 
  } else {
239
 
    return @children;
 
267
    my $data;
 
268
    for my $c (@children) {
 
269
      push @{$$data{$c->primary_tag}{$c->source_tag||''}}, $c;
 
270
    }
 
271
    @children = ();
 
272
    for my $type (@types) {
 
273
      $type .= ':' if (not $type =~ m/:/);
 
274
      my ($primary_tag, undef, $source_tag) = ($type =~ m/^(.*?)(:(.*?))$/);
 
275
      $source_tag ||= '';
 
276
      if ($source_tag eq '') {
 
277
        for my $source (keys %{$$data{$primary_tag}}) {
 
278
          if (exists $$data{$primary_tag}{$source_tag}) {
 
279
            push @children, @{$$data{$primary_tag}{$source_tag}};
 
280
          }
 
281
        }
 
282
      } else {
 
283
        if (exists $$data{$primary_tag}{$source_tag}) {
 
284
          push @children, @{$$data{$primary_tag}{$source_tag}};
 
285
        }
 
286
      }
 
287
    }
240
288
  }
 
289
 
 
290
  return @children;
241
291
}
242
292
 
243
293
sub _update_indexes {
244
 
  my $self = shift;
245
 
  my $obj  = shift;
246
 
  defined (my $id   = $obj->primary_id) or return;
247
 
  $self->_update_name_index($obj,$id);
248
 
  $self->_update_type_index($obj,$id);
249
 
  $self->_update_location_index($obj,$id);
250
 
  $self->_update_attribute_index($obj,$id);
 
294
  my ($self, $obj, $del) = @_;
 
295
  defined (my $id = $obj->primary_id) or return;
 
296
  $del ||= 0;
 
297
  $self->_update_name_index($obj,$id, $del);
 
298
  $self->_update_type_index($obj,$id, $del);
 
299
  $self->_update_location_index($obj, $id, $del);
 
300
  $self->_update_attribute_index($obj,$id, $del);
251
301
}
252
302
 
253
303
sub _update_name_index {
254
 
  my $self = shift;
255
 
  my ($obj,$id) = @_;
256
 
  my ($names,$aliases) = $self->feature_names($obj);
 
304
  my ($self, $obj, $id, $del) = @_;
 
305
  my ($names, $aliases) = $self->feature_names($obj);
257
306
  foreach (@$names) {
258
 
    $self->{_index}{name}{lc $_}{$id}   = 1;
 
307
    if (not $del) {
 
308
      $self->{_index}{name}{lc $_}{$id}   = 1;
 
309
    } else {
 
310
      delete $self->{_index}{name}{lc $_}{$id};
 
311
      if (scalar keys %{ $self->{_index}{name}{lc $_} } == 0) {
 
312
        delete $self->{_index}{name}{lc $_};
 
313
      }
 
314
    };
259
315
  }
260
316
  foreach (@$aliases) {
261
 
    $self->{_index}{name}{lc $_}{$id} ||= 2;
 
317
    if (not $del) {
 
318
      $self->{_index}{name}{lc $_}{$id} ||= 2;
 
319
    } else {
 
320
      delete $self->{_index}{name}{lc $_}{$id};
 
321
      if (scalar keys %{ $self->{_index}{name}{lc $_} } == 0) {
 
322
        delete $self->{_index}{name}{lc $_};
 
323
      }
 
324
    }
262
325
  }
263
326
}
264
327
 
265
328
sub _update_type_index {
266
 
  my $self = shift;
267
 
  my ($obj,$id) = @_;
268
 
 
269
 
  my $primary_tag = $obj->primary_tag;
270
 
  my $source_tag  = $obj->source_tag || '';
271
 
  return unless defined $primary_tag;
272
 
 
273
 
  $primary_tag    .= ":$source_tag";
274
 
  $self->{_index}{type}{lc $primary_tag}{$id} = undef;
 
329
  my ($self, $obj, $id, $del) = @_;
 
330
  my $primary_tag = lc($obj->primary_tag) || return;
 
331
  my $source_tag  = lc($obj->source_tag || '');
 
332
  if (not $del) {
 
333
    $self->{_index}{type}{$primary_tag}{$source_tag}{$id} = undef;
 
334
  } else {
 
335
    delete $self->{_index}{type}{$primary_tag}{$source_tag}{$id};
 
336
    if ( scalar keys %{$self->{_index}{type}{$primary_tag}{$source_tag}} == 0 ) {
 
337
      delete $self->{_index}{type}{$primary_tag}{$source_tag};
 
338
      if (scalar keys %{$self->{_index}{type}{$primary_tag}} == 0 ) {
 
339
        delete $self->{_index}{type}{$primary_tag};
 
340
      }
 
341
    }
 
342
  }
275
343
}
276
344
 
277
345
sub _update_location_index {
278
 
  my $self = shift;
279
 
  my ($obj,$id) = @_;
280
 
 
 
346
  my ($self, $obj, $id, $del) = @_;
281
347
  my $seq_id      = $obj->seq_id || '';
282
348
  my $start       = $obj->start  || 0;
283
349
  my $end         = $obj->end    || 0;
284
350
  my $strand      = $obj->strand;
285
351
  my $bin_min     = int $start/BINSIZE;
286
352
  my $bin_max     = int $end/BINSIZE;
287
 
 
288
353
  for (my $bin = $bin_min; $bin <= $bin_max; $bin++ ) {
289
 
    $self->{_index}{location}{lc $seq_id}{$bin}{$id} = undef;
 
354
    if (not $del) {
 
355
      $self->{_index}{location}{lc $seq_id}{$bin}{$id} = undef;
 
356
    } else {
 
357
      delete $self->{_index}{location}{lc $seq_id}{$bin}{$id};
 
358
      if (scalar keys %{$self->{_index}{location}{lc $seq_id}{$bin}{$id}} == 0) {
 
359
        delete $self->{_index}{location}{lc $seq_id}{$bin}{$id};
 
360
      }
 
361
      if (scalar keys %{$self->{_index}{location}{lc $seq_id}{$bin}} == 0) {
 
362
        delete $self->{_index}{location}{lc $seq_id}{$bin};
 
363
      }
 
364
      if (scalar keys %{$self->{_index}{location}{lc $seq_id}} == 0) {
 
365
        delete $self->{_index}{location}{lc $seq_id};
 
366
      }
 
367
    }
290
368
  }
291
 
 
292
369
}
293
370
 
294
371
sub _update_attribute_index {
295
 
  my $self = shift;
296
 
  my ($obj,$id) = @_;
297
 
 
 
372
  my ($self, $obj, $id, $del) = @_;
298
373
  for my $tag ($obj->get_all_tags) {
299
374
    for my $value ($obj->get_tag_values($tag)) {
300
 
      $self->{_index}{attribute}{lc $tag}{lc $value}{$id} = undef;
 
375
      if (not $del) {
 
376
        $self->{_index}{attribute}{lc $tag}{lc $value}{$id} = undef;
 
377
      } else {
 
378
        delete $self->{_index}{attribute}{lc $tag}{lc $value}{$id};
 
379
        if ( scalar keys %{$self->{_index}{attribute}{lc $tag}{lc $value}} == 0) {
 
380
          delete $self->{_index}{attribute}{lc $tag}{lc $value};
 
381
        }
 
382
        if ( scalar keys %{$self->{_index}{attribute}{lc $tag}} == 0) {
 
383
          delete $self->{_index}{attribute}{lc $tag};
 
384
        }
 
385
        if ( scalar keys %{$self->{_index}{attribute}} == 0) {
 
386
          delete $self->{_index}{attribute};
 
387
        }
 
388
      }
301
389
    }
302
390
  }
303
391
}
355
443
 
356
444
 
357
445
sub filter_by_type {
358
 
  my $self = shift;
359
 
  my ($types,$filter) = @_;
360
 
  my @types = ref $types eq 'ARRAY' ?  @$types : $types;
361
 
 
362
 
  my $index = $self->{_index}{type};
363
 
 
364
 
  my @types_found = $self->find_types(@types);
 
446
  my ($self, $types_req, $filter) = @_;
 
447
  my @types_req = ref $types_req eq 'ARRAY' ?  @$types_req : $types_req;
 
448
 
 
449
  my $types = $self->{_index}{type};
 
450
  my @types_found = $self->find_types(\@types_req);
365
451
 
366
452
  my @results;
367
 
  for my $type (@types_found) {
368
 
    next unless exists $index->{$type};
369
 
    push @results,keys %{$index->{$type}};
 
453
  for my $type_found (@types_found) {
 
454
    my ($primary_tag, undef, $source_tag) = ($type_found =~ m/^(.*?)(:(.*?))$/);
 
455
    next unless exists $types->{$primary_tag}{$source_tag};
 
456
    push @results, keys %{$types->{$primary_tag}{$source_tag}};
370
457
  }
371
458
 
372
459
  $self->update_filter($filter,\@results);
373
460
}
374
461
 
375
462
sub find_types {
376
 
  my $self = shift;
377
 
  my @types = @_;
378
 
 
 
463
  my ($self, $types_req) = @_;
379
464
  my @types_found;
380
 
  my $index = $self->{_index}{type};
381
 
 
382
 
  for my $type (@types) {
383
 
 
384
 
    my ($primary_tag,$source_tag);
385
 
    if (ref $type && $type->isa('Bio::DB::GFF::Typename')) {
386
 
      $primary_tag = $type->method;
387
 
      $source_tag  = $type->source;
388
 
    } else {
389
 
      ($primary_tag,$source_tag) = split ':',$type,2;
390
 
    }
391
 
    push @types_found,defined $source_tag ? lc "$primary_tag:$source_tag"
392
 
                                          : grep {/^$primary_tag:/i} keys %{$index};
 
465
 
 
466
  my $types = $self->{_index}{type};
 
467
 
 
468
  for my $type_req (@$types_req) {
 
469
 
 
470
    # Type is the primary tag and an optional source tag
 
471
    my ($primary_tag, $source_tag);
 
472
    if (ref $type_req && $type_req->isa('Bio::DB::GFF::Typename')) {
 
473
      $primary_tag = $type_req->method;
 
474
      $source_tag  = $type_req->source;
 
475
    } else {
 
476
      ($primary_tag, undef, $source_tag) = ($type_req =~ m/^(.*?)(:(.*))?$/); 
 
477
    }
 
478
    ($primary_tag, $source_tag) = (lc $primary_tag, lc($source_tag || ''));
 
479
 
 
480
    next if not exists $$types{$primary_tag};
 
481
 
 
482
    if ($source_tag eq '') {
 
483
      # Match all sources for this primary_tag
 
484
      push @types_found, map {"$primary_tag:$_"} (keys %{ $$types{$primary_tag} });
 
485
    } else {
 
486
      # Match only the requested source
 
487
      push @types_found, "$primary_tag:$source_tag";
 
488
    }
 
489
 
393
490
  }
394
491
  return @types_found;
395
492
}
396
493
 
397
494
sub attributes {
398
 
    my $self = shift;
399
 
    return keys %{$self->{_index}{attribute}};
 
495
  my $self = shift;
 
496
  return keys %{$self->{_index}{attribute}};
400
497
}
401
498
 
402
499
sub filter_by_attribute {
403
 
  my $self = shift;
404
 
  my ($attributes,$filter) = @_;
 
500
  my ($self, $attributes, $filter) = @_;
405
501
 
406
502
  my $index = $self->{_index}{attribute};
407
503
  my $result;
434
530
}
435
531
 
436
532
sub filter_by_location {
437
 
  my $self = shift;
438
 
  my ($seq_id,$start,$end,$strand,$range_type,$filter) = @_;
 
533
  my ($self, $seq_id, $start, $end, $strand, $range_type, $filter) = @_;
439
534
  $strand ||= 0;
440
535
 
441
536
  my $index = $self->{_index}{location}{lc $seq_id};
444
539
  if (!defined $start or !defined $end or $range_type eq 'contained_in') {
445
540
    @bins = sort {$a<=>$b} keys %{$index};
446
541
    $start = $bins[0]  * BINSIZE  unless defined $start;
447
 
    $end   = @bins == 1 ? BINSIZE : $bins[-1] * BINSIZE  unless defined $end;
 
542
    $end   = (($bins[-1] + 1) * BINSIZE) - 1 unless defined $end;
448
543
  }
449
544
  my %seenit;
450
545
  my $bin_min       = int $start/BINSIZE;
479
574
 
480
575
 
481
576
sub filter_by_name {
482
 
  my $self = shift;
483
 
  my ($name,$allow_aliases,$filter) = @_;
 
577
  my ($self, $name, $allow_aliases, $filter) = @_;
484
578
 
485
579
  my $index = $self->{_index}{name};
486
580
 
503
597
}
504
598
 
505
599
sub glob_match {
506
 
  my $self = shift;
507
 
  my $term = shift;
 
600
  my ($self, $term) = @_;
508
601
  return unless $term =~ /(?:^|[^\\])[*?]/;
509
602
  $term =~ s/(^|[^\\])([+\[\]^{}\$|\(\).])/$1\\$2/g;
510
603
  $term =~ s/(^|[^\\])\*/$1.*/g;
514
607
 
515
608
 
516
609
sub update_filter {
517
 
  my $self = shift;
518
 
  my ($filter,$results) = @_;
 
610
  my ($self, $filter, $results) = @_;
519
611
  return unless @$results;
520
612
 
521
613
  if (%$filter) {
528
620
}
529
621
 
530
622
sub _search_attributes {
531
 
  my $self = shift;
532
 
  my ($search_string,$attribute_array,$limit) = @_;
 
623
  my ($self, $search_string, $attribute_array, $limit) = @_;
533
624
 
534
625
  $search_string =~ tr/*?//d;
535
626
 
579
670
=cut
580
671
 
581
672
sub types {
582
 
    my $self = shift;
583
 
    eval "require Bio::DB::GFF::Typename" 
584
 
        unless Bio::DB::GFF::Typename->can('new');
585
 
    return map {
586
 
        Bio::DB::GFF::Typename->new($_);
587
 
    } keys %{$self->{_index}{type}};
 
673
  my $self = shift;
 
674
  eval "require Bio::DB::GFF::Typename" unless Bio::DB::GFF::Typename->can('new');
 
675
  my @types;
 
676
  for my $primary_tag ( keys %{$$self{_index}{type}} ) {
 
677
    for my $source_tag ( keys %{$$self{_index}{type}{$primary_tag}} ) {
 
678
      my $type = $$self{_index}{type}{$primary_tag}{$source_tag};
 
679
      push @types, Bio::DB::GFF::Typename->new($type);
 
680
    }
 
681
  }
 
682
  return @types;
588
683
}
589
684
 
590
685
# this is ugly
591
686
sub _insert_sequence {
592
 
  my $self = shift;
593
 
  my ($seqid,$seq,$offset) = @_;
 
687
  my ($self, $seqid, $seq, $offset) = @_;
594
688
  my $dna_fh = $self->private_fasta_file or return;
595
689
  if ($offset == 0) { # start of the sequence
596
690
    print $dna_fh ">$seqid\n";
599
693
}
600
694
 
601
695
sub _fetch_sequence {
602
 
  my $self = shift;
603
 
  my ($seqid,$start,$end) = @_;
 
696
  my ($self, $seqid, $start, $end) = @_;
604
697
  my $db = $self->{fasta_db} or return;
605
698
  $db->seq($seqid,$start,$end);
606
699
}
613
706
  return $self->{fasta_fh} = IO::File->new($self->{fasta_file},">");
614
707
}
615
708
 
 
709
# summary support
 
710
sub coverage_array {
 
711
    my $self = shift;
 
712
 
 
713
    my ($seq_name,$start,$end,$types,$bins) = 
 
714
        rearrange([['SEQID','SEQ_ID','REF'],'START',['STOP','END'],
 
715
                   ['TYPES','TYPE','PRIMARY_TAG'],'BINS'],@_);
 
716
 
 
717
    my @features = $self->_features(-seq_id=> $seq_name,
 
718
                                    -start => $start,
 
719
                                    -end   => $end,
 
720
                                    -types => $types);
 
721
 
 
722
    my $binsize = ($end-$start+1)/$bins;
 
723
    my $report_tag;
 
724
    my @coverage_array = (0) x $bins;
 
725
    
 
726
    for my $f (@features) {
 
727
        $report_tag ||= $f->primary_tag;
 
728
        my $fs        = $f->start;
 
729
        my $fe        = $f->end;
 
730
        my $start_bin = int(($fs-$start)/$binsize);
 
731
        my $end_bin   = int(($fe-$start)/$binsize);
 
732
        $start_bin    = 0       if $start_bin < 0;
 
733
        $end_bin      = $bins-1 if $end_bin  >= $bins;
 
734
        $coverage_array[$_]++ for ($start_bin..$end_bin);
 
735
    }
 
736
    return wantarray ? (\@coverage_array,$report_tag) : \@coverage_array;
 
737
}
 
738
 
 
739
sub _seq_ids {
 
740
    my $self = shift;
 
741
 
 
742
    if (my $fa = $self->{fasta_db}) {
 
743
        if (my @s = eval {$fa->ids}) {
 
744
            return @s;
 
745
        }
 
746
    } 
 
747
    
 
748
    my $l    = $self->{_index}{location} or return;
 
749
    return keys %$l;
 
750
}
 
751
 
616
752
package Bio::DB::SeqFeature::Store::memory::Iterator;
617
753
 
618
754
sub new {
619
 
  my $class = shift;
620
 
  my $store = shift;
621
 
  my $ids   = shift;
 
755
  my ($class, $store, $ids) = @_;
622
756
  return bless {store => $store,
623
757
                ids   => $ids},ref($class) || $class;
624
758
}