gbrowse 2.54+dfsg-6build1 / etc / gbrowse / plugins / AttributeHiliter.pm

package Bio::Graphics::Browser2::Plugin::AttributeHiliter;
# $Id: AttributeHiliter.pm,v 1.3 2009-05-22 14:33:38 lstein Exp $
use strict;
use Bio::Graphics::Browser2::Plugin;
use Bio::Graphics::Browser2::Util 'shellwords';
use CGI qw(:standard);

use constant DEBUG => 0;

use vars qw($VERSION @ISA);

my @COLORS = ('',qw(
		   red brown magenta maroon pink orange
		   yellow tan teal cyan lime green blue
		   lightgrey grey darkgrey
		  ));

$VERSION = '0.01';

@ISA = qw(Bio::Graphics::Browser2::Plugin);

sub name { "Selected Properties" }
sub description {
  p("This plugin highlights features whose properties match certain criteria.",
    "It was written by Lincoln Stein.");
}

sub type { 'highlighter' }

# This routine is a bit more complicated than it needs to be because of
# an optimization.  What it does is to compile the highlighting pattern specified
# by the current configuration into a subroutine called "memoized_sub" and then
# invoke it.  On subsequent invocations if the config hasn't changed, the
# compiled subroutine is reinvoked.  Otherwise a new sub is compiled.  The compiled
# sub can be seen by setting the DEBUG constant at the top of this file to true.

sub highlight {
  my $self = shift;
  my $feature = shift;

  my $config = $self->configuration;
  return unless %$config;

  return $self->{memoized_sub}->($feature)
    if $self->{memoized_sub} && $self->{memoized_config} eq join ' ',%$config;

  my $sub = "sub { \n";
  $sub   .= "  my \$feature = shift;\n";

  for my $attribute (keys %$config) {
    my ($color,$text) = split(/\s+/,$config->{$attribute},2);
    next unless defined $color && defined $text;

    warn "trying to colorize $attribute with text=$text, color = $color\n" if DEBUG;

    my $regexp = quotemeta($text);
    if ($attribute eq 'Feature Name') {
      $sub .= "  return '$color' if \$feature->display_name =~ /$regexp/i;\n";
    } elsif ($attribute eq 'Feature Type') {
      $sub .= "  return '$color' if \$feature->type =~ /$regexp/i;\n";
    } elsif (defined $attribute) {
      $sub .= "  return unless \$feature->can('attributes');\n";
      $sub .= "  foreach (\$feature->attributes('$attribute')) { return '$color' if /$regexp/i }\n";
    }
  }
  $sub .= "  return\n}";
  warn $sub if DEBUG;
  $self->{memoized_sub}    = eval $sub or warn $@;
  $self->{memoized_config} = join ' ',%$config;
  return $self->{memoized_sub}->($feature) if $self->{memoized_sub};
  return;
}

sub config_defaults {
    my $self = shift;
    return { };
}

sub reconfigure {
  my $self = shift;
  my $current_config = $self->configuration;
  my %c;
  foreach my $param ($self->config_param) {
    warn "param = $param" if DEBUG;
    my ($operation,$attribute) = $param =~ /(match|color)\.(.+)/ or next;
    $c{$attribute}{$operation} = $self->config_param($param);
  }
  foreach my $attribute (keys %c) {
    if ( (my $match_text = $c{$attribute}{match}) && (my $match_color = $c{$attribute}{color})) {
      $current_config->{$attribute} = "$match_color $match_text";
    } else {
      delete $current_config->{$attribute};
    }
  }
  delete $self->{memoized_sub};
}

sub configure_form {
    my $self = shift;
    my $current_config = $self->configuration;
    my @attributes     = shellwords $self->browser_config->plugin_setting('attributes');
    unshift @attributes,'Feature Name','Feature Type';

    my @rows;
    push @rows,TR({-class=>'searchtitle'},th(['Property','Text to Match','Highlight Color']));

    for my $attribute (@attributes) {
      next unless $attribute;
      my ($color,$text) = split(/\s+/,$current_config->{$attribute}||'',2);
      push @rows,TR(
		    th({-class=>'searchtitle',-align=>'RIGHT'},$attribute),
		    td({-align=>'CENTER'},textfield(-name    => $self->config_name("match.$attribute"),
						    -default => $text,
						    -size    => 60)),
		    td(popup_menu(-name  => $self->config_name("color.$attribute"),
				  -values=> \@COLORS,
				  -default => $color,
				 )))
    }

    return table({-width=>'10%',-border=>0},@rows);
}


1;


__END__

=head1 NAME

Bio::Graphics::Browser2::Plugin::AttributeHiliter -- hilite features based on attributes

=head1 SYNOPSIS

In the appropriate gbrowse configuration file:

 plugin = AttributeHiliter

 [AttributeHiliter:plugin]
 attributes    = Note prediction_status tissue_source

=head1 DESCRIPTION

This plugin creates a configuration page that prompts the user to
select features to hilite based on their attributes (also known as
feature tags in BioPerl parlance). You specify which attributes to
present in a [AttributeHiliter:plugin] configuration track with a
single "attributes" option. The value of this option is a
space-delimited list of attributes to present to the user.

A more sophisticated example using popup menus to select particular
attributes from a controlled vocabulary would be easy to write.

=head1 OPTIONS

None

=head1 BUGS

None known yet.

=head1 SEE ALSO

L<Bio::Graphics::Browser2::Plugin>

=head1 AUTHOR

Lincoln Stein E<lt>lincoln.stein@gmail.comE<gt>.

Copyright (c) 2009 Ontario Institute for Cancer Research

This library is free software; you can redistribute it and/or modify
it under the same terms as Perl itself.

=cut