lib/SGN/Feature/GBrowse2/DataSource.pm

   1 package SGN::Feature::GBrowse2::DataSource;
   2 use Moose;
   3 use namespace::autoclean;
   4 use Scalar::Util qw/ blessed /;
   5 use Text::ParseWords;
   6 use Path::Class ();
   7 use URI::Escape;
   8 use Class::Load ':all';
   9 use Bio::Range;
  10
  11 extends 'SGN::Feature::GBrowse::DataSource';
  12
  13 has 'xref_discriminator' => (
  14     is => 'ro',
  15     isa => 'CodeRef',
  16     lazy_build => 1,
  17    ); sub _build_xref_discriminator {
  18        my ( $self ) = @_;
  19        return $self->gbrowse->config_master->code_setting( $self->name => 'restrict_xrefs' )
  20               || sub { 1 }
  21    }
  22
  23 has 'debug' => (
  24     is => 'rw',
  25     isa => 'Bool',
  26     default => 0,
  27    );
  28
  29 sub _build__databases {
  30     my $self = shift;
  31     local $_; #< Bio::Graphics::* sloppily clobbers $_
  32     my $conf = $self->config;
  33     my @dbs =  grep /:database$/i, $self->config->configured_types;
  34     return {
  35         map {
  36             my $dbname = $_;
  37             my $adaptor = $conf->setting( $dbname => 'db_adaptor' )
  38                 or confess "no db adaptor for [$_] in ".$self->path->basename;
  39             my @args = shellwords( $conf->setting( $dbname => 'db_args' ));
  40             my $conn = eval {
  41                 Class::Load::load_class( $adaptor );
  42                 local $SIG{__WARN__} = sub { warn @_ if $self->debug };
  43                 $adaptor->new( @args );
  44             };
  45             if( $@ ) {
  46                 warn $self->gbrowse->feature_name.": database [$dbname] in ".$self->path->basename." not available\n";
  47                 warn $@ if $self->debug;
  48                 ()
  49             } else {
  50                 $dbname =~ s/:database$//;
  51                 $dbname => $conn
  52             }
  53         } @dbs
  54        };
  55 }
  56
  57
  58 # can accept either plaintext queries, or hashrefs describing features in the DB to search for
  59 sub xrefs {
  60     my ($self, $q) = @_;
  61
  62     return unless $self->xref_discriminator->($q);
  63
  64     if( my $ref =  ref $q ) {
  65         return unless $ref eq 'HASH';
  66
  67         # search for features in all our DBs
  68         return $self->_make_feature_xrefs([
  69             map $_->features( %$q ), $self->databases
  70          ]);
  71     } else {
  72         # search for a region on a reference sequence specified like seq_name:23423..66666
  73         if( my ($ref_name,$start,$end) = $q =~ /^ \s* ([^:]+) \s* : (\d+) \s* .. \s* (\d+) $/x) {
  74
  75             sub _uniq_features(@) {
  76                 my %seen;
  77                 grep !($seen{ $_->seq_id.':'.$_->name.':'.$_->start.'..'.$_->end }++), @_;
  78             }
  79
  80             return
  81                 # make xrefs for the given range of each of the ref features
  82                 map $self->_make_region_xref({
  83                       features => [$_],
  84                       range    => Bio::Range->new( -start => $start, -end => $end )
  85                      }),
  86                 # remove any duplicate ref features
  87                 _uniq_features
  88                 # make sure they are all actually reference features
  89                 grep { $_->seq_id eq $_->display_name }
  90                 # search for features with the ref seq name
  91                 map $self->_search_db( $_, $ref_name ),
  92                 # for each database
  93                 $self->databases;
  94
  95         } else {
  96             # search for features by text in all our DBs
  97             return $self->_make_feature_xrefs([
  98                 map $self->_search_db($_,$q),
  99                 $self->databases
 100             ]);
 101         }
 102     }
 103
 104     return;
 105 }
 106 sub _search_db {
 107     my ( $self, $db, $name ) = @_;
 108     my $f =
 109             $db->can('get_features_by_alias')
 110          || $db->can('get_feature_by_name')
 111       or return;
 112     return $db->$f( $name );
 113 }
 114
 115 sub _make_feature_xrefs {
 116     my ( $self, $features ) = @_;
 117
 118     # group the features by source sequence
 119     my %src_sequence_matches;
 120     push @{$src_sequence_matches{$_->seq_id}{features}}, $_ for @$features;
 121
 122     # group the features for each src sequence into non-overlapping regions
 123     for my $src ( values %src_sequence_matches ) {
 124
 125         # if the features are Bio::DB::GFF::Features, union() is buggy, so convert them
 126         # to Bio::Range to perform the union calculation
 127         my $ranges = $src->{features}->[0]->isa('Bio::DB::GFF::Feature')
 128             ? [ map Bio::Range->new( -start => $_->start, -end => $_->end ), @{$src->{features}} ]
 129             : $src->{features};
 130         my @regions =  map { {range => $_} } Bio::Range->unions( @$ranges );
 131
 132         # assign the features to each region
 133       FEATURE:
 134         foreach my $feature (@{$src->{features}}) {
 135             foreach my $region (@regions) {
 136                 if( $feature->overlaps( $region->{range} )) {
 137                     push @{$region->{features}}, $feature;
 138                     next FEATURE;
 139                 }
 140             }
 141         }
 142         $src->{regions} = \@regions;
 143         delete $src->{features}; #< not needed anymore
 144     }
 145
 146     # make CrossReference object for each region
 147     return  map $self->_make_region_xref( $_ ),
 148             map @{$_->{regions}},
 149             values %src_sequence_matches;
 150 }
 151
 152 sub _make_cross_ref {
 153     shift;
 154     return (__PACKAGE__.'::CrossReference')->new( @_ );
 155 }
 156
 157 sub _make_region_xref {
 158     my ( $self, $region ) = @_;
 159
 160     my $features      = $region->{features};
 161     my $first_feature = $features->[0];
 162     my $range         = $region->{range};
 163
 164     my ( $start, $end ) = ( $range->start, $range->end );
 165     ( $start, $end ) = ( $end, $start ) if $start > $end;
 166
 167     my @highlight =
 168         @$features == 1 # highlight our feature or region if we can
 169             ? ( h_feat => $first_feature->display_name )
 170             : ( h_region =>  $first_feature->seq_id.":$start..$end" );
 171
 172     my $is_whole_sequence = # is the region the whole reference sequence?
 173        (    scalar @$features == 1
 174          && $first_feature->seq_id eq $first_feature->display_name
 175          && $start == 1
 176          && $first_feature->can('length') && $end == $first_feature->length
 177        );
 178
 179     my $region_string =
 180        $is_whole_sequence
 181        # if so, just use the seq name as the region string
 182        ? $first_feature->seq_id
 183        # otherwise, print coords on the region string
 184        : $first_feature->seq_id.":$start..$end";
 185
 186     my @features_to_print = grep $_->display_name ne $_->seq_id, @{$region->{features}};
 187
 188     return $self->_make_cross_ref(
 189         text => join( ' ',
 190             $self->description.' - ',
 191             "view $region_string",
 192             ( @features_to_print
 193                  ? ' ('.join(', ', map $_->display_name || $_->primary_id, @features_to_print).')'
 194                  : ()
 195             ),
 196             ),
 197         url =>
 198             $self->view_url({
 199                 name => $region_string,
 200                 @highlight,
 201             }),
 202         preview_image_url =>
 203             $self->image_url({
 204                 name   => $region_string,
 205                 format => 'GD',
 206             }),
 207
 208         seqfeatures  => $features,
 209         seq_id       => $first_feature->seq_id,
 210         is_whole_sequence => $is_whole_sequence,
 211         start        => $start,
 212         end          => $end,
 213         feature      => $self->gbrowse,
 214         data_source  => $self,
 215        );
 216 }
 217
 218 sub image_url {
 219     my ( $self, $q ) = @_;
 220     $q ||= {};
 221     $q->{width}    ||= 600;
 222     $q->{keystyle} ||= 'between',
 223     $q->{grid}     ||= 1;
 224     return $self->_url( 'gbrowse_img', $q );
 225 }
 226
 227
 228 package SGN::Feature::GBrowse2::DataSource::CrossReference;
 229 use Moose;
 230 use MooseX::Types::URI qw/ Uri /;
 231 extends 'SGN::SiteFeatures::CrossReference';
 232
 233 with 'SGN::SiteFeatures::CrossReference::WithPreviewImage',
 234      'SGN::SiteFeatures::CrossReference::WithSeqFeatures';
 235
 236 has 'data_source' => ( is => 'ro', required => 1 );
 237
 238 has 'is_whole_sequence' => (
 239     is => 'ro',
 240     isa => 'Bool',
 241     documentation => 'true if this cross-reference points to the entire reference sequence',
 242     );
 243
 244 has 'seq_id' => (
 245     is  => 'ro',
 246     isa => 'Str',
 247     );
 248
 249 has $_ => ( is => 'ro', isa => 'Int' )
 250   for 'start', 'end';
 251
 252 __PACKAGE__->meta->make_immutable;
 253 1;