Bio::DB::GFF::Aggregator::waba_alignment - A WABA alignment

  use Bio::DB::GFF;

  # Open the sequence database
  my $db      = Bio::DB::GFF->new( -adaptor => 'dbi:mysql',
                                   -dsn     => 'dbi:mysql:elegans42',
				   -aggregator => ['waba_alignment'],
				 );
  # fetch the synthetic feature type "waba_alignment"
  my @waba    = $db->features('waba_alignment');

 -------------------------------------------------------------------------------------
 Aggregator method: waba_alignment
 Main method:       -none
 Sub methods:       nucleotide_match:waba_weak nucleotide_match:waba_strong 
                    nucleotide_match::waba_coding
 -------------------------------------------------------------------------------------

   nucleotide_match:waba_weak
   nucleotide_match:waba_strong
   nucleotide_match:waba_coding

 Title   : method
 Usage   : $aggregator->method
 Function: return the method for the composite object
 Returns : the string "waba_alignment"
 Args    : none
 Status  : Public

 Title   : part_names
 Usage   : $aggregator->part_names
 Function: return the methods for the sub-parts
 Returns : the list "nucleotide_match:waba_weak", "nucleotide_match:waba_strong" and "nucleotide_match:waba_coding"
 Args    : none
 Status  : Public

package Bio::DB::GFF::Aggregator::waba_alignment;

use strict;
use Bio::DB::GFF::Aggregator;
use constant CONTINUITY_BIN => 5000;

use vars qw($VERSION @ISA);
@ISA = qw(Bio::DB::GFF::Aggregator);

$VERSION = '0.20';

sub method { 'waba_alignment' }

sub part_names {
  return qw(
	  nucleotide_match:waba_weak
	  nucleotide_match:waba_strong
	  nucleotide_match:waba_coding
	   );
}

# we modify the aggregate method so that significant breaks in continuity
# result in distinct groups.  This is done by binning the absolute difference
# between the source and target coordinates.  Mostly contiguous 
sub aggregate {
  my $self = shift;
  my $features = shift;
  my $factory  = shift;

  my $meth        = $self->method;
  my $main_method = $self->get_main_name;
  my $matchsub    = $self->match_sub($factory) or return;
  my $passthru    = $self->passthru_sub($factory);

  my (%aggregates,@result);
  for my $feature (@$features) {
    if ($feature->group && $matchsub->($feature)) {
      my $bin = get_bin($feature);
      if ($main_method && lc $feature->method eq lc $main_method) {
	$aggregates{$feature->group,$feature->ref,$bin}{base} ||= $feature->clone;
      } else {
	push @{$aggregates{$feature->group,$feature->ref,$bin}{subparts}},$feature;
      }
      push @result,$feature if $passthru && $passthru->($feature);

    } else {
      push @result,$feature;
    }
  }

  # aggregate components
  my $pseudo_method        = $self->get_method;
  my $require_whole_object = $self->require_whole_object;
  foreach (keys %aggregates) {
    if ($require_whole_object && $self->components) {
      next unless $aggregates{$_}{base} && $aggregates{$_}{subparts};
    }
    my $base = $aggregates{$_}{base};
    unless ($base) { # no base, so create one
      my $first = $aggregates{$_}{subparts}[0];
      $base = $first->clone;     # to inherit parent coordinate system, etc
      $base->score(undef);
      $base->phase(undef);
    }
    $base->method($pseudo_method);
    $base->source('waba') if $pseudo_method eq $meth;
    $base->add_subfeature($_) foreach @{$aggregates{$_}{subparts}};
    $base->adjust_bounds;
    $base->compound(1);  # set the compound flag
    push @result,$base;
  }
  @$features = @result;
}

sub get_bin {
  my $feature = shift;
  my $target = $feature->target or return 0;
  my ($start,$end) = ($target->start,$target->end);
  my $distance = $end > $start ? $target->start-$feature->start : $target->start+$feature->start;
  return int(abs($distance)/CONTINUITY_BIN);
}

1;
__END__