[Bio] / FigWebServices / diagram.cgi Repository:
ViewVC logotype

View of /FigWebServices/diagram.cgi

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.9 - (download) (annotate)
Fri Apr 17 15:26:53 2009 UTC (10 years, 7 months ago) by parrello
Branch: MAIN
CVS Tags: mgrast_dev_08112011, rast_rel_2009_05_18, mgrast_dev_08022011, rast_rel_2014_0912, myrast_rel40, mgrast_dev_05262011, mgrast_dev_04082011, rast_rel_2010_0928, mgrast_version_3_2, mgrast_dev_12152011, mgrast_dev_06072011, rast_rel_2009_0925, rast_rel_2010_0526, rast_rel_2014_0729, mgrast_dev_02212011, rast_rel_2010_1206, mgrast_release_3_0, mgrast_dev_03252011, rast_rel_2010_0118, rast_rel_2011_0119, 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_2, mgrast_release_3_1_1, mgrast_release_3_1_0, mgrast_dev_04132011, mgrast_dev_04012011, rast_rel_2009_07_09, rast_rel_2010_0827, myrast_33, rast_rel_2011_0928, mgrast_dev_04052011, mgrast_dev_02222011, mgrast_dev_10262011, HEAD
Changes since 1.8: +2 -14 lines
Changed to load the default styles.

#
# 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.
#

# $Id: diagram.cgi,v 1.9 2009/04/17 15:26:53 parrello Exp $

use strict;
use warnings;
no warnings qw( numeric ); # variant code comparison with >

use FIG_CGI;
use FIG_Config;
use CGI;

use Diagram;

eval {
    &main;
};

if ($@)
{
    my $cgi = new CGI();

    print $cgi->header();
    print $cgi->start_html();
    print "<pre>$@</pre>";
    print $cgi->end_html();

}

sub main {

    my ($fig, $cgi, $user) = FIG_CGI::init(debug_save => 0, debug_load => 0, print_params => 0);
    
    # print out the page
    print $cgi->header();
    print "<html>\n<head>\n";
    print "<title>The SEED - Subsystem Diagram</title>\n";
    print "<link rel='stylesheet' type='text/css' href='$FIG_Config::cgi_url/Html/default.css' />\n";
    print "</head> \n <body> \n";

    print &get_Diagram($fig, $cgi);

    print $cgi->end_html;

}


sub get_Diagram {
    # get parameters
    my ($fig, $cgi) = @_;

    # get the subsystem
    unless ($cgi->param('subsystem_name')) {
	return '<p>CGI Parameter missing.</p>';
    }
    my $subsystem_name = $cgi->param('subsystem_name') || '';
    my $subsystem_pretty = $subsystem_name;
    $subsystem_pretty =~ s/_/ /g;
    my $subsystem = $fig->get_subsystem($subsystem_name);

    # check subsystem
    unless ($subsystem) {
	return "<p>Unable to find a subsystem called '$subsystem_name'.</p>";
    }


    # if diagram.cgi is called without the CGI param diagram (the diagram id)
    # it will try to load the first 'new' diagram from the subsystem and
    # print out an error message if there is no 'new' diagram
    my $diagram_id  = $cgi->param('diagram') || '';
    unless ($diagram_id) {
	foreach my $d ($subsystem->get_diagrams) {
	    my ($id) = @$d;
	    if ($subsystem->is_new_diagram($id)) {
		$diagram_id = $id;
		last;
	    }
	}
    }

    # check diagram id
    unless ($diagram_id) {
	return "<h1>Subsystem: $subsystem_pretty</h1>".
	    "<p><em>Unable to find a diagram for this subsystem.</em><p>";
    }
    unless ($subsystem->is_new_diagram($diagram_id)) {
	return "<h1>Subsystem: $subsystem_pretty</h1>".
	    "<p><em>Diagram '$diagram_id' is not a new diagram.</em><p>";
    }


    # find out about sort order
    my $sort_by = $cgi->param('sort_by') || 'name';

    # get the genomes from the subsystem 
    my @genomes;
    my $genome = $cgi->param('genome_id');
    if ($sort_by eq 'variant_code') {
 	@genomes = sort { ($subsystem->get_variant_code( $subsystem->get_genome_index($a) ) cmp
 			   $subsystem->get_variant_code( $subsystem->get_genome_index($b) )) or
 			   ( $fig->genus_species($a) cmp $fig->genus_species($b) )
 	                } $subsystem->get_genomes()
    }
    else { 
	@genomes = sort { $fig->genus_species($a) cmp $fig->genus_species($b) } $subsystem->get_genomes();
    }

    # show only genomes with zero or positive variant codes
    # unless user switched that off
    unless ($cgi->param('show_negative')) {
	my @temp;
	foreach (@genomes) {
 	    my $vcode = $subsystem->get_variant_code( $subsystem->get_genome_index( $_ ) );
 	    push @temp, $_ if ($vcode >= 0);
	}
	@genomes = @temp;
    }
    
    my %genome_labels = map { $_ => $fig->genus_species($_)." ( $_ ) [".
				  $subsystem->get_variant_code( $subsystem->get_genome_index( $_ ) )."]"
                            } @genomes;

    @genomes = ('0', @genomes);
    $genome_labels{'0'} = 'please select a genome to color the diagram with' ;
    
		       
    # generate the content
    my $content = "<h1>Subsystem: $subsystem_pretty</h1>";
    $content .= '<hr/>';
    
    $content .= $cgi->start_form( -id => 'diagram_select_genome', -action => 'diagram.cgi' ); 
    $content .= $cgi->hidden( -name  => 'subsystem_name',
			      -value => $subsystem_name );	
    $content .= $cgi->hidden( -name  => 'diagram',
			      -value => $diagram_id );
    $content .= $cgi->hidden( -name  => 'dont_scale', -value => 1 ) 
	if ($cgi->param('dont_scale'));
    $content .= $cgi->hidden( -name  => 'show_negative', -value => 1 ) 
	if ($cgi->param('show_negative'));
    $content .= $cgi->hidden( -name  => 'debug', -value => 1 )
	if ($cgi->param('debug'));
    $content .= '<p>Sort by: '.
	$cgi->radio_group( -name    => 'sort_by',
			   -values  => ['name', 'variant_code'],
			   -default => $sort_by,
			   -labels  => { 'name' => 'Genome name',
					 'variant_code' => 'Variant code, then genome name' },
			   -onChange => 'document.getElementById("diagram_select_genome").submit();',
	).' &nbsp; | &nbsp; ';
    $content .= ''.$cgi->checkbox( -name  => 'show_negative',
				       -value => 1,
				       -label => 'Show genomes with negative variant codes',
				       -onChange => 'document.getElementById("diagram_select_genome").submit();',
	).'</p>';
    $content .= $cgi->popup_menu( -name    => 'genome_id',
				  -values  => \@genomes,
				  -default => $genome,
				  -labels  => \%genome_labels,
	);
    $content .= $cgi->submit( -name => 'Color diagram' );
    $content .= $cgi->end_form();
    
    # initialise a status string (log)
    my $status = '';
    
    # fetch the diagram
    my $diagram_dir = $subsystem->{dir}."/diagrams/$diagram_id/";
    my $d = Diagram->new($subsystem_name, $diagram_dir);

    # turn off scaling?
    $d->min_scale(1) if ($cgi->param('dont_scale'));
    
    
    # DEBUG: test all items of the diagram against the subsystem
    # (for debug purposes during introduction of new diagrams)
    # (remove when no longer needed)
    # (1) roles
    my $types = [ 'role', 'role_and', 'role_or' ];
    foreach my $t (@$types) {
	foreach my $id (@{$d->item_ids_of_type($t)}) {
	    unless ($subsystem->get_role_from_abbr($id) or
		    scalar($subsystem->get_subsetC_roles($id))) {
		$status .= "Diagram item '$t' = '$id' not found in the subsystem.\n";
	    }
	}
    }
    # (2) subsystem
    foreach my $s (@{$d->item_ids_of_type('subsystem')}) {
	unless ($fig->subsystem_version($s)) {
	    $status .= "Diagram item 'subsystem' = '$s' is not a subsystem.\n";
	}
    }
    # END 


    # add notes to roles
    # to reduce the total number of loos role_or, role_and get their notes 
    # attached in the loops further down
    foreach my $id (@{$d->item_ids_of_type('role')}) {
	my $role = $subsystem->get_role_from_abbr($id);
	if ($role) {
	    $d->add_note('role', $id, $role);
	}
    }

    
    # build a lookup hash, make one entry for each role_and and role_or item
    # the index references to the inner hash of the role_and/role_or hash
    # to set a value there use $lookup->{role_abbr}->{role_abbr} = 1;
    # declared outside if to be available for debug output
    my $lookup = {};

    # find out about role_and
    my $role_and = {};
    if (scalar(@{$d->item_ids_of_type('role_and')})) {
	foreach my $subset (@{$d->item_ids_of_type('role_and')}) {
	    
	    $role_and->{$subset} = {};
	    
	    my $note = '';
	    foreach my $r ($subsystem->get_subsetC_roles($subset)) {
		my $r_abbr = $subsystem->get_abbr_for_role($r);
		unless ($r_abbr) {
		    die "Unable to get the abbreviation for role '$r'.";
		}
		
		$note .= "<li>$r</li>";
		$lookup->{$r_abbr} = $role_and->{$subset};
		$role_and->{$subset}->{$r_abbr} = 0;
	    }
	    $d->add_note('role_and', $subset, "<h4>Requires all of:</h4><ul>$note</ul>");
	}
    }
    
    # find out about role_or
    my $role_or = {};
    if (scalar(@{$d->item_ids_of_type('role_or')})) {
	foreach my $subset (@{$d->item_ids_of_type('role_or')}) {
	    
	    $role_or->{$subset} = {};
	    
	    my $note = '';
	    foreach my $r ($subsystem->get_subsetC_roles($subset)) {
		my $r_abbr = $subsystem->get_abbr_for_role($r);
		
		unless ($r_abbr) {
		    die "Unable to get the abbreviation for role '$r'.";
		}
		
		$note .= "<li>$r</li>";
		$lookup->{$r_abbr} = $role_or->{$subset};
		$role_or->{$subset}->{$r_abbr} = 0;
	    }
	    $d->add_note('role_or', $subset, "<h4>Requires any of:</h4><ul>$note</ul>");
	}
    }

    
    if ($genome) {
	
	my @roles = $subsystem->get_roles_for_genome($genome);
	
	# check if genome is present in subsystem
	# genomes not present, unfortunately return @roles = ( undef )
	if (scalar(@roles) == 0 or 
	    (scalar(@roles) and !defined($roles[0]))) {
	    $content .= "<p><em>Genome '$genome' is not present in this subsystem.</em><p>";
	    shift(@roles);
	}
	else {
	    $content .= "<p><em>Showing colors for genome: ".
		$fig->genus_species($genome)." ( $genome ), variant code ".
		$subsystem->get_variant_code($subsystem->get_genome_index($genome)) ."</em><p>";
	}
	
	
	# iterate over all roles present in a subsystem:
	# -> map roles to abbr in the foreach loop
	# -> color simple roles present
	# -> tag roles being part of a logical operator in $lookup
	foreach (map { $subsystem->get_abbr_for_role($_) } @roles) {
	    
	    # color normal roles
	    if ($d->has_item('role', $_)) {
		$d->color_item('role',$_,'green');
		next;
	    }
	    
	    # try to find role_and / role_or
	    if (exists($lookup->{$_})) {
		$lookup->{$_}->{$_} = 1;
		next;
	    }
	    
	    $status .= "Role '$_' not found in the diagram.\n";
	}
	
	# check if to color any role_and
	foreach my $id_role_and (keys(%$role_and)) {
	    my $result = 1;
	    foreach (keys(%{$role_and->{$id_role_and}})) {
		$result = 0 unless ($role_and->{$id_role_and}->{$_});
	    }
	    $d->color_item('role_and', $id_role_and, 'green') if ($result);
	}

	# check if to color any role_or
	foreach my $id_role_or (keys(%$role_or)) {
	    foreach (keys(%{$role_or->{$id_role_or}})) {
		if ($role_or->{$id_role_or}->{$_}) {
		    $d->color_item('role_or', $id_role_or, 'green');
		    last;
		}
	    }
	}

    }
    else {
	$content .= '<p><em>You have not provided a genome id to color the diagram with.</em><p>';
    }

    # add an info line about diagram scaling
    my $scale = $d->calculate_scale * 100;
    unless ($scale == 100) {
	$content .= '<p><em>This diagram has been scaled to '.sprintf("%.2f", $scale).'%. ';
	$content .= "(<a href='?subsystem_name=$subsystem_name&diagram=$diagram_id&dont_scale=1'>".
	    "view in original size</a>)";
	$content .= '</em></p>';
    }
    if ($cgi->param('dont_scale')) {
	$content .= '<p><em>You have switched off scaling this diagram down. ';
	$content .= "(<a href='?subsystem_name=$subsystem_name&diagram=$diagram_id'>".
	    "Allow scaling</a>)";
	$content .= '</em></p>';
    }	
	
    # print diagram
    $content .= $d->html;

    # print status 
    $content .= '<hr/><p><em>Below follows a status message to help test the new diagrams:</em><p>'.
	"<pre>$status</pre>" if ($status);
    
    # print debug
    if ($cgi->param('debug')) {
	require Data::Dumper;
	$content .= '<hr/>';
	$content .= "<h2>Diagram dump:</h2><pre>".Data::Dumper->Dump([ $d ])."</pre>";
	$content .= "<h2>Lookup dump:</h2><pre>".Data::Dumper->Dump([ $lookup ])."</pre>";
    }

    return $content;
}



MCS Webmaster
ViewVC Help
Powered by ViewVC 1.0.3