view release on metacpan or  search on metacpan

conf/plugins/Aligner.pm  view on Meta::CPAN

package Bio::Graphics::Browser2::Plugin::Aligner;
# $Id: Aligner.pm,v 1.13 2008-09-18 15:27:07 lstein Exp $

use strict;
use Bio::Graphics::Browser2::Plugin;
use CGI qw(table a TR td th p popup_menu radio_group checkbox checkbox_group h1 h2 pre);
use Bio::Graphics::Browser2::Realign 'align_segs';
use Bio::Graphics::Browser2::PadAlignment;
use Bio::Graphics::Browser2::Util 'shellwords';

use constant DEBUG => 0;
use constant DEFAULT_RAGGED_ENDS => (0,10,25,50,100,150,500);

use vars '$VERSION','@ISA';
$VERSION = '0.23';
@ISA = qw(Bio::Graphics::Browser2::Plugin);

use constant TARGET    => 0;
use constant SRC_START => 1;
use constant SRC_END   => 2;
use constant TGT_START => 3;
use constant TGT_END   => 4;

sub name { "Alignments" }

sub description {
  p("This plugin prints out a multiple alignment of the selected features.",
    'It was written by',a({-href=>'mailto:lstein@cshl.org'},'Lincoln Stein.')
   );
}

sub init {
  my $self = shift;
  my $browser_conf = $self->browser_config;
  my @alignable       = shellwords($browser_conf->plugin_setting('alignable_tracks'));
  @alignable = grep {$browser_conf->setting($_=>'draw_target') } $browser_conf->labels
    unless @alignable;
  $self->{alignable} = \@alignable;

  my @upcase          = shellwords($browser_conf->plugin_setting('upcase_tracks'));
  $self->{upcase}     = \@upcase;

  my @ragged          = shellwords($browser_conf->plugin_setting('ragged_ends'));
  @ragged             = DEFAULT_RAGGED_ENDS unless @ragged;
  $self->{ragged}     = \@ragged;

  $self->{upcase_default} = $browser_conf->plugin_setting('upcase_default');
  $self->{align_default}  = $browser_conf->plugin_setting('align_default')
                           ? [shellwords($browser_conf->plugin_setting('align_default'))]
			   : \@alignable;
  $self->{ragged_default} = $browser_conf->plugin_setting('ragged_default');

}

sub config_defaults {
  my $self = shift;
  return { align  => @{$self->{align_default}} ? $self->{align_default} : $self->{alignable},
	   upcase => $self->{upcase}[0]
	 };
}

sub configure_form {
  my $self    = shift;
  my $current = $self->configuration;
  my $browser = $self->browser_config;
  my $html;
  if ($self->{upcase}) {
    my %labels = map {$_ => $browser->setting($_=>'key') || $_} @{$self->{upcase}};
    $html .= TR(
		th('Features to render uppercase:'),
		td(radio_group(-name    => $self->config_name('upcase'),
			       -values  => ['none',@{$self->{upcase}}],
			       -default  => $current->{upcase} || $self->{upcase_default} || 'none',
			       -labels   => \%labels,
			       @{$self->{upcase}} > 4 ? (-cols     => 4) : ()
			      ))
	       );
  }
  if ($self->{alignable} && @{$self->{alignable}}) {
    my %labels = map {$_ => $browser->setting($_=>'key') || $_} @{$self->{alignable}};
    $html .= TR(
		th('Features to include in alignment:'),
		td(checkbox_group(-name     => $self->config_name('align'),
				  -values   => $self->{alignable},
				  -defaults => $current->{align},
				  -labels   => \%labels,
				  @{$self->{alignable}} > 4 ? (-cols     => 4) : ()
				 )));
  }
  $html .= TR(
	      th({-colspan=>2,-align=>'left'},
		 'Allow up to',popup_menu(-name     => $self->config_name('ragged'),
					  -values   => $self->{ragged},
					  -default  => $current->{ragged} || $self->{ragged_default} || 0),
		 ' bp of unaligned sequence at ends.')
	      );
  return $html ? table({-class=>'searchtitle'},$html) : undef;
}

sub reconfigure {
  my $self = shift;
  my $current = $self->configuration;
  my @align   = $self->config_param('align');
  my $upcase  = $self->config_param('upcase');
  $current->{align}  = \@align;
  $current->{upcase} = $upcase eq 'none' ? undef : $upcase;
  $current->{ragged} = $self->config_param('ragged');
  $current->{flip} = $self->config_param('flip');
}

sub mime_type { 'text/html' }

sub dump {
  my $self    = shift;
  my $segment = shift;

  unless ($segment) {
    print "No sequence specified.\n";
    exit 0;
  }

  my $database      = $self->database;
  my $browser       = $self->browser_config;
  my $configuration = $self->configuration;

#  $configuration->{flip} = $self->page_settings->{flip};

  my $flipped = $configuration->{flip} ? " (reverse complemented)" :'';
  print h1("Alignments for $segment$flipped");

  my $ref_dna = lc $segment->dna;

  if ($segment->strand < 0) {  # don't ask
    $ref_dna    = reversec($ref_dna);
    $configuration->{flip} = 1;
  }

  my ($abs_start,$abs_end) = ($segment->start,$segment->end);

  # do upcasing
  if (my $upcase_track  = $configuration->{upcase}) {
    my @upcase_types    = shellwords($browser->setting($upcase_track=>'feature'));
    my @upcase_features = $segment->features(-types=>\@upcase_types);
    for my $f (@upcase_features) {
      my @segments = $f->segments;
      @segments    = $f unless @segments;
      for my $s (@segments) {
	my $upstart   = $s->low-$abs_start;
	my $uplength  = $s->length;
	$upstart      = 0 if $upstart < 0;
	$uplength     = length($ref_dna) if $uplength > length($ref_dna);
	substr($ref_dna,$upstart,$uplength) =~ tr/a-z/A-Z/;