lib/CXGN/Dataset/Cache.pm

   1
   2 package CXGN::Dataset::Cache;
   3
   4 use strict;
   5 use warnings;
   6 use Moose;
   7 use Cache::File;
   8 use Digest::MD5 qw | md5_hex |;
   9 use JSON::Any;
  10 use JSON;
  11 use Data::Dumper;
  12
  13 extends 'CXGN::Dataset';
  14
  15 has 'cache_root' => (
  16     isa => 'Str',
  17     is => 'rw',
  18     required => 1,
  19 );
  20
  21 has 'cache' => (
  22     isa => 'Cache::File',
  23     is => 'rw',
  24 );
  25
  26 has 'cache_expiry' => (
  27     isa => 'Int',
  28     is => 'rw',
  29     default => 0, # never expires?
  30 );
  31
  32 sub key {
  33     my $self = shift;
  34     my $datatype = shift;
  35
  36     #print STDERR Dumper($self->_get_dataref());
  37     my $json = JSON->new();
  38     #preserve order of hash keys to get same text
  39     $json = $json->canonical();
  40     my $key = md5_hex($json->encode( $self-> _get_dataref() )."_$datatype");
  41     return $key;
  42 }
  43
  44 sub genotype_key {
  45     my $self = shift;
  46     my $datatype = shift;
  47     my $protocol_id = shift;
  48     my $markerprofiles = shift;
  49     my $genotypedataprojects = shift;
  50     my $markernames = shift;
  51     my $genotypeprophash = shift;
  52     my $protocolprophash = shift;
  53     my $protocolpropmarkerhash = shift;
  54     my $return_only_first_genotypeprop_for_stock = shift;
  55     my $chromosome_list = shift;
  56     my $start_position = shift;
  57     my $end_position = shift;
  58     my $marker_name_list = shift;
  59
  60     #print STDERR Dumper($self->_get_dataref());
  61     my $json = JSON->new();
  62     #preserve order of hash keys to get same text
  63     $json = $json->canonical();
  64     my $dataref = $json->encode( $self-> _get_dataref() );
  65     $markerprofiles = $json->encode( $markerprofiles || [] );
  66     $genotypedataprojects = $json->encode( $genotypedataprojects || [] );
  67     $markernames = $json->encode( $markernames || [] );
  68     $genotypeprophash = $json->encode( $genotypeprophash || [] );
  69     $protocolprophash = $json->encode( $protocolprophash || [] );
  70     $protocolpropmarkerhash = $json->encode( $protocolpropmarkerhash || [] );
  71     $chromosome_list = $json->encode( $chromosome_list || [] );
  72     $start_position = $start_position || '';
  73     $end_position = $end_position || '';
  74     $marker_name_list = $json->encode( $marker_name_list || [] );
  75     my $key = md5_hex($dataref.$protocol_id.$markerprofiles.$genotypedataprojects.$markernames.$genotypeprophash.$protocolprophash.$protocolpropmarkerhash.$return_only_first_genotypeprop_for_stock.$chromosome_list.$start_position.$end_position.$marker_name_list."_$datatype");
  76     return $key;
  77 }
  78
  79
  80 after('BUILD', sub {
  81     my $self = shift;
  82     $self->cache( Cache::File->new( cache_root => $self->cache_root() ));
  83 });
  84
  85
  86 override('retrieve_genotypes',
  87     sub {
  88         my $self = shift;
  89         my $protocol_id = shift;
  90         my $genotypeprop_hash_select = shift;
  91         my $protocolprop_top_key_select = shift;
  92         my $protocolprop_marker_hash_select = shift;
  93         my $return_only_first_genotypeprop_for_stock = shift;
  94         my $chromosome_list = shift || [];
  95         my $start_position = shift;
  96         my $end_position = shift;
  97         my $marker_name_list = shift || [];
  98
  99         my $key = $self->genotype_key("retrieve_genotypes", $protocol_id, undef, undef, undef, $genotypeprop_hash_select, $protocolprop_top_key_select, $protocolprop_marker_hash_select, $return_only_first_genotypeprop_for_stock, $chromosome_list, $start_position, $end_position, $marker_name_list);
 100
 101         if ($self->cache()->exists($key)) {
 102             my $genotype_json = $self->cache()->get($key);
 103             my $genotypes = JSON::Any->decode($genotype_json);
 104             undef $genotype_json;
 105             return $genotypes;
 106         }
 107         else {
 108             my $genotypes = $self->SUPER::retrieve_genotypes($protocol_id, $genotypeprop_hash_select, $protocolprop_top_key_select, $protocolprop_marker_hash_select, $return_only_first_genotypeprop_for_stock, $chromosome_list, $start_position, $end_position, $marker_name_list);
 109             my $genotype_json = JSON::Any->encode($genotypes);
 110             $self->cache()->set($key, $genotype_json, $self->cache_expiry());
 111             undef $genotype_json;
 112             return $genotypes;
 113         }
 114     });
 115
 116 override('retrieve_phenotypes',
 117     sub {
 118         my $self = shift;
 119         if ($self->cache()->exists($self->key("phenotype"))) {
 120             my $phenotype_json = $self->cache()->get($self->key("phenotype"));
 121             my $phenotypes = JSON::Any->decode($phenotype_json);
 122             return $phenotypes;
 123         }
 124         else {
 125             my $phenotypes = $self->SUPER::retrieve_phenotypes();
 126             my $phenotype_json = JSON::Any->encode($phenotypes);
 127             $self->cache()->set($self->key("phenotype"), $phenotype_json, $self->cache_expiry());
 128             return $phenotypes;
 129         }
 130     });
 131
 132 override('retrieve_accessions',
 133          sub {
 134              my $self = shift;
 135              if ($self->cache()->exists($self->key("accessions"))) {
 136                  my $accession_json = $self->cache()->get($self->key("accessions"));
 137                  my $accessions = JSON::Any->decode($accession_json);
 138                  return $accessions;
 139              }
 140              else {
 141                  my $accessions = $self->SUPER::retrieve_accessions();
 142                  my $accession_json = JSON::Any->encode($accessions);
 143                  $self->cache()->set($self->key("accessions"), $accession_json, $self->cache_expiry());
 144                  return $accessions;
 145              }
 146          });
 147
 148 override('retrieve_plots',
 149          sub {
 150              my $self = shift;
 151
 152              if ($self->cache()->exists($self->key("plots"))) {
 153                  print STDERR "Retrieving plots from cache...\n";
 154                  my $plot_json = $self->cache()->get($self->key("plots"));
 155                  my $plots = JSON::Any->decode($plot_json);
 156                  return $plots;
 157              }
 158              else {
 159                  print STDERR "Retrieving plots and caching them...\n";
 160                  my $plots = $self->SUPER::retrieve_plots();
 161                  #print STDERR Dumper($plots);
 162                  my $plot_json = JSON::Any->encode($plots);
 163                  $self->cache()->set($self->key("plots"), $plot_json, $self->cache_expiry());
 164                  return $plots;
 165              }
 166          });
 167
 168 override('retrieve_trials',
 169          sub {
 170              my $self = shift;
 171
 172              if ($self->cache()->exists($self->key("trials"))) {
 173                  my $trial_json = $self->cache()->get($self->key("trials"));
 174                  my $trials = JSON::Any->decode($trial_json);
 175                  return $trials;
 176              }
 177              else {
 178                  my $trials = $self->SUPER::retrieve_trials();
 179                  my $trial_json = JSON::Any->encode($trials);
 180                  $self->cache()->set(
 181                      $self->key("trials"), $trial_json, $self->cache_expiry()
 182                  );
 183                  return $trials;
 184              }
 185          });
 186
 187 override('retrieve_traits',
 188          sub {
 189              my $self = shift;
 190              if ($self->cache()->exists($self->key("traits"))) {
 191                  my $traits_json = $self->cache()->get($self->key("traits"));
 192                  my $traits = JSON::Any->decode($traits_json);
 193                  return $traits;
 194              }
 195              else {
 196                  my $traits = $self->SUPER::retrieve_traits();
 197                  my $trait_json = JSON::Any->encode($traits);
 198                  $self->cache()->set(
 199                      $self->key("traits"), $trait_json, $self->cache_expiry()
 200                  );
 201                  return $traits;
 202              }
 203          });
 204
 205 override('retrieve_years',
 206          sub {
 207              my $self = shift;
 208              if ($self->cache()->exists($self->key("years"))) {
 209                  my $year_json = $self->cache()->get($self->key("years"));
 210                  my $years = JSON::Any->decode($year_json);
 211                  return $years;
 212              }
 213              else {
 214                  my $years = $self->SUPER::retrieve_years();
 215                  my $year_json = JSON::Any->encode($years);
 216                  $self->cache()->set(
 217                      $self->key("years"), $year_json, $self->cache_expiry()
 218                  );
 219                  return $years;
 220              }
 221          });
 222
 223
 224
 225 1;