[Bio] / FigKernelPackages / FIGgjo.pm Repository:
ViewVC logotype

View of /FigKernelPackages/FIGgjo.pm

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.3 - (download) (as text) (annotate)
Thu Apr 12 04:06:45 2007 UTC (12 years, 8 months ago) by golsen
Branch: MAIN
CVS Tags: rast_rel_2009_05_18, rast_rel_2008_06_18, myrast_rel40, rast_rel_2008_06_16, mgrast_dev_05262011, rast_rel_2008_12_18, mgrast_dev_04082011, rast_rel_2008_07_21, rast_rel_2010_0928, rast_2008_0924, rast_rel_2008_04_23, mgrast_dev_06072011, rast_rel_2008_09_30, rast_rel_2009_0925, rast_rel_2010_0526, mgrast_dev_02212011, rast_rel_2010_1206, mgrast_release_3_0, mgrast_dev_03252011, rast_rel_2010_0118, mgrast_rel_2008_0924, mgrast_rel_2008_1110_v2, rast_rel_2009_02_05, rast_rel_2011_0119, mgrast_rel_2008_0625, mgrast_release_3_0_4, mgrast_release_3_0_2, mgrast_release_3_0_3, mgrast_release_3_0_1, mgrast_dev_03312011, mgrast_release_3_1_0, mgrast_dev_04132011, rast_rel_2008_10_09, mgrast_dev_04012011, rast_release_2008_09_29, mgrast_rel_2008_0806, mgrast_rel_2008_0923, mgrast_rel_2008_0919, rast_rel_2009_07_09, rast_rel_2010_0827, mgrast_rel_2008_1110, myrast_33, rast_rel_2008_09_29, mgrast_rel_2008_0917, rast_rel_2008_10_29, mgrast_dev_04052011, mgrast_dev_02222011, rast_rel_2009_03_26, rast_rel_2008_11_24, rast_rel_2008_08_07
Changes since 1.2: +23 -8 lines
Improve handling of multidomain query sequences in coloring of sims
matches (do not include white, and fade all colors in the case of a
perfect match).

#
# Copyright (c) 2003-2007 University of Chicago and Fellowship
# for Interpretations of Genomes. All Rights Reserved.
#
# This file is part of the SEED Toolkit.
# 
# The SEED Toolkit is free software. You can redistribute
# it and/or modify it under the terms of the SEED Toolkit
# Public License. 
#
# You should have received a copy of the SEED Toolkit Public License
# along with this program; if not write to the University of Chicago
# at info@ci.uchicago.edu or the Fellowship for Interpretation of
# Genomes at veronika@thefig.info or download a copy from
# http://www.theseed.org/LICENSE.TXT.
#

#  This is a collection point for miscellaneous functions created by GJO
#  that are useful in multiple scripts within the SEED.  They could be put
#  in FIG.pm, but these are less central.

package FIGgjo;

use gjocolorlib;
use strict;

#------------------------------------------------------------------------------
#  This is a sufficient set of escaping for text in HTML (function and alias):
#
#     $html = html_esc( $text )
#------------------------------------------------------------------------------

sub html_esc { local $_ = $_[0]; s/\&/&amp;/g; s/\>/&gt;/g; s/\</&lt;/g; $_ }


#------------------------------------------------------------------------------
#  Set background color for html text:
#
#     $html = bgcolor( $html, $color )
#------------------------------------------------------------------------------
sub bgcolor
{
    return ! $_[0] ? ''       # No text
         : ! $_[1] ? $_[0]    # No color
         : "<span style='background-color:$_[1]'>$_[0]</span>"
}


#------------------------------------------------------------------------------
#  Default pallets for colorizing functions and roles.
#------------------------------------------------------------------------------

my @pallets = ( [ '#DDCCAA', '#FFAAAA', '#FFCC66', '#FFFF44',
                  '#CCFF66', '#88FF88', '#88EECC', '#88FFFF',
                  '#66CCFF', '#AAAAFF', '#CC88FF', '#FFAAFF'
                ],
                [ '#DDCCAA', '#FFAAAA', '#FFCC66', '#FFFF44',
                  '#AAFFAA', '#BBBBFF', '#FFAAFF'
                ]
              );

#  Find the smallest pallet that fits all of the colors

sub choose_pallet
{
    my ( $ncolor, $pallets ) = @_;
    my @pals = sort { @$b <=> @$a }  #  most to fewest colors
               ( $pallets ? @$pallets : @pallets );
    my $pallet = $pals[0];
    foreach ( @pals )
    {
        last if $ncolor > @$_;
        $pallet = $_;
    }
    wantarray ? @$pallet : $pallet;
}

#------------------------------------------------------------------------------
#  colorize_roles creates a hash relating functions to html versions in which
#  identical roles are colored the same.
#
#     %colorized_function = colorize_roles(  @functions )
#     %colorized_function = colorize_roles( \@functions )
#     %colorized_function = colorize_roles( \%functions )
#     %colorized_function = colorize_roles( \@functions, $current_func )
#     %colorized_function = colorize_roles( \%functions, $current_func )
#
#  where:
#
#     @functions           list of functions
#     %functions           hash of functions (key does not matter)
#     %colorized_function  hash of colorized html text keyed by function
#------------------------------------------------------------------------------
sub colorize_roles
{
    my $role_clr = role_colors( @_ );

    my @funcs = ref( $_[0] ) eq 'ARRAY' ? @{ $_[0] }
              : ref( $_[0] ) eq 'HASH'  ? map { $_[0]->{$_} } keys %{$_[0]}
              : @_;

    push @funcs, $_[1] if $_[1] && ref( $_[0] );
    
    my %funcs = map { $_ => 1 } @funcs;

    my %formatted_func = ();
    foreach my $func ( keys %funcs )
    {
        $formatted_func{ $func }
           = join( '', map { my $c = $role_clr->{ $_ };
                             my $t = html_esc( $_ );
                             $c ? bgcolor( $t, $c ) : $t
                           }
                       split /( +[#!].*$| *\; +| +\/ | +\@ +)/, $func
                 );
    }

    wantarray ? %formatted_func : \%formatted_func
}


#------------------------------------------------------------------------------
#  colorize_roles creates a hash relating functions to html versions in which
#  identical roles are colored the same.
#
#     %cell_info = colorize_roles_in_cell(  @functions )
#     %cell_info = colorize_roles_in_cell( \@functions )
#     %cell_info = colorize_roles_in_cell( \%functions )
#     %cell_info = colorize_roles_in_cell( \@functions, $current_func )
#     %cell_info = colorize_roles_in_cell( \%functions, $current_func )
#
#  where:
#
#     @functions  list of functions
#     %functions  hash of functions (key does not matter)
#     %cell_info  hash of [ html_text, cell_color ], keyed by function
#------------------------------------------------------------------------------
sub colorize_roles_in_cell
{
    my ( $role_clr, $clr_priority ) = role_colors( @_ );

    #  Make nonredundant list of functions:

    my %seen;
    my @funcs = grep { $_ && ! $seen{$_}++ }
                ( ref( $_[0] ) eq 'ARRAY' ? @{ $_[0] }
                : ref( $_[0] ) eq 'HASH'  ? map { $_[0]->{$_} } keys %{$_[0]}
                : @_
                );
    push @funcs, $_[1] if $_[1] && ! $seen{ $_[1] };

    my ( @parts, $cell, $c, $t );
    my %cell_info = ();
    foreach my $func ( @funcs )
    {
        $cell_info{ $func } = cell_guts( $func, $role_clr, $clr_priority );
    }

    wantarray ? %cell_info : \%cell_info
}


#------------------------------------------------------------------------------
#  colorize_roles creates a hash relating functions to html versions in which
#  identical roles are colored the same.
#
#     %cell_info = colorize_roles_in_cell_2(  @functions )
#     %cell_info = colorize_roles_in_cell_2( \@functions )
#     %cell_info = colorize_roles_in_cell_2( \%functions )
#     %cell_info = colorize_roles_in_cell_2( \@functions, $current_func )
#     %cell_info = colorize_roles_in_cell_2( \%functions, $current_func )
#
#  where:
#
#     @functions  list of functions
#     %functions  hash of functions (key does not matter)
#     %cell_info  hash of [ html_text, cell_color ], keyed by function
#------------------------------------------------------------------------------
sub colorize_roles_in_cell_2
{
    my ( $role_clr, $clr_priority ) = role_colors( @_ );

    #  Make nonredundant list of functions:

    my %seen;
    my @funcs = grep { $_ && ! $seen{$_}++ }
                ( ref( $_[0] ) eq 'ARRAY' ? @{ $_[0] }
                : ref( $_[0] ) eq 'HASH'  ? map { $_[0]->{$_} } keys %{$_[0]}
                : @_
                );

    my $current_func = ref( $_[0] ) && $_[1] ? $_[1] : '';
    $current_func =~ s/ +[#!].*$//;

    my ( @parts, $cell, $c, $t );
    my %cell_info = ();
    foreach my $func ( @funcs )
    {
        # Split multidomain proteins, displaying roles side-by-side:

        my @subcells = split / +\/ /, $func;
        if ( @subcells == 1 )
        {
            $cell_info{ $func } = cell_guts( $func, $role_clr, $clr_priority );
        }
        else
        {
            my $f2 = $func;
            $f2 =~ s/ +[#!].*$//;
            my $is_current = ( $f2 eq $current_func ) ? 1 : 0;

            my $html = '<TABLE><TR>'
                     . join( '', map { colored_cell( cell_guts( $_, $role_clr, $clr_priority, $is_current ) ) }
                                 @subcells
                           )
                     . '</TD></TABLE>';
            $cell_info{ $func } = [ $html, '' ];
        }
    }

    wantarray ? %cell_info : \%cell_info
}


#------------------------------------------------------------------------------
#  colored cell provides html text for one cell
#
#     $table_cell_html = colored_cell( $text, $color )
#------------------------------------------------------------------------------

sub colored_cell { "<TD BgColor=$_[1]>$_[0]</TD>" }


#------------------------------------------------------------------------------
#  cell_guts provides the html text and cell color for one function colorized
#  by role.
#
#      @html_color = cell_guts(  $function, \%role_clr, \%clr_priority, $is_curr )
#     \@html_color = cell_guts(  $function, \%role_clr, \%clr_priority, $is_curr )
#
#  where:
#
#     @html_color  = ( html_text, cell_color ) for the function
#------------------------------------------------------------------------------
sub cell_guts
{
    my ( $func, $role_clr, $clr_priority, $is_curr ) = @_;

    my $cc; # cell color
    my $rc; # role color
    my $rt; # role text
    my @parts = split /( +[#!].*$| *\; +| +\/ | +\@ +)/, $func;
    if ( $is_curr )
    {
        my %clrs2 = map { $_ => faded( $role_clr->{ $_ } ) } @parts;
        $role_clr = \%clrs2;
    }
    ( $cc ) = sort { $clr_priority->{$a} <=> $clr_priority->{$b} }
              grep { $_ }
              map  { $role_clr->{ $_ } }
              @parts;
    my @cell_guts = ( join( '', map { $rc = $role_clr->{ $_ };
                                      $rt = html_esc( $_ );
                                      $rc ne $cc ? bgcolor( $rt, $rc ) : $rt
                                    }
                                @parts
                          ),
                      $cc
                    );

   wantarray ? @cell_guts : \@cell_guts;
}


sub faded { gjocolorlib::blend_html_colors( $_[0], '#FFFFFF' ) }

#------------------------------------------------------------------------------
#  role_colors creates a hash of colors for roles in a set of functions.
#
#     %colors = role_colors(  @functions )
#     %colors = role_colors( \@functions )
#     %colors = role_colors( \%functions )
#     %colors = role_colors( \@functions, $current_func )
#     %colors = role_colors( \%functions, $current_func )
#
#  where:
#
#     @functions  list of functions
#     %functions  hash of functions (key does not matter)
#     %colors     hash of colors keyed by role
#------------------------------------------------------------------------------
sub role_colors
{
    my $funcs = ref( $_[0] ) eq 'ARRAY' ? $_[0]
              : ref( $_[0] ) eq 'HASH'  ? [ map { $_[0]->{$_} } keys %{$_[0]} ]
              : [ @_ ];

    my $current_func = ref( $_[0] ) eq 'ARRAY' ? $_[1]
                     : ref( $_[0] ) eq 'HASH'  ? $_[1]
                     : '';
    $current_func =~ s/ +[#!].*$//;  #  strip comment

    my %func_cnt = ();               #  count function occurrances
    foreach my $func ( @$funcs )
    {
        $func_cnt{ $func }++ if $func =~ /\S/;
    }

    my %role_cnt = ();               #  count role occurances
    foreach my $func ( keys %func_cnt )
    {
        $func =~ s/ +[#!].*$//;
        my $cnt = $func_cnt{ $func };
        foreach ( split / *\; +| +\/ | +\@ +/, $func )
        {
            $role_cnt{ $_ } += $cnt if $_ =~ /\S/;
        }
    }

    my %role_clr;
    my @current_roles = sort { $role_cnt{ $b } <=> $role_cnt{ $a } }
                        grep { /\S/ }
                        split / *\; +| +\/ | +\@ +/, $current_func;
    if ( @current_roles )
    {
        foreach ( @current_roles ) { delete $role_cnt{ $_ } }
        $role_clr{ shift @current_roles } = "#FFFFFF" if @current_roles == 1;
    }

    my @roles = ( @current_roles,
                  sort { $role_cnt{ $b } <=> $role_cnt{ $a } } keys %role_cnt
                );

    my @colors = choose_pallet( scalar @roles );
    my $n  = 0;
    my %clr_priority = map { $_ => $n++ } ( "#FFFFFF", @colors, "#DDDDDD" );

    foreach ( @roles )
    {
        $role_clr{ $_ } = ( shift @colors ) || "#DDDDDD";
    }

    wantarray ? ( \%role_clr, \%clr_priority ) : \%role_clr
}


#------------------------------------------------------------------------------
#  colorize_functions creates a hash relating functions to html versions in
#  which identical functions are colored the same.
#
#     %colorized_function = colorize_functions(  @functions )
#     %colorized_function = colorize_functions( \@functions )
#     %colorized_function = colorize_functions( \%functions )
#     %colorized_function = colorize_functions( \@functions, $current_func )
#     %colorized_function = colorize_functions( \%functions, $current_func )
#
#  where:
#
#     @functions           list of functions
#     %functions           hash of functions (key does not matter)
#     %colorized_function  hash of colorized html text keyed by function
#------------------------------------------------------------------------------
sub colorize_functions
{
    my %func_color = function_colors( @_ );
 
    my %formatted_func = ();
    foreach my $func ( keys %func_color )
    {
        $formatted_func{ $func } = bgcolor( html_esc( $func ), $func_color{ $func } );
    }

    wantarray ? %formatted_func : \%formatted_func
}


#------------------------------------------------------------------------------
#  function_colors creates a hash of colors for a list of functions.
#
#     %colors = function_colors(  @functions )
#     %colors = function_colors( \@functions )
#     %colors = function_colors( \%functions )
#     %colors = function_colors( \@functions, $current_func )
#     %colors = function_colors( \%functions, $current_func )
#
#  where:
#
#     @functions  list of functions
#     %functions  hash of functions (key does not matter)
#     %colors     hash of colors keyed by function
#------------------------------------------------------------------------------
sub function_colors
{
    my $funcs = ref( $_[0] ) eq 'ARRAY' ? $_[0]
              : ref( $_[0] ) eq 'HASH'  ? [ map { $_[0]->{$_} } keys %{$_[0]} ]
              : [ @_ ];

    my $current_func = ref( $_[0] ) eq 'ARRAY' ? $_[1]
                     : ref( $_[0] ) eq 'HASH'  ? $_[1]
                     : '';

    my %func_cnt = ();
    foreach my $func ( @$funcs )
    {
        $func_cnt{ $func }++ if $func =~ /\S/;
    }

    my %func_color;
    if ( $current_func =~ /\S/ )
    {
        $func_color{ $current_func } = '#FFFFFF';  # white
        delete $func_cnt{ $current_func };
    }

    my @funcs = sort { $func_cnt{ $b } <=> $func_cnt{ $a } }
                keys %func_cnt;

    my @colors = choose_pallet( scalar @funcs );

    foreach ( @funcs )
    {
        $func_color{ $_ } = ( shift @colors ) || "#DDDDDD";
    }

    wantarray ? %func_color : \%func_color
}


1;


MCS Webmaster
ViewVC Help
Powered by ViewVC 1.0.3