view release on metacpan or  search on metacpan

lib/Bio/EnsEMBL/IdMapping/Cache.pm  view on Meta::CPAN

  my $self = shift;
  my $name = shift;
  my $type = shift;
  my $key = shift;
  my $val = shift;

  throw("You must provide a cache name (e.g. genes_by_id.") unless $name;
  throw("You must provide a cache type.") unless $type;
  throw("You must provide a cache key (e.g. a gene dbID).") unless $key;

  $self->{'cache'}->{$type}->{$name}->{$key} = $val;

  return $self->{'cache'}->{$type}->{$name}->{$key};
}

=head2 add_list

  Arg[1]      : String $name - a cache name (e.g. 'genes_by_id')
  Arg[2]      : String type - a cache type (e.g. "source.$slice_name")
  Arg[3]      : String $key - key of this entry (e.g. a gene dbID)
  Arg[4]      : List of Bio::EnsEMBL::IdMappping::TinyFeature @val - values
                to cache
  Example     : $cache->add_list('transcripts_by_exon_id',
                  'source.chromosome:NCBI36:X:1:1000000:1', '1234',
                  $tiny_transcript1, $tiny_transcript2);
  Description : Adds a list of TinyFeature objects to a named cache.
  Return type : Listref of Bio::EnsEMBL::IdMapping::TinyFeature objects
  Exceptions  : thrown on wrong or missing arguments
  Caller      : internal
  Status      : At Risk
              : under development

=cut

sub add_list {
  my $self = shift;
  my $name = shift;
  my $type = shift;
  my $key = shift;
  my @vals = @_;

  throw("You must provide a cache name (e.g. genes_by_id.") unless $name;
  throw("You must provide a cache type.") unless $type;
  throw("You must provide a cache key (e.g. a gene dbID).") unless $key;

  push @{ $self->{'cache'}->{$type}->{$name}->{$key} }, @vals;

  return $self->{'cache'}->{$type}->{$name}->{$key};
}

sub get_by_key {
  my $self = shift;
  my $name = shift;
  my $type = shift;
  my $key = shift;

  throw("You must provide a cache name (e.g. genes_by_id.") unless $name;
  throw("You must provide a cache type.") unless $type;
  throw("You must provide a cache key (e.g. a gene dbID).") unless $key;

  # transparently load cache from file unless already loaded
  unless ($self->{'instance'}->{'loaded'}->{"$type"}) {
    $self->read_and_merge($type);
  }

  return $self->{'cache'}->{$type}->{$name}->{$key};
}

sub get_by_name {
  my $self = shift;
  my $name = shift;
  my $type = shift;

  throw("You must provide a cache name (e.g. genes_by_id.") unless $name;
  throw("You must provide a cache type.") unless $type;
  
  # transparently load cache from file unless already loaded
  unless ($self->{'instance'}->{'loaded'}->{$type}) {
    $self->read_and_merge($type);
  }

  return $self->{'cache'}->{$type}->{$name} || {};
}


sub get_count_by_name {
  my $self = shift;
  my $name = shift;
  my $type = shift;

  throw("You must provide a cache name (e.g. genes_by_id.") unless $name;
  throw("You must provide a cache type.") unless $type;
  
  # transparently load cache from file unless already loaded
  unless ($self->{'instance'}->{'loaded'}->{$type}) {
    $self->read_and_merge($type);
  }

  return scalar(keys %{ $self->get_by_name($name, $type) });
}


sub find_common_coord_systems {
  my $self = shift;

  # get adaptors for source db
  my $s_dba = $self->get_DBAdaptor('source');
  my $s_csa = $s_dba->get_CoordSystemAdaptor;
  my $s_sa  = $s_dba->get_SliceAdaptor;

  # get adaptors for target db
  my $t_dba = $self->get_DBAdaptor('target');
  my $t_csa = $t_dba->get_CoordSystemAdaptor;
  my $t_sa  = $t_dba->get_SliceAdaptor;

  # find common coord_systems
  my @s_coord_systems = @{ $s_csa->fetch_all };
  my @t_coord_systems = @{ $t_csa->fetch_all };
  my $found_highest   = 0;

SOURCE:
  foreach my $s_cs (@s_coord_systems) {
    if ( !$s_cs->is_default() ) { next SOURCE }

  TARGET:
    foreach my $t_cs (@t_coord_systems) {
      if ( !$t_cs->is_default() ) { next TARGET }

      if ( $s_cs->name eq $t_cs->name ) {

        # test for identical coord_system version
        if ( $s_cs->version and ( $s_cs->version ne $t_cs->version ) ) {
          next TARGET;
        }

        # test for at least 50% identical seq_regions
        if ( $self->seq_regions_compatible( $s_cs, $s_sa, $t_sa ) ) {
          $self->add_common_cs($s_cs);

          unless ($found_highest) {
            $self->highest_common_cs( $s_cs->name );
            $self->highest_common_cs_version( $s_cs->version );
          }

          $found_highest = 1;

          next SOURCE;
        }
      }
    } ## end foreach my $t_cs (@t_coord_systems)
  } ## end foreach my $s_cs (@s_coord_systems)

  return $found_highest;
} ## end sub find_common_coord_systems