# # 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.7 2007/03/23 18:29:33 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 "
$@
"; 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; } th, td { font-size: 12px; } ~; # print out the page print $cgi->header(); print "\n\n"; print "The SEED - Subsystem Diagram\n"; print " \n"; print " \n \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 '

CGI Parameter missing.

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

Unable to find a subsystem called '$subsystem_name'.

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

Subsystem: $subsystem_pretty

". "

Unable to find a diagram for this subsystem.

"; } unless ($subsystem->is_new_diagram($diagram_id)) { return "

Subsystem: $subsystem_pretty

". "

Diagram '$diagram_id' is not a new diagram.

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

Subsystem: $subsystem_pretty

"; $content .= '
'; $content .= $cgi->start_form( -id => 'diagram_select_genome' ); $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 .= '

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();', ).'   |   '; $content .= ''.$cgi->checkbox( -name => 'show_negative', -value => 1, -label => 'Show genomes with negative variant codes', -onChange => 'document.getElementById("diagram_select_genome").submit();', ).'

'; $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 .= "
  • $r
  • "; $lookup->{$r_abbr} = $role_and->{$subset}; $role_and->{$subset}->{$r_abbr} = 0; } $d->add_note('role_and', $subset, "

    Requires all of:

    "); } } # 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 .= "
  • $r
  • "; $lookup->{$r_abbr} = $role_or->{$subset}; $role_or->{$subset}->{$r_abbr} = 0; } $d->add_note('role_or', $subset, "

    Requires any of:

    "); } } 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 .= "

    Genome '$genome' is not present in this subsystem.

    "; shift(@roles); } else { $content .= "

    Showing colors for genome: ". $fig->genus_species($genome)." ( $genome ), variant code ". $subsystem->get_variant_code($subsystem->get_genome_index($genome)) ."

    "; } # 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 .= '

    You have not provided a genome id to color the diagram with.

    '; } # add an info line about diagram scaling my $scale = $d->calculate_scale * 100; unless ($scale == 100) { $content .= '

    This diagram has been scaled to '.sprintf("%.2f", $scale).'%. '; $content .= "(". "view in original size)"; $content .= '

    '; } if ($cgi->param('dont_scale')) { $content .= '

    You have switched off scaling this diagram down. '; $content .= "(". "Allow scaling)"; $content .= '

    '; } # print diagram $content .= $d->html; # print status $content .= '

    Below follows a status message to help test the new diagrams:

    '. "

    $status
    " if ($status); # print debug if ($cgi->param('debug')) { require Data::Dumper; $content .= '
    '; $content .= "

    Diagram dump:

    ".Data::Dumper->Dump([ $d ])."
    "; $content .= "

    Lookup dump:

    ".Data::Dumper->Dump([ $lookup ])."
    "; } return $content; }