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

View of /FigKernelPackages/GenoGraphics.pm

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.13 - (download) (as text) (annotate)
Mon Dec 5 19:06:30 2005 UTC (14 years, 4 months ago) by olson
Branch: MAIN
CVS Tags: caBIG-05Apr06-00, caBIG-13Feb06-00
Changes since 1.12: +17 -0 lines
Added license words.

#
# Copyright (c) 2003-2006 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.
#

package GenoGraphics;

use GD;
use Data::Dumper;
use Carp;
use FIG;
use FIGjs;
use CGI;


my $cgi = new CGI;
use strict;

#
# A GenoGraphics request is a data structure of the form:
# 
#   1. $gg is a pointer to a list of "maps"
#   2. Each map is a 4-tuple of the form
# 
# 	  [$text, $beg, $end, $objects]
# 
#   3. $objects is a pointer to a list.  Each entry is of the form
# 
# 	  [$beg,$end,$shape,$color,$text,$url]
# 
# When $gg is rendered, each map may be split into a set of
# "submaps", each containing a set of non-overlapping objects.
#
# Thus, $ggR is a data structure in which maps become
#
#         [$text, $beg, $end, $submaps]
#
# Where $submaps is a pointer to a list; each entry in the list
# is a pointer to a list of objects.


sub render {
    my($gg,$width,$obj_half_heigth,$save,$img) = @_;

    if (! $img) { $img = 1 }
    my $left_margin   = (15 * gdSmallFont->width) + 5; ### need to compute left margin based on text
    my $image_width   = $width + $left_margin;
    
    my $ggR       = &generate_submaps($gg);            # introduces sublevels
    my $gd        = new GD::Image($image_width+5,&height($ggR,$obj_half_heigth));

    my $ismap     = [];
    my $color_of = &choose_colors($gd,$ggR);
    &draw($gd,$ismap,$ggR,$color_of,$width,$obj_half_heigth);
    &labels($gd,$ggR,$color_of->{"text"},$obj_half_heigth);
    my($img_file,$img_url);
    if ($save) 
    { 
	&FIG::verify_dir("$FIG_Config::temp/Save"); 
	$img_file = "$FIG_Config::temp/Save/GenoGraphics_$$.$img.jpg";
	$img_url = &FIG::temp_url . "/Save/GenoGraphics_$$.$img.jpg";
    }
    else
    {
	$img_file = "$FIG_Config::temp/GenoGraphics_$$.$img.jpg";
	$img_url = &FIG::temp_url . "/GenoGraphics_$$.$img.jpg";
    }
    &write_image($gd,$img_file);
    return &generate_html($ismap,$img_url,$ggR,$img);
}

sub draw {
    my($gd,$ismap,$ggR,$colors,$width,$obj_half_heigth) = @_;
    my($y,$map,$text,$beg,$end,$submaps,$submap,$object);
    
    my $map_incr    = 3 * $obj_half_heigth;
    my $submap_incr = (4 * $obj_half_heigth) + int(1.1 * gdSmallFont->height);

    $y = (2 * $obj_half_heigth) + gdSmallFont->height;
    foreach $map (@$ggR)
    {
	($text,$beg,$end,$submaps) = @$map;
	my $begP = &get_pos_of_pixel($gd,$beg,$beg,$end,$width);
	my $endP = &get_pos_of_pixel($gd,$end,$beg,$end,$width);

	$gd->line($begP,$y,$endP,$y,$colors->{"text"});        # draw map line + ticks at ends
	$gd->line($begP,$y-$obj_half_heigth,$begP,$y+$obj_half_heigth,$colors->{"text"});
	$gd->line($endP,$y-$obj_half_heigth,$endP,$y+$obj_half_heigth,$colors->{"text"});

	foreach $submap ( @$submaps)
	{
	    foreach $object ( @$submap)
	    {
		my($begO,$endO,$shapeO,$colorO) = @$object;
		my $begOP = &get_pos_of_pixel($gd,$begO,$beg,$end,$width);
		my $endOP = &get_pos_of_pixel($gd,$endO,$beg,$end,$width);

		my $rtn = \&{$shapeO};   
		&$rtn($gd,$ismap,$y,$begOP,$endOP,$colors->{$colorO},$obj_half_heigth);
            }
	    &text($gd,$colors->{"text"},$submap,$y,$beg,$end,$begP,$endP,$width,$obj_half_heigth);
            $y += $submap_incr;
        }
        $y += $map_incr;
    }
}

sub text {
    my($gd,$color,$submap,$y,$beg,$end,$begP,$endP,$width,$obj_half_heigth) = @_;
    my($object);

    my $font_sz       = gdSmallFont->width;
    my $text_y        = int($y - ((2 * $obj_half_heigth) + gdSmallFont->height));

    foreach $object (@$submap)
    {
	my($begO,$endO,undef,undef,$textO) = @$object;
	my $begOP = &get_pos_of_pixel($gd,$begO,$beg,$end,$width);
	my $endOP = &get_pos_of_pixel($gd,$endO,$beg,$end,$width);
	my $text_start = int((($begOP + $endOP) / 2) - ((length($textO) * $font_sz)/2));
	if ($text_start < $begP)
	{
	    $text_start = $begP;
	}
	else
	{
	    my $adj_left = $endP - (length($textO) * $font_sz);
	    if ($text_start > $adj_left)
	    {
		$text_start = $adj_left;
	    }
	}
	if ($text_start >= $begOP)
	{
	    $gd->string(gdSmallFont,$text_start,$text_y,$textO,$color);
	}
    }
}

sub generate_submaps {
    my($gg) = @_;
    my($ggR,$map,$text,$beg,$end,$objects);

    $ggR = [];
    foreach $map (@$gg)
    {
        ($text,$beg,$end,$objects) = @$map;
	push(@$ggR,[$text,$beg,$end,&split_overlaps($objects)]);
    }
    return $ggR;
}

sub split_overlaps {
    my($objects) = @_;
    my($submaps,$object,$i);

    $submaps = [];
    foreach $object (@$objects)
    {
	for ($i=0; ($i < @$submaps) && &will_not_fit($object,$submaps->[$i]); $i++) {}
	if ($i < @$submaps)
	{
	    push(@{$submaps->[$i]},$object);
	}
	else
	{
	    push(@$submaps,[$object]);
	}
    }
    return $submaps;
}

sub will_not_fit {
    my($object,$submap) = @_;
    my($i);

    for ($i=0; ($i < @$submap) && (! &overlaps($object,$submap->[$i])); $i++) {}
    return ($i < @$submap);
}

sub overlaps {
    my($obj1,$obj2) = @_;

    return &FIG::between($obj1->[0],$obj2->[0],$obj1->[1]) ||
	   &FIG::between($obj2->[0],$obj1->[0],$obj2->[1]);
}

sub height {
    my($ggR,$obj_half_heigth) = @_;
    my($sz,$map,$sub);

    my $map_incr    = 3 * $obj_half_heigth;
    my $submap_incr = (4 * $obj_half_heigth) + int(1.1 * gdSmallFont->height);

    $sz             = (2 * $obj_half_heigth) + gdSmallFont->height;
    foreach $map (@$ggR)
    {
	$sub = $map->[3];
	$sz += ($map_incr + ($submap_incr * @$sub));
    }
    return $sz;
}

sub choose_colors {
    my($gd,$ggR) = @_;

    my $color_of = {};
    my $colors =
        [
          '255-255-255',  # white
          '0-0-0',        # black
          '192-192-192',  # ltgray
          '128-128-128',  # gray
          '64-64-64',     # dkgray
          '255-0-0',      # red
          '0-255-0',      # green
          '0-0-255',      # blue
          '255-64-192',
          '255-128-64',
          '255-0-128',
          '255-192-64',
          '64-192-255',
          '64-255-192',
          '192-128-128',
          '192-255-0',
          '0-255-128',
          '0-192-64',
          '128-0-0',
          '255-0-192',
          '64-0-128',
          '128-64-64',
          '64-255-0',
          '128-0-64',
          '128-192-255',
          '128-192-0',
          '64-0-0',
          '128-128-0',
          '255-192-255',
          '128-64-255',
          '64-0-192',
          '0-64-64',
          '64-0-255',
          '192-64-255',
          '128-0-128',
          '192-255-64',
          '64-128-255',
          '255-128-192',
          '64-192-64',
          '0-128-128',
          '255-0-64',
          '128-64-0',
          '128-255-128',
          '255-64-128',
          '128-192-64',
          '128-128-64',
          '255-255-192',
          '192-192-128',
          '192-64-128',
          '64-128-192',
          '192-192-64',
          '192-0-128',
          '64-64-192',
          '0-128-192',
          '0-128-64',
          '255-192-128',
          '192-128-0',
          '64-255-255',
          '255-0-255',
          '128-255-255',
          '255-255-64',
          '0-128-0',
          '192-255-192',
          '0-192-0',
          '0-64-192',
          '0-64-128',
          '192-0-255',
          '192-192-255',
          '64-255-128',
          '0-0-128',
          '255-64-64',
          '192-192-0',
          '192-128-192',
          '128-64-192',
          '0-192-255',
          '128-192-192',
          '192-0-64',
          '192-255-255',
          '255-192-0',
          '255-255-128',
          '192-0-0',
          '64-64-0',
          '192-64-192',
          '192-128-255',
          '128-255-192',
          '64-64-255',
          '0-64-255',
          '128-64-128',
          '255-64-255',
          '192-128-64',
          '64-64-128',
          '0-128-255',
          '64-0-64',
          '128-0-192',
          '255-128-255',
          '64-128-0',
          '255-64-0',
          '64-192-192',
          '255-128-0',
          '0-0-64',
          '128-128-192',
          '128-128-255',
          '0-192-192',
          '0-255-192',
          '128-192-128',
          '192-0-192',
          '0-255-64',
          '64-192-0',
          '0-192-128',
          '128-255-64',
          '255-255-0',
          '64-255-64',
          '192-64-64',
          '192-64-0',
          '255-192-192',
          '192-255-128',
          '0-64-0',
          '0-0-192',
          '128-0-255',
          '64-128-64',
          '64-192-128',
          '0-255-255',
          '255-128-128',
          '64-128-128',
          '128-255-0'
        ];

    $color_of->{"background"} = $color_of->{"white"}      = &take_color($gd,$colors);
    $color_of->{"text"}       = $color_of->{"black"}      = &take_color($gd,$colors);
    $color_of->{"ltgray"}     = $color_of->{"ltgrey"}     = &take_color($gd,$colors);
    $color_of->{"gray"}       = $color_of->{"grey"}       = &take_color($gd,$colors);
    $color_of->{"dkgray"}     = $color_of->{"dkgrey"}     = &take_color($gd,$colors);
    $color_of->{'color0'}     = $color_of->{"red"}        = &take_color($gd,$colors);
    $color_of->{'color1'}     = $color_of->{"green"}      = &take_color($gd,$colors);
    $color_of->{'color2'}     = $color_of->{"blue"}       = &take_color($gd,$colors);
    $color_of->{'color3'}     = &take_color($gd,$colors);
    $color_of->{'color4'}     = &take_color($gd,$colors);
    $color_of->{'color5'}     = &take_color($gd,$colors);
    $color_of->{'color6'}     = &take_color($gd,$colors);
    $color_of->{'color7'}     = &take_color($gd,$colors);
    $color_of->{'color8'}     = &take_color($gd,$colors);
    $color_of->{'color9'}     = &take_color($gd,$colors);
    $color_of->{'color10'}    = &take_color($gd,$colors);
    $color_of->{'color11'}    = &take_color($gd,$colors);
    $color_of->{'color12'}    = &take_color($gd,$colors);
    $color_of->{'color13'}    = &take_color($gd,$colors);
    $color_of->{'color14'}    = &take_color($gd,$colors);
    $color_of->{'color15'}    = &take_color($gd,$colors);
    $color_of->{'color16'}    = &take_color($gd,$colors);
    $color_of->{'color17'}    = &take_color($gd,$colors);
    $color_of->{'color18'}    = &take_color($gd,$colors);
    $color_of->{'color19'}    = &take_color($gd,$colors);
    $color_of->{'color20'}    = &take_color($gd,$colors);
    
    my ($map,$submap,$object,$rgb,$color);
    my %how_many;
    foreach $map (@$ggR)
    {
	foreach $submap (@{$map->[3]})
	{
	    foreach $object (@$submap)
	    {
		$color = $object->[3];
		$how_many{$color}++;
	    }
	}
    }

    foreach $color (sort { $how_many{$b} <=> $how_many{$a} } keys(%how_many))
    {
	if ((! $color_of->{$color}) &&
	    ($rgb = &take_color($gd,$colors)))
	{
	    $color_of->{$color} = $rgb;
	}
    }
	
    foreach $map (@$ggR)
    {
	foreach $submap (@{$map->[3]})
	{
	    foreach $object (@$submap)
	    {
		$color = $object->[3];
		if (! $color_of->{$color})
		{
		    print STDERR "could not allocate enough colors\n";
		    $color_of->{$color} = $color_of->{"grey"};
		}
	    }
	}
    }
    return $color_of;
}

sub take_color {
    my($gd,$colors) = @_;
    my($color);

    if (@$colors > 0)
    {
	$color = shift @$colors;
#	print STDERR "allocating $color: ", scalar @$colors, " left\n";
	return $gd->colorAllocate(split(/-/,$color));
    }
    return undef;
}

sub get_pos_of_pixel {
    my($gd,$pos,$beg,$end,$width) = @_;

    my $font_sz       = gdSmallFont->width;
    my $left_margin   = (15 * $font_sz) + 5; ### need to compute left margin based on text
    my $right_margin  = $width + $left_margin;

    if (($end - $beg) == 0)
    {
	confess "Zero-length segment";
    }
    
    return int($left_margin + ($width * (($pos - $beg) / ($end - $beg))));
}

sub rightArrow {
    my($gd,$ismap,$y,$begOP,$endOP,$color,$obj_half_heigth) = @_;

    my @poly = ();

    if (($endOP - $begOP) <= (2 * $obj_half_heigth))
    {
	push(@poly,[$endOP,$y]);
	push(@poly,[$begOP,$y+(2 * $obj_half_heigth)]);
	push(@poly,[$begOP,$y-(2 * $obj_half_heigth)]);
    }
    else
    {
	push(@poly,[$endOP,$y]);
	push(@poly,[$endOP-(2 * $obj_half_heigth),$y+(2 * $obj_half_heigth)]);
	push(@poly,[$endOP-(2 * $obj_half_heigth),$y+$obj_half_heigth]);
	push(@poly,[$begOP,$y+$obj_half_heigth]);
	push(@poly,[$begOP,$y-$obj_half_heigth]);
	push(@poly,[$endOP-(2 * $obj_half_heigth),$y-$obj_half_heigth]);
	push(@poly,[$endOP-(2 * $obj_half_heigth),$y-(2 * $obj_half_heigth)]);
    }
    &render_poly($gd,$y,\@poly,$color);
    push(@$ismap,[[$begOP,$y-$obj_half_heigth],[$endOP,$y+$obj_half_heigth]]);
}

sub leftArrow {
    my($gd,$ismap,$y,$begOP,$endOP,$color,$obj_half_heigth) = @_;
    my @poly;

    if (($endOP - $begOP) <= (2 * $obj_half_heigth))
    {
	push(@poly,[$begOP,$y]);
	push(@poly,[$endOP,$y+(2 * $obj_half_heigth)]);
	push(@poly,[$endOP,$y-(2 * $obj_half_heigth)]);
    }
    else
    {
	push(@poly,[$begOP,$y]);
	push(@poly,[$begOP+(2 * $obj_half_heigth),$y+(2 * $obj_half_heigth)]);
	push(@poly,[$begOP+(2 * $obj_half_heigth),$y+$obj_half_heigth]);
	push(@poly,[$endOP,$y+$obj_half_heigth]);
	push(@poly,[$endOP,$y-$obj_half_heigth]);
	push(@poly,[$begOP+(2 * $obj_half_heigth),$y-$obj_half_heigth]);
	push(@poly,[$begOP+(2 * $obj_half_heigth),$y-(2 * $obj_half_heigth)]);
    }
    &render_poly($gd,$y,\@poly,$color);
    push(@$ismap,[[$begOP,$y-$obj_half_heigth],[$endOP,$y+$obj_half_heigth]]);
}

sub render_poly {
    my($gd,$y,$poly,$color) = @_;
    my($pt);

    my $GDpoly = new GD::Polygon;

    foreach $pt (@$poly)
    {
	my($x,$y) = @$pt;
	$GDpoly->addPt($x,$y);
    }

    $gd->filledPolygon($GDpoly,$color);
}

sub labels {
    my($gd,$ggR,$color,$obj_half_heigth) = @_;
    my($map,$submap);

    my $map_incr    = 3 * $obj_half_heigth;
    my $submap_incr = (4 * $obj_half_heigth) + int(1.1 * gdSmallFont->height);

    my $font_sz       = gdSmallFont->width;
    my $left_margin   = (15 * $font_sz) + 5;  ### need to compute left margin based on text

    my $y = (2 * $obj_half_heigth) + gdSmallFont->height;

    foreach $map (@$ggR)
    {
	$gd->string(gdSmallFont,10,int($y - (0.5 * gdSmallFont->height)),$map->[0],$color);
	foreach $submap (@{$map->[3]})
	{
            $y += $submap_incr;
        }
        $y += $map_incr;
    }
}

sub write_image {
    my($gd,$file) = @_;

    open(TMP,">$file")
	|| die "could not open $file";
    print TMP $gd->jpeg;
    close(TMP);
    chmod 0777,$file;
}


sub generate_html {
    my( $ismap, $gif, $ggR, $img ) = @_;
    my( $map, $i, $submap, $object, $link, $tip, $menu, $coords, $title, $java, $tag );

    my $html = [];
    my $map_name = "map_table_$$" . "_$img";

    push @$html, qq(<img src="$gif" usemap="#$map_name" border=0>\n),
                 qq(<map name="$map_name">\n);

    $i = 0;
    foreach $map ( @$ggR )
    {
	foreach $submap ( @{$map->[3]} )
	{
	    foreach $object ( @$submap )
	    {
		$link = $object->[5];  # Usual html link
		$tip  = $object->[6];  # html text that is displayed on mouseover
		$menu = $object->[7];  # Context menu.  Do not follow the href on
		                       #    click, put $object->[7] html in a box
		#       $object->[8];  # Alternative to "Peg info" title text
		#                      #    (not everything is a Peg!)

		#  Logic modified so that we can have pop-up info without a hot link

		if ( $link || $tip || $menu )
		{
		    $coords = join( ",", @{$ismap->[$i]->[0]}, @{$ismap->[$i]->[1]} );
		    $title  = $object->[8] || "Peg info";
		    $java   = ( $tip || $menu ) ? &FIGjs::mouseover( $title, $tip, $menu )
		                                : undef;

		    $tag    =           qq(<area shape="rect" coords="$coords")
		            . ( $link ? qq( href="$link")                       : () )
		            . ( $java ? qq( $java)                              : () )
		            .           qq(>\n);
		    push @$html, $tag;
		}
		$i++;
	    }
	}
    }

    push @$html, "</map>\n";
    return $html;
}


sub disambiguate_maps {
    my($gg) = @_;
    my($map,$id,%seen);

    foreach $map (@$gg)
    {
	$id  = $map->[0];
	while ($seen{$id}) 
	{ 
	    if ($id =~ /^(.*)\*(\d+)$/)
	    {
		$id = $1 . "*" . ($2 + 1);
	    }
	    else
	    {
		substr($id,-2) = "*0";
	    }
	}
	$seen{$id} = 1;
	$map->[0] = $id;
    }
}

1

MCS Webmaster
ViewVC Help
Powered by ViewVC 1.0.3