<commit_before>package Bio::EnsEMBL::IdMapping::Cache;

=head1 NAME

Bio::EnsEMBL::IdMapping::Cache - a cache to hold data objects used by the 
IdMapping application

=head1 SYNOPSIS


=head1 DESCRIPTION


=head1 METHODS


=head1 LICENCE

This code is distributed under an Apache style licence. Please see
http://www.ensembl.org/info/about/code_licence.html for details.

=head1 AUTHOR

<NAME> <<EMAIL>>, Ensembl core API team

=head1 CONTACT

Please post comments/questions to the Ensembl development list
<<EMAIL>>

=cut


use strict;
use warnings;
no warnings 'uninitialized';

use Bio::EnsEMBL::Utils::Argument qw(rearrange);
use Bio::EnsEMBL::Utils::Exception qw(throw warning);
use Bio::EnsEMBL::Utils::ScriptUtils qw(parse_bytes path_append);
use Bio::EnsEMBL::IdMapping::TinyGene;
use Bio::EnsEMBL::IdMapping::TinyTranscript;
use Bio::EnsEMBL::IdMapping::TinyTranslation;
use Bio::EnsEMBL::IdMapping::TinyExon;
use Bio::EnsEMBL::DBSQL::DBAdaptor;
use Storable qw(nfreeze thaw nstore retrieve);
use Digest::MD5 qw(md5_hex);


# define available cache names here
my @cache_names = qw(
    exons_by_id
    transcripts_by_id
    transcripts_by_exon_id
    translations_by_id
    genes_by_id
    genes_by_transcript_id
);


=head2 new

  Arg [LOGGER]: Bio::EnsEMBL::Utils::Logger $logger - a logger object
  Arg [CONF]  : Bio::EnsEMBL::Utils::ConfParser $conf - a configuration object
  Example     : my $cache = Bio::EnsEMBL::IdMapping::Cache->new(
                  -LOGGER => $logger,
                  -CONF   => $conf,
                );
  Description : constructor
  Return type : Bio::EnsEMBL::IdMapping::Cache object
  Exceptions  : thrown on wrong or missing arguments
  Caller      : general
  Status      : At Risk
              : under development

=cut

sub new {
  my $caller = shift;
  my $class = ref($caller) || $caller;

  my ($logger, $conf) = rearrange(['LOGGER', 'CONF'], @_);

  unless ($logger->isa('Bio::EnsEMBL::Utils::Logger')) {
    throw("You must provide a Bio::EnsEMBL::Utils::Logger for logging.");
  }
  
  unless ($conf->isa('Bio::EnsEMBL::Utils::ConfParser')) {
    throw("You must provide configuration as a Bio::EnsEMBL::Utils::ConfParser object.");
  }
  
  my $self = {};
  bless ($self, $class);

  # initialise
  $self->logger($logger);
  $self->conf($conf);
  
  return $self;
}


=head2 build_cache

  Arg[1]      : String $dbtype - db type (source|target)
  Arg[2]      : String $slice_name - the name of a slice (format as returned by
                Bio::EnsEMBL::Slice->name)
  Example     : my ($num_genes, $filesize) = $cache->build_cache('source',
                  'chromosome:NCBI36:X:1:1000000:-1');
  Description : Builds a cache of genes, transcripts, translations and exons
                needed by the IdMapping application and serialises the resulting
                cache object to a file.
  Return type : list of the number of genes processed and the size of the
                serialised cache file
  Exceptions  : thrown on invalid slice name
  Caller      : general
  Status      : At Risk
              : under development

=cut

sub build_cache {
  my $self = shift;
  my $dbtype = shift;
  my $slice_name = shift;
  
  my $dba = $self->get_DBAdaptor($dbtype);
  my $sa = $dba->get_SliceAdaptor;
  
  my $slice = $sa->fetch_by_name($slice_name);
  unless ($slice) {
    throw("Could not retrieve slice $slice_name.");
  }
  
  my $genes = $slice->get_all_Genes(undef, undef, 1);

  # biotype filter
  $genes = $self->filter_biotype($genes) if ($self->conf->param('biotypes'));
  my $i = scalar(@$genes);

  # find common coord_system
  my $common_cs_found = $self->find_common_coord_systems;

  # find out whether native coord_system is a common coord_system.
  # if so, you don't need to project.
  # also don't project if no common coord_system present
  my $need_project = 1;
  my $csid = join(':', $slice->coord_system_name,
                       $slice->coord_system->version);
  if ($self->is_common_cs($csid) or !$self->highest_common_cs) {
    $need_project = 0;
  }
  
  # build cache
  my $type = "$dbtype.$slice_name";
  $self->build_cache_from_genes($type, $genes, $need_project);
  undef $genes;

  # write cache to file, then flush cache to reclaim memory
  my $size = $self->write_all_to_file($type);

  return $i, $size;
}


=head2 filter_biotypes

  Arg[1]      : Listref of Bio::EnsEMBL::Genes $genes - the genes to filter
  Example     : my @filtered = @{ $cache->filter_biotypes(\@genes) };
  Description : Filters a list of genes by biotype. Biotypes are taken from the
                IdMapping configuration parameter 'biotypes'.
  Return type : Listref of Bio::EnsEMBL::Genes (or empty list)
  Exceptions  : none
  Caller      : internal
  Status      : At Risk
              : under development

=cut

sub filter_biotypes {
  my $self = shift;
  my $genes = shift;

  my $filtered = [];

  foreach my $biotype ($self->conf->param('biotypes')) {
    push @$filtered, grep { $_->biotype eq $biotype } @$genes;
  }

  return $filtered;
}


=head2 build_cache_from_genes 

  Arg[1]      : String $type - cache type
  Arg[2]      : Listref of Bio::EnsEMBL::Genes $genes - genes to build cache
                from
  Arg[3]      : Boolean $need_project - indicate if we need to project exons to
                common coordinate system
  Example     : $cache->build_cache_from_genes(
                  'source.chromosome:NCBI36:X:1:100000:1', \@genes);
  Description : Builds the cache by fetching transcripts, translations and exons
                for a list of genes from the database, and creating lightweight
                Bio::EnsEMBL::IdMapping::TinyFeature objects containing only the
                data needed by the IdMapping application. These objects are
                attached to a name cache in this cache object. Exons only need
                to be projected to a commond coordinate system if their native
                coordinate system isn't common to source and target assembly
                itself.
  Return type : none
  Exceptions  : thrown on wrong or missing arguments
  Caller      : internal
  Status      : At Risk
              : under development

=cut

sub build_cache_from_genes {
  my $self = shift;
  my $type = shift;
  my $genes = shift;
  my $need_project = shift;
  
  throw("You must provide a type.") unless $type;
  throw("You must provide a listref of genes.") unless (ref($genes) eq 'ARRAY');

  # initialise cache for the given type.
  # this is a workaround for a problem with the checkpointing implementation
  # which caused re-dumping of regions without features
  foreach my $name (@{ $self->cache_names }) {
    $self->{'cache'}->{$name}->{$type} = {};
  }

  #my $i = 0;
  #my $num_genes = scalar(@$genes);
  #my $progress_id = $self->logger->init_progress($num_genes);

  # loop over genes sorted by gene location.
  # the sort will hopefully improve assembly mapper cache performance and
  # therefore speed up exon sequence retrieval
  foreach my $gene (sort { $a->start <=> $b->start } @$genes) {
    #$self->logger->log_progressbar($progress_id, ++$i, 2);
    #$self->logger->log_progress($num_genes, ++$i, 20, 3, 1);

    # create lightweigt gene
    my $lgene = Bio::EnsEMBL::IdMapping::TinyGene->new_fast([
        $gene->dbID,
        $gene->stable_id,
        $gene->version,
        $gene->created_date,
        $gene->modified_date,
        $gene->start,
        $gene->end,
        $gene->strand,
        $gene->slice->seq_region_name,
        $gene->biotype,
        $gene->status,
        $gene->analysis->logic_name,
        $gene->display_id,
        ($gene->is_known ? 1 : 0),
    ]);

    # build gene caches
    $self->add('genes_by_id', $type, $gene->dbID, $lgene);
    
    # transcripts
    foreach my $tr (@{ $gene->get_all_Transcripts }) {
      my $ltr = Bio::EnsEMBL::IdMapping::TinyTranscript->new_fast([
          $tr->dbID,
          $tr->stable_id,
          $tr->version,
          $tr->created_date,
          $tr->modified_date,
          $tr->start,
          $tr->end,
          $tr->strand,
          $tr->length,
          md5_hex($tr->spliced_seq),
          ($tr->is_known ? 1 : 0),
      ]);

      $lgene->add_Transcript($ltr);

      # build transcript caches
      $self->add('transcripts_by_id', $type, $tr->dbID, $ltr);
      $self->add('genes_by_transcript_id', $type, $tr->dbID, $lgene);

      # translation (if there is one)
      if (my $tl = $tr->translation) {
        my $ltl = Bio::EnsEMBL::IdMapping::TinyTranslation->new_fast([
            $tl->dbID,
            $tl->stable_id,
            $tl->version,
            $tl->created_date,
            $tl->modified_date,
            $tr->dbID,
            $tr->translate->seq,
            ($tr->is_known ? 1 : 0),
        ]);

        $ltr->add_Translation($ltl);

        $self->add('translations_by_id', $type, $tl->dbID, $ltl);

        undef $tl;
      }

      # exons
      foreach my $exon (@{ $tr->get_all_Exons }) {
        my $lexon = Bio::EnsEMBL::IdMapping::TinyExon->new_fast([
            $exon->dbID,
            $exon->stable_id,
            $exon->version,
            $exon->created_date,
            $exon->modified_date,
            $exon->start,
            $exon->end,
            $exon->strand,
            $exon->slice->seq_region_name,
            $exon->slice->coord_system_name,
            $exon->slice->coord_system->version,
            $exon->slice->subseq($exon->start, $exon->end, $exon->strand),
            $exon->phase,
            $need_project,
        ]);

        # get coordinates in common coordinate system if needed
        if ($need_project) {
          my @seg = @{ $exon->project($self->highest_common_cs,
                                      $self->highest_common_cs_version) };

          if (scalar(@seg) == 1) {
            my $sl = $seg[0]->to_Slice;
            $lexon->common_start($sl->start);
            $lexon->common_end($sl->end);
            $lexon->common_strand($sl->strand);
            $lexon->common_sr_name($sl->seq_region_name);
          }
        }
        
        $ltr->add_Exon($lexon);

        $self->add('exons_by_id', $type, $exon->dbID, $lexon);
        $self->add_list('transcripts_by_exon_id', $type, $exon->dbID, $ltr);

        undef $exon;
      }

      undef $tr;
    }

    undef $gene;
  }

}


=head2 add

  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]      : Bio::EnsEMBL::IdMappping::TinyFeature $val - value to cache
  Example     : $cache->add('genes_by_id',
                  'source.chromosome:NCBI36:X:1:1000000:1', '1234', $tiny_gene);
  Description : Adds a TinyFeature object to a named cache.
  Return type : Bio::EnsEMBL::IdMapping::TinyFeature
  Exceptions  : thrown on wrong or missing arguments
  Caller      : internal
  Status      : At Risk
              : under development

=cut

sub add {
  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'}->{$name}->{$type}->{$key} = $val;

  return $self->{'cache'}->{$name}->{$type}->{$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'}->{$name}->{$type}->{$key} }, @vals;

  return $self->{'cache'}->{$name}->{$type}->{$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'}->{"$name:$type"}) {
    $self->read_and_merge($name, $type);
  }

  return $self->{'cache'}->{$name}->{$type}->{$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'}->{"$name:$type"}) {
    $self->read_and_merge($name, $type);
  }

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


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'}->{"$name:$type"}) {
    $self->read_and_merge($name, $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) {
    
    TARGET:
    foreach my $t_cs (@t_coord_systems) {
      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;
        }
      }
    }
  }
  
  return $found_highest;
}


sub seq_regions_compatible {
  my $self = shift;
  my $cs = shift;
  my $s_sa = shift;
  my $t_sa = shift;

  unless ($cs and $cs->isa('Bio::EnsEMBL::CoordSystem')) {
    throw('You must provide a CoordSystem');
  }

  unless ($s_sa and $t_sa and $s_sa->isa('Bio::EnsEMBL::DBSQL::SliceAdaptor')
          and $t_sa->isa('Bio::EnsEMBL::DBSQL::SliceAdaptor')) {
    throw('You must provide a source and target SliceAdaptor');
  }

  my %sr_match;
  my $equal = 0;

  my $s_seq_regions = $s_sa->fetch_all($cs->name, $cs->version);
  my $t_seq_regions = $t_sa->fetch_all($cs->name, $cs->version);
  
  # sanity check to prevent divison by zero
  my $s_count = scalar(@$s_seq_regions);
  my $t_count = scalar(@$t_seq_regions);
  return(0) if ($s_count == 0 or $t_count == 0);
  
  foreach my $s_sr (@$s_seq_regions) {
    $sr_match{$s_sr->seq_region_name} = $s_sr->length;
  }

  foreach my $t_sr (@$t_seq_regions) {
    if (exists($sr_match{$t_sr->seq_region_name})) {
      $equal++;

      # return false if we have a region with same name but different length
      return(0) unless ($sr_match{$t_sr->seq_region_name} == $t_sr->length);
    }
  }

  if ($equal/$s_count > 0.5 and $equal/$t_count > 0.5) {
    return(1);
  } else {
    $self->logger->info("Only $equal seq_regions identical for ".$cs->name." ".$cs->version."\n");
    return(0);
  }
  
}


sub get_DBAdaptor {
  my $self = shift;
  my $prefix = shift;

  unless ($self->{'_dba'}->{$prefix}) {
    # connect to database
    my $dba = new Bio::EnsEMBL::DBSQL::DBAdaptor(
            -host   => $self->conf->param("${prefix}host"),
            -port   => $self->conf->param("${prefix}port"),
            -user   => $self->conf->param("${prefix}user"),
            -pass   => $self->conf->param("${prefix}pass"),
            -dbname => $self->conf->param("${prefix}dbname"),
            -group  => $prefix,
    );
    
    # explicitely set the dnadb to itself - by default the Registry assumes
    # a group 'core' for this now
    $dba->dnadb($dba);

    $self->{'_dba'}->{$prefix} = $dba;
  }

  return $self->{'_dba'}->{$prefix};
}


sub all_cache_files_exist {
  my $self = shift;
  my $type = shift;

  throw("You must provide a cache type.") unless $type;

  my $i = 1;
  foreach my $name (@{ $self->cache_names }) {
    $i *= $self->cache_file_exists($name, $type);
  }

  return $i;
}


sub cache_names {
  return \@cache_names;
}


sub cache_file_exists {
  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;

  my $cache_file = $self->cache_file($name, $type);

  if (-e $cache_file) {
    $self->logger->info("Cache file found for $name.\n", 3);
    $self->logger->debug("Will read from $cache_file.\n", 3);
    return 1;
  } else {
    $self->logger->info("No cache file found for $name.\n", 3);
    $self->logger->info("Will build cache from db.\n", 3);
    return 0;
  }
}


sub cache_file {
  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;

  return $self->dump_path."/$name.$type.object_cache.ser";
}


sub instance_file {
  my $self = shift;

  return $self->dump_path."/cache_instance.ser";
}


sub dump_path {
  my $self = shift;

  $self->{'dump_path'} ||= path_append($self->conf->param('dumppath'), 'cache');

  return $self->{'dump_path'};
}


sub write_all_to_file {
  my $self = shift;
  my $type = shift;

  throw("You must provide a cache type.") unless $type;

  my $size = 0;

  foreach my $name (@{ $self->cache_names }) {
    $size += $self->write_to_file($name, $type);
  }

  $size += $self->write_instance_to_file;

  return parse_bytes($size);
}


sub write_to_file {
  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;

  unless ($self->{'cache'}->{$name}->{$type}) {
    $self->logger->warning("No features found in $name/$type. Won't write cache file.\n");
    return;
  }

  my $cache_file = $self->cache_file($name, $type);

  eval { nstore($self->{'cache'}->{$name}->{$type}, $cache_file) };
  if ($@) {
    throw("Unable to store $cache_file: $@\n");
  }

  my $size = -s $cache_file;
  return $size;
}


sub write_instance_to_file {
  my $self = shift;

  my $instance_file = $self->instance_file;

  eval { nstore($self->{'instance'}, $instance_file) };
  if ($@) {
    throw("Unable to store $instance_file: $@\n");
  }

  my $size = -s $instance_file;
  return $size;
}


sub read_from_file {
  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;

  my $cache_file = $self->cache_file($name, $type);

  if (-s $cache_file) {
    
    #$self->logger->info("Reading cache from file...\n", 0, 'stamped');
    #$self->logger->info("Cache file $cache_file.\n", 1);
    eval { $self->{'cache'}->{$name}->{$type} = retrieve($cache_file); };
    if ($@) {
      throw("Unable to retrieve cache: $@");
    }
    #$self->logger->info("Done.\n", 0, 'stamped');

  } else {
    $self->logger->warning("Cache file $cache_file not found or empty.\n");
  }


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


sub read_and_merge {
  my $self = shift;
  my $name = shift;
  my $dbtype = shift;

  throw("You must provide a cache name (e.g. genes_by_id.") unless $name;
  unless ($dbtype eq 'source' or $dbtype eq 'target') {
    throw("Db type must be 'source' or 'target'.");
  }

  foreach my $slice_name (@{ $self->slice_names($dbtype) }) {
    $self->read_from_file($name, "$dbtype.$slice_name");
  }

  $self->merge($name, $dbtype);

  # flag as being loaded
  $self->{'instance'}->{'loaded'}->{"$name:$dbtype"} = 1;
}


sub merge {
  my $self = shift;
  my $name = shift;
  my $dbtype = shift;

  throw("You must provide a cache name (e.g. genes_by_id.") unless $name;
  unless ($dbtype eq 'source' or $dbtype eq 'target') {
    throw("Db type must be 'source' or 'target'.");
  }

  foreach my $type (keys %{ $self->{'cache'}->{$name} || {} }) {
    next unless ($type =~ /^$dbtype/);
    
    (my $merged_type = $type) =~ s/^(\w+)\..+/$1/;
    
    foreach my $key (keys %{ $self->{'cache'}->{$name}->{$type} || {} }) {
      if (defined $self->{'cache'}->{$name}->{$merged_type}->{$key}) {
        # warning("Duplicate key in cache: $name|$merged_type|$key. Skipping.\n");
      } else {
        $self->{'cache'}->{$name}->{$merged_type}->{$key} =
          $self->{'cache'}->{$name}->{$type}->{$key};
      }

      delete $self->{'cache'}->{$name}->{$type}->{$key};
    }
    
    delete $self->{'cache'}->{$name}->{$type};
<commit_msg>changed internal implementation to store all cache types in one file (fixes shared references issue with Storable and largely reduces memory consumption)<commit_after>package Bio::EnsEMBL::IdMapping::Cache;

=head1 NAME

Bio::EnsEMBL::IdMapping::Cache - a cache to hold data objects used by the 
IdMapping application

=head1 SYNOPSIS


=head1 DESCRIPTION


=head1 METHODS


=head1 LICENCE

This code is distributed under an Apache style licence. Please see
http://www.ensembl.org/info/about/code_licence.html for details.

=head1 AUTHOR

<NAME> <<EMAIL>>, Ensembl core API team

=head1 CONTACT

Please post comments/questions to the Ensembl development list
<<EMAIL>>

=cut


use strict;
use warnings;
no warnings 'uninitialized';

use Bio::EnsEMBL::Utils::Argument qw(rearrange);
use Bio::EnsEMBL::Utils::Exception qw(throw warning);
use Bio::EnsEMBL::Utils::ScriptUtils qw(parse_bytes path_append);
use Bio::EnsEMBL::IdMapping::TinyGene;
use Bio::EnsEMBL::IdMapping::TinyTranscript;
use Bio::EnsEMBL::IdMapping::TinyTranslation;
use Bio::EnsEMBL::IdMapping::TinyExon;
use Bio::EnsEMBL::DBSQL::DBAdaptor;
use Storable qw(nstore retrieve);
use Digest::MD5 qw(md5_hex);


# define available cache names here
my @cache_names = qw(
    exons_by_id
    transcripts_by_id
    transcripts_by_exon_id
    translations_by_id
    genes_by_id
    genes_by_transcript_id
);


=head2 new

  Arg [LOGGER]: Bio::EnsEMBL::Utils::Logger $logger - a logger object
  Arg [CONF]  : Bio::EnsEMBL::Utils::ConfParser $conf - a configuration object
  Example     : my $cache = Bio::EnsEMBL::IdMapping::Cache->new(
                  -LOGGER => $logger,
                  -CONF   => $conf,
                );
  Description : constructor
  Return type : Bio::EnsEMBL::IdMapping::Cache object
  Exceptions  : thrown on wrong or missing arguments
  Caller      : general
  Status      : At Risk
              : under development

=cut

sub new {
  my $caller = shift;
  my $class = ref($caller) || $caller;

  my ($logger, $conf) = rearrange(['LOGGER', 'CONF'], @_);

  unless ($logger->isa('Bio::EnsEMBL::Utils::Logger')) {
    throw("You must provide a Bio::EnsEMBL::Utils::Logger for logging.");
  }
  
  unless ($conf->isa('Bio::EnsEMBL::Utils::ConfParser')) {
    throw("You must provide configuration as a Bio::EnsEMBL::Utils::ConfParser object.");
  }
  
  my $self = {};
  bless ($self, $class);

  # initialise
  $self->logger($logger);
  $self->conf($conf);
  
  return $self;
}


=head2 build_cache

  Arg[1]      : String $dbtype - db type (source|target)
  Arg[2]      : String $slice_name - the name of a slice (format as returned by
                Bio::EnsEMBL::Slice->name)
  Example     : my ($num_genes, $filesize) = $cache->build_cache('source',
                  'chromosome:NCBI36:X:1:1000000:-1');
  Description : Builds a cache of genes, transcripts, translations and exons
                needed by the IdMapping application and serialises the resulting
                cache object to a file.
  Return type : list of the number of genes processed and the size of the
                serialised cache file
  Exceptions  : thrown on invalid slice name
  Caller      : general
  Status      : At Risk
              : under development

=cut

sub build_cache {
  my $self = shift;
  my $dbtype = shift;
  my $slice_name = shift;
  
  my $dba = $self->get_DBAdaptor($dbtype);
  my $sa = $dba->get_SliceAdaptor;
  
  my $slice = $sa->fetch_by_name($slice_name);
  unless ($slice) {
    throw("Could not retrieve slice $slice_name.");
  }
  
  my $genes = $slice->get_all_Genes(undef, undef, 1);

  # biotype filter
  $genes = $self->filter_biotype($genes) if ($self->conf->param('biotypes'));
  my $i = scalar(@$genes);

  # find common coord_system
  my $common_cs_found = $self->find_common_coord_systems;

  # find out whether native coord_system is a common coord_system.
  # if so, you don't need to project.
  # also don't project if no common coord_system present
  my $need_project = 1;
  my $csid = join(':', $slice->coord_system_name,
                       $slice->coord_system->version);
  if ($self->is_common_cs($csid) or !$self->highest_common_cs) {
    $need_project = 0;
  }
  
  # build cache
  my $type = "$dbtype.$slice_name";
  $self->build_cache_from_genes($type, $genes, $need_project);
  undef $genes;

  # write cache to file, then flush cache to reclaim memory
  my $size = $self->write_all_to_file($type);

  return $i, $size;
}


=head2 filter_biotypes

  Arg[1]      : Listref of Bio::EnsEMBL::Genes $genes - the genes to filter
  Example     : my @filtered = @{ $cache->filter_biotypes(\@genes) };
  Description : Filters a list of genes by biotype. Biotypes are taken from the
                IdMapping configuration parameter 'biotypes'.
  Return type : Listref of Bio::EnsEMBL::Genes (or empty list)
  Exceptions  : none
  Caller      : internal
  Status      : At Risk
              : under development

=cut

sub filter_biotypes {
  my $self = shift;
  my $genes = shift;

  my $filtered = [];

  foreach my $biotype ($self->conf->param('biotypes')) {
    push @$filtered, grep { $_->biotype eq $biotype } @$genes;
  }

  return $filtered;
}


=head2 build_cache_from_genes 

  Arg[1]      : String $type - cache type
  Arg[2]      : Listref of Bio::EnsEMBL::Genes $genes - genes to build cache
                from
  Arg[3]      : Boolean $need_project - indicate if we need to project exons to
                common coordinate system
  Example     : $cache->build_cache_from_genes(
                  'source.chromosome:NCBI36:X:1:100000:1', \@genes);
  Description : Builds the cache by fetching transcripts, translations and exons
                for a list of genes from the database, and creating lightweight
                Bio::EnsEMBL::IdMapping::TinyFeature objects containing only the
                data needed by the IdMapping application. These objects are
                attached to a name cache in this cache object. Exons only need
                to be projected to a commond coordinate system if their native
                coordinate system isn't common to source and target assembly
                itself.
  Return type : none
  Exceptions  : thrown on wrong or missing arguments
  Caller      : internal
  Status      : At Risk
              : under development

=cut

sub build_cache_from_genes {
  my $self = shift;
  my $type = shift;
  my $genes = shift;
  my $need_project = shift;
  
  throw("You must provide a type.") unless $type;
  throw("You must provide a listref of genes.") unless (ref($genes) eq 'ARRAY');

  # initialise cache for the given type.
  $self->{'cache'}->{$type} = {};

  #my $i = 0;
  #my $num_genes = scalar(@$genes);
  #my $progress_id = $self->logger->init_progress($num_genes);

  # loop over genes sorted by gene location.
  # the sort will hopefully improve assembly mapper cache performance and
  # therefore speed up exon sequence retrieval
  foreach my $gene (sort { $a->start <=> $b->start } @$genes) {
    #$self->logger->log_progressbar($progress_id, ++$i, 2);
    #$self->logger->log_progress($num_genes, ++$i, 20, 3, 1);

    # create lightweigt gene
    my $lgene = Bio::EnsEMBL::IdMapping::TinyGene->new_fast([
        $gene->dbID,
        $gene->stable_id,
        $gene->version,
        $gene->created_date,
        $gene->modified_date,
        $gene->start,
        $gene->end,
        $gene->strand,
        $gene->slice->seq_region_name,
        $gene->biotype,
        $gene->status,
        $gene->analysis->logic_name,
        ($gene->is_known ? 1 : 0),
    ]);

    # build gene caches
    $self->add('genes_by_id', $type, $gene->dbID, $lgene);
    
    # transcripts
    foreach my $tr (@{ $gene->get_all_Transcripts }) {
      my $ltr = Bio::EnsEMBL::IdMapping::TinyTranscript->new_fast([
          $tr->dbID,
          $tr->stable_id,
          $tr->version,
          $tr->created_date,
          $tr->modified_date,
          $tr->start,
          $tr->end,
          $tr->strand,
          $tr->length,
          md5_hex($tr->spliced_seq),
          ($tr->is_known ? 1 : 0),
      ]);

      $lgene->add_Transcript($ltr);

      # build transcript caches
      $self->add('transcripts_by_id', $type, $tr->dbID, $ltr);
      $self->add('genes_by_transcript_id', $type, $tr->dbID, $lgene);

      # translation (if there is one)
      if (my $tl = $tr->translation) {
        my $ltl = Bio::EnsEMBL::IdMapping::TinyTranslation->new_fast([
            $tl->dbID,
            $tl->stable_id,
            $tl->version,
            $tl->created_date,
            $tl->modified_date,
            $tr->dbID,
            $tr->translate->seq,
            ($tr->is_known ? 1 : 0),
        ]);

        $ltr->add_Translation($ltl);

        $self->add('translations_by_id', $type, $tl->dbID, $ltl);

        undef $tl;
      }

      # exons
      foreach my $exon (@{ $tr->get_all_Exons }) {
        my $lexon = Bio::EnsEMBL::IdMapping::TinyExon->new_fast([
            $exon->dbID,
            $exon->stable_id,
            $exon->version,
            $exon->created_date,
            $exon->modified_date,
            $exon->start,
            $exon->end,
            $exon->strand,
            $exon->slice->seq_region_name,
            $exon->slice->coord_system_name,
            $exon->slice->coord_system->version,
            $exon->slice->subseq($exon->start, $exon->end, $exon->strand),
            $exon->phase,
            $need_project,
        ]);

        # get coordinates in common coordinate system if needed
        if ($need_project) {
          my @seg = @{ $exon->project($self->highest_common_cs,
                                      $self->highest_common_cs_version) };

          if (scalar(@seg) == 1) {
            my $sl = $seg[0]->to_Slice;
            $lexon->common_start($sl->start);
            $lexon->common_end($sl->end);
            $lexon->common_strand($sl->strand);
            $lexon->common_sr_name($sl->seq_region_name);
          }
        }
        
        $ltr->add_Exon($lexon);

        $self->add('exons_by_id', $type, $exon->dbID, $lexon);
        $self->add_list('transcripts_by_exon_id', $type, $exon->dbID, $ltr);

        undef $exon;
      }

      undef $tr;
    }

    undef $gene;
  }

}


=head2 add

  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]      : Bio::EnsEMBL::IdMappping::TinyFeature $val - value to cache
  Example     : $cache->add('genes_by_id',
                  'source.chromosome:NCBI36:X:1:1000000:1', '1234', $tiny_gene);
  Description : Adds a TinyFeature object to a named cache.
  Return type : Bio::EnsEMBL::IdMapping::TinyFeature
  Exceptions  : thrown on wrong or missing arguments
  Caller      : internal
  Status      : At Risk
              : under development

=cut

sub add {
  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) {
    
    TARGET:
    foreach my $t_cs (@t_coord_systems) {
      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;
        }
      }
    }
  }
  
  return $found_highest;
}


sub seq_regions_compatible {
  my $self = shift;
  my $cs = shift;
  my $s_sa = shift;
  my $t_sa = shift;

  unless ($cs and $cs->isa('Bio::EnsEMBL::CoordSystem')) {
    throw('You must provide a CoordSystem');
  }

  unless ($s_sa and $t_sa and $s_sa->isa('Bio::EnsEMBL::DBSQL::SliceAdaptor')
          and $t_sa->isa('Bio::EnsEMBL::DBSQL::SliceAdaptor')) {
    throw('You must provide a source and target SliceAdaptor');
  }

  my %sr_match;
  my $equal = 0;

  my $s_seq_regions = $s_sa->fetch_all($cs->name, $cs->version);
  my $t_seq_regions = $t_sa->fetch_all($cs->name, $cs->version);
  
  # sanity check to prevent divison by zero
  my $s_count = scalar(@$s_seq_regions);
  my $t_count = scalar(@$t_seq_regions);
  return(0) if ($s_count == 0 or $t_count == 0);
  
  foreach my $s_sr (@$s_seq_regions) {
    $sr_match{$s_sr->seq_region_name} = $s_sr->length;
  }

  foreach my $t_sr (@$t_seq_regions) {
    if (exists($sr_match{$t_sr->seq_region_name})) {
      $equal++;

      # return false if we have a region with same name but different length
      return(0) unless ($sr_match{$t_sr->seq_region_name} == $t_sr->length);
    }
  }

  if ($equal/$s_count > 0.5 and $equal/$t_count > 0.5) {
    return(1);
  } else {
    $self->logger->info("Only $equal seq_regions identical for ".$cs->name." ".$cs->version."\n");
    return(0);
  }
  
}


sub get_DBAdaptor {
  my $self = shift;
  my $prefix = shift;

  unless ($self->{'_dba'}->{$prefix}) {
    # connect to database
    my $dba = new Bio::EnsEMBL::DBSQL::DBAdaptor(
            -host   => $self->conf->param("${prefix}host"),
            -port   => $self->conf->param("${prefix}port"),
            -user   => $self->conf->param("${prefix}user"),
            -pass   => $self->conf->param("${prefix}pass"),
            -dbname => $self->conf->param("${prefix}dbname"),
            -group  => $prefix,
    );
    
    # explicitely set the dnadb to itself - by default the Registry assumes
    # a group 'core' for this now
    $dba->dnadb($dba);

    $self->{'_dba'}->{$prefix} = $dba;
  }

  return $self->{'_dba'}->{$prefix};
}


sub cache_file_exists {
  my $self = shift;
  my $type = shift;

  throw("You must provide a cache type.") unless $type;

  my $cache_file = $self->cache_file($type);

  if (-e $cache_file) {
    $self->logger->info("Cache file found.\n", 3);
    $self->logger->debug("Will read from $cache_file.\n", 3);
    return 1;
  } else {
    $self->logger->info("No cache file found.\n", 3);
    $self->logger->info("Will build cache from db.\n", 3);
    return 0;
  }
}


sub cache_file {
  my $self = shift;
  my $type = shift;

  throw("You must provide a cache type.") unless $type;

  return $self->dump_path."/$type.object_cache.ser";
}


sub instance_file {
  my $self = shift;

  return $self->dump_path."/cache_instance.ser";
}


sub dump_path {
  my $self = shift;

  $self->{'dump_path'} ||= path_append($self->conf->param('dumppath'), 'cache');

  return $self->{'dump_path'};
}


sub write_all_to_file {
  my $self = shift;
  my $type = shift;

  throw("You must provide a cache type.") unless $type;

  my $size = 0;
  $size += $self->write_to_file($type);
  $size += $self->write_instance_to_file;

  return parse_bytes($size);
}


sub write_to_file {
  my $self = shift;
  my $type = shift;

  throw("You must provide a cache type.") unless $type;

  unless ($self->{'cache'}->{$type}) {
    $self->logger->warning("No features found in $type. Won't write cache file.\n");
    return;
  }

  my $cache_file = $self->cache_file($type);

  eval { nstore($self->{'cache'}->{$type}, $cache_file) };
  if ($@) {
    throw("Unable to store $cache_file: $@\n");
  }

  my $size = -s $cache_file;
  return $size;
}


sub write_instance_to_file {
  my $self = shift;

  my $instance_file = $self->instance_file;

  eval { nstore($self->{'instance'}, $instance_file) };
  if ($@) {
    throw("Unable to store $instance_file: $@\n");
  }

  my $size = -s $instance_file;
  return $size;
}


sub read_from_file {
  my $self = shift;
  my $type = shift;

  throw("You must provide a cache type.") unless $type;

  my $cache_file = $self->cache_file($type);

  if (-s $cache_file) {
    
    #$self->logger->info("Reading cache from file...\n", 0, 'stamped');
    #$self->logger->info("Cache file $cache_file.\n", 1);
    eval { $self->{'cache'}->{$type} = retrieve($cache_file); };
    if ($@) {
      throw("Unable to retrieve cache: $@");
    }
    #$self->logger->info("Done.\n", 0, 'stamped');

  } else {
    $self->logger->warning("Cache file $cache_file not found or empty.\n");
  }


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


sub read_and_merge {
  my $self = shift;
  my $dbtype = shift;

  unless ($dbtype eq 'source' or $dbtype eq 'target') {
    throw("Db type must be 'source' or 'target'.");
  }

  foreach my $slice_name (@{ $self->slice_names($dbtype) }) {
    $self->read_from_file("$dbtype.$slice_name");
  }

  $self->merge($dbtype);

  # flag as being loaded
  $self->{'instance'}->{'loaded'}->{$dbtype} = 1;
}


sub merge {
  my $self = shift;
  my $dbtype = shift;

  unless ($dbtype eq 'source' or $dbtype eq 'target') {
    throw("Db type must be 'source' or 'target'.");
  }

  foreach my $type (keys %{ $self->{'cache'} || {} }) {
    next unless ($type =~ /^$dbtype/);

    foreach my $name (keys %{ $self->{'cache'}->{$type} || {} }) {
    
      foreach my $key (keys %{ $self->{'cache'}->{$type}->{$name} || {} }) {
        if (defined $self->{'cache'}->{$dbtype}->{$name}->{$key}) {
          # warning("Duplicate key in cache: $name|$dbtype|$key. Skipping.\n");
        } else {
          $self->{'cache'}->{$dbtype}->{$name}->{$key} =
            $self->{'cache'}->{$type}->{$name}->{$key};
        }

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

{'fraction_non_alphanumeric': 0.15826973183610413, 'fraction_numerical': 0.005856717932163527, 'mean_word_length': 2.8057213057213057, 'pattern_counts': {'":': 0, '<': 15, '<?xml version=': 0, '>': 624, 'https://': 0, 'lorem ipsum': 0, 'www.': 2, 'xml': 0}, 'pii_count': 0, 'substrings_counts': 0, 'word_list_counts': {'cursed_substrings.json': 2, 'profanity_word_list.json': 0, 'sexual_word_list.json': 0, 'zh_pornsignals.json': 0}}
{'dir': 'git-commits-cleaned', 'id': '5548978', 'n_tokens_mistral': 15584, 'n_tokens_neox': 14727, 'n_words': 3760}