view release on metacpan or  search on metacpan

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

    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