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

Annotation of /FigWebServices/diagram.cgi

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.4 - (view) (download)

1 : paarmann 1.1 #
2 :     # Copyright (c) 2003-2006 University of Chicago and Fellowship
3 :     # for Interpretations of Genomes. All Rights Reserved.
4 :     #
5 :     # This file is part of the SEED Toolkit.
6 :     #
7 :     # The SEED Toolkit is free software. You can redistribute
8 :     # it and/or modify it under the terms of the SEED Toolkit
9 :     # Public License.
10 :     #
11 :     # You should have received a copy of the SEED Toolkit Public License
12 :     # along with this program; if not write to the University of Chicago
13 :     # at info@ci.uchicago.edu or the Fellowship for Interpretation of
14 :     # Genomes at veronika@thefig.info or download a copy from
15 :     # http://www.theseed.org/LICENSE.TXT.
16 :     #
17 :    
18 : paarmann 1.4 # $Id: diagram.cgi,v 1.3 2007/03/02 18:03:18 paarmann Exp $
19 : paarmann 1.2
20 : paarmann 1.1 use strict;
21 :     use warnings;
22 : paarmann 1.3 no warnings qw( numeric ); # variant code comparison with >
23 : paarmann 1.1
24 :     use FIG_CGI;
25 :     use FIG_Config;
26 :     use CGI;
27 :    
28 :     use Diagram;
29 :    
30 :     eval {
31 :     &main;
32 :     };
33 :    
34 :     if ($@)
35 :     {
36 :     my $cgi = new CGI();
37 :    
38 :     print $cgi->header();
39 :     print $cgi->start_html();
40 :     print "<pre>$@</pre>";
41 :     print $cgi->end_html();
42 :    
43 :     }
44 :    
45 :     sub main {
46 :    
47 :     my ($fig, $cgi, $user) = FIG_CGI::init(debug_save => 0, debug_load => 0, print_params => 0);
48 :    
49 :     my $css = qq~body {
50 :     font-family: Verdana, Arial, sans-serif;
51 :     font-size: 12px;
52 :     font-weight: normal;
53 :     color: #000;
54 :     background-color: #FFFFFF;
55 :     }~;
56 :    
57 :     # print out the page
58 :     print $cgi->header();
59 :     print $cgi->start_html(-title => 'The SEED - Subsystem Diagram',
60 :     -style => { -code => $css }
61 :     );
62 :    
63 :     print &get_Diagram($fig, $cgi);
64 :    
65 : paarmann 1.2 print $cgi->end_html;
66 :    
67 : paarmann 1.1 }
68 :    
69 :    
70 :     sub get_Diagram {
71 :     # get parameters
72 :     my ($fig, $cgi) = @_;
73 :    
74 : paarmann 1.3 # get the subsystem
75 :     unless ($cgi->param('subsystem_name')) {
76 : paarmann 1.1 return '<p>CGI Parameter missing.</p>';
77 :     }
78 : paarmann 1.3 my $subsystem_name = $cgi->param('subsystem_name') || '';
79 : paarmann 1.1 my $subsystem_pretty = $subsystem_name;
80 :     $subsystem_pretty =~ s/_/ /g;
81 : paarmann 1.3 my $subsystem = $fig->get_subsystem($subsystem_name);
82 : paarmann 1.1
83 : paarmann 1.3 # check subsystem
84 :     unless ($subsystem) {
85 :     return "<p>Unable to find a subsystem called '$subsystem_name'.</p>";
86 :     }
87 : paarmann 1.1
88 :    
89 : paarmann 1.3 # if diagram.cgi is called without the CGI param diagram (the diagram id)
90 :     # it will try to load the first 'new' diagram from the subsystem and
91 :     # print out an error message if there is no 'new' diagram
92 :     my $diagram_id = $cgi->param('diagram') || '';
93 :     unless ($diagram_id) {
94 :     foreach my $d ($subsystem->get_diagrams) {
95 :     my ($id) = @$d;
96 :     if ($subsystem->is_new_diagram($id)) {
97 :     $diagram_id = $id;
98 :     last;
99 : paarmann 1.1 }
100 :     }
101 : paarmann 1.3 }
102 : paarmann 1.1
103 : paarmann 1.3 # check diagram id
104 :     unless ($diagram_id) {
105 :     return "<h1>Subsystem: $subsystem_pretty</h1>".
106 :     "<p><em>Unable to find a diagram for this subsystem.</em><p>";
107 :     }
108 :     unless ($subsystem->is_new_diagram($diagram_id)) {
109 :     return "<h1>Subsystem: $subsystem_pretty</h1>".
110 :     "<p><em>Diagram '$diagram_id' is not a new diagram.</em><p>";
111 :     }
112 : paarmann 1.1
113 :    
114 : paarmann 1.3 # get the genomes from the subsystem with positive variant codes
115 :     my @genomes;
116 :     my $genome = $cgi->param('genome_id');
117 :     foreach (sort { $fig->genus_species($a) cmp $fig->genus_species($b) } $subsystem->get_genomes()) {
118 :     my $vcode = $subsystem->get_variant_code( $subsystem->get_genome_index( $_ ) );
119 :     push @genomes, $_ if ($vcode > 0);
120 :     }
121 :    
122 : paarmann 1.4 my %genome_labels = map { $_ => $fig->genus_species($_)." ( $_ ) [".
123 :     $subsystem->get_variant_code( $subsystem->get_genome_index( $_ ) )."]"
124 :     } @genomes;
125 : paarmann 1.3
126 :    
127 :     # generate the content
128 :     my $content = "<h1>Subsystem: $subsystem_pretty</h1>";
129 :     $content .= '<hr/>';
130 :    
131 :     $content .= $cgi->start_form();
132 :     $content .= $cgi->hidden( -name => 'subsystem_name',
133 :     -value => $subsystem_name );
134 :     $content .= $cgi->hidden( -name => 'diagram',
135 :     -value => $diagram_id );
136 :     $content .= $cgi->popup_menu( -name => 'genome_id',
137 :     -values => \@genomes,
138 :     -default => $genome,
139 :     -labels => \%genome_labels,
140 :     );
141 :     $content .= $cgi->submit( -name => 'Color diagram' );
142 :     $content .= $cgi->end_form();
143 :    
144 :     # initialise a status string (log)
145 :     my $status = '';
146 :    
147 :     # fetch the diagram
148 :     my $diagram_dir = $subsystem->{dir}."/diagrams/$diagram_id/";
149 :     my $d = Diagram->new($subsystem_name, $diagram_dir);
150 :    
151 :    
152 :     # DEBUG: test all items of the diagram against the subsystem
153 :     # (for debug purposes during introduction of new diagrams)
154 :     # (remove when no longer needed)
155 :     # (1) roles
156 :     my $types = [ 'role', 'role_and', 'role_or' ];
157 :     foreach my $t (@$types) {
158 :     foreach my $id (@{$d->item_ids_of_type($t)}) {
159 :     unless ($subsystem->get_role_from_abbr($id) or
160 :     scalar($subsystem->get_subsetC_roles($id))) {
161 :     $status .= "Diagram item '$t' = '$id' not found in the subsystem.\n";
162 :     }
163 :     }
164 :     }
165 :     # (2) subsystem
166 :     foreach my $s (@{$d->item_ids_of_type('subsystem')}) {
167 :     unless ($fig->subsystem_version($s)) {
168 :     $status .= "Diagram item 'subsystem' = '$s' is not a subsystem.\n";
169 :     }
170 :     }
171 :     # END
172 :    
173 :     if ($genome) {
174 :    
175 :     my @roles = $subsystem->get_roles_for_genome($genome);
176 :    
177 :     # build a lookup hash, make one entry for each role_and and role_or item
178 :     # the index references to the inner hash of the role_and/role_or hash
179 :     # to set a value there use $lookup->{role_abbr}->{role_abbr} = 1;
180 :     my $lookup = {};
181 :    
182 :     # find out about role_and
183 :     my $role_and = {};
184 :     if (scalar(@{$d->item_ids_of_type('role_and')})) {
185 :     foreach my $subset (@{$d->item_ids_of_type('role_and')}) {
186 :    
187 :     $role_and->{$subset} = {};
188 :    
189 :     foreach my $r ($subsystem->get_subsetC_roles($subset)) {
190 :     my $r_abbr = $subsystem->get_abbr_for_role($r);
191 :     unless ($r_abbr) {
192 :     die "Unable to get the abbreviation for role '$r'.";
193 : paarmann 1.1 }
194 :    
195 : paarmann 1.3 $lookup->{$r_abbr} = $role_and->{$subset};
196 :     $role_and->{$subset}->{$r_abbr} = 0;
197 : paarmann 1.1 }
198 :     }
199 : paarmann 1.3 }
200 :    
201 :     # find out about role_or
202 :     my $role_or = {};
203 :     if (scalar(@{$d->item_ids_of_type('role_or')})) {
204 :     foreach my $subset (@{$d->item_ids_of_type('role_or')}) {
205 : paarmann 1.1
206 : paarmann 1.3 $role_or->{$subset} = {};
207 : paarmann 1.1
208 : paarmann 1.3 foreach my $r ($subsystem->get_subsetC_roles($subset)) {
209 :     my $r_abbr = $subsystem->get_abbr_for_role($r);
210 :     unless ($r_abbr) {
211 :     die "Unable to get the abbreviation for role '$r'.";
212 :     }
213 :    
214 :     $lookup->{$r_abbr} = $role_and->{$subset};
215 :     $role_or->{$subset}->{$r_abbr} = 0;
216 : paarmann 1.1 }
217 :     }
218 : paarmann 1.3 }
219 :    
220 :    
221 :     # check if genome is present in subsystem
222 :     # genomes not present, unfortunately return @roles = ( undef )
223 :     if (scalar(@roles) == 0 or
224 :     (scalar(@roles) and !defined($roles[0]))) {
225 :     $content .= "<p><em>Genome '$genome' is not present in this subsystem.</em><p>";
226 :     shift(@roles);
227 :     }
228 :     else {
229 : paarmann 1.4 $content .= "<p><em>Showing colors for genome: ".
230 :     $fig->genus_species($genome)." ( $genome ), variant code ".
231 :     $subsystem->get_variant_code($subsystem->get_genome_index($genome)) ."</em><p>";
232 : paarmann 1.3 }
233 :    
234 :    
235 :     # iterate over all roles present in a subsystem:
236 :     # -> map roles to abbr in the foreach loop
237 :     # -> color simple roles present
238 :     # -> tag roles being part of a logical operator in $lookup
239 :     foreach (map { $subsystem->get_abbr_for_role($_) } @roles) {
240 : paarmann 1.1
241 : paarmann 1.3 # color normal roles
242 :     if ($d->has_item('role', $_)) {
243 :     $d->color_item('role',$_,'green');
244 :     next;
245 :     }
246 : paarmann 1.1
247 : paarmann 1.3 # try to find role_and / role_or
248 :     if (exists($lookup->{$_})) {
249 :     $lookup->{$_}->{$_} = 1;
250 :     next;
251 : paarmann 1.1 }
252 : paarmann 1.3
253 :     $status .= "Role '$_' not found in the diagram.\n";
254 : paarmann 1.1 }
255 : paarmann 1.3
256 :     # use Data::Dumper;
257 :     # $content .= "<pre>".Data::Dumper->Dump([ $lookup ])."</pre>";
258 :    
259 :     # check if to color any role_and
260 :     foreach my $id_role_and (keys(%$role_and)) {
261 :     my $result = 1;
262 :     foreach (keys(%{$role_and->{$id_role_and}})) {
263 :     $result = 0 unless ($role_and->{$id_role_and}->{$_});
264 :     }
265 :     $d->color_item('role_and', $id_role_and, 'green') if ($result);
266 : paarmann 1.1 }
267 : paarmann 1.3 }
268 :     else {
269 :     $content .= '<p><em>You have not provided a genome id to color the diagram with.</em><p>';
270 : paarmann 1.1 }
271 :    
272 : paarmann 1.3 $content .= $d->html;
273 :     $content .= '<hr/><p><em>Below follows a status message to help test the new diagrams:</em><p>'.
274 :     "<pre>$status</pre>" if ($status);
275 :    
276 : paarmann 1.1 return $content;
277 :     }
278 :    
279 :    

MCS Webmaster
ViewVC Help
Powered by ViewVC 1.0.3