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

Annotation of /FigWebServices/diagram.cgi

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.7 - (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.7 # $Id: diagram.cgi,v 1.6 2007/03/09 20:11:48 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 : paarmann 1.6 }
56 :     th, td {
57 :     font-size: 12px;
58 :     }
59 :     ~;
60 : paarmann 1.1
61 :     # print out the page
62 :     print $cgi->header();
63 : paarmann 1.6 print "<html>\n<head>\n";
64 :     print "<title>The SEED - Subsystem Diagram</title>\n";
65 :     print "<style type='text/css'> \n <!-- \n $css \n --> \n </style> \n";
66 :     print "</head> \n <body> \n";
67 : paarmann 1.1
68 :     print &get_Diagram($fig, $cgi);
69 :    
70 : paarmann 1.2 print $cgi->end_html;
71 :    
72 : paarmann 1.1 }
73 :    
74 :    
75 :     sub get_Diagram {
76 :     # get parameters
77 :     my ($fig, $cgi) = @_;
78 :    
79 : paarmann 1.3 # get the subsystem
80 :     unless ($cgi->param('subsystem_name')) {
81 : paarmann 1.1 return '<p>CGI Parameter missing.</p>';
82 :     }
83 : paarmann 1.3 my $subsystem_name = $cgi->param('subsystem_name') || '';
84 : paarmann 1.1 my $subsystem_pretty = $subsystem_name;
85 :     $subsystem_pretty =~ s/_/ /g;
86 : paarmann 1.3 my $subsystem = $fig->get_subsystem($subsystem_name);
87 : paarmann 1.1
88 : paarmann 1.3 # check subsystem
89 :     unless ($subsystem) {
90 :     return "<p>Unable to find a subsystem called '$subsystem_name'.</p>";
91 :     }
92 : paarmann 1.1
93 :    
94 : paarmann 1.3 # if diagram.cgi is called without the CGI param diagram (the diagram id)
95 :     # it will try to load the first 'new' diagram from the subsystem and
96 :     # print out an error message if there is no 'new' diagram
97 :     my $diagram_id = $cgi->param('diagram') || '';
98 :     unless ($diagram_id) {
99 :     foreach my $d ($subsystem->get_diagrams) {
100 :     my ($id) = @$d;
101 :     if ($subsystem->is_new_diagram($id)) {
102 :     $diagram_id = $id;
103 :     last;
104 : paarmann 1.1 }
105 :     }
106 : paarmann 1.3 }
107 : paarmann 1.1
108 : paarmann 1.3 # check diagram id
109 :     unless ($diagram_id) {
110 :     return "<h1>Subsystem: $subsystem_pretty</h1>".
111 :     "<p><em>Unable to find a diagram for this subsystem.</em><p>";
112 :     }
113 :     unless ($subsystem->is_new_diagram($diagram_id)) {
114 :     return "<h1>Subsystem: $subsystem_pretty</h1>".
115 :     "<p><em>Diagram '$diagram_id' is not a new diagram.</em><p>";
116 :     }
117 : paarmann 1.1
118 :    
119 : paarmann 1.6 # find out about sort order
120 :     my $sort_by = $cgi->param('sort_by') || 'name';
121 :    
122 : paarmann 1.7 # get the genomes from the subsystem
123 : paarmann 1.3 my @genomes;
124 :     my $genome = $cgi->param('genome_id');
125 : paarmann 1.6 if ($sort_by eq 'variant_code') {
126 : paarmann 1.7 @genomes = sort { ($subsystem->get_variant_code( $subsystem->get_genome_index($a) ) cmp
127 :     $subsystem->get_variant_code( $subsystem->get_genome_index($b) )) or
128 :     ( $fig->genus_species($a) cmp $fig->genus_species($b) )
129 :     } $subsystem->get_genomes()
130 : paarmann 1.6 }
131 :     else {
132 : paarmann 1.7 @genomes = sort { $fig->genus_species($a) cmp $fig->genus_species($b) } $subsystem->get_genomes();
133 :     }
134 :    
135 :     # show only genomes with zero or positive variant codes
136 :     # unless user switched that off
137 :     unless ($cgi->param('show_negative')) {
138 :     my @temp;
139 :     foreach (@genomes) {
140 :     my $vcode = $subsystem->get_variant_code( $subsystem->get_genome_index( $_ ) );
141 :     push @temp, $_ if ($vcode >= 0);
142 : paarmann 1.6 }
143 : paarmann 1.7 @genomes = @temp;
144 : paarmann 1.3 }
145 :    
146 : paarmann 1.4 my %genome_labels = map { $_ => $fig->genus_species($_)." ( $_ ) [".
147 :     $subsystem->get_variant_code( $subsystem->get_genome_index( $_ ) )."]"
148 :     } @genomes;
149 : paarmann 1.6
150 :     @genomes = ('0', @genomes);
151 :     $genome_labels{'0'} = 'please select a genome to color the diagram with' ;
152 : paarmann 1.3
153 :    
154 :     # generate the content
155 :     my $content = "<h1>Subsystem: $subsystem_pretty</h1>";
156 :     $content .= '<hr/>';
157 :    
158 : paarmann 1.6 $content .= $cgi->start_form( -id => 'diagram_select_genome' );
159 : paarmann 1.3 $content .= $cgi->hidden( -name => 'subsystem_name',
160 :     -value => $subsystem_name );
161 :     $content .= $cgi->hidden( -name => 'diagram',
162 :     -value => $diagram_id );
163 : paarmann 1.5 $content .= $cgi->hidden( -name => 'dont_scale', -value => 1 )
164 :     if ($cgi->param('dont_scale'));
165 : paarmann 1.7 $content .= $cgi->hidden( -name => 'show_negative', -value => 1 )
166 :     if ($cgi->param('show_negative'));
167 : paarmann 1.5 $content .= $cgi->hidden( -name => 'debug', -value => 1 )
168 :     if ($cgi->param('debug'));
169 : paarmann 1.6 $content .= '<p>Sort by: '.
170 :     $cgi->radio_group( -name => 'sort_by',
171 :     -values => ['name', 'variant_code'],
172 :     -default => $sort_by,
173 :     -labels => { 'name' => 'Genome name',
174 :     'variant_code' => 'Variant code, then genome name' },
175 :     -onChange => 'document.getElementById("diagram_select_genome").submit();',
176 : paarmann 1.7 ).' &nbsp; | &nbsp; ';
177 :     $content .= ''.$cgi->checkbox( -name => 'show_negative',
178 :     -value => 1,
179 :     -label => 'Show genomes with negative variant codes',
180 :     -onChange => 'document.getElementById("diagram_select_genome").submit();',
181 : paarmann 1.6 ).'</p>';
182 : paarmann 1.3 $content .= $cgi->popup_menu( -name => 'genome_id',
183 :     -values => \@genomes,
184 :     -default => $genome,
185 :     -labels => \%genome_labels,
186 :     );
187 :     $content .= $cgi->submit( -name => 'Color diagram' );
188 :     $content .= $cgi->end_form();
189 :    
190 :     # initialise a status string (log)
191 :     my $status = '';
192 :    
193 :     # fetch the diagram
194 :     my $diagram_dir = $subsystem->{dir}."/diagrams/$diagram_id/";
195 :     my $d = Diagram->new($subsystem_name, $diagram_dir);
196 : paarmann 1.5
197 :     # turn off scaling?
198 :     $d->min_scale(1) if ($cgi->param('dont_scale'));
199 : paarmann 1.3
200 :    
201 :     # DEBUG: test all items of the diagram against the subsystem
202 :     # (for debug purposes during introduction of new diagrams)
203 :     # (remove when no longer needed)
204 :     # (1) roles
205 :     my $types = [ 'role', 'role_and', 'role_or' ];
206 :     foreach my $t (@$types) {
207 :     foreach my $id (@{$d->item_ids_of_type($t)}) {
208 :     unless ($subsystem->get_role_from_abbr($id) or
209 :     scalar($subsystem->get_subsetC_roles($id))) {
210 :     $status .= "Diagram item '$t' = '$id' not found in the subsystem.\n";
211 :     }
212 :     }
213 :     }
214 :     # (2) subsystem
215 :     foreach my $s (@{$d->item_ids_of_type('subsystem')}) {
216 :     unless ($fig->subsystem_version($s)) {
217 :     $status .= "Diagram item 'subsystem' = '$s' is not a subsystem.\n";
218 :     }
219 :     }
220 :     # END
221 : paarmann 1.6
222 :    
223 :     # add notes to roles
224 :     # to reduce the total number of loos role_or, role_and get their notes
225 :     # attached in the loops further down
226 :     foreach my $id (@{$d->item_ids_of_type('role')}) {
227 :     my $role = $subsystem->get_role_from_abbr($id);
228 :     if ($role) {
229 :     $d->add_note('role', $id, $role);
230 :     }
231 :     }
232 :    
233 : paarmann 1.3
234 : paarmann 1.5 # build a lookup hash, make one entry for each role_and and role_or item
235 :     # the index references to the inner hash of the role_and/role_or hash
236 :     # to set a value there use $lookup->{role_abbr}->{role_abbr} = 1;
237 :     # declared outside if to be available for debug output
238 :     my $lookup = {};
239 :    
240 : paarmann 1.6 # find out about role_and
241 :     my $role_and = {};
242 :     if (scalar(@{$d->item_ids_of_type('role_and')})) {
243 :     foreach my $subset (@{$d->item_ids_of_type('role_and')}) {
244 :    
245 :     $role_and->{$subset} = {};
246 :    
247 :     my $note = '';
248 :     foreach my $r ($subsystem->get_subsetC_roles($subset)) {
249 :     my $r_abbr = $subsystem->get_abbr_for_role($r);
250 :     unless ($r_abbr) {
251 :     die "Unable to get the abbreviation for role '$r'.";
252 :     }
253 : paarmann 1.3
254 : paarmann 1.6 $note .= "<li>$r</li>";
255 :     $lookup->{$r_abbr} = $role_and->{$subset};
256 :     $role_and->{$subset}->{$r_abbr} = 0;
257 : paarmann 1.1 }
258 : paarmann 1.6 $d->add_note('role_and', $subset, "<h4>Requires all of:</h4><ul>$note</ul>");
259 : paarmann 1.3 }
260 : paarmann 1.6 }
261 :    
262 :     # find out about role_or
263 :     my $role_or = {};
264 :     if (scalar(@{$d->item_ids_of_type('role_or')})) {
265 :     foreach my $subset (@{$d->item_ids_of_type('role_or')}) {
266 :    
267 :     $role_or->{$subset} = {};
268 :    
269 :     my $note = '';
270 :     foreach my $r ($subsystem->get_subsetC_roles($subset)) {
271 :     my $r_abbr = $subsystem->get_abbr_for_role($r);
272 : paarmann 1.1
273 : paarmann 1.6 unless ($r_abbr) {
274 :     die "Unable to get the abbreviation for role '$r'.";
275 : paarmann 1.1 }
276 : paarmann 1.6
277 :     $note .= "<li>$r</li>";
278 :     $lookup->{$r_abbr} = $role_or->{$subset};
279 :     $role_or->{$subset}->{$r_abbr} = 0;
280 : paarmann 1.1 }
281 : paarmann 1.6 $d->add_note('role_or', $subset, "<h4>Requires any of:</h4><ul>$note</ul>");
282 : paarmann 1.3 }
283 : paarmann 1.6 }
284 :    
285 :    
286 :     if ($genome) {
287 : paarmann 1.3
288 : paarmann 1.6 my @roles = $subsystem->get_roles_for_genome($genome);
289 : paarmann 1.3
290 :     # check if genome is present in subsystem
291 :     # genomes not present, unfortunately return @roles = ( undef )
292 :     if (scalar(@roles) == 0 or
293 :     (scalar(@roles) and !defined($roles[0]))) {
294 :     $content .= "<p><em>Genome '$genome' is not present in this subsystem.</em><p>";
295 :     shift(@roles);
296 :     }
297 :     else {
298 : paarmann 1.4 $content .= "<p><em>Showing colors for genome: ".
299 :     $fig->genus_species($genome)." ( $genome ), variant code ".
300 :     $subsystem->get_variant_code($subsystem->get_genome_index($genome)) ."</em><p>";
301 : paarmann 1.3 }
302 :    
303 :    
304 :     # iterate over all roles present in a subsystem:
305 :     # -> map roles to abbr in the foreach loop
306 :     # -> color simple roles present
307 :     # -> tag roles being part of a logical operator in $lookup
308 :     foreach (map { $subsystem->get_abbr_for_role($_) } @roles) {
309 : paarmann 1.1
310 : paarmann 1.3 # color normal roles
311 :     if ($d->has_item('role', $_)) {
312 :     $d->color_item('role',$_,'green');
313 :     next;
314 :     }
315 : paarmann 1.1
316 : paarmann 1.3 # try to find role_and / role_or
317 :     if (exists($lookup->{$_})) {
318 :     $lookup->{$_}->{$_} = 1;
319 :     next;
320 : paarmann 1.1 }
321 : paarmann 1.3
322 :     $status .= "Role '$_' not found in the diagram.\n";
323 : paarmann 1.1 }
324 : paarmann 1.3
325 :     # check if to color any role_and
326 :     foreach my $id_role_and (keys(%$role_and)) {
327 :     my $result = 1;
328 :     foreach (keys(%{$role_and->{$id_role_and}})) {
329 :     $result = 0 unless ($role_and->{$id_role_and}->{$_});
330 :     }
331 :     $d->color_item('role_and', $id_role_and, 'green') if ($result);
332 : paarmann 1.1 }
333 : paarmann 1.5
334 :     # check if to color any role_or
335 :     foreach my $id_role_or (keys(%$role_or)) {
336 :     foreach (keys(%{$role_or->{$id_role_or}})) {
337 :     if ($role_or->{$id_role_or}->{$_}) {
338 :     $d->color_item('role_or', $id_role_or, 'green');
339 :     last;
340 :     }
341 :     }
342 :     }
343 :    
344 : paarmann 1.3 }
345 :     else {
346 :     $content .= '<p><em>You have not provided a genome id to color the diagram with.</em><p>';
347 : paarmann 1.1 }
348 :    
349 : paarmann 1.5 # add an info line about diagram scaling
350 :     my $scale = $d->calculate_scale * 100;
351 :     unless ($scale == 100) {
352 :     $content .= '<p><em>This diagram has been scaled to '.sprintf("%.2f", $scale).'%. ';
353 : paarmann 1.7 $content .= "(<a href='?subsystem_name=$subsystem_name&diagram=$diagram_id&dont_scale=1'>".
354 : paarmann 1.5 "view in original size</a>)";
355 :     $content .= '</em></p>';
356 :     }
357 :     if ($cgi->param('dont_scale')) {
358 :     $content .= '<p><em>You have switched off scaling this diagram down. ';
359 : paarmann 1.7 $content .= "(<a href='?subsystem_name=$subsystem_name&diagram=$diagram_id'>".
360 : paarmann 1.5 "Allow scaling</a>)";
361 :     $content .= '</em></p>';
362 :     }
363 :    
364 :     # print diagram
365 : paarmann 1.3 $content .= $d->html;
366 : paarmann 1.5
367 :     # print status
368 : paarmann 1.3 $content .= '<hr/><p><em>Below follows a status message to help test the new diagrams:</em><p>'.
369 :     "<pre>$status</pre>" if ($status);
370 :    
371 : paarmann 1.5 # print debug
372 :     if ($cgi->param('debug')) {
373 :     require Data::Dumper;
374 :     $content .= '<hr/>';
375 :     $content .= "<h2>Diagram dump:</h2><pre>".Data::Dumper->Dump([ $d ])."</pre>";
376 :     $content .= "<h2>Lookup dump:</h2><pre>".Data::Dumper->Dump([ $lookup ])."</pre>";
377 :     }
378 :    
379 : paarmann 1.1 return $content;
380 :     }
381 :    
382 :    

MCS Webmaster
ViewVC Help
Powered by ViewVC 1.0.3