Bio::Das::ProServer::SourceAdaptor::bed12 - Bio::Das::ProServer::SourceAdaptor::bed12 documentation

  Features by segment:
  <host>/das/<source>/features?segment=X:1,100

  Features by group ID:
  <host>/das/<source>/features?group_id=TRAN1

  Features by feature ID:
  <host>/das/<source>/features?feature_id=TRAN1:4

  [mybed]
  state       = on
  adaptor     = bed12
  path        = /data/
  filename    = example.bed
  ; coordinates -> test segment
  coordinates = NCBI_36,Chromosome,Homo sapiens -> X:1,100

#########
# Author:        Andy Jenkinson
# Maintainer:    $Author: zerojinx $
# Created:       2008-09-19
# Last Modified: $Date: $
# $Id: bed12.pm 549 2008-12-03 23:35:54Z zerojinx $
# $HeadURL: https://proserver.svn.sf.net/svnroot/proserver/trunk/lib/Bio/Das/ProServer/SourceAdaptor/bed12.pm $
#
## no critic (ValuesAndExpressions::ProhibitImplicitNewlines)
#
package Bio::Das::ProServer::SourceAdaptor::bed12;

use strict;
use warnings;
use Carp;
use base qw(Bio::Das::ProServer::SourceAdaptor);

our $VERSION = do { my ($v) = (q$Revision: $ =~ /\d+/mxg); $v; };

sub init {
  my $self = shift;
  $self->config()->{'transport'} ||= 'bed12';
  return;
}

sub capabilities {
  return {
	  features        => '1.0',
	  'feature-by-id' => '1.0',
	  'group-by-id'   => '1.0',
	 };
}

sub build_features {
  my ( $self, $args ) = @_;
  
  my $segmentid = $args->{'segment'};
  my $featureid = $args->{'feature_id'};
  my $groupid   = $args->{'group_id'};
  my $start     = $args->{'start'};
  my $end       = $args->{'end'};

  # Querying by feature ID and not segment ID
  if ( my $name = $featureid ) {
    $self->{'debug'} && carp $self->dsn.": querying by feature ID $featureid";
    # The 'name' field can either be the feature ID or the group ID, depending
    # on whether the BED line contains blocks. If the latter, the feature ID
    # is actually groupid:1 groupid:2 etc
    $name =~ s/:\d+$//mx;
    my $query = sprintf
      'SELECT chrom, chromStart, chromEnd,
                            name, score, strand,
                            blockCount, blockSizes, blockStarts
              FROM   %s
              WHERE  name = ?', $self->transport()->tablename();
    my $rows = $self->transport()->query( $query, $name );
    return grep {
      $_->{feature_id} eq $featureid
    } @{ $self->_build_features_from_rows( $rows ) };
  }

  # Querying by group ID and not segment ID
  elsif ( $groupid ) {
    # Assume that the 'name' field refers to the group ID
    $self->{'debug'} && carp $self->dsn.": querying by group ID $groupid";
    my $query = sprintf
      'SELECT chrom, chromStart, chromEnd,
                            name, score, strand,
                            blockCount, blockSizes, blockStarts
              FROM   %s
              WHERE  name = ?', $self->transport()->tablename();
    my $rows = $self->transport()->query( $query, $groupid );
    # Still need to check that the name field doesn't actually refer to the feature ID
    return grep {
      $_->{group_id} eq $groupid
    } @{ $self->_build_features_from_rows( $rows ) };
  }

  # Querying by segment ID
  elsif ( $segmentid ) {
    $self->{'debug'} && carp $self->dsn.": querying by segment $segmentid:$start,$end";
    my $query = sprintf
      'SELECT chrom, chromStart, chromEnd,
                            name, score, strand,
                            blockCount, blockSizes, blockStarts
              FROM   %s
              WHERE  chrom = ?', $self->transport()->tablename();
    my @args = ("chr$segmentid");
    if ( defined $start && defined $end ) {
      $query .= ' AND chromEnd >= ? AND chromStart <= ?';
      push @args, $start-1, $end; # BED start position is zero-based
    }
    my $rows = $self->transport()->query( $query, @args );
    return @{ $self->_build_features_from_rows( $rows ) };
  }

  # Not specified... 
  carp $self->dsn.': no segment ID, group ID or feature ID given';
  return ();
}

sub _build_features_from_rows {
  my $self     = shift;
  my $rows     = shift;
  my @features = ();

  for my $row ( @{ $rows } ) {

    defined $row->{'chromStart'} || next;
    my $segment = $row->{'chrom'};
    $segment    =~ s/^chr//mx;

    # One feature line can represent several features
    if ( my $block_count = $row->{'blockCount'} ) {
      my @block_sizes  = split m/,/mx, $row->{'blockSizes'} , $block_count;
      my @block_starts = split m/,/mx, $row->{'blockStarts'}, $block_count;

      my $i = 0;
      while ($i<$block_count) {
        push @features, {
          'segment'    => $segment,
          'start'      => $block_starts[$i] + $row->{'chromStart'} + 1,
          'end'        => $block_starts[$i] + $row->{'chromStart'} + $block_sizes[$i],
          'ori'        => $row->{'strand'},
          'score'      => $row->{'score'},
          'group_id'   => $row->{'name'},
          'feature_id' => $row->{'name'} . q[:] . ++$i,
          'type'       => $row->{'name'},
          'method'     => 'BED conversion',
        };
      }

    } else {
      push @features, {
        'segment'    => $segment,
        'start'      => $row->{'chromStart'} + 1,
        'end'        => $row->{'chromEnd'},
        'ori'        => $row->{'strand'},
        'score'      => $row->{'score'},
        'group_id'   => $row->{'name'},
        'feature_id' => $row->{'name'} . ':1',
        'type'       => $row->{'name'},
        'method'     => 'BED conversion',
      };
    }
  }

  $self->{'debug'} && printf "%s: returning %d features\n", $self->dsn, scalar @features;
  return \@features;
}

1;
__END__