package Bio::Graphics::Browser2::Markup;
use strict;
use Carp 'croak';
use Bio::Graphics::Panel;
=head1 NAME
Bio::Graphics::Browser2::Markup - Markup routines for sequences in text form
=head1 VERSION (CVS-info)
$RCSfile: Markup.pm,v $
$Revision$
$Author: lstein $
$Date: 2008-09-09 20:53:36 $
=head1 SYNOPSIS
use Bio::Graphics::Browser2::Markup;
my $string = join '','a'..'z','a'..'z','a'..'z';
my $markup = Bio::Graphics::Browser2::Markup->new;
$markup->add_style(cds=>'UPPERCASE');
$markup->add_style(exon =>'Text-decoration: underline');
$markup->add_style(variation=>'Font-weight: bold');
$markup->add_style(italic=>'Font-style: oblique');
$markup->add_style(yellow=>'BGCOLOR blue');
$markup->add_style(green=>'BGCOLOR red');
$markup->add_style(orange=>'BGCOLOR orange');
$markup->add_style(mango=>'FGCOLOR red');
$markup->add_style(br=>'<br>');
$markup->markup(\$string,[
['cds',1=>10],
['cds',12=>15],
['variation',20=>41],
['exon',0=>29],
['exon',32=>40],
['italic',18=>29],
['yellow',5=>40],
['green',20=>50],
['orange',30=>60],
['mango',0=>36],
['br',10=>10],
['br',20=>20],
['br',30=>30],
['br',40=>40],
['br',50=>50],
['br',60=>60],
]);
print $string,"\n";
=head1 DESCRIPTION
This module marks up a string with HTML cascading stylesheet styles in
such a way that intersecting regions contain the union of the two
intersecting styles. It also handles colors in such a way that
intersecting colors are added up.
=head1 METHODS
=head2 $annotator = Bio::Graphics::Browser2::Markup->new
Create a new Markup object.
=cut
my $SYNTHETIC_SYMBOL = "CLR00000000000";
sub new {
my $class = shift;
my $self = {
colors => {},
seq => 0,
symbols => {},
};
return bless $self,ref($class) || $class;
}
=head2 $old_style = $annotator->add_style($symbolic_name=>$style)
Add an annotation style.
$symbolic name is a unique identifier to be used for ornamenting the
string.
$style is one of:
- a CSS/2 stylesheet entry of form "style: value"
- the word "UPPERCASE" (make uppercase)
- the word "LOWERCASE" (make lowercase)
- the phrase "FGCOLOR #RRGGBB" (foreground color)
- the phrase "FGCOLOR color-name"
- the phrase "BGCOLOR #RRGGBB" (background color)
- the phrase "BGCOLOR color-name"
- an HTML tag, indicated by a leading "E<lt>" character
- anything else, will be inserted blindly
When calculating intersected regions, styles will be aggregated, upper
and lowercasing will be performed directly on the data, colors will be
additive, and HTML will be inserted blindly.
An invalid color name will cause this module to die. Valid color
names can be obtained this way:
perl -MBio::Graphics::Panel \
-e 'print join "\n",sort Bio::Graphics::Panel->color_names'
=cut
sub add_style {
my $self = shift;
my ($symbolic_name,$style) = @_;
my $entry;
if ($style =~ /^(UPPER|LOWER)CASE$/) { # upper/lower case
$entry = [uclc => $1];
}
elsif ($style =~ /^(FG|BG)COLOR\s+\#([0-9A-Fa-f])([0-9A-Fa-f])([0-9A-Fa-f])/){ # a hex color
$entry = [lc($1).'color' => [hex $2, hex $3, hex $4]];
}
elsif ($style =~ /^(FG|BG)COLOR\s+(\w+)/) { # a symbolic color
my $rgb = Bio::Graphics::Panel->color_name_to_rgb($2) or croak "invalid color name";
$entry = [lc($1).'color' => $rgb];
}
elsif ($style =~ /^[\w-]+:.+/) { # css entry
$entry = [style => $style ];
}
elsif ($style =~ /^<.+>$/) { # html
$entry = [html => $style];
}
else { # something else, just insert it blindly
$entry = [literal => $style];
}
$self->{symbols}{$symbolic_name} = $entry;
}
=head2 $style = $annotator->style($symbolic_name)
Get the style corresponding to symbolic name, or undef if the name is
unrecognized.
=cut
sub style {
my $self = shift;
my $symbolic = shift;
return $self->{symbols}{$symbolic}[1];
}
=head2 $style = $annotator->get_style($symbolic_name)
Get a list of CSS/2 styles corresponding to symbolic name. Will die
if the name is not recognized or does not correspond to an entry of
type "style".
=cut
sub get_style {
my $self = shift;
my $symbolic = shift;
croak "invalid style" unless $self->{symbols}{$symbolic}[0] eq 'style';
return split /[:;]\s*/,$self->{symbols}{$symbolic}[1];
}
=head2 $flag = $annotator->valid_symbol($symbolic_name)
Return true if the symbolic name is valid.
=cut
sub valid_symbol {
my $self = shift;
my $symbolic = shift;
return exists $self->{symbols}{$symbolic};
}
=head2 $result = $annotator->markup(\$sequence,\@annotated_regions)
Mark up the string referenced by $sequence, according to the regions
contained in $annotated_regions.
$sequence is a scalar ref, which will be modified in place (make a
copy of it if you need to). $annotated_regions is a arrayref to the
following list:
([symbolic_name,start,end], [symbolic_name,start,end], ....)
The result indicates whether the markup was successful.
IMPORTANT: Regions are numbered using space-oriented coordinates,
which means that start=0 means to insert in front of the first base
pair, and an end equal to the sequence length will insert after the
last base pair:
0 1 2 3 4 5 6 7 perl string coordinates
1 2 3 4 5 6 7 8 sequence coordinates
g a t c g a t c sequence
0 1 2 3 4 5 6 7 8 space coordinates
To select first base: start=0, end=1
To insert markup between bases 1 and 2: start=1, end=1
To select last base: start=7, end=8
To select entire sequence: start=0, end=8
This means that some munging of the sequence annotation must be
performed, but it keeps the notation unambiguous.
=cut
sub markup {
my $self = shift;
my ($sequence,$regions) = @_;
$self->{seq} = 0; # package global
# classify regions by type
my %regions;
foreach (@$regions) {
my $type = $self->{symbols}{$_->[0]}[0] or croak "Unknown region type: $_->[0]";
push @{$regions{$type}},$_;
}
# pull out the regions that ask for upper/lower case and
# give them the special treatment
foreach (@{$regions{uclc}}) {
my ($style,$start,$end) = @$_;
$self->{symbols}{$style}[1] eq 'UPPER' ? substr($$sequence,$start,$end-$start) =~ tr/a-z/A-Z/
: substr($$sequence,$start,$end-$start) =~ tr/A-Z/a-z/;
}
my @style_regions;
# meld the "color" regions into a set of additive regions
push @style_regions,$self->_add_colors('Color',$regions{fgcolor}) if $regions{fgcolor};
push @style_regions,$self->_add_colors('Background-color',$regions{bgcolor}) if $regions{bgcolor};
# add the "style" regions
push @style_regions,@{$regions{style}} if $regions{style};
my @tags = $self->_unify(\@style_regions);
# add HTML markup
push @tags,$self->_linearize_html($regions{html});
# add literals
push @tags,map { [$self->{symbols}{$_->[0]}[1],$_->[1],$self->{seq}++] } @{$regions{literal}}
if $regions{literal};
# insert the tags in their proper place
$self->_add_markup($sequence,\@tags);
1;
}
=head2 Internal Methods (not for external use; documentation incomplete)
=over 4
=item @events = $annotator->_add_colors($style_tag,$regions)
=back
=cut
# calculate the intersection of the regions with additive colors
sub _add_colors {
my $self = shift;
my ($style_tag,$regions) = @_;
# convert regions into events
my $events = $self->_regions_to_events($regions);
# insert new color events whenever we see two or more start events in a row
my @events;
my $current_color = [0,0,0];
my $current_position;
for my $e (@$events) {
my ($event,$symbol,$position) = @$e;
my $rgb = $self->{symbols}{$symbol}[1] or croak "unknown color style";
my $cc = join '',@$current_color;
if ($event eq 'start') {
push @events,[$self->_color_symbol($style_tag,$current_color),$current_position,$position]
if defined $current_position && $cc != 0;
$current_color = $self->_add_color($current_color,$rgb);
}
else { # event eq 'end'
push @events,[$self->_color_symbol($style_tag,$current_color),$current_position,$position]
if defined $current_position && $cc != 0;
$current_color = $self->_subtract_color($current_color,$rgb);
}
$current_position = $position;
}
return @events;
}
=over 4
=item $style_symbol = $annotator->_add_colors($style_tag,$regions)
=back
=cut
sub _color_symbol {
my $self = shift;
my ($style_tag,$color) = @_;
my $html_color = $self->_to_html_color($color);
if (!$self->{colors}{$style_tag,$html_color}) {
my $synthetic = $self->{colors}{$style_tag,$html_color} = $SYNTHETIC_SYMBOL++;
$self->add_style($synthetic,"$style_tag: $html_color");
}
$self->{colors}{$style_tag,$html_color}
}
=over 4
=item $color = $annotator->_add_color($color1,$color2)
=back
=cut
sub _add_color {
my $self = shift;
my ($a_color,$b_color) = @_;
my @result;
for (0..2) {
my $result = $a_color->[$_] + $b_color->[$_];
push @result,$result;
}
\@result;
}
=over 4
=item $color = $annotator->_subtract_color($color1,$color2)
=back
=cut
sub _subtract_color {
my $self = shift;
my ($a_color,$b_color) = @_;
my @result;
for (0..2) {
my $result = $a_color->[$_] - $b_color->[$_];
push @result,$result;
}
\@result;
}
=over 4
=item $html_color = $annotator->_to_html_color($color)
=back
=cut
sub _to_html_color {
my $self = shift;
my $rgb = shift;
my @hex = map {sprintf("%02X",$_ % 256)} @$rgb;
return '#'.join '',@hex;
}
=over 4
=item @tag_positions = $annotator->_unify($region_definitions)
=back
=cut
sub _unify {
my $self = shift;
my $regions = shift;
# convert regions into events
my $events = $self->_regions_to_events($regions);
my @result;
my %current_symbols;
my $open = 0;
for my $e (@$events) {
my ($event,$symbol,$position,$seq) = @$e;
if ($event eq 'start') {
$current_symbols{$symbol}++;
if ($open++) {
if ($result[-1][1] < $position) { # this test inhibits empty <span></span> sections
push @result,[qq(</span>),$position,$self->{seq}++];
} else {
pop @result; # suppress empty tag sections
}
}
my $style = $self->_to_style(\%current_symbols);
push @result,[qq(<span style="$style">),$position,$self->{seq}++];
}
elsif ($event eq 'end') {
$current_symbols{$symbol}--;
if ($open--) { # this test inhibits empty <span></span> sections
if ($result[-1][1] < $position) {
push @result,[qq(</span>),$position,$self->{seq}++];
} else {
pop @result; # suppress empty tag sections
}
}
next unless $open;
my $style = $self->_to_style(\%current_symbols);
push @result,[qq(<span style="$style">),$position,$self->{seq}++];
}
}
die "programmer error: open tags != close tags" if $open != 0;
return @result;
}
=over 4
=item $style_fragment = $annotator->_to_style($symbols)
=back
=cut
sub _to_style {
my $self = shift;
my $symbols = shift;
my @active = sort grep {$symbols->{$_}>0} keys %$symbols;
my $symbol_key = join '-',@active;
return $self->{_style_cache}{$symbol_key}
if exists $self->{_style_cache}{$symbol_key};
my %attributes;
foreach (@active) {
next unless $symbols->{$_}>0;
my %a = $self->get_style($_);
%attributes = (%attributes,%a);
}
my @style;
foreach (keys %attributes) {
push @style,"$_: $attributes{$_}";
}
my $style = join '; ',@style;
return $self->{_style_cache}{$symbol_key} = $style;
}
=over 4
=item @tag_positions = $annotator->_linearize_html($region_definitions)
=back
=cut
sub _linearize_html {
my $self = shift;
my $regions = shift;
my $events = $self->_regions_to_events($regions);
my @result;
my ($last_symbol,$last_position);
foreach (@$events) {
my ($event,$symbol,$pos,$seq) = @$_;
if ($event eq 'end'
&& defined($last_symbol)
&& $symbol eq $last_symbol
&& $pos == $last_position) {
my $tag = $self->{symbols}{$symbol}[1];
$tag =~ s!>$! />!;
push @result,[$tag,$pos,$self->{seq}++];
undef $last_symbol;
next;
}
if (defined $last_symbol) {
my $tag = $self->{symbols}{$last_symbol}[1];
push @result,[$tag,$pos,$self->{seq}++];
}
if ($event eq 'start') {
$last_symbol = $symbol;
$last_position = $pos;
}
else {
my $tag = $self->{symbols}{$last_symbol}[1];
$tag =~ s!^<(\w+).*>$!</$1>!;
push @result,[$tag,$pos,-$self->{seq}++];
undef $last_symbol;
}
}
if (defined $last_symbol) {
my $tag = $self->{symbols}{$last_symbol}[1];
push @result,[$tag,$last_position,$self->{seq}++];
}
@result;
}
=over 4
=item \@events = $annotator->_regions_to_events($regions)
turn a series of regions into a series of start and end events
because of the problem of events that start/stop in the same place
each event also gets a sequence that can be used to keep events
matched in a nested way
=back
=cut
sub _regions_to_events {
my $self = shift;
my $regions = shift;
my @events;
foreach (@$regions) {
$self->{seq}++;
my ($symbol,$start,$end) = @$_;
push @events,[start => $symbol,$start,$self->{seq}];
push @events,[end => $symbol,$end, $start == $end ? ++$self->{seq} : -$self->{seq}];
}
# now sort events according to their position, using the
# sequence to resolve ties. Notice the use of -$seq so
# that the sorting order of end ties is reversed relative
# to start ties. This causes regions to nest properly.
my @sorted_events = sort {$a->[2]<=>$b->[2] || $a->[3]<=>$b->[3]} @events;
\@sorted_events;
}
=over 4
=item $annotator->_add_markup($string_to_modify,$tag_positions)
=back
=cut
sub _add_markup {
my $self = shift;
my $string = shift;
my $markups = shift;
for my $m (sort {$b->[1]<=>$a->[1] || $b->[2]<=>$a->[2]} @$markups) {
my ($thing,$position) = @$m;
next if $position > length($$string);
substr($$string,$position,0) = $thing;
}
}
=head1 SEE ALSO
L<Bio::Graphics::Panel>,
L<Bio::Graphics::Glyph>,
L<Bio::Graphics::Feature>,
L<Bio::Graphics::FeatureFile>,
L<Bio::Graphics::Browser>,
L<Bio::Graphics::Browser2::Plugin>
=head1 AUTHOR
Lincoln Stein E<lt>lstein@cshl.orgE<gt>.
Copyright (c) 2002 Cold Spring Harbor Laboratory
This library is free software; you can redistribute it and/or modify
it under the same terms as Perl itself. See DISCLAIMER.txt for
disclaimers of warranty.
=cut
1;
__END__