lib/Bio/DB/SeqFeature/Store/memory.pm

   1 package Bio::DB::SeqFeature::Store::memory;
   2
   3 =head1 NAME
   4
   5 Bio::DB::SeqFeature::Store::memory -- In-memory implementation of Bio::DB::SeqFeature::Store
   6
   7 =head1 SYNOPSIS
   8
   9   use Bio::DB::SeqFeature::Store;
  10
  11   # Open the sequence database
  12   my $db      = Bio::DB::SeqFeature::Store->new( -adaptor => 'memory',
  13                                                  -dsn     => '/var/databases/test');
  14   # search... by id
  15   my @features = $db->fetch_many(@list_of_ids);
  16
  17   # ...by name
  18   @features = $db->get_features_by_name('ZK909');
  19
  20   # ...by alias
  21   @features = $db->get_features_by_alias('sma-3');
  22
  23   # ...by type
  24   @features = $db->get_features_by_type('gene');
  25
  26   # ...by location
  27   @features = $db->get_features_by_location(-seq_id=>'Chr1',-start=>4000,-end=>600000);
  28
  29   # ...by attribute
  30   @features = $db->get_features_by_attribute({description => 'protein kinase'})
  31
  32   # ...by the GFF "Note" field
  33   @result_list = $db->search_notes('kinase');
  34
  35   # ...by arbitrary combinations of selectors
  36   @features = $db->features(-name => $name,
  37                             -type => $types,
  38                             -seq_id => $seqid,
  39                             -start  => $start,
  40                             -end    => $end,
  41                             -attributes => $attributes);
  42
  43   # ...using an iterator
  44   my $iterator = $db->get_seq_stream(-name => $name,
  45                                      -type => $types,
  46                                      -seq_id => $seqid,
  47                                      -start  => $start,
  48                                      -end    => $end,
  49                                      -attributes => $attributes);
  50
  51   while (my $feature = $iterator->next_seq) {
  52     # do something with the feature
  53   }
  54
  55   # ...limiting the search to a particular region
  56   my $segment  = $db->segment('Chr1',5000=>6000);
  57   my @features = $segment->features(-type=>['mRNA','match']);
  58
  59   # getting & storing sequence information
  60   # Warning: this returns a string, and not a PrimarySeq object
  61   $db->insert_sequence('Chr1','GATCCCCCGGGATTCCAAAA...');
  62   my $sequence = $db->fetch_sequence('Chr1',5000=>6000);
  63
  64   # what feature types are defined in the database?
  65   my @types    = $db->types;
  66
  67   # create a new feature in the database
  68   my $feature = $db->new_feature(-primary_tag => 'mRNA',
  69                                  -seq_id      => 'chr3',
  70                                  -start      => 10000,
  71                                  -end        => 11000);
  72
  73 =head1 DESCRIPTION
  74
  75 Bio::DB::SeqFeature::Store::memory is the in-memory adaptor for
  76 Bio::DB::SeqFeature::Store. You will not create it directly, but
  77 instead use Bio::DB::SeqFeature::Store-E<gt>new() to do so.
  78
  79 See L<Bio::DB::SeqFeature::Store> for complete usage instructions.
  80
  81 =head2 Using the memory adaptor
  82
  83 Before using the memory adaptor, populate a readable-directory on the
  84 file system with annotation and/or sequence files. The annotation
  85 files must be in GFF3 format, and sholud end in the extension .gff or
  86 .gff3. They may be compressed with "compress", "gzip" or "bzip2" (in
  87 which case the appropriate compression extension must be present as
  88 well.)
  89
  90 You may include sequence data inline in the GFF3 files, or put the
  91 sequence data in one or more separate FASTA-format files. These files
  92 must end with .fa or .fasta and may be compressed. Because of the way
  93 the adaptor works, you will get much better performance if you keep
  94 the sequence data in separate FASTA files.
  95
  96 Initialize the database using the -dsn option. This should point to
  97 the directory creating the annotation and sequence files, or to a
  98 single GFF3 file. Examples:
  99
 100
 101   # load all GFF3 and FASTA files located in /var/databases/test directory
 102   $db  = Bio::DB::SeqFeature::Store->new( -adaptor => 'memory',
 103                                           -dsn     => '/var/databases/test');
 104
 105
 106   # load the data in a single compressed GFF3 file located at
 107   # /usr/annotations/worm.gf33.gz
 108   $db  = Bio::DB::SeqFeature::Store->new( -adaptor => 'memory',
 109                                           -dsn     => '/usr/annotations/worm.gff3.gz');
 110
 111 For compatibility with the Bio::DB::GFF memory adaptor, -gff is
 112 recognized as an alias for -dsn.
 113
 114 See L<Bio::DB::SeqFeature::Store> for all the access methods supported
 115 by this adaptor. The various methods for storing and updating features
 116 and sequences into the database are supported, including GFF3 loading
 117 support, but since this is an in-memory adaptor all changes you make
 118 will be lost when the script exits.
 119
 120 =cut
 121
 122 use strict;
 123 use base 'Bio::DB::SeqFeature::Store';
 124 use Bio::DB::SeqFeature::Store::GFF3Loader;
 125 use Bio::DB::GFF::Util::Rearrange 'rearrange';
 126 use File::Temp 'tempdir';
 127 use IO::File;
 128 use Bio::DB::Fasta;
 129 use File::Glob ':glob';
 130
 131 use constant BINSIZE => 10_000;
 132
 133 ###
 134 # object initialization
 135 #
 136 sub init {
 137   my ($self, $args) = @_;
 138   $self->SUPER::init($args);
 139   $self->{_data}     = {};
 140   $self->{_children} = {};
 141   $self->{_index}    = {};
 142   $self;
 143 }
 144
 145 sub post_init {
 146   my $self = shift;
 147   my ($file_or_dir) = rearrange([['DIR','DSN','FILE','GFF']],@_);
 148   return unless $file_or_dir;
 149
 150   my $loader = Bio::DB::SeqFeature::Store::GFF3Loader->new(-store    => $self,
 151                                                            -sf_class => $self->seqfeature_class,
 152                                                            -no_close_fasta => 1
 153       )  or $self->throw("Couldn't create GFF3Loader");
 154   my @argv;
 155   if (-d $file_or_dir) {
 156     @argv = (
 157              bsd_glob("$file_or_dir/*.size*"),
 158              bsd_glob("$file_or_dir/*.gff"),            bsd_glob("$file_or_dir/*.gff3"),
 159              bsd_glob("$file_or_dir/*.gff.{gz,Z,bz2}"), bsd_glob("$file_or_dir/*.gff3.{gz,Z,bz2}")
 160              );
 161   } else {
 162     @argv = $file_or_dir;
 163   }
 164   local $self->{file_or_dir} = $file_or_dir;
 165   $loader->load(@argv);
 166   warn $@ if $@;
 167 }
 168
 169 sub commit { # reindex fasta files
 170   my $self = shift;
 171
 172   my $db;
 173   if (my $fh = $self->{fasta_fh}) {
 174       $fh->close;
 175       $db = Bio::DB::Fasta->new($self->{fasta_file});
 176   } elsif (exists $self->{file_or_dir} && -d $self->{file_or_dir}) {
 177       $db = Bio::DB::Fasta->new($self->{file_or_dir});
 178   }
 179   $self->{fasta_db} = $db if $db;
 180 }
 181
 182 sub can_store_parentage { 1 }
 183
 184 # return a hash ref in which each key is primary id
 185 sub data {
 186   shift->{_data};
 187 }
 188
 189 sub _init_database { shift->init }
 190
 191 sub _store {
 192   my $self    = shift;
 193   my $indexed = shift;
 194   my @objs    = @_;
 195   my $data = $self->data;
 196   my $count = 0;
 197   for my $obj (@objs) {
 198     # Add unique ID to feature if needed
 199     my $primary_id = $self->_autoid($obj);
 200     # Store feature (overwriting any existing feature with the same primary ID
 201     # as required by Bio::DB::SF::Store)
 202     $data->{$primary_id} = $obj;
 203     if ($indexed) {
 204       $self->{_index}{ids}{$primary_id} = undef;
 205       $self->_update_indexes($obj);
 206     }
 207     $count++;
 208   }
 209   return $count;
 210 }
 211
 212
 213 sub _autoid {
 214   # If a feature has no ID, assign it a unique ID
 215   my ($self, $obj) = @_;
 216   my $data = $self->data;
 217   my $primary_id = $obj->primary_id;
 218   if (not defined $primary_id) {
 219     # Create a unique ID
 220     $primary_id = 1 + scalar keys %{$data};
 221     while (exists $data->{$primary_id}) {
 222       $primary_id++;
 223     }
 224     $obj->primary_id($primary_id);
 225   }
 226   return $primary_id;
 227 }
 228
 229
 230 sub _deleteid {
 231   my ($self, $id) = @_;
 232   if (exists $self->{_index}{ids}{$id}) {
 233     # $indexed was true
 234     $self->_update_indexes( $self->fetch($id), 1 );
 235     delete $self->{_index}{ids}{$id};
 236   }
 237   delete $self->data->{$id};
 238   return 1;
 239 }
 240
 241 sub _fetch {
 242   my ($self, $id) = @_;
 243   return $self->data->{$id};
 244 }
 245
 246 sub _add_SeqFeature {
 247   my ($self, $parent, @children) = @_;
 248   my $count = 0;
 249   my $parent_id = ref $parent ? $parent->primary_id : $parent;
 250   defined $parent_id or $self->throw("Parent $parent should have a primary ID");
 251   for my $child (@children) {
 252     my $child_id = ref $child ? $child->primary_id : $child;
 253     defined $child_id or $self->throw("Child $child should have a primary ID");
 254     $self->{_children}{$parent_id}{$child_id}++;
 255     $count++;
 256   }
 257   return $count;
 258 }
 259
 260 sub _fetch_SeqFeatures {
 261   my ($self, $parent, @types) = @_;
 262   my $parent_id = $parent->primary_id;
 263   defined $parent_id or $self->throw("Parent $parent should have a primary ID");
 264   my @children_ids  = keys %{$self->{_children}{$parent_id}};
 265   my @children      = map {$self->fetch($_)} @children_ids;
 266
 267   if (@types) {
 268     my $data;
 269     for my $c (@children) {
 270       push @{$$data{$c->primary_tag}{$c->source_tag||''}}, $c;
 271     }
 272     @children = ();
 273     for my $type (@types) {
 274       $type .= ':' if (not $type =~ m/:/);
 275       my ($primary_tag, undef, $source_tag) = ($type =~ m/^(.*?)(:(.*?))$/);
 276       $source_tag ||= '';
 277       if ($source_tag eq '') {
 278         for my $source (keys %{$$data{$primary_tag}}) {
 279           if (exists $$data{$primary_tag}{$source_tag}) {
 280             push @children, @{$$data{$primary_tag}{$source_tag}};
 281           }
 282         }
 283       } else {
 284         if (exists $$data{$primary_tag}{$source_tag}) {
 285           push @children, @{$$data{$primary_tag}{$source_tag}};
 286         }
 287       }
 288     }
 289   }
 290
 291   return @children;
 292 }
 293
 294 sub _update_indexes {
 295   my ($self, $obj, $del) = @_;
 296   defined (my $id = $obj->primary_id) or return;
 297   $del ||= 0;
 298   $self->_update_name_index($obj,$id, $del);
 299   $self->_update_type_index($obj,$id, $del);
 300   $self->_update_location_index($obj, $id, $del);
 301   $self->_update_attribute_index($obj,$id, $del);
 302 }
 303
 304 sub _update_name_index {
 305   my ($self, $obj, $id, $del) = @_;
 306   my ($names, $aliases) = $self->feature_names($obj);
 307   foreach (@$names) {
 308     if (not $del) {
 309       $self->{_index}{name}{lc $_}{$id}   = 1;
 310     } else {
 311       delete $self->{_index}{name}{lc $_}{$id};
 312       if (scalar keys %{ $self->{_index}{name}{lc $_} } == 0) {
 313         delete $self->{_index}{name}{lc $_};
 314       }
 315     };
 316   }
 317   foreach (@$aliases) {
 318     if (not $del) {
 319       $self->{_index}{name}{lc $_}{$id} ||= 2;
 320     } else {
 321       delete $self->{_index}{name}{lc $_}{$id};
 322       if (scalar keys %{ $self->{_index}{name}{lc $_} } == 0) {
 323         delete $self->{_index}{name}{lc $_};
 324       }
 325     }
 326   }
 327 }
 328
 329 sub _update_type_index {
 330   my ($self, $obj, $id, $del) = @_;
 331   my $primary_tag = lc($obj->primary_tag) || return;
 332   my $source_tag  = lc($obj->source_tag || '');
 333   if (not $del) {
 334     $self->{_index}{type}{$primary_tag}{$source_tag}{$id} = undef;
 335   } else {
 336     delete $self->{_index}{type}{$primary_tag}{$source_tag}{$id};
 337     if ( scalar keys %{$self->{_index}{type}{$primary_tag}{$source_tag}} == 0 ) {
 338       delete $self->{_index}{type}{$primary_tag}{$source_tag};
 339       if (scalar keys %{$self->{_index}{type}{$primary_tag}} == 0 ) {
 340         delete $self->{_index}{type}{$primary_tag};
 341       }
 342     }
 343   }
 344 }
 345
 346 sub _update_location_index {
 347   my ($self, $obj, $id, $del) = @_;
 348   my $seq_id      = $obj->seq_id || '';
 349   my $start       = $obj->start  || 0;
 350   my $end         = $obj->end    || 0;
 351   my $strand      = $obj->strand;
 352   my $bin_min     = int $start/BINSIZE;
 353   my $bin_max     = int $end/BINSIZE;
 354   for (my $bin = $bin_min; $bin <= $bin_max; $bin++ ) {
 355     if (not $del) {
 356       $self->{_index}{location}{lc $seq_id}{$bin}{$id} = undef;
 357     } else {
 358       delete $self->{_index}{location}{lc $seq_id}{$bin}{$id};
 359       if (scalar keys %{$self->{_index}{location}{lc $seq_id}{$bin}{$id}} == 0) {
 360         delete $self->{_index}{location}{lc $seq_id}{$bin}{$id};
 361       }
 362       if (scalar keys %{$self->{_index}{location}{lc $seq_id}{$bin}} == 0) {
 363         delete $self->{_index}{location}{lc $seq_id}{$bin};
 364       }
 365       if (scalar keys %{$self->{_index}{location}{lc $seq_id}} == 0) {
 366         delete $self->{_index}{location}{lc $seq_id};
 367       }
 368     }
 369   }
 370 }
 371
 372 sub _update_attribute_index {
 373   my ($self, $obj, $id, $del) = @_;
 374   for my $tag ($obj->get_all_tags) {
 375     for my $value ($obj->get_tag_values($tag)) {
 376       if (not $del) {
 377         $self->{_index}{attribute}{lc $tag}{lc $value}{$id} = undef;
 378       } else {
 379         delete $self->{_index}{attribute}{lc $tag}{lc $value}{$id};
 380         if ( scalar keys %{$self->{_index}{attribute}{lc $tag}{lc $value}} == 0) {
 381           delete $self->{_index}{attribute}{lc $tag}{lc $value};
 382         }
 383         if ( scalar keys %{$self->{_index}{attribute}{lc $tag}} == 0) {
 384           delete $self->{_index}{attribute}{lc $tag};
 385         }
 386         if ( scalar keys %{$self->{_index}{attribute}} == 0) {
 387           delete $self->{_index}{attribute};
 388         }
 389       }
 390     }
 391   }
 392 }
 393
 394 sub _features {
 395   my $self = shift;
 396   my ($seq_id,$start,$end,$strand,
 397       $name,$class,$allow_aliases,
 398       $types,
 399       $attributes,
 400       $range_type,
 401       $iterator
 402      ) = rearrange([['SEQID','SEQ_ID','REF'],'START',['STOP','END'],'STRAND',
 403                     'NAME','CLASS','ALIASES',
 404                     ['TYPES','TYPE','PRIMARY_TAG'],
 405                     ['ATTRIBUTES','ATTRIBUTE'],
 406                     'RANGE_TYPE',
 407                     'ITERATOR',
 408                    ],@_);
 409
 410   my (@from,@where,@args,@group);
 411   $range_type ||= 'overlaps';
 412
 413   my @result;
 414   unless (defined $name or defined $seq_id or defined $types or defined $attributes) {
 415     @result = keys %{$self->{_index}{ids}};
 416   }
 417
 418   my %found  = ();
 419   my $result = 1;
 420
 421   if (defined($name)) {
 422     # hacky backward compatibility workaround
 423     undef $class if $class && $class eq 'Sequence';
 424     $name     = "$class:$name" if defined $class && length $class > 0;
 425     $result &&= $self->filter_by_name($name,$allow_aliases,\%found);
 426   }
 427
 428   if (defined $seq_id) {
 429     $result &&= $self->filter_by_location($seq_id,$start,$end,$strand,$range_type,\%found);
 430   }
 431
 432   if (defined $types) {
 433     $result &&= $self->filter_by_type($types,\%found);
 434   }
 435
 436   if (defined $attributes) {
 437     $result &&= $self->filter_by_attribute($attributes,\%found);
 438   }
 439
 440   push @result,keys %found if $result;
 441   return $iterator ? Bio::DB::SeqFeature::Store::memory::Iterator->new($self,\@result)
 442                    : map {$self->fetch($_)} @result;
 443 }
 444
 445
 446 sub filter_by_type {
 447   my ($self, $types_req, $filter) = @_;
 448   my @types_req = ref $types_req eq 'ARRAY' ?  @$types_req : $types_req;
 449
 450   my $types = $self->{_index}{type};
 451   my @types_found = $self->find_types(\@types_req);
 452
 453   my @results;
 454   for my $type_found (@types_found) {
 455     my ($primary_tag, undef, $source_tag) = ($type_found =~ m/^(.*?)(:(.*?))$/);
 456     next unless exists $types->{$primary_tag}{$source_tag};
 457     push @results, keys %{$types->{$primary_tag}{$source_tag}};
 458   }
 459
 460   $self->update_filter($filter,\@results);
 461 }
 462
 463 sub find_types {
 464   my ($self, $types_req) = @_;
 465   my @types_found;
 466
 467   my $types = $self->{_index}{type};
 468
 469   for my $type_req (@$types_req) {
 470
 471     # Type is the primary tag and an optional source tag
 472     my ($primary_tag, $source_tag);
 473     if (ref $type_req && $type_req->isa('Bio::DB::GFF::Typename')) {
 474       $primary_tag = $type_req->method;
 475       $source_tag  = $type_req->source;
 476     } else {
 477       ($primary_tag, undef, $source_tag) = ($type_req =~ m/^(.*?)(:(.*))?$/);
 478     }
 479     ($primary_tag, $source_tag) = (lc $primary_tag, lc($source_tag || ''));
 480
 481     next if not exists $$types{$primary_tag};
 482
 483     if ($source_tag eq '') {
 484       # Match all sources for this primary_tag
 485       push @types_found, map {"$primary_tag:$_"} (keys %{ $$types{$primary_tag} });
 486     } else {
 487       # Match only the requested source
 488       push @types_found, "$primary_tag:$source_tag";
 489     }
 490
 491   }
 492   return @types_found;
 493 }
 494
 495 sub attributes {
 496   my $self = shift;
 497   return keys %{$self->{_index}{attribute}};
 498 }
 499
 500 sub filter_by_attribute {
 501   my ($self, $attributes, $filter) = @_;
 502
 503   my $index = $self->{_index}{attribute};
 504   my $result;
 505
 506   for my $att_name (keys %$attributes) {
 507     my @result;
 508     my @matching_values;
 509     my @search_terms = ref($attributes->{$att_name}) && ref($attributes->{$att_name}) eq 'ARRAY'
 510                            ? @{$attributes->{$att_name}} : $attributes->{$att_name};
 511     my @regexp_terms;
 512     my @terms;
 513
 514     for my $v (@search_terms) {
 515       if (my $regexp = $self->glob_match($v)) {
 516         @regexp_terms      = keys %{$index->{lc $att_name}} unless @regexp_terms;
 517         push @terms,grep {/^$v$/i} @regexp_terms;
 518       } else {
 519         push @terms,lc $v;
 520       }
 521     }
 522
 523     for my $v (@terms) {
 524       push @result,keys %{$index->{lc $att_name}{$v}};
 525     }
 526
 527     $result ||= $self->update_filter($filter,\@result);
 528   }
 529
 530   $result;
 531 }
 532
 533 sub filter_by_location {
 534   my ($self, $seq_id, $start, $end, $strand, $range_type, $filter) = @_;
 535   $strand ||= 0;
 536
 537   my $index = $self->{_index}{location}{lc $seq_id};
 538   my @bins;
 539
 540   if (!defined $start or !defined $end or $range_type eq 'contained_in') {
 541     @bins = sort {$a<=>$b} keys %{$index};
 542     $start = $bins[0]  * BINSIZE  unless defined $start;
 543     $end   = (($bins[-1] + 1) * BINSIZE) - 1 unless defined $end;
 544   }
 545   my %seenit;
 546   my $bin_min       = int $start/BINSIZE;
 547   my $bin_max       = int $end/BINSIZE;
 548   my @bins_in_range = $range_type eq 'contained_in' ? ($bins[0]..$bin_min,$bin_max..$bins[-1])
 549                                                     : ($bin_min..$bin_max);
 550
 551   my @results;
 552   for my $bin (@bins_in_range) {
 553     next unless exists $index->{$bin};
 554     my @found = keys %{$index->{$bin}};
 555     for my $f (@found) {
 556       next if $seenit{$f}++;
 557       my $feature = $self->_fetch($f) or next;
 558       next if $strand && $feature->strand != $strand;
 559
 560       if ($range_type eq 'overlaps') {
 561         next unless $feature->end >= $start && $feature->start <= $end;
 562       }
 563       elsif ($range_type eq 'contains') {
 564         next unless $feature->start >= $start && $feature->end <= $end;
 565       }
 566       elsif ($range_type eq 'contained_in') {
 567         next unless $feature->start <= $start && $feature->end >= $end;
 568       }
 569
 570       push @results,$f;
 571     }
 572   }
 573   $self->update_filter($filter,\@results);
 574 }
 575
 576
 577 sub filter_by_name {
 578   my ($self, $name, $allow_aliases, $filter) = @_;
 579
 580   my $index = $self->{_index}{name};
 581
 582   my @names_to_fetch;
 583   if (my $regexp = $self->glob_match($name)) {
 584     @names_to_fetch = grep {/^$regexp$/i} keys %{$index};
 585   } else {
 586     @names_to_fetch = lc $name;
 587   }
 588
 589   my @results;
 590   for my $n (@names_to_fetch) {
 591     if ($allow_aliases) {
 592       push @results,keys %{$index->{$n}};
 593     } else {
 594       push @results,grep {$index->{$n}{$_} == 1} keys %{$index->{$n}};
 595     }
 596   }
 597   $self->update_filter($filter,\@results);
 598 }
 599
 600 sub glob_match {
 601   my ($self, $term) = @_;
 602   return unless $term =~ /(?:^|[^\\])[*?]/;
 603   $term =~ s/(^|[^\\])([+\[\]^{}\$|\(\).])/$1\\$2/g;
 604   $term =~ s/(^|[^\\])\*/$1.*/g;
 605   $term =~ s/(^|[^\\])\?/$1./g;
 606   return $term;
 607 }
 608
 609
 610 sub update_filter {
 611   my ($self, $filter, $results) = @_;
 612   return unless @$results;
 613
 614   if (%$filter) {
 615     my @filtered = grep {$filter->{$_}} @$results;
 616     %$filter     = map {$_=>1} @filtered;
 617   } else {
 618     %$filter     = map {$_=>1} @$results;
 619   }
 620
 621 }
 622
 623 sub _search_attributes {
 624   my ($self, $search_string, $attribute_array, $limit) = @_;
 625
 626   $search_string =~ tr/*?//d;
 627
 628   my @words = map {quotemeta($_)} $search_string =~ /(\w+)/g;
 629   my $search = join '|',@words;
 630
 631   my (%results,%notes);
 632
 633   my $index  = $self->{_index}{attribute};
 634   for my $tag (@$attribute_array) {
 635     my $attributes = $index->{lc $tag};
 636     for my $value (keys %{$attributes}) {
 637       next unless $value =~ /$search/i;
 638       my @ids = keys %{$attributes->{$value}};
 639       for my $w (@words) {
 640         my @hits = $value =~ /($w)/ig or next;
 641         $results{$_} += @hits foreach @ids;
 642       }
 643       $notes{$_} .= "$value " foreach @ids;
 644     }
 645   }
 646
 647   my @results;
 648   for my $id (keys %results) {
 649     my $hits = $results{$id};
 650     my $note = $notes{$id};
 651     $note =~ s/\s+$//;
 652     my $relevance = 10 * $hits;
 653     my $feature   = $self->fetch($id);
 654     my $name      = $feature->display_name or next;
 655     my $type      = $feature->type;
 656     push @results,[$name,$note,$relevance,$type,$id];
 657   }
 658
 659   return @results;
 660 }
 661
 662 =head2 types
 663
 664  Title   : types
 665  Usage   : @type_list = $db->types
 666  Function: Get all the types in the database
 667  Returns : array of Bio::DB::GFF::Typename objects (arrayref in scalar context)
 668  Args    : none
 669  Status  : public
 670
 671 =cut
 672
 673 sub types {
 674   my $self = shift;
 675   eval "require Bio::DB::GFF::Typename" unless Bio::DB::GFF::Typename->can('new');
 676   my @types;
 677   for my $primary_tag ( keys %{$$self{_index}{type}} ) {
 678     for my $source_tag ( keys %{$$self{_index}{type}{$primary_tag}} ) {
 679         push @types, Bio::DB::GFF::Typename->new($primary_tag,$source_tag);
 680     }
 681   }
 682   return @types;
 683 }
 684
 685 # this is ugly
 686 sub _insert_sequence {
 687   my ($self, $seqid, $seq, $offset) = @_;
 688   my $dna_fh = $self->private_fasta_file or return;
 689   if ($offset == 0) { # start of the sequence
 690     print $dna_fh ">$seqid\n";
 691   }
 692   print $dna_fh $seq,"\n";
 693 }
 694
 695 sub _fetch_sequence {
 696   my ($self, $seqid, $start, $end) = @_;
 697   my $db = $self->{fasta_db} or return;
 698   return $db->seq($seqid,$start,$end);
 699 }
 700
 701 sub private_fasta_file {
 702   my $self = shift;
 703   return $self->{fasta_fh} if exists $self->{fasta_fh};
 704   my $dir = tempdir (CLEANUP => 1);
 705   $self->{fasta_file}   = "$dir/sequence.$$.fasta";
 706   return $self->{fasta_fh} = IO::File->new($self->{fasta_file},">");
 707 }
 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
 752 package Bio::DB::SeqFeature::Store::memory::Iterator;
 753
 754 sub new {
 755   my ($class, $store, $ids) = @_;
 756   return bless {store => $store,
 757                 ids   => $ids},ref($class) || $class;
 758 }
 759
 760 sub next_seq {
 761   my $self  = shift;
 762   my $store = $self->{store} or return;
 763   my $id    = shift @{$self->{ids}};
 764   defined $id or return;
 765   return $store->fetch($id);
 766 }
 767
 768 1;
 769
 770 __END__
 771
 772 =head1 BUGS
 773
 774 This is an early version, so there are certainly some bugs. Please
 775 use the BioPerl bug tracking system to report bugs.
 776
 777 =head1 SEE ALSO
 778
 779 L<bioperl>,
 780 L<Bio::DB::SeqFeature>,
 781 L<Bio::DB::SeqFeature::Store>,
 782 L<Bio::DB::SeqFeature::GFF3Loader>,
 783 L<Bio::DB::SeqFeature::Segment>,
 784 L<Bio::DB::SeqFeature::Store::berkeleydb>,
 785 L<Bio::DB::SeqFeature::Store::DBI::mysql>
 786
 787 =head1 AUTHOR
 788
 789 Lincoln Stein E<lt>lstein@cshl.orgE<gt>.
 790
 791 Copyright (c) 2006 Cold Spring Harbor Laboratory.
 792
 793 This library is free software; you can redistribute it and/or modify
 794 it under the same terms as Perl itself.
 795
 796 =cut
 797