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

View of /FigWebServices/diagram.cgi

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.3 - (download) (annotate)
Fri Mar 2 18:03:18 2007 UTC (13 years, 3 months ago) by paarmann
Branch: MAIN
Changes since 1.2: +173 -140 lines
sorting genomes to color by name
no longer showing non-positive variant codes in the select box
changed spelling of colour to american spelling
calling the script without a diagram id will try to find a new diagram

#
# 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.3 2007/03/02 18:03:18 paarmann 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);
    
    my $css = qq~body {
      font-family: Verdana, Arial, sans-serif;
      font-size: 12px;
      font-weight: normal;
      color: #000;
      background-color: #FFFFFF;
    }~;

    # print out the page
    print $cgi->header();
    print $cgi->start_html(-title => 'The SEED - Subsystem Diagram',
			   -style => { -code => $css }
	);

    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>";
    }


    # get the genomes from the subsystem with positive variant codes
    my @genomes;
    my $genome = $cgi->param('genome_id');
    foreach (sort { $fig->genus_species($a) cmp $fig->genus_species($b) } $subsystem->get_genomes()) {
	my $vcode = $subsystem->get_variant_code( $subsystem->get_genome_index( $_ ) );
	push @genomes, $_ if ($vcode > 0);
    }
    
    my %genome_labels = map { $_ => $fig->genus_species($_)." ( $_ )" } @genomes;
    
		       
    # generate the content
    my $content = "<h1>Subsystem: $subsystem_pretty</h1>";
    $content .= '<hr/>';
    
    $content .= $cgi->start_form();
    $content .= $cgi->hidden( -name  => 'subsystem_name',
			      -value => $subsystem_name );	
    $content .= $cgi->hidden( -name  => 'diagram',
			      -value => $diagram_id );
    $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);
    
    
    # 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 
    
    if ($genome) {
	
	my @roles = $subsystem->get_roles_for_genome($genome);
	
	# 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;
	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} = {};
		
		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'.";
		    }
		    
		    $lookup->{$r_abbr} = $role_and->{$subset};
		    $role_and->{$subset}->{$r_abbr} = 0;
		}
	    }
	}
	
	# 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} = {};
		
		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'.";
		    }
		    
		    $lookup->{$r_abbr} = $role_and->{$subset};
		    $role_or->{$subset}->{$r_abbr} = 0;
		}
	    }
	}
	
	
	# 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: $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";
	}
	
	# use Data::Dumper;
	# $content .= "<pre>".Data::Dumper->Dump([ $lookup ])."</pre>";
	
	# 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);
	}
    }
    else {
	$content .= '<p><em>You have not provided a genome id to color the diagram with.</em><p>';
    }

    $content .= $d->html;
    $content .= '<hr/><p><em>Below follows a status message to help test the new diagrams:</em><p>'.
	"<pre>$status</pre>" if ($status);
    
    return $content;
}



MCS Webmaster
ViewVC Help
Powered by ViewVC 1.0.3