Bio::Das::ProServer::SourceAdaptor::styletest - Bio::Das::ProServer::SourceAdaptor::styletest documentation

 Test harness for stylesheets.  Retrieves stylesheet, parses out
 feature types, and creates fake features with the correct type for
 each style.

 Bio::Das::ProServer::SourceAdaptor

#########
# Author:        jws
# Maintainer:    jws
# Created:       2005-04-20
# Last Modified: $Date: 2008-12-03 23:14:25 +0000 (Wed, 03 Dec 2008) $
# $Id: styletest.pm 548 2008-12-03 23:14:25Z zerojinx $
# $HeadURL: https://proserver.svn.sf.net/svnroot/proserver/trunk/lib/Bio/Das/ProServer/SourceAdaptor/styletest.pm $
#
# lots of magic numbers in this package:
## no critic (ValuesAndExpressions::ProhibitMagicNumbers)
#
package Bio::Das::ProServer::SourceAdaptor::styletest;
use strict;
use warnings;
use base qw(Bio::Das::ProServer::SourceAdaptor);

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

sub capabilities {
  return {
	  features   => '1.0',
	  stylesheet => '1.0',
	 };
}

sub length { ## no critic
  return 1;
}

sub build_features {
  my ($self, $opts) = @_;
  my $seg     = $opts->{segment};
  my $start   = $opts->{start};
  my $end     = $opts->{end};
  my @features;

  if(CORE::length($seg) > 2) {
    #########
    # only do this for chromosomes
    #
    return;
  }

  my $stylesheet = $self->das_stylesheet();

  #########
  # This is a quick hack, so we aren't going to do a full XML parsing
  # of the stylesheet tree here.  Just grab out the id from the TYPE lines:
  # e.g. <TYPE id="segdup:direct_mid_vfar">
  #
  my @types;

  for my $ss (split /\n/mx, $stylesheet) {
    if($ss !~ /<\s*TYPE/mix) {
      next;
    }

    my ($trap) = $ss =~ /id\s*=\s*["']{1}([^"']*)["']{1}/mix;
    if($trap) {
      push @types, $1;
    }
  }

  for my $type (@types) {
    #########
    # workaround for annoying Bio::Das method forcing type to method:type
    #
    my $method = $type;
    $method    =~ s/:.*//mx; # throw away everything after :

    #########
    # create a number of features for each type, on each strand:
    #  - overlapping start (by 5% of range)
    #  - 1 bp
    #  - small (5% of range)
    #  - medium-ish (25% of range)
    #  - overlapping end (by 5% of range)
    #
    # All pretty arbitrary, obviously.
    # Adjust the spacing so the features all get a share of the space to
    # try and minimise bumping caused by label overlaps.
    #
    my $range = $end - $start;

    #########
    # generate features on both strands
    #
    for my $ori (qw(+ -)) {

      my $oldend = $start-100;

      #########
      # overlapping start feature - width is 5% of range
      #
      my $newend = $start + ($range * 0.05);

      push @features, {
		       id           => $type,
		       start        => $oldend,
		       end          => $newend,
		       ori          => $ori,
		       type         => $type,
		       typecategory => 'similarity',
		       method       => $method
		      };

      #########
      # add spacer
      #
      $oldend = $newend + ($range * 0.17);

      #########
      # 1 bp feature
      #
      $newend = $oldend + 1;

      push @features, {
		       id           => $type,
		       start        => $oldend,
		       end          => $newend,
		       ori          => $ori,
		       type         => $type,
		       typecategory => 'similarity',
		       method       => $method
		      };

      #########
      # add a bigger spacer
      #
      $oldend = $newend + ($range * 0.22);

      #########
      # small (5% range) feature
      #
      $newend = $oldend + ($range * 0.05);
      push @features, {
		       id           => $type,
		       start        => $oldend,
		       end          => $newend,
		       ori          => $ori,
		       type         => $type,
		       typecategory => 'similarity',
		       method       => $method
		      };

      $oldend = $newend + ($range * 0.16);

      #########
      # medium (25% range) feature
      #
      $newend = $oldend + ($range * 0.25);
      push @features, {
		       id           => $type,
		       start        => $oldend,
		       end          => $newend,
		       ori          => $ori,
		       type         => $type,
		       typecategory => 'similarity',
		       method       => $method
		      };

      $oldend = $newend + ($range * 0.05);

      #########
      # overlapping end
      #
      $newend = $end + 100;
      push @features, {
		       id           => $type,
		       start        => $oldend,
		       end          => $newend,
		       ori          => $ori,
		       type         => $type,
		       typecategory => 'similarity',
		       method       => $method
		      };
    }
  }

  return @features;
}

1;
__END__