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

Annotation of /FigWebServices/subsys.cgi

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.218 - (view) (download)

1 : overbeek 1.1 # -*- perl -*-
2 : olson 1.130 #
3 :     # Copyright (c) 2003-2006 University of Chicago and Fellowship
4 :     # for Interpretations of Genomes. All Rights Reserved.
5 :     #
6 :     # This file is part of the SEED Toolkit.
7 :     #
8 :     # The SEED Toolkit is free software. You can redistribute
9 :     # it and/or modify it under the terms of the SEED Toolkit
10 :     # Public License.
11 :     #
12 :     # You should have received a copy of the SEED Toolkit Public License
13 :     # along with this program; if not write to the University of Chicago
14 :     # at info@ci.uchicago.edu or the Fellowship for Interpretation of
15 :     # Genomes at veronika@thefig.info or download a copy from
16 :     # http://www.theseed.org/LICENSE.TXT.
17 :     #
18 :    
19 : overbeek 1.1 use FIG;
20 : golsen 1.103 use FIGjs; # mouseover()
21 : mkubal 1.165 use GD;
22 :     use MIME::Base64;
23 : olson 1.206 use KGMLData; # to parse relations in KEGG maps
24 : mkubal 1.165
25 : olson 1.216 our $fig = new FIG;
26 : overbeek 1.9
27 : overbeek 1.1 use Subsystem;
28 :    
29 : golsen 1.75 use URI::Escape; # uri_escape()
30 : overbeek 1.1 use HTML;
31 :     use strict;
32 :     use tree_utilities;
33 :    
34 : overbeek 1.158 use raelib;
35 : olson 1.216 our $raelib=new raelib; #this is for the excel workbook stuff.
36 : overbeek 1.158
37 : overbeek 1.1 use CGI;
38 : overbeek 1.135 use CGI::Carp qw(fatalsToBrowser); # this makes debugging a lot easier by throwing errors out to the browser
39 : overbeek 1.9
40 : olson 1.216 our $cgi = new CGI;
41 : redwards 1.121
42 : olson 1.143 $ENV{"PATH"} = "$FIG_Config::bin:$FIG_Config::ext_bin:" . $ENV{"PATH"};
43 : redwards 1.121
44 : overbeek 1.146 if (0)
45 : overbeek 1.1 {
46 :     my $VAR1;
47 :     eval(join("",`cat /tmp/ssa_parms`));
48 :     $cgi = $VAR1;
49 :     # print STDERR &Dumper($cgi);
50 :     }
51 :    
52 :     if (0)
53 :     {
54 :     print $cgi->header;
55 :     my @params = $cgi->param;
56 :     print "<pre>\n";
57 :     foreach $_ (@params)
58 :     {
59 : parrello 1.127 print "$_\t:",join(",",$cgi->param($_)),":\n";
60 : overbeek 1.1 }
61 :    
62 :     if (0)
63 :     {
64 : parrello 1.127 if (open(TMP,">/tmp/ssa_parms"))
65 :     {
66 :     print TMP &Dumper($cgi);
67 :     close(TMP);
68 :     }
69 : overbeek 1.1 }
70 :     exit;
71 :     }
72 :    
73 :     # request to display the phylogenetic tree
74 :     #
75 :     my $request = $cgi->param("request");
76 :     if ($request && ($request eq "show_tree"))
77 :     {
78 :     print $cgi->header;
79 :     &show_tree;
80 :     exit;
81 :     }
82 :    
83 : golsen 1.186 # Some timing code that can be deleted: ## time ##
84 :     my $time_it = 0; ## time ##
85 :     my @times; ## time ##
86 :     push @times, scalar time() if $time_it; ## time ##
87 :    
88 : overbeek 1.1 my $html = [];
89 : golsen 1.186 push @$html, ( $cgi->param('ssa_name') ? "<TITLE>SEED Subsystem: " . $cgi->param('ssa_name') . "</TITLE>\n"
90 :     : "<TITLE>SEED Subsystems</TITLE>\n"
91 :     ); # RAE: every page deserves a title
92 : overbeek 1.1
93 : overbeek 1.128 my $user = $cgi->param('user');
94 : overbeek 1.205 if (($user =~ /^\S/) && ($user !~ /^master:/)) { $user = "master:$user" }
95 : redwards 1.121
96 : overbeek 1.1 $fig->set_user($user);
97 :    
98 : overbeek 1.14 if ($cgi->param('resynch_peg_connections') && (my $ssa = $cgi->param('ssa_name')))
99 : overbeek 1.9 {
100 : overbeek 1.187 $ssa =~ s/ /_/g;
101 : overbeek 1.9 my $subsystem = new Subsystem($ssa,$fig,0);
102 :     $subsystem->db_sync(0);
103 :     undef $subsystem;
104 :     &one_cycle($fig,$cgi,$html);
105 :     }
106 : overbeek 1.14 elsif ($user && ($cgi->param("extend_with_billogix")))
107 : overbeek 1.1 {
108 :     #
109 :     # Start a bg task to extend the subsystem.
110 :     #
111 :    
112 :     my $ssa = $cgi->param('ssa_name');
113 :    
114 :     my $sub = $fig->get_subsystem($ssa);
115 :    
116 : overbeek 1.14 if ($sub && ($user eq $sub->get_curator))
117 : overbeek 1.1 {
118 : parrello 1.127 #
119 :     # See if there's already an extend job running.
120 :     #
121 :    
122 :     my $curpid = $sub->get_current_extend_pid();
123 :     if ($curpid)
124 :     {
125 :     warn "Found current pid $curpid\n";
126 :     my $j = $fig->get_job($curpid);
127 :     warn "job is $j\n";
128 :     warn "running is ", $j->running(), "\n" if $j;
129 :     if ($j && $j->running())
130 :     {
131 :     push(@$html, "Subsystem extension is already running as job number $curpid. <br>",
132 :     "Click <a href=\"seed_ctl.cgi?user=$user\">here</a> to see currently running jobs and their status");
133 :     last;
134 :     }
135 :     }
136 :    
137 :     my $pid = $fig->run_in_background(sub {$sub->extend_with_billogix($user);});
138 :    
139 :     push(@$html,
140 :     "Subsystem extension started as background job number $pid <br>\n",
141 :     "Click <a href=\"seed_ctl.cgi?user=$user\">here</a> to see currently running jobs and their status");
142 :    
143 :     $sub->set_current_extend_pid($pid);
144 : overbeek 1.1 }
145 :     else
146 :     {
147 : parrello 1.127 push(@$html, "Subsystem '$ssa' could not be loaded");
148 : overbeek 1.1 }
149 :     &HTML::show_page($cgi, $html);
150 :     exit;
151 :     }
152 : overbeek 1.180 elsif ($cgi->param('lock annotations') && ($user = $cgi->param('user')))
153 :     {
154 :     my @orgs = $cgi->param('genome_to_lock');
155 :     @orgs = map { $_ =~ /^(\d+\.\d+)/; $1 } @orgs;
156 :     my @roles = $cgi->param('roles_to_lock');
157 :     my $ssa = $cgi->param('ssa_name');
158 : overbeek 1.187 $ssa =~ s/ /_/g;
159 : overbeek 1.180 push(@$html,"<br>");
160 :    
161 :     foreach my $genome (@orgs)
162 :     {
163 :     foreach my $role (@roles)
164 :     {
165 :     foreach my $peg ($fig->pegs_in_subsystem_cell($ssa,$genome,$role))
166 :     {
167 :     $user =~ s/master://;
168 :     $fig->lock_fid($user,$peg);
169 :     push(@$html,"locked $peg<br>\n");
170 :     }
171 :     }
172 :     }
173 :     &HTML::show_page($cgi, $html);
174 :     exit;
175 :     }
176 :     elsif ($cgi->param('unlock annotations') && ($user = $cgi->param('user')))
177 :     {
178 :     my @orgs = $cgi->param('genome_to_lock');
179 :     @orgs = map { $_ =~ /^(\d+\.\d+)/; $1 } @orgs;
180 :     my @roles = $cgi->param('roles_to_lock');
181 :     my $ssa = $cgi->param('ssa_name');
182 : overbeek 1.187 $ssa =~ s/ /_/g;
183 :    
184 : overbeek 1.180 push(@$html,"<br>");
185 :    
186 :     foreach my $genome (@orgs)
187 :     {
188 :     foreach my $role (@roles)
189 :     {
190 :     foreach my $peg ($fig->pegs_in_subsystem_cell($ssa,$genome,$role))
191 :     {
192 :     $user =~ s/master://;
193 :     $fig->unlock_fid($user,$peg);
194 :     push(@$html,"unlocked $peg<br>\n");
195 :     }
196 :     }
197 :     }
198 :     &HTML::show_page($cgi, $html);
199 :     exit;
200 :     }
201 : overbeek 1.1 else
202 :     {
203 :     $request = defined($request) ? $request : "";
204 : overbeek 1.8
205 : overbeek 1.14 if (($request eq "reset") && $user)
206 : overbeek 1.1 {
207 : parrello 1.127 &reset_ssa($fig,$cgi,$html); # allow user to go back to a previous version of the ss
208 : overbeek 1.1 }
209 : overbeek 1.14 elsif (($request eq "reset_to") && $user)
210 : overbeek 1.1 {
211 : parrello 1.127 &reset_ssa_to($fig,$cgi,$html); # this actually resets to the previous version
212 :     &one_cycle($fig,$cgi,$html);
213 : overbeek 1.1 }
214 : overbeek 1.14 elsif (($request eq "make_exchangable") && $user)
215 : overbeek 1.1 {
216 : parrello 1.127 &make_exchangable($fig,$cgi,$html);
217 :     &show_initial($fig,$cgi,$html);
218 : overbeek 1.1 }
219 : overbeek 1.14 elsif (($request eq "make_unexchangable") && $user)
220 : overbeek 1.1 {
221 : parrello 1.127 &make_unexchangable($fig,$cgi,$html);
222 :     &show_initial($fig,$cgi,$html);
223 : overbeek 1.1 }
224 :     elsif ($request eq "show_ssa")
225 :     {
226 : overbeek 1.185 my $ssa = $cgi->param('ssa_name');
227 : overbeek 1.187 $ssa =~ s/ /_/g;
228 : overbeek 1.188 my $html1 = [];
229 :     my $html2 = [];
230 :     &one_cycle($fig,$cgi,$html2);
231 :    
232 : overbeek 1.189 if (-e "$FIG_Config::data/Subsystems/$ssa/warnings")
233 : overbeek 1.185 {
234 :     my $ts = localtime($^T - ((-M "$FIG_Config::data/Subsystems/$ssa/warnings") * 24 * 60 * 60));
235 : overbeek 1.188 push(@$html1,$cgi->h1("Last check was at $ts"));
236 : overbeek 1.185
237 : overbeek 1.193 my @tmp = $fig->file_read("$FIG_Config::data/Subsystems/$ssa/warnings");
238 : overbeek 1.187 my @mismatches = grep { ($_ =~ /mismatch\t(\S+)\t([^\t]+)/) &&
239 : overbeek 1.194 &still_in($fig,$1,$2,$ssa)
240 : overbeek 1.187 } @tmp;
241 : overbeek 1.185 my $mismatchesN = (@mismatches > 0) ? @mismatches : 0;
242 : overbeek 1.189 push(@$html1,$cgi->h2("$mismatchesN entries mismatch the role"));
243 : overbeek 1.187
244 :     my @left_out = grep { ($_ =~ /left-out\t(\S+)\t([^\t]+)/) &&
245 : overbeek 1.190 &still_left_out($fig,$1,$2,$ssa)
246 : overbeek 1.187 } @tmp;
247 : overbeek 1.190
248 : overbeek 1.185 my $left_outN = (@left_out > 0) ? @left_out : 0;
249 : overbeek 1.189 push(@$html1,$cgi->h2("$left_outN entries should be added for existing genomes"));
250 : overbeek 1.187
251 :     my $sobj = $fig->get_subsystem($ssa);
252 :     my %genomes_in_sub = map { $_ => 1 } $sobj->get_genomes;
253 :     my @maybe_add = grep { ($_ =~ /maybe-add\t[^\t]+\t[^\t]+\t(\d+\.\d+)/) &&
254 :     (! $genomes_in_sub{$1})
255 :     } @tmp;
256 : overbeek 1.185 my $maybe_addN = (@maybe_add > 0) ? @maybe_add : 0;
257 : overbeek 1.189 push(@$html1,$cgi->h2("$maybe_addN genomes maybe should be added"));
258 : olson 1.195 my $esc_ssa = uri_escape($ssa);
259 : overbeek 1.185 if ($mismatchesN || $left_outN || $maybe_addN)
260 :     {
261 : overbeek 1.188 push(@$html1,"<b>To see results of the last check:</b>&nbsp;",
262 : olson 1.195 $cgi->a({href => "check_subsys.cgi?user=$user&subsystem=$esc_ssa&request=check_ssa&fast=1",
263 : overbeek 1.185 target => 'check_window'
264 :     },
265 :     "click here")
266 :     );
267 :     }
268 : overbeek 1.188 push(@$html1,"<br>","If you wish to run a new check now: ",
269 : olson 1.195 $cgi->a({href => "check_subsys.cgi?user=$user&subsystem=$esc_ssa&request=check_ssa",
270 : overbeek 1.185 target => 'check_window'
271 :     },
272 : overbeek 1.192 "click here<br>")
273 :     );
274 :    
275 :     push(@$html1,"If you wish to run a summary for all of your subsystems: ",
276 :     $cgi->a({href => "check_subsys.cgi?user=$user&request=check_summary",
277 :     target => 'check_window'
278 :     },
279 : overbeek 1.185 "click here<hr><br>")
280 :     );
281 :    
282 :     }
283 : overbeek 1.188 push(@$html,@$html1,@$html2);
284 : overbeek 1.1 }
285 :     #
286 :     # Note that this is a little different; I added another submit button
287 :     # to the delete_or_export_ssa form, so have to distinguish between them
288 :     # here based on $cgi->param('delete_export') - the original button,
289 :     # or $cgi->param('publish') - the new one.
290 :     #
291 : overbeek 1.14 elsif (($request eq "delete_or_export_ssa") && $user &&
292 : parrello 1.127 defined($cgi->param('delete_export')))
293 : overbeek 1.1 {
294 : parrello 1.127 my($ssa,$exported);
295 :     $exported = 0;
296 :     foreach $ssa ($cgi->param('export'))
297 :     {
298 :     if (! $exported)
299 :     {
300 :     print $cgi->header;
301 :     print "<pre>\n";
302 :     }
303 :     &export($fig,$cgi,$ssa);
304 :     $exported = 1;
305 :     }
306 :    
307 :     foreach $ssa ($cgi->param('export_assignments'))
308 :     {
309 :     &export_assignments($fig,$cgi,$ssa);
310 :     }
311 :    
312 :     foreach $ssa ($cgi->param('delete'))
313 :     {
314 :     my $sub = $fig->get_subsystem($ssa);
315 :     $sub->delete_indices();
316 : overbeek 1.139
317 : parrello 1.127 my $cmd = "rm -rf '$FIG_Config::data/Subsystems/$ssa'";
318 :     my $rc = system $cmd;
319 :     }
320 :    
321 :     if (! $exported)
322 :     {
323 : overbeek 1.139 &show_initial($fig,$cgi,$html);
324 :     }
325 :     else
326 :     {
327 :     print "</pre>\n";
328 :     exit;
329 :     }
330 :     }
331 :     elsif (($request eq "delete_or_export_ssa") && $user &&
332 :     defined($cgi->param('publish')))
333 :     {
334 :     my($ssa,$exported);
335 :     my($ch) = $fig->get_clearinghouse();
336 :    
337 :     print $cgi->header;
338 :    
339 :     if (!defined($ch))
340 :     {
341 :     print "cannot publish: clearinghouse not available\n";
342 :     exit;
343 :     }
344 :    
345 :     foreach $ssa ($cgi->param('publish_to_clearinghouse'))
346 :     {
347 :     print "<h2>Publishing $ssa to clearinghouse...</h2>\n";
348 :     $| = 1;
349 :     print "<pre>\n";
350 :     my $res = $fig->publish_subsystem_to_clearinghouse($ssa);
351 :     print "</pre>\n";
352 :     if ($res)
353 :     {
354 :     print "Published <i>$ssa </i> to clearinghouse<br>\n";
355 : parrello 1.127 }
356 : overbeek 1.139 else
357 : parrello 1.127 {
358 : overbeek 1.139 print "<b>Failed</b> to publish <i>$ssa</i> to clearinghouse<br>\n";
359 :     }
360 :     }
361 :     exit;
362 :     }
363 :     elsif (($request eq "delete_or_export_ssa") && $user &&
364 :     defined($cgi->param('reindex')))
365 :     {
366 : parrello 1.127
367 : overbeek 1.139 my @ss=$cgi->param('index_subsystem');
368 :     my $job = $fig->index_subsystems(@ss);
369 :     push @$html, "<h2>ReIndexing these subsystems...</h2>\n<ul>", map {"<li>$_</li>"} @ss;
370 :     push @$html, "</ul>\n<p>... is running in the background with job id $job. You may check it in the ",
371 :     "<a href=\"seed_ctl.cgi?user=$user\">SEED Control Panel</a></p>\n";
372 :     &show_initial($fig,$cgi,$html);
373 :     }
374 :     elsif (($request eq "delete_or_export_ssa") && $user &&
375 : redwards 1.176 defined($cgi->param('save_clicks')))
376 : overbeek 1.139 {
377 :     my @userss=$cgi->param("users_ss");
378 :     my %nmpdrss=map {($_=>1)} $cgi->param("nmpdr_ss");
379 : redwards 1.176 my %distss=map {($_=>1)} $cgi->param("dist_ss");
380 :     my %autoss=map {($_=>1)} $cgi->param("auto_update_ok");
381 : parrello 1.127
382 : overbeek 1.139 foreach my $ssa (@userss)
383 :     {
384 :     $nmpdrss{$ssa} ? $fig->nmpdr_subsystem($ssa, 1) : $fig->nmpdr_subsystem($ssa, -1);
385 : redwards 1.176 $distss{$ssa} ? $fig->distributable_subsystem($ssa, 1) : $fig->distributable_subsystem($ssa, -1);
386 :     $autoss{$ssa} ? $fig->ok_to_auto_update_subsys($ssa, 1) : $fig->ok_to_auto_update_subsys($ssa, -1);
387 : overbeek 1.140 }
388 :     &manage_subsystems($fig,$cgi,$html);
389 :     }
390 : overbeek 1.14 elsif ($user && ($request eq "new_ssa") && ($cgi->param('copy_from1')) && (! $cgi->param('cols_to_take1')))
391 : overbeek 1.1 {
392 : parrello 1.127 my $name = $cgi->param('ssa_name');
393 :     my $copy_from1 = $cgi->param('copy_from1');
394 :     my $copy_from2 = $cgi->param('copy_from2');
395 : overbeek 1.1 my(@roles1,@roles2);
396 :    
397 : parrello 1.127 push(@$html,$cgi->start_form(-action => "subsys.cgi",
398 : overbeek 1.139 -method => 'post'),
399 :     $cgi->hidden(-name => 'copy_from1', -value => $copy_from1, -override => 1),
400 :     $cgi->hidden(-name => 'user', -value => $user, -override => 1),
401 :     $cgi->hidden(-name => 'ssa_name', -value => $name, -override => 1),
402 :     $cgi->hidden(-name => 'request', -value => 'new_ssa', -override => 1)
403 :     );
404 : parrello 1.127
405 :     @roles1 = $fig->subsystem_to_roles($copy_from1);
406 :     if (@roles1 > 0)
407 :     {
408 :     push(@$html,$cgi->h1("select columns to be taken from $copy_from1"),
409 : overbeek 1.139 $cgi->scrolling_list(-name => 'cols_to_take1',
410 :     -values => ['all',@roles1],
411 :     -size => 10,
412 :     -multiple => 1
413 :     ),
414 :     $cgi->hr
415 :     );
416 : parrello 1.127 }
417 :    
418 :     if ($copy_from2)
419 :     {
420 :     @roles2 = $fig->subsystem_to_roles($copy_from2);
421 :     if (@roles2 > 0)
422 :     {
423 :     push(@$html,$cgi->hidden(-name => 'copy_from2', -value => $copy_from2, -override => 1));
424 :     push(@$html,$cgi->h1("select columns to be taken from $copy_from2"),
425 : overbeek 1.139 $cgi->scrolling_list(-name => 'cols_to_take2',
426 :     -values => ['all',@roles2],
427 :     -size => 10,
428 :     -multiple => 1
429 :     ),
430 :     $cgi->hr
431 :     );
432 : parrello 1.127 }
433 :     }
434 :     push(@$html,$cgi->submit('build new subsystem'),
435 : overbeek 1.139 $cgi->end_form
436 :     );
437 : overbeek 1.1 }
438 : redwards 1.89 elsif ($user && ($request eq "new_ssa") && ($cgi->param('move_from')))
439 :     {
440 : parrello 1.127 my $name = $cgi->param('ssa_name');
441 :     $name=$fig->clean_spaces($name);
442 :     $name=~s/ /_/g;
443 :     my $move_from = $cgi->param('move_from');
444 : redwards 1.89 if (-d "$FIG_Config::data/Subsystems/$move_from" && !(-e "$FIG_Config::data/Subsystems/$name")) {
445 : overbeek 1.139 my $res=`mv $FIG_Config::data/Subsystems/$move_from $FIG_Config::data/Subsystems/$name`;
446 :     my $job = $fig->index_subsystems($name);
447 :     push @$html, "<p>The subsystem <b>$move_from</b> was moved to <b>$name</b> and got the result $res. The new subsystem is being indexed with job id $job\n",
448 :     "(check the <a href=\"seed_ctl.cgi?user=$user\">SEED control panel</a> for more information</p>\n";
449 : parrello 1.127 }
450 :     elsif (-e "$FIG_Config::data/Subsystems/$name")
451 :     {
452 : overbeek 1.139 push @$html, "<p>The subsystem <b>$move_from</b> was <b><i>NOT</i></b> moved because the subsystem $name already exists</p>";
453 : parrello 1.127 }
454 :     else {
455 : overbeek 1.139 push @$html, "<p>The subsystem <b>$move_from</b> was not found. Sorry</p>";
456 : parrello 1.127 }
457 : redwards 1.89 &show_initial($fig,$cgi,$html);
458 : parrello 1.127 }
459 : overbeek 1.1 elsif ($request eq "new_ssa")
460 :     {
461 : parrello 1.127 &new_ssa($fig,$cgi,$html);
462 : overbeek 1.1 }
463 : mkubal 1.165
464 : redwards 1.108 #RAE: undelete these 5 commented out line for the new interface
465 : overbeek 1.112 elsif ($request eq "manage_ss")
466 :     # else
467 : redwards 1.108 {
468 :     &manage_subsystems($fig,$cgi,$html);
469 : overbeek 1.1 }
470 : overbeek 1.112 else
471 :     {
472 : overbeek 1.141 # push @$html, $cgi->div({class=>"diagnostic"}, "Request: $request\n");
473 : parrello 1.127 &show_initial($fig,$cgi,$html);
474 : overbeek 1.112 }
475 : overbeek 1.1 }
476 :    
477 :     &HTML::show_page($cgi,$html);
478 : golsen 1.91 exit;
479 : overbeek 1.1
480 : overbeek 1.190 sub still_left_out {
481 :     my($fig,$peg,$func,$sub) = @_;
482 :    
483 :     if ($func ne $fig->function_of($peg)) { return 0 }
484 :     my @subs = $fig->peg_to_subsystems($peg);
485 :     my $i;
486 :     for ($i=0; ($i < @subs) && ($sub ne $subs[$i]); $i++) {}
487 : overbeek 1.191 return ($i == @subs);
488 : overbeek 1.190 }
489 :    
490 : overbeek 1.194 sub still_in {
491 : overbeek 1.197 my($fig,$peg,$func,$role,$sub) = @_;
492 :    
493 :     if ($func ne &stripped_function_of($fig,$peg)) { return 0 }
494 :     $role =~ s/\s+$//;
495 :     if ($func eq $role) { return 0 }
496 : overbeek 1.194
497 :     my @subs = $fig->peg_to_subsystems($peg);
498 :     my $i;
499 :     for ($i=0; ($i < @subs) && ($sub ne $subs[$i]); $i++) {}
500 :     return ($i < @subs);
501 :     }
502 :    
503 : overbeek 1.197 sub stripped_function_of {
504 :     my($fig,$peg) = @_;
505 :    
506 :     my $func = $fig->function_of($peg);
507 :     $func =~ s/\s*\#.*$//;
508 :     return $func;
509 :     }
510 : overbeek 1.190
511 : redwards 1.108 sub show_initial {
512 :     # a new first page written by Rob
513 :     my($fig,$cgi,$html) = @_;
514 : overbeek 1.1
515 : redwards 1.121 # we get this information here and set things so that when we create the links later everything is already set.
516 : overbeek 1.128 my $sort = $cgi->param('sortby');
517 : redwards 1.121 unless ($sort) {$sort="Classification"}
518 :     my $show_clusters=$cgi->param('show_clusters');
519 :     my $sort_ss=$cgi->param('sort');
520 :     my $minus=$cgi->param('show_minus1');
521 :     my $show_genomes=$cgi->param('showgenomecounts');
522 :    
523 :    
524 :     # now set the values into $cgi so that we have them for later
525 :     $cgi->param('sortby', $sort); # this is the table sort
526 :     $cgi->param('show_clusters', $show_clusters); # whether or not to show the clusters
527 :     $cgi->param('sort', $sort_ss); # this is the sort of the organisms in display
528 :     $cgi->param('show_minus1', $minus); # whether to show -1 variants
529 :     $cgi->param('showgenomecounts', $show_genomes); # whether to show genomes on the first page
530 : redwards 1.108
531 :     my @ssa = map {
532 :     my $ss=$_;
533 :     my ($version, $curator, $pedigree, $roles)=$fig->subsystem_info($ss->[0]);
534 : overbeek 1.112 push @$ss, scalar(@$roles), $version;
535 :     push @$ss, scalar(@{$fig->subsystem_genomes($ss->[0])}) if ($cgi->param('showgenomecounts'));
536 : redwards 1.114 $fig->subsystem_classification($ss->[0], [$cgi->param($ss->[0].".class1"), $cgi->param($ss->[0].".class2")]) if ($cgi->param($ss->[0].".class1"));
537 : redwards 1.108 unshift @$ss, @{$fig->subsystem_classification($ss->[0])};
538 :     if ($ss->[3] eq $user) {$ss->[3] = [$ss->[3], "td style='background-color: #BA55D3'"]}
539 :     $_=$ss;
540 :     }
541 :     &existing_subsystem_annotations($fig);
542 :    
543 :     # sort the cells
544 : overbeek 1.162 if ($sort eq "Classification") {@ssa=sort {uc($a->[0]) cmp uc($b->[0]) || uc($a->[1]) cmp uc($b->[1]) || uc($a->[2]) cmp uc($b->[2])} @ssa}
545 :     elsif ($sort eq "Subsystem") {@ssa=sort {uc($a->[2]) cmp uc($b->[2])} @ssa}
546 :     elsif ($sort eq "Curator") {@ssa=sort {uc($a->[3]) cmp uc($b->[3])} @ssa}
547 : redwards 1.108 elsif ($sort eq "Number of Roles") {@ssa=sort {$a->[4] <=> $b->[4]} @ssa}
548 :     elsif ($sort eq "Version") {@ssa=sort {$a->[5] <=> $b->[5]} @ssa}
549 : redwards 1.114
550 :     ##### Add the ability to change empty classifications
551 :    
552 :     # get the complete list of classifications
553 :     my %class1=(""=>1); my %class2=(""=>1);
554 :     map {$class1{$_->[0]}++; $class2{$_->[1]}++} @ssa;
555 :    
556 : redwards 1.121
557 :     # replace empty classifications with the popup_menus and create links
558 : overbeek 1.117 # Disabled this because it is causing the page to load _very_ slowly as the browser has to render all the menus
559 :     # two alternatives: put only a popup for the first field if both are empty and then a popup for the second if neither are empty
560 :     # or put textfields to allow people to cut/paste.
561 :    
562 : overbeek 1.119 map {
563 :     my $ss=$_;
564 :     unless (1 || $ss->[0]) # remove the '1 ||' from this line to reinstate the menus
565 :     {
566 :     $ss->[0] = $cgi->popup_menu(-name=>$ss->[2].".class1", -values=>[sort {$a cmp $b} keys %class1]);
567 :     $ss->[1] = $cgi->popup_menu(-name=>$ss->[2].".class2", -values=>[sort {$a cmp $b} keys %class2]);
568 :     }
569 :     $ss->[2]=&ssa_link($fig, $ss->[2], $user);
570 :     $_=$ss;
571 :     } @ssa;
572 : redwards 1.114
573 : overbeek 1.112 my $col_hdrs=[["Classification", "th colspan=2 style='text-align: center'"], "Subsystem", "Curator", "Number of Roles", "Version"];
574 :     push @$col_hdrs, "Number of Genomes" if ($cgi->param('showgenomecounts'));
575 :    
576 : redwards 1.108 my $tab=HTML->merge_table_rows(\@ssa);
577 :     my $url = &FIG::cgi_url . "/subsys.cgi?user=$user&request=manage_ss";
578 :     my $target = "window$$";
579 :    
580 : overbeek 1.112 my %sortmenu=(
581 : parrello 1.127 unsorted=>"None",
582 :     alphabetic=>"Alphabetical",
583 :     by_pattern=>"Patterns",
584 :     by_phylo=>"Phylogeny",
585 :     by_tax_id=>"Taxonomy",
586 :     by_variant=>"Variant Code",
587 : overbeek 1.112 );
588 : mkubal 1.165
589 : redwards 1.108 push(@$html,
590 : overbeek 1.125 $cgi->start_form(-action => "subsys.cgi"),
591 : redwards 1.108 "<div class='ssinstructions'>\n",
592 :     "Please choose one of the subsystems from this list, or begin working on your own by entering a name in the box at the bottom of the page. ",
593 :     "We suggest that you take some time to look at the subsystems others have developed before working on your own.",
594 :     "<ul><li>Please do not ever edit someone else's spreadsheet</li>\n<li>Please do not open multiple windows to process the same spreadsheet.</li>",
595 :     "<li>Feel free to open a subsystem spreadsheet and then open multiple other SEED windows to access data and modify annotations.</li>",
596 :     "<li>You can access someone else's subsystem spreadsheet using your ID</li>",
597 : redwards 1.114 "<li>To change the classification of an unclassified subsystem, choose the desired classification from the menus and click Update Table View</li>");
598 :    
599 :     push @$html, "<li>You can <a href='$url&manage=mine'>manage your subsystems</a></li>" if ($user);
600 :     push(@$html,
601 : redwards 1.108 "<li>You can <a href='$url'>manage all subsystems</a></li>",
602 :     "</ul></div>",
603 :     "<div class='page_settings' style='width: 75%; margin-left: auto; margin-right: auto'>Please enter your username: ", $cgi->textfield(-name=>"user"), "\n",
604 :     "<table border=1>\n",
605 :     "<tr><th>Settings for this page</th><th>Settings for the links to the next page.<br>Change these and click Update Table View.</th></tr>\n",
606 :     "<tr><td>",
607 : parrello 1.127 "<table><tr>",
608 :     "<td valign=center>Sort table by</td><td valign=center>",
609 :     $cgi->popup_menu(-name=>'sortby', -values=>['Classification', 'Subsystem', 'Curator', 'Number of Roles', 'Version'], -default=>$sort), "</td></tr></table\n",
610 : redwards 1.108 "</td>\n<td>",
611 :     "<table><tr>",
612 : overbeek 1.161 "<td valign=center>Show clusters</td><td valign=center>", $cgi->checkbox(-name=>'show_clusters', -label=>''), "</td>\n",
613 : parrello 1.127 "<td valign=center>Default Spreadsheet Sorted By:</td><td valign=center>",
614 : overbeek 1.128 $cgi->popup_menu(-name => 'sort', -values => [keys %sortmenu], -labels=>\%sortmenu),
615 : parrello 1.127 "</td></tr></table>\n",
616 : redwards 1.108 "</td></tr></table>\n",
617 :     $cgi->submit('Update Table View'), $cgi->reset, $cgi->p,
618 :     "</div>\n",
619 :     &HTML::make_table($col_hdrs,$tab,"Subsystems"),
620 :     $cgi->end_form(),
621 :    
622 :    
623 :     # $cgi->h3('To start a new subsystem'), $cgi->p("Please enter the name of the subsystem that you would like to start. You will be provided with a blank",
624 :     # " form that you can fill in with the roles and genomes to create a subsystem like those above."),
625 :     # $cgi->start_form(-action => "subsys.cgi",
626 : parrello 1.127 # -target => $target,
627 :     # -method => 'post'),
628 : redwards 1.108 # $cgi->hidden(-name => 'user', -value => $user, -override => 1),
629 :     # $cgi->hidden(-name => 'request', -value => 'new_ssa', -override => 1),
630 :     # "Name of New Subsystem: ",
631 :     # $cgi->textfield(-name => "ssa_name", -size => 50),
632 :     # $cgi->hidden(-name => 'can_alter', -value => 1, -override => 1),
633 :     # $cgi->br,
634 :     #
635 :     # $cgi->submit('start new subsystem'),
636 :     );
637 : redwards 1.121
638 : redwards 1.108 }
639 :    
640 : mkubal 1.172 #sub make_link_to_painted_diagram{
641 :     # my($fig, $cgi, $html ) = @_;
642 :     # my $new_html = [];
643 :     # push(@$new_html,"<br><br>");
644 :     # push(@$new_html,"<a href='$FIG_Config::temp_url/painted_diagram.html'>data painted on diagram</a>");
645 :     # push(@$new_html,"<br>");
646 :     # &HTML::show_page($cgi,$new_html);
647 :     # exit;
648 :     #}
649 :    
650 : mkubal 1.165 sub make_link_to_painted_diagram{
651 : mkubal 1.156 my($fig, $cgi, $html ) = @_;
652 : mkubal 1.172 my $script = "<script>
653 :     window.open('$FIG_Config::temp_url/painted_diagram.html');
654 :     </script>";
655 :     push(@$html,$script);
656 :     &HTML::show_page($cgi,$html);
657 : mkubal 1.156 exit;
658 :     }
659 :    
660 : mkubal 1.165 sub find_roles_to_color
661 :     {
662 :     my ($fig,$cgi,$html)=@_;
663 :     my ($genome_id,$key,$value);
664 :    
665 :     if($cgi->param('att_data_genome_id')){$genome_id = $cgi->param('att_data_genome_id');}
666 :    
667 :     if($cgi->param('color_diagram_by_peg_tag')){$key = $cgi->param('color_diagram_by_peg_tag');}
668 :    
669 :     if($cgi->param('value_to_color')){$value = $cgi->param('value_to_color');}
670 : mkubal 1.168
671 :     my @results;
672 :     if($value eq "all"){
673 :     @results = $fig->get_attributes(undef,$key,undef);
674 :     }
675 :     else{
676 :     @results = $fig->get_attributes(undef,$key,$value);
677 :     }
678 : mkubal 1.165
679 : mkubal 1.168 my (@pegs,%roles,%p2v);
680 : mkubal 1.165 foreach my $result (@results){
681 :     my($p,$a,$v,$l)= @$result;
682 :     if($p =~/$genome_id/){
683 :     push(@pegs,$p);
684 : mkubal 1.168 $p2v{$p} = $v;
685 : mkubal 1.165 }
686 :     }
687 :    
688 :     foreach my $peg (@pegs){
689 : mkubal 1.168 my $value = $p2v{$peg};
690 : mkubal 1.165 my $function = $fig->function_of($peg);
691 :     my @function_roles = $fig->roles_of_function($function);
692 : mkubal 1.168 foreach my $fr (@function_roles){$roles{$fr} = $value;}
693 : mkubal 1.165 }
694 :    
695 : mkubal 1.168 return \%roles;
696 : mkubal 1.165 }
697 :    
698 :     sub color_diagram_role_by_av
699 :     {
700 :    
701 : mkubal 1.166 my ($fig,$cgi,$ss_name,$ss_obj,$roles,$diagram_name)=@_;
702 : mkubal 1.165 my $dir = "$FIG_Config::temp_url";
703 :     my $genome_id = $cgi->param('att_data_genome_id');
704 :     my $attribute=$cgi->param('color_diagram_by_peg_tag');
705 : mkubal 1.166 my $diagram_id = "d01";
706 : mkubal 1.165
707 : mkubal 1.166 my @all_diagrams = $ss_obj->get_diagrams();
708 :     foreach my $ad (@all_diagrams){
709 :     if ($diagram_name eq @$ad[1]){
710 :     $diagram_id = @$ad[0];
711 :     }
712 :     }
713 :    
714 :     my $diagram_html_file = $ss_obj->get_diagram_html_file($diagram_id);
715 : mkubal 1.165 open(IN2, $diagram_html_file);
716 :     open(OUT2,">$FIG_Config::temp/painted_diagram.html");
717 :    
718 :     my %role_to_abbr;
719 :     my @r_and_abbr = $ss_obj->roles_with_abbreviations();
720 :     foreach my $r (@r_and_abbr){
721 :     $role_to_abbr{@$r[1]} = @$r[0];
722 :     }
723 :    
724 :     my %abbr_to_coords;
725 :     while ($_ = <IN2>){
726 :     chomp($_);
727 :     my @temp = split("<AREA SHAPE",$_);
728 :     foreach my $t (@temp){
729 :     if( $t =~/COORDS=\"(\d+,\d+,\d+,\d+)\".*Role=\"(\w+)\"/){
730 :     $abbr_to_coords{$2} = $1;
731 :     }
732 :     }
733 :     }
734 :    
735 : mkubal 1.169 print OUT2 qq(<html><head><title>Painted Diagram</title><link rel='stylesheet' title='default' href='../FIG/Html/css/default.css' type='text/css'>
736 :     <link rel='alternate stylesheet' title='Sans Serif' href='../FIG/Html/css/sanserif.css' type='text/css'>
737 :     <link rel='alternate' title='SEED RSS feeds' href='../FIG/Html/rss/SEED.rss' type='application/rss+xml'>
738 :     <script src="../FIG/Html/css/FIG.js" type="text/javascript"></script></HEAD>
739 :     <script src="../FIG/Html/css/coloring.js" type="text/javascript"></script>);
740 :    
741 :     print OUT2 qq(<style type="text/css">
742 :     .colored {
743 :     background-repeat:repeat;
744 :     border: 0;
745 :     border-style: solid;
746 :     margin: 0;
747 :     border: 0;
748 :     font-size: 8pt;
749 :     }
750 :     .colored[class] {
751 :     background-image: url(../FIG/Html/diagram_overlay.png);
752 :     }
753 :    
754 :     .coloredRed {
755 :     background-repeat:repeat;
756 :     border: 0;
757 :     border-style: solid;
758 :     margin: 0;
759 :     border: 0;
760 :     font-size: 8pt;
761 :     }
762 :     .coloredRed[class] {
763 :     background-image: url(../FIG/Html/diagram_overlay_red.png);
764 :     }
765 :    
766 :     .coloredBlue {
767 :     background-repeat:repeat;
768 :     border: 0;
769 :     border-style: solid;
770 :     margin: 0;
771 :     border: 0;
772 :     font-size: 8pt;
773 :     }
774 :     .coloredBlue[class] {
775 :     background-image: url(../FIG/Html/diagram_overlay_blue.png);
776 :     }
777 :    
778 :     .coloredGreen {
779 :     background-repeat:repeat;
780 :     border: 0;
781 :     border-style: solid;
782 :     margin: 0;
783 :     border: 0;
784 :     font-size: 8pt;
785 :     }
786 :     .coloredGreen[class] {
787 :     background-image: url(../FIG/Html/diagram_overlay_green.png);
788 :     }
789 :    
790 :     .coloredGray {
791 :     background-repeat:repeat;
792 :     border: 0;
793 :     border-style: solid;
794 :     margin: 0;
795 :     border: 0;
796 :     font-size: 8pt;
797 :     }
798 :     .coloredGray[class] {
799 :     background-image: url(../FIG/Html/diagram_overlay_gray.png);
800 :     }
801 :    
802 :     .xcolored {
803 :     background-color: red
804 :     }
805 :    
806 :     .transparent {
807 :     background-color: transparent
808 :     }
809 :     </style>);
810 :    
811 :     print OUT2 qq(<body onload="onBodyLoad()">);
812 :     print OUT2 qq(<div id="map_div" style="position:relative; left:0px; top:0px;"><MAP NAME="painted_diagram">);
813 : mkubal 1.168
814 : mkubal 1.165 #iterate through roles passed in to subroutine for consideration
815 : mkubal 1.169 my(@RedRoles,@BlueRoles,@GrayRoles,@GreenRoles);
816 : mkubal 1.168 foreach my $role (keys(%$roles)){
817 :     my %temp_hash = %$roles;
818 : mkubal 1.165 if($role_to_abbr{$role}){
819 :     my $abbr =$role_to_abbr{$role};
820 :     if($abbr_to_coords{$abbr}){
821 : mkubal 1.169 my $temp = $abbr_to_coords{$abbr};
822 :     my @coords = split(",",$temp);
823 :     my $x1 = $coords[0];
824 :     my $y1 = $coords[1];
825 :     my $x2 = $coords[2];
826 :     my $y2 = $coords[3];
827 :     print OUT2 qq(<AREA SHAPE="rect" COORDS="$x1,$y1,$x2,$y2" NOHREF Role="$abbr">);
828 : mkubal 1.168 my $value = $temp_hash{$role};
829 : mkubal 1.171 if($value eq "essential"){
830 :     $abbr = "'".$abbr."'";
831 : mkubal 1.169 push(@RedRoles,$abbr);
832 : mkubal 1.168 }
833 : mkubal 1.170 elsif($value eq "nonessential"){
834 :     $abbr = "'".$abbr."'";
835 : mkubal 1.169 push(@BlueRoles,$abbr);
836 : mkubal 1.168 }
837 : mkubal 1.171 elsif($value eq "undetermined"){
838 :     $abbr = "'".$abbr."'";
839 : mkubal 1.169 push(@GrayRoles,$abbr);
840 : mkubal 1.168 }
841 : mkubal 1.171 else{
842 : mkubal 1.172 $abbr = qq("$abbr");
843 : mkubal 1.169 push(@GreenRoles,$abbr);
844 : mkubal 1.168 }
845 :     }
846 :     }
847 : mkubal 1.165 }
848 : mkubal 1.168
849 : mkubal 1.169 system `cp $FIG_Config::data/Subsystems/$ss_name/diagrams/$diagram_id/diagram.jpg $FIG_Config::temp/painted_diagram.jpg`;
850 :     print OUT2 qq(</MAP><img border="0" src="$FIG_Config::temp_url/painted_diagram.jpg" usemap="#painted_diagram"></div>);
851 :    
852 : mkubal 1.170 my $BlueRolesString = join(",",@BlueRoles);
853 : mkubal 1.171 my $GreenRolesString = join(",",@GreenRoles);
854 :     my $RedRolesString = join(",",@RedRoles);
855 :     my $GrayRolesString = join(",",@GrayRoles);
856 : mkubal 1.172
857 : mkubal 1.169 print OUT2 qq(<script language="JavaScript">
858 :     function onBodyLoad()
859 :     {
860 : mkubal 1.172 var rolesToColorGreen = new Array($GreenRolesString);
861 :     var rolesToColorRed = new Array($RedRolesString);
862 :     var rolesToColorBlue = new Array($BlueRolesString);
863 :     var rolesToColorGray = new Array($GrayRolesString);
864 :     colorEngine = new ActiveDiagram("map_div");
865 : mkubal 1.169 colorEngine.load();
866 : mkubal 1.172 colorEngine.colorRedRoles(rolesToColorRed);
867 :     colorEngine.colorBlueRoles(rolesToColorBlue);
868 :     colorEngine.colorGrayRoles(rolesToColorGray);
869 :     colorEngine.colorGreenRoles(rolesToColorGreen);
870 : mkubal 1.169 }
871 :     </script>);
872 :    
873 : mkubal 1.165 print OUT2 "</BODY></HTML>";
874 :     }
875 :    
876 : mkubal 1.156 sub paint_ma_data
877 :     {
878 :    
879 :     my ($fig,$cgi,$ss_name,$ss_obj)=@_;
880 :     my @inputs;
881 :     my $dir = "$FIG_Config::temp_url";
882 :     my $genome_id = $cgi->param('ma_data_genome_id');
883 : mkubal 1.165
884 : mkubal 1.156 my %peg_to_level;
885 : mkubal 1.165 my $ma_data = 0;
886 :    
887 : mkubal 1.156 if ($cgi->upload('ma_data_file'))
888 :     {
889 : mkubal 1.165 my $fh=$cgi->upload('ma_data_file');
890 :     @inputs = <$fh> ;
891 :     $ma_data = 1;
892 :    
893 :     foreach my $i (@inputs){
894 :     chomp($i);
895 :     my @temp = split("\t",$i);
896 :     $peg_to_level{$temp[0]} = $temp[1];
897 :     }
898 : mkubal 1.156 }
899 : mkubal 1.165
900 : mkubal 1.156 my $diagram_html_file = $ss_obj->get_diagram_html_file("d01");
901 :     open(IN2, $diagram_html_file);
902 : mkubal 1.165 open(OUT2,">$FIG_Config::temp/painted_diagram.html");
903 : redwards 1.108
904 : mkubal 1.156 my %role_to_coords;
905 :    
906 :     while ($_ = <IN2>){
907 :     chomp($_);
908 :     my @temp = split("<AREA SHAPE",$_);
909 :     foreach my $t (@temp){
910 :    
911 :     if( $t =~/COORDS=\"(\d+,\d+,\d+,\d+)\".*Role=\"(\w+)\"/){
912 :     $role_to_coords{$2} = $1;
913 :     }
914 :     }
915 :     }
916 : redwards 1.108
917 : mkubal 1.156 print OUT2 "<HTML><HEAD>
918 :     <TITLE>microarray data painted on subsystem diagram</TITLE>
919 : mkubal 1.165 </HEAD>";
920 :    
921 :     print OUT2 "<BODY><MAP NAME='painted_diagram'>";
922 :    
923 : mkubal 1.156 my @roles = keys(%role_to_coords);
924 :     my $color;
925 :     foreach my $role (@roles){
926 : mkubal 1.165 my $temp = $role_to_coords{$role};
927 :     my @coords = split(",",$temp);
928 : mkubal 1.156 my @pegs = $ss_obj->get_pegs_from_cell($genome_id,$role);
929 :     foreach my $peg (@pegs){
930 :     my $temp = $role_to_coords{$role};
931 :     my @coords = split(",",$temp);
932 : mkubal 1.178 my $top = $coords[1] - 35;
933 : mkubal 1.165 #my $top = $coords[0];
934 : mkubal 1.178 my $left = $coords[0] + 15;
935 : mkubal 1.165 #my $left = $coords[1];
936 :     if($ma_data){
937 :     my $tag = $peg_to_level{$peg};
938 : mkubal 1.178 if($tag < -.99){$color ="#009900" }
939 :     elsif($tag < 1){$color ="#FF0099" }
940 :     #elsif($tag < .50){$color ="#00FF00" }
941 :     #elsif($tag < 2){$color ="#CCFF00" }
942 :     #elsif($tag < 20){$color ="#FF00FF" }
943 :     #elsif($tag < 40){$color ="#FF00CC" }
944 :     #elsif($tag < 80){$color ="#FF0066" }
945 : mkubal 1.165 elsif($tag < 100){$color ="#FF0033" }
946 :     else{$color ="#FF0000" }
947 :     print OUT2 "<h5 STYLE='position: absolute; top:$top; left:$left'><font Color='$color'>$tag</font></h5>\n";
948 :     }
949 :     # else{
950 :     # my @rets = $fig->get_attributes($peg,$attribute);
951 :     # foreach my $ret (@rets){
952 :     # my($p,$t,$value,$l) = @$ret;
953 :     # #print STDERR "value:$value\n";
954 :     # print OUT2 "<h5 STYLE='position: absolute; top:$top; left:$left'><font Color='$color'>$value</font></h5>\n";
955 :     # }
956 :     # }
957 :     }
958 : mkubal 1.156 }
959 : mkubal 1.165
960 :     my $jpg_file = "$FIG_Config::data/Subsystems/$ss_name/diagrams/d01/diagram.jpg";
961 :     system "cp $jpg_file $FIG_Config::temp/painted_diagram.jpg";
962 : mkubal 1.156
963 : mkubal 1.165 my $width;
964 :     my $height;
965 :    
966 :     if($cgi->param('image_file_width')){
967 :     $width = $cgi->param('image_file_width');
968 :     $height = $cgi->param('image_file_height');
969 :     }
970 : mkubal 1.156
971 : mkubal 1.165 print OUT2 "</MAP><IMG SRC='painted_diagram.jpg' WIDTH='$width' HEIGHT='$height' USEMAP='#painted_diagram' BORDER='0'></BODY></HTML>";
972 : mkubal 1.156 }
973 : redwards 1.108
974 :     sub manage_subsystems {
975 : overbeek 1.1 my($fig,$cgi,$html) = @_;
976 :     my($set,$when,$comment);
977 :    
978 : redwards 1.108 my $ss_to_manage=$cgi->param('manage'); # we will only display a subset of subsystems on the old SS page
979 :     if ($ss_to_manage eq "mine") {$ss_to_manage=$user}
980 :    
981 : overbeek 1.51 my @ssa = &existing_subsystem_annotations($fig);
982 : overbeek 1.112 # RAE comment out the next line to hide selection
983 :     $ss_to_manage && (@ssa=grep {$_->[1] eq $ss_to_manage} @ssa); # limit the set if we want to
984 : overbeek 1.1
985 :     if (@ssa > 0)
986 :     {
987 : parrello 1.127 &format_ssa_table($cgi,$html,$user,\@ssa);
988 : overbeek 1.1 }
989 :    
990 :     my $target = "window$$";
991 :     push(@$html, $cgi->h1('To Start or Copy a Subsystem'),
992 :     $cgi->start_form(-action => "subsys.cgi",
993 : parrello 1.127 -target => $target,
994 :     -method => 'post'),
995 :     $cgi->hidden(-name => 'user', -value => $user, -override => 1),
996 :     $cgi->hidden(-name => 'request', -value => 'new_ssa', -override => 1),
997 :     "Name of New Subsystem: ",
998 :     $cgi->textfield(-name => "ssa_name", -size => 50),
999 :     $cgi->hidden(-name => 'can_alter', -value => 1, -override => 1),
1000 :     $cgi->br,
1001 :    
1002 :     "Copy from (leave blank to start from scratch): ",
1003 :     $cgi->textfield(-name => "copy_from1", -size => 50),
1004 :     $cgi->br,
1005 :    
1006 :     "Copy from (leave blank to start from scratch): ",
1007 :     $cgi->textfield(-name => "copy_from2", -size => 50),
1008 :     $cgi->br,
1009 :    
1010 :     "Rename an existing subsystem: ",
1011 :     $cgi->textfield(-name => "move_from", -size => 50),
1012 :     $cgi->br,
1013 :    
1014 :     $cgi->submit('start new subsystem'),
1015 :     $cgi->end_form,
1016 :     "<br>You can start a subsystem from scratch, in which case you should leave these two \"copy from\"
1017 : overbeek 1.1 fields blank. If you wish to just copy a subsystem (in order to become the owner so that you can modify it),
1018 :     just fill in one of the \"copy from\" fields with the name of the subsystem you wish to copy. If you wish to
1019 :     extract a a subset of the columns to build a smaller spreadsheet (which could later be merged with another one),
1020 :     fill in the name of the subsystem. You will be prompted for the columns that you wish to extract (choose <i>all</i> to
1021 :     just copy all of the columns). Finally, if you wish to build a new spreadsheet by including columns from two existing
1022 :     spreadsheets (including a complete merger), fill in the names of both the existing \"copy from\" subsystems"
1023 : parrello 1.127 );
1024 :     }
1025 : overbeek 1.1
1026 :     sub new_ssa {
1027 :     my($fig,$cgi,$html) = @_;
1028 :    
1029 : redwards 1.82 my $name = $fig->clean_spaces($cgi->param('ssa_name')); # RAE remove extraneous spaces in the name
1030 : overbeek 1.1
1031 :     if (! $user)
1032 :     {
1033 : parrello 1.127 push(@$html,$cgi->h1('You need to specify a user before starting a new subsystem annotation'));
1034 :     return;
1035 : overbeek 1.1 }
1036 :    
1037 :     if (! $name)
1038 :     {
1039 : parrello 1.127 push(@$html,$cgi->h1("You need to specify a subsystem name, $name is not valid"));
1040 :     return;
1041 : overbeek 1.1 }
1042 :    
1043 :     my $ssa = $name;
1044 :     $ssa =~ s/[ \/]/_/g;
1045 :    
1046 :     &FIG::verify_dir("$FIG_Config::data/Subsystems");
1047 :    
1048 :     if (-d "$FIG_Config::data/Subsystems/$ssa")
1049 :     {
1050 : parrello 1.127 push(@$html,$cgi->h1("You need to specify a new subsystem name; $ssa already is being used"));
1051 :     return;
1052 : overbeek 1.1 }
1053 :    
1054 :     my $subsystem = new Subsystem($ssa,$fig,1); # create new subsystem
1055 :    
1056 :     my $copy_from1 = $cgi->param('copy_from1');
1057 :     $copy_from1 =~ s/[ \/]/_/g;
1058 :     my $copy_from2 = $cgi->param('copy_from2');
1059 :     $copy_from2 =~ s/[ \/]/_/g;
1060 :     my @cols_to_take1 = $cgi->param('cols_to_take1');
1061 :     my @cols_to_take2 = $cgi->param('cols_to_take2');
1062 :    
1063 :    
1064 :     if ($copy_from1 && (@cols_to_take1 > 0))
1065 :     {
1066 : parrello 1.127 $subsystem->add_to_subsystem($copy_from1,\@cols_to_take1,"take notes"); # add columns and notes
1067 : overbeek 1.1 }
1068 :    
1069 :     if ($copy_from2 && (@cols_to_take2 > 0))
1070 :     {
1071 : parrello 1.127 $subsystem->add_to_subsystem($copy_from2,\@cols_to_take2,"take notes"); # add columns and notes
1072 : overbeek 1.1 }
1073 :    
1074 : olson 1.120 $subsystem->db_sync();
1075 : overbeek 1.1 $subsystem->write_subsystem();
1076 :    
1077 : redwards 1.82 $cgi->param(-name => "ssa_name",
1078 : parrello 1.127 -value => $ssa); # RAE this line was needed because otherwise a newly created subsystem was not opened!
1079 : redwards 1.82 $cgi->param(-name => "can_alter",
1080 : parrello 1.127 -value => 1);
1081 : overbeek 1.1 &one_cycle($fig,$cgi,$html);
1082 :     }
1083 :    
1084 :     # The basic update logic (cycle) includes the following steps:
1085 :     #
1086 :     # 1. Load the existing spreadsheet
1087 :     # 2. reconcile row and subset changes
1088 : overbeek 1.9 # 3. process spreadsheet changes (fill/refill/add genomes/update variants)
1089 : overbeek 1.1 # 4. write the updated spreadsheet back to disk
1090 :     # 5. render the spreadsheet
1091 :     #
1092 :     sub one_cycle {
1093 :     my($fig,$cgi,$html) = @_;
1094 : overbeek 1.57 my $subsystem;
1095 : overbeek 1.1
1096 :     my $ssa = $cgi->param('ssa_name');
1097 :    
1098 : overbeek 1.57 if ((! $ssa) || (! ($subsystem = new Subsystem($ssa,$fig,0))))
1099 : overbeek 1.1 {
1100 : parrello 1.127 push(@$html,$cgi->h1('You need to specify a subsystem'));
1101 :     return;
1102 : overbeek 1.1 }
1103 : olson 1.109
1104 :     #
1105 :     # Initialize can_alter if it is not set.
1106 :     #
1107 :    
1108 :     my $can_alter = $cgi->param("can_alter");
1109 :     if (!defined($can_alter))
1110 :     {
1111 : parrello 1.127 if ($user and ($user eq $subsystem->get_curator))
1112 :     {
1113 :     $can_alter = 1;
1114 :     $cgi->param(-name => 'can_alter', -value => 1);
1115 :     }
1116 : olson 1.109 }
1117 : overbeek 1.115
1118 :     #
1119 :     # If we're not the curator, force the active subsets to All.
1120 :     #
1121 :    
1122 :     if (not $can_alter)
1123 :     {
1124 : parrello 1.127 $subsystem->set_active_subsetC("All");
1125 :     $subsystem->set_active_subsetR("All");
1126 : overbeek 1.115 }
1127 : olson 1.104
1128 : redwards 1.121 if ($cgi->param('can_alter') && $user && ($user eq $subsystem->get_curator))
1129 : olson 1.104 {
1130 : parrello 1.127 handle_diagram_changes($fig, $subsystem, $cgi, $html);
1131 : olson 1.104 }
1132 : overbeek 1.1
1133 :     if (&handle_role_and_subset_changes($fig,$subsystem,$cgi,$html))
1134 :     {
1135 : parrello 1.127 &process_spreadsheet_changes($fig,$subsystem,$cgi,$html);
1136 : overbeek 1.10
1137 : parrello 1.127 if ($cgi->param('can_alter') && $user && ($user eq $subsystem->get_curator))
1138 :     {
1139 :     $subsystem->write_subsystem();
1140 :     # RAE: Adding a call to HTML.pm to write the changes to the RSS feed. Not 100% sure we want to do this
1141 :     # everytime we write a SS, but we'll see
1142 :    
1143 :     # note in the RSS we want a barebones link because anyone can access it.
1144 :     my $esc_ssa=uri_escape($ssa);
1145 :     my $url = &FIG::cgi_url . "/subsys.cgi?user=&ssa_name=$esc_ssa&request=show_ssa";
1146 :    
1147 :     &HTML::rss_feed(
1148 :     ["SEEDsubsystems.rss"],
1149 :     {
1150 :     "title" => "Updated $ssa",
1151 :     "description" => "$ssa was updated with some changes, and saved",
1152 :     "link" => $url,
1153 :     });
1154 :     }
1155 :    
1156 :     my $col;
1157 :     if ($cgi->param('show_sequences_in_column') &&
1158 :     ($col = $cgi->param('col_to_align')) &&
1159 :     ($col =~ /^\s*(\d+)\s*$/))
1160 :     {
1161 :     &show_sequences_in_column($fig,$cgi,$html,$subsystem,$col);
1162 :     }
1163 :     else
1164 :     {
1165 :     if ($cgi->param('align_column') &&
1166 :     ($col = $cgi->param('col_to_align')) && ($col =~ /^\s*(\d+)\s*$/))
1167 :     {
1168 :     my $col = $1;
1169 :     &align_column($fig,$cgi,$html,$col,$subsystem);
1170 :     $cgi->delete('col_to_align');
1171 :     }
1172 :     elsif ($cgi->param('realign_column') &&
1173 :     ($col = $cgi->param('subcol_to_realign')) && ($col =~ /^\s*(\d+)\.(\d+)\s*$/))
1174 :     {
1175 :     &align_subcolumn($fig,$cgi,$html,$1,$2,$subsystem);
1176 :     $cgi->delete('subcol_to_realign');
1177 :     }
1178 :     &produce_html_to_display_subsystem($fig,$subsystem,$cgi,$html,$ssa);
1179 :     }
1180 : overbeek 1.1 }
1181 :     }
1182 :    
1183 :     sub handle_role_and_subset_changes {
1184 :     my($fig,$subsystem,$cgi,$html) = @_;
1185 :    
1186 : redwards 1.121 if ((! $cgi->param('can_alter')) || (!$user) || ($user ne $subsystem->get_curator))
1187 : overbeek 1.1 {
1188 : parrello 1.127 return 1; # no changes, so...
1189 : overbeek 1.1 }
1190 :     else
1191 :     {
1192 : parrello 1.127 my @roles = $subsystem->get_roles;
1193 :     my($rparm,$vparm);
1194 :     foreach $rparm (grep { $_ =~ /^react\d+/ } $cgi->param)
1195 :     {
1196 :     if ($vparm = $cgi->param($rparm))
1197 :     {
1198 :     $vparm =~ s/ //g;
1199 :     $rparm =~ /^react(\d+)/;
1200 :     my $roleN = $1 - 1;
1201 :     $subsystem->set_reaction($roles[$roleN],$vparm);
1202 :     }
1203 :     }
1204 : overbeek 1.97
1205 : olson 1.206 foreach $rparm (grep { $_ =~ /^hopeReact\d+/ } $cgi->param)
1206 :     {
1207 :     if ($vparm = $cgi->param($rparm))
1208 :     {
1209 :     $vparm =~ s/ /,/g;
1210 :     $vparm =~ s/,+/,/g;
1211 :     $rparm =~ /^hopeReact(\d+)/;
1212 :     my $roleN = $1 - 1;
1213 :     $subsystem->set_hope_reaction($roles[$roleN],$vparm);
1214 :     }
1215 :     }
1216 :    
1217 :     foreach $rparm (grep { $_ =~ /^hopeNote\d+/ } $cgi->param)
1218 :     {
1219 :     if ($vparm = $cgi->param($rparm))
1220 :     {
1221 :     $vparm =~ s/\t/ /g;
1222 :     $rparm =~ /^hopeNote(\d+)/;
1223 :     my $roleN = $1 - 1;
1224 :     $subsystem->set_hope_reaction_note($roles[$roleN],$vparm);
1225 :     }
1226 :     }
1227 :    
1228 : parrello 1.127 my($role,$p,$abr,$r,$n);
1229 :     my @tuplesR = ();
1230 : overbeek 1.97
1231 : overbeek 1.182 ### NOTE: the meaning (order) of @roles shifts here to the NEW order
1232 : parrello 1.127 @roles = grep { $_ =~ /^role/ } $cgi->param();
1233 :     if (@roles == 0) { return 1 } # initial call, everything is as it was
1234 :    
1235 :     foreach $role (@roles)
1236 :     {
1237 :     if (($role =~ /^role(\d+)/) && defined($n = $1))
1238 :     {
1239 :     if ($r = $cgi->param("role$n"))
1240 :     {
1241 :     $r =~ s/^\s+//;
1242 :     $r =~ s/\s+$//;
1243 :    
1244 :     if (($p = $cgi->param("posR$n")) && ($abr = $cgi->param("abbrev$n")))
1245 :     {
1246 : overbeek 1.182 push(@tuplesR,[$p,$r,$abr,$n]);
1247 : parrello 1.127 }
1248 :     else
1249 :     {
1250 :     push(@$html,$cgi->h1("You need to give a position and abbreviation for $r"));
1251 :     return 0;
1252 :     }
1253 :     }
1254 :     }
1255 :     }
1256 :     @tuplesR = sort { $a->[0] <=> $b->[0] } @tuplesR;
1257 : overbeek 1.182
1258 : parrello 1.127 $subsystem->set_roles([map { [$_->[1],$_->[2]] } @tuplesR]);
1259 :    
1260 :     my($subset_name,$s,$test,$entries,$entry);
1261 :     my @subset_names = grep { $_ =~ /^nameCS/ } $cgi->param();
1262 :    
1263 :     if (@subset_names == 0) { return 1 }
1264 :    
1265 :     my %defined_subsetsC;
1266 :     foreach $s (@subset_names)
1267 :     {
1268 :     if (($s =~ /^nameCS(\d+)/) && defined($n = $1) && ($subset_name = $cgi->param($s)))
1269 :     {
1270 :    
1271 :     my($text);
1272 :     $entries = [];
1273 :     if ($text = $cgi->param("subsetC$n"))
1274 :     {
1275 :     foreach $entry (split(/[\s,]+/,$text))
1276 :     {
1277 :     if ($role = &to_role($entry,\@tuplesR))
1278 :     {
1279 :     push(@$entries,$role);
1280 :     }
1281 :     else
1282 :     {
1283 :     push(@$html,$cgi->h1("Invalid role designation in subset $s: $entry"));
1284 :     return 0;
1285 :     }
1286 :     }
1287 :     }
1288 :     $defined_subsetsC{$subset_name} = $entries;
1289 :     }
1290 :     }
1291 :    
1292 :     foreach $s ($subsystem->get_subset_namesC)
1293 :     {
1294 :     next if ($s eq "All");
1295 :     if ($entries = $defined_subsetsC{$s})
1296 :     {
1297 :     $subsystem->set_subsetC($s,$entries);
1298 :     delete $defined_subsetsC{$s};
1299 :     }
1300 :     else
1301 :     {
1302 :     $subsystem->delete_subsetC($s);
1303 :     }
1304 :     }
1305 : overbeek 1.1
1306 : parrello 1.127 foreach $s (keys(%defined_subsetsC))
1307 :     {
1308 :     $subsystem->set_subsetC($s,$defined_subsetsC{$s});
1309 :     }
1310 :    
1311 :     my $active_subsetC;
1312 :     if ($active_subsetC = $cgi->param('active_subsetC'))
1313 :     {
1314 :     $subsystem->set_active_subsetC($active_subsetC);
1315 :     }
1316 : overbeek 1.1 }
1317 :     return 1;
1318 :     }
1319 :    
1320 :     sub to_role {
1321 :     my($x,$role_tuples) = @_;
1322 :     my $i;
1323 :    
1324 :     for ($i=0; ($i < @$role_tuples) &&
1325 : overbeek 1.182 ($role_tuples->[$i]->[3] != $x) &&
1326 :     ($role_tuples->[$i]->[2] ne $x); $i++) {}
1327 : overbeek 1.1 if ($i < @$role_tuples)
1328 :     {
1329 : parrello 1.127 return $role_tuples->[$i]->[1];
1330 : overbeek 1.1 }
1331 :     return undef;
1332 :     }
1333 :    
1334 :     sub process_spreadsheet_changes {
1335 :     my($fig,$subsystem,$cgi,$html) = @_;
1336 :    
1337 : redwards 1.121 if ((! $cgi->param('can_alter')) || (!$user) || ($user ne $subsystem->get_curator))
1338 : overbeek 1.1 {
1339 : parrello 1.127 return 1; # no changes, so...
1340 : overbeek 1.1 }
1341 :     else
1342 :     {
1343 : olson 1.206 my @hope_scenario_names = $subsystem->get_hope_scenario_names;
1344 :    
1345 :     foreach my $scenario_name (@hope_scenario_names)
1346 :     {
1347 :     my $inputcpd = $cgi->param($scenario_name.'_InputCompounds');
1348 :     if($inputcpd ne "")
1349 :     {
1350 :     $subsystem->set_hope_input_compounds($scenario_name, $inputcpd);
1351 :     }
1352 :     my $outputcpd = $cgi->param($scenario_name.'_OutputCompounds');
1353 :     if($outputcpd ne "")
1354 :     {
1355 :     $subsystem->set_hope_output_compounds($scenario_name, $outputcpd);
1356 :     }
1357 :     my $mapIDs = $cgi->param($scenario_name.'_MapIDs');
1358 :     if($mapIDs ne "")
1359 :     {
1360 :     $subsystem->set_hope_map_ids($scenario_name, $mapIDs);
1361 :     }
1362 :     my $addRxns = $cgi->param($scenario_name.'_AddRxns');
1363 :     if($addRxns ne "")
1364 :     {
1365 :     $subsystem->set_hope_additional_reactions($scenario_name, $addRxns);
1366 :     }
1367 :     my $ignoreRxns = $cgi->param($scenario_name.'_IgnoreRxns');
1368 :     if($ignoreRxns ne "")
1369 :     {
1370 :     $subsystem->set_hope_ignore_reactions($scenario_name, $ignoreRxns);
1371 :     }
1372 :     my $new_name = $cgi->param($scenario_name."_Name");
1373 :     if ($new_name ne "")
1374 :     {
1375 :     $new_name =~ s/\//_/g;
1376 :     $new_name =~ s/\,/_/g;
1377 :     $new_name =~ s/ /_/g;
1378 :     $new_name =~ s/-/_/g;
1379 :     $subsystem->change_hope_scenario_name($scenario_name, $new_name);
1380 :     }
1381 :     if ($cgi->param($scenario_name."_Delete"))
1382 :     {
1383 :     $subsystem->delete_hope_scenario($scenario_name);
1384 :     }
1385 :     }
1386 :     my $new_name = $cgi->param("newscenario_Name");
1387 :     if ($new_name ne "")
1388 :     {
1389 :     $new_name =~ s/\//_/g;
1390 :     $new_name =~ s/\,/_/g;
1391 :     $new_name =~ s/ /_/g;
1392 :     $new_name =~ s/-/_/g;
1393 :     $subsystem->add_hope_scenario($new_name);
1394 :     }
1395 :    
1396 : parrello 1.127 my $notes = $cgi->param('notes');
1397 :     if ($notes)
1398 :     {
1399 :     $subsystem->set_notes($notes);
1400 :     }
1401 : bartels 1.212
1402 :     ## as description and notes are now separate, I (DB) put in this for description
1403 :     my $description = $cgi->param('description');
1404 :     if ($description)
1405 :     {
1406 :     $subsystem->set_description($description);
1407 :     }
1408 :     ## end of added code
1409 :    
1410 : olson 1.206 my $hope_curation_notes = $cgi->param('hope_curation_notes');
1411 :     if ($hope_curation_notes)
1412 :     {
1413 :     $subsystem->set_hope_curation_notes($hope_curation_notes);
1414 :     }
1415 : parrello 1.127 if ($cgi->param('classif1t') || $cgi->param('classif2t'))
1416 :     {
1417 :     $subsystem->set_classification([$cgi->param('classif1t'), $cgi->param('classif2t')]);
1418 :     }
1419 :     elsif ($cgi->param('classif1') || $cgi->param('classif2'))
1420 :     {
1421 :     $subsystem->set_classification([$cgi->param('classif1'), $cgi->param('classif2')]);
1422 :     }
1423 :    
1424 :     my(@param,$param,$genome,$val);
1425 :     @param = grep { $_ =~ /^genome\d+\.\d+$/ } $cgi->param;
1426 :    
1427 :     my %removed;
1428 :     foreach $param (@param)
1429 :     {
1430 :     if ($cgi->param($param) =~ /^\s*$/)
1431 :     {
1432 :     $param =~ /^genome(\d+\.\d+)/;
1433 :     $genome = $1;
1434 :     $subsystem->remove_genome($genome);
1435 :     $removed{$genome} = 1;
1436 :     }
1437 :     }
1438 :    
1439 :     @param = grep { $_ =~ /^vcode\d+\.\d+$/ } $cgi->param;
1440 :     foreach $param (@param)
1441 :     {
1442 :     if ($cgi->param($param) =~ /^\s*(\S+)\s*$/)
1443 :     {
1444 :     $val = $1;
1445 :     $param =~ /^vcode(\d+\.\d+)/;
1446 :     $genome = $1;
1447 :     if (! $removed{$genome})
1448 :     {
1449 :     $subsystem->set_variant_code($subsystem->get_genome_index($genome),$val);
1450 :     }
1451 :     }
1452 :     }
1453 :    
1454 :     if ($cgi->param('refill'))
1455 :     {
1456 :     &refill_spreadsheet($fig,$subsystem);
1457 :     }
1458 :     elsif ($cgi->param('precise_fill'))
1459 :     {
1460 :     &fill_empty_cells($fig,$subsystem);
1461 :     }
1462 :    
1463 :     my @orgs = $cgi->param('new_genome');
1464 :     @orgs = map { $_ =~ /\((\d+\.\d+)\)/; $1 } @orgs;
1465 :    
1466 : overbeek 1.136 # RAE: Add organisms to extend with from checkboxes
1467 :     # moregenomes takes either a specifically encoded list like phylogeny, a file that must be present in the organisms dir (e.g. COMPLETE or NMPDR)
1468 :     # or a set of attributes
1469 : overbeek 1.147 if ($cgi->param('moregenomes')) {push @orgs, &moregenomes}
1470 :    
1471 : overbeek 1.136
1472 :     # flatten the list so we don't add more than we need to
1473 :     {
1474 :     my %flatlist=map {($_=>1)} @orgs;
1475 :     @orgs=keys %flatlist;
1476 :     }
1477 :    
1478 : parrello 1.127 my $org;
1479 :     foreach $org (@orgs)
1480 :     {
1481 :     &add_genome($fig,$subsystem,$cgi,$html,$org);
1482 :     }
1483 :    
1484 :     my $active_subsetR;
1485 :     if ($active_subsetR = $cgi->param('active_subsetR'))
1486 :     {
1487 :     $subsystem->set_active_subsetR($active_subsetR);
1488 :     }
1489 : overbeek 1.1 }
1490 :     }
1491 :    
1492 :     sub refill_spreadsheet {
1493 :     my($fig,$subsystem) = @_;
1494 : overbeek 1.5 my($genome,$role,@pegs1,@pegs2,$i);
1495 : overbeek 1.1
1496 :     foreach $genome ($subsystem->get_genomes())
1497 :     {
1498 : parrello 1.127 foreach $role ($subsystem->get_roles())
1499 :     {
1500 :     @pegs1 = sort $subsystem->get_pegs_from_cell($genome,$role);
1501 :     @pegs2 = sort $fig->seqs_with_role($role,"master",$genome);
1502 :    
1503 :     if (@pegs1 != @pegs2)
1504 :     {
1505 :     $subsystem->set_pegs_in_cell($genome,$role,\@pegs2);
1506 :     }
1507 :     else
1508 :     {
1509 :     for ($i=0; ($i < @pegs1) && ($pegs1[$i] eq $pegs2[$i]); $i++) {}
1510 :     if ($i < @pegs1)
1511 :     {
1512 :     $subsystem->set_pegs_in_cell($genome,$role,\@pegs2);
1513 :     }
1514 :     }
1515 :     }
1516 : overbeek 1.1 }
1517 :     }
1518 :    
1519 :     sub fill_empty_cells {
1520 :     my($fig,$subsystem) = @_;
1521 :     my($genome,$role,@pegs);
1522 :    
1523 :     foreach $genome ($subsystem->get_genomes())
1524 :     {
1525 : parrello 1.127 foreach $role ($subsystem->get_roles())
1526 :     {
1527 :     @pegs = $subsystem->get_pegs_from_cell($genome,$role);
1528 :     if (@pegs == 0)
1529 :     {
1530 :     @pegs = $fig->seqs_with_role($role,"master",$genome);
1531 :     if (@pegs > 0)
1532 :     {
1533 :     $subsystem->set_pegs_in_cell($genome,$role,\@pegs);
1534 :     }
1535 :     }
1536 :     }
1537 : overbeek 1.1 }
1538 :     }
1539 :    
1540 :     sub add_genome {
1541 :     my($fig,$subsystem,$cgi,$html,$genome) = @_;
1542 :     my($role,@pegs);
1543 :    
1544 :     $subsystem->add_genome($genome);
1545 :     foreach $role ($subsystem->get_roles())
1546 :     {
1547 : parrello 1.127 @pegs = $fig->seqs_with_role($role,"master",$genome);
1548 :     $subsystem->set_pegs_in_cell($genome,$role,\@pegs);
1549 : overbeek 1.1 }
1550 :     }
1551 :    
1552 :     sub produce_html_to_display_subsystem {
1553 : overbeek 1.20 my($fig,$subsystem,$cgi,$html,$ssa) = @_;
1554 : overbeek 1.1
1555 :     my $ssa = $cgi->param('ssa_name');
1556 : bartels 1.213 my $compuser = $user;
1557 :     $compuser =~ s/master\://g;
1558 :     my $curateuser = $subsystem->get_curator;
1559 :     $curateuser =~ s/master\://g;
1560 :    
1561 :     my $can_alter = ($cgi->param('can_alter') && $user && ($compuser eq $curateuser));
1562 :    
1563 : redwards 1.83 my $tagvalcolor; # RAE: this is a reference to a hash that stores the colors of cells by tag. This has to be consistent over the whole table.
1564 : overbeek 1.1
1565 :     my $name = $ssa;
1566 :     $name =~ s/_/ /g;
1567 :     $ssa =~ s/[ \/]/_/g;
1568 : overbeek 1.154 my $curator = &subsystem_curator($ssa);
1569 :    
1570 : overbeek 1.1 push(@$html, $cgi->h1("Subsystem: $name"),
1571 : overbeek 1.157 $cgi->h1("Author: $curator"));
1572 : dejongh 1.211
1573 : overbeek 1.157 my($t,@spreadsheets);
1574 :     if (opendir(BACKUP,"$FIG_Config::data/Subsystems/$ssa/Backup"))
1575 :     {
1576 :     @spreadsheets = sort { $b <=> $a }
1577 :     map { $_ =~ /^spreadsheet.(\d+)/; $1 }
1578 :     grep { $_ =~ /^spreadsheet/ }
1579 :     readdir(BACKUP);
1580 :     closedir(BACKUP);
1581 :     if ($t = shift @spreadsheets)
1582 :     {
1583 :     my $last_modified = &FIG::epoch_to_readable($t);
1584 :     push(@$html, $cgi->h1("Last modified: $last_modified"));
1585 :     }
1586 :     }
1587 :    
1588 : golsen 1.186 if ( $time_it ) ## time ##
1589 :     { ## time ##
1590 :     push @times, scalar time(); ## time ##
1591 :     push @$html, "<br>dT = @{[$times[-1]-$times[-2]]}, T = @{[$times[-1]-$times[0]]}<br>"; ## time ##
1592 :     } ## time ##
1593 :    
1594 : overbeek 1.157 push(@$html, $cgi->start_form(-action => "subsys.cgi",
1595 : parrello 1.127 -method => 'post',
1596 : olson 1.206 -name => 'MainForm',
1597 : parrello 1.127 -enctype => &CGI::MULTIPART),
1598 :     $cgi->hidden(-name => 'user', -value => $user, -override => 1),
1599 :     $cgi->hidden(-name => 'request', -value => 'show_ssa', -override => 1),
1600 :     $cgi->hidden(-name => 'can_alter', -value => $can_alter, -override => 1),
1601 :     $cgi->hidden(-name => 'ssa_name', -value => $name, -override => 1),
1602 :     $cgi->br,
1603 :     );
1604 : overbeek 1.1
1605 : redwards 1.25 # RAE: First, a sanity check.
1606 :     # We may have to move this a little earlier, and show probably throw some nicer
1607 :     # errors to the end user (.e.g try setting can_alter and choosing an illegitimate ss
1608 :     # Do we know about this subsystem:
1609 : overbeek 1.26 my $ssaQ = quotemeta $ssa;
1610 : overbeek 1.124
1611 :     if (! -d "$FIG_Config::data/Subsystems/$ssa")
1612 :     ###### unless (grep {/$ssaQ/} map {$_->[0]} &existing_subsystem_annotations($fig))
1613 : redwards 1.25 {
1614 :     # No, we don't know about this subsystem
1615 :     my $url = &FIG::cgi_url . "/subsys.cgi?user=$user";
1616 :     push @$html, "Sorry. $name is not a valid subsystem. <p>\n",
1617 :     "Please return to the <a href=\"$url\">Subsystems Page</a> and choose an exisiting subsystem. <p>\n",
1618 :     "Sorry.";
1619 :     return undef;
1620 :     }
1621 :    
1622 : olson 1.109 &format_js_data($fig,$cgi,$html,$subsystem,$can_alter);
1623 : redwards 1.25
1624 : overbeek 1.14 &format_roles($fig,$cgi,$html,$subsystem,$can_alter);
1625 :     &format_subsets($fig,$cgi,$html,$subsystem,$can_alter);
1626 : olson 1.18
1627 : overbeek 1.115
1628 :     my $have_diagrams = &format_diagrams($fig, $cgi, $html, $subsystem, $can_alter);
1629 : olson 1.104
1630 :     #
1631 : olson 1.18 # Put link into constructs tool.
1632 :     #
1633 :    
1634 :     if ($can_alter)
1635 :     {
1636 : olson 1.195 my $esc_ssa = uri_escape($ssa);
1637 : parrello 1.127 push(@$html, $cgi->p,
1638 : olson 1.195 $cgi->a({href => "construct.cgi?ssa=$esc_ssa&user=$user",
1639 : parrello 1.127 target => "_blank"},
1640 :     "Define higher level constructs."),
1641 : redwards 1.217 $cgi->p,
1642 :     $cgi->a({href => "set_variants.cgi?subsystem=$esc_ssa&user=$user&request=show_variants"},
1643 :     "Set subsystem variants."),
1644 :     );
1645 :    
1646 :    
1647 : olson 1.18 }
1648 :    
1649 :    
1650 : golsen 1.91 # Display the subsystem table rows, saving the list genomes displayed
1651 : olson 1.18
1652 : overbeek 1.115 my $active_genome_list = &format_rows($fig,$cgi,$html,$subsystem, $tagvalcolor,$have_diagrams);
1653 : redwards 1.64
1654 : golsen 1.91
1655 :     if ( $can_alter ) { format_extend_with($fig,$cgi,$html,$subsystem) }
1656 : golsen 1.73
1657 : golsen 1.75 my $esc_ssa = uri_escape( $ssa );
1658 : golsen 1.73 push @$html, "<TABLE width=\"100%\">\n",
1659 :     " <TR>\n",
1660 :     ($can_alter) ? " <TD>" . $cgi->checkbox(-name => 'precise_fill', -value => 1, -checked => 0, -override => 1,-label => 'fill') . "</TD>\n" : (),
1661 : parrello 1.127 " <TD><a href=\"Html/conflict_resolution.html\" class=\"help\" target=\"help\">Help on conflict resolution</a></TD>\n",
1662 :     " <TD><a href=\"Html/seedtips.html#edit_variants\" class=\"help\" target=\"help\">Help on editing variants</a></TD>\n",
1663 : redwards 1.198 " <TD><a href=\"Html/seedtips.html#make_trees\" class=\"help\" target=\"help\">Help on making trees</a></td>\n",
1664 : parrello 1.127 " <TD><a href=\"ss_export.cgi?user=$user&ssa_name=$esc_ssa\" class=\"help\">Export subsystem data</a></TD>\n",
1665 : golsen 1.73 " </TR>\n",
1666 :     "</TABLE>\n";
1667 : redwards 1.64
1668 :     if ($can_alter)
1669 :     {
1670 : overbeek 1.180 push(@$html,$cgi->submit('update spreadsheet')," OR ");
1671 : overbeek 1.1 }
1672 :     else
1673 :     {
1674 : parrello 1.127 push(@$html,$cgi->br);
1675 :     push(@$html,$cgi->submit('show spreadsheet'),$cgi->br);
1676 : overbeek 1.1 }
1677 : overbeek 1.134
1678 :    
1679 : redwards 1.24 push(@$html,$cgi->checkbox(-name => 'ignore_alt', -value => 1, -override => 1, -label => 'ignore alternatives', -checked => ($cgi->param('ignore_alt'))),$cgi->br);
1680 : overbeek 1.17 push(@$html,$cgi->checkbox(-name => 'ext_ids', -value => 1, -checked => 0, -label => 'use external ids'),$cgi->br);
1681 : redwards 1.121 push(@$html,$cgi->checkbox(-name => 'show_clusters', -value => 1, -label => 'show clusters'),$cgi->br);
1682 : golsen 1.186
1683 :     my @options = ();
1684 :     @options = sort {uc($a) cmp uc($b)} $fig->get_genome_keys(); # get all the genome keys
1685 : redwards 1.52 unshift(@options, undef); # a blank field at the start
1686 : redwards 1.54 push(@$html,"color rows by each organism's attribute: &nbsp; ", $cgi->popup_menu(-name => 'color_by_ga', -values=>\@options), $cgi->br);
1687 :    
1688 : golsen 1.186 # Compile and order the attribute keys found on pegs:
1689 :    
1690 :     my $high_priority = qr/(essential|fitness)/i;
1691 :     @options = sort { $b =~ /$high_priority/o <=> $a =~ /$high_priority/o
1692 :     || uc($a) cmp uc($b)
1693 :     }
1694 :     $fig->get_peg_keys();
1695 :     unshift @options, undef; # Start list with empty
1696 :    
1697 :     push( @$html, "color columns by each PEGs attribute: &nbsp; ",
1698 :     $cgi->popup_menu(-name => 'color_by_peg_tag', -values=>\@options),
1699 :     $cgi->br
1700 :     );
1701 :    
1702 :     if ( $time_it ) ## time ##
1703 :     { ## time ##
1704 :     push @times, scalar time(); ## time ##
1705 :     push @$html, "<br>dT = @{[$times[-1]-$times[-2]]}, T = @{[$times[-1]-$times[0]]}<br>"; ## time ##
1706 :     } ## time ##
1707 : mkubal 1.173
1708 : golsen 1.91 push @$html, $cgi->checkbox(-name => 'show_missing', -value => 1, -checked => 0, -override => 1,-label => 'show missing'),
1709 :     $cgi->br, $cgi->br;
1710 :    
1711 : overbeek 1.3
1712 : golsen 1.91 # Format the organism list for a pop-up menu:
1713 : overbeek 1.3
1714 : golsen 1.92 my @genomes = sort { lc $a->[1] cmp lc $b->[1] } map { [ $_->[0], "$_->[1] [$_->[0]]" ] } @$active_genome_list;
1715 : golsen 1.91 unshift @genomes, [ '', 'select it in this menu' ];
1716 : mkubal 1.36
1717 : golsen 1.91 # Make a list of index number and roles for pop-up selections:
1718 :    
1719 :     my @roles = map { [ $subsystem->get_role_index( $_ ) + 1, $_ ] } $subsystem->get_roles;
1720 :     unshift @roles, [ '', 'select it in this menu' ];
1721 :    
1722 :     push @$html, "<table><tr><td>",
1723 :     $cgi->checkbox(-name => 'show_missing_including_matches', -value => 1, -checked => 0, -override => 1,-label => 'show missing with matches'), $cgi->br,
1724 : parrello 1.127 $cgi->checkbox(-name => 'show_missing_including_matches_in_ss', -value => 1, -checked => 0, -override => 1,-label => 'show missing with matches in ss'), "&nbsp;&nbsp;",
1725 : golsen 1.93 "</td>\n<td><big><big><big>} {</big></big></big></td>",
1726 : golsen 1.91 "<td>",
1727 : parrello 1.127 "[To restrict to a single genome: ",
1728 : golsen 1.91 $cgi->popup_menu( -name => 'just_genome',
1729 :     -values => [ map { $_->[0] } @genomes ],
1730 :     -labels => { map { ( $_->[0], $_->[1] ) } @genomes }
1731 :     ), "]", $cgi->br,
1732 : parrello 1.127 "[To restrict to a single role: ",
1733 : golsen 1.91 $cgi->popup_menu( -name => 'just_role',
1734 :     -values => [ map { $_->[0] } @roles ],
1735 :     -labels => { map { ( $_->[0], $_->[1] ) } @roles }
1736 :     ),
1737 : parrello 1.127 "]</td></tr></table>\n",
1738 :     $cgi->br;
1739 : golsen 1.91
1740 :    
1741 :     push @$html, "<table><tr><td>",
1742 :     $cgi->checkbox(-name => 'check_assignments', -value => 1, -checked => 0, -override => 1, -label => 'check assignments'),
1743 :     "&nbsp;&nbsp;[", $cgi->checkbox(-name => 'strict_check', -value => 1, -checked => 0, -override => 1, -label => 'strict'), "]&nbsp;&nbsp;",
1744 : golsen 1.93 "</td>\n<td><big><big><big>{</big></big></big></td>",
1745 : golsen 1.91 "<td>",
1746 : parrello 1.127 "[To restrict to a single genome: ",
1747 : golsen 1.91 $cgi->popup_menu( -name => 'just_genome_assignments',
1748 :     -values => [ map { $_->[0] } @genomes ],
1749 :     -labels => { map { ( $_->[0], $_->[1] ) } @genomes }
1750 :     ), "]", $cgi->br,
1751 : parrello 1.127 "[To restrict to a single role: ",
1752 : golsen 1.91 $cgi->popup_menu( -name => 'just_role_assignments',
1753 :     -values => [ map { $_->[0] } @roles ],
1754 :     -labels => { map { ( $_->[0], $_->[1] ) } @roles }
1755 :     ),
1756 : parrello 1.127 "]</td></tr></table>\n",
1757 :     $cgi->br;
1758 : mkubal 1.36
1759 : overbeek 1.3
1760 : golsen 1.186 if ( $time_it ) ## time ##
1761 :     { ## time ##
1762 :     push @times, scalar time(); ## time ##
1763 :     push @$html, "<br>dT = @{[$times[-1]-$times[-2]]}, T = @{[$times[-1]-$times[0]]}<br>"; ## time ##
1764 :     } ## time ##
1765 :    
1766 : overbeek 1.14 if ($can_alter)
1767 :     {
1768 : parrello 1.127 push(@$html,$cgi->checkbox(-name => 'refill', -value => 1, -checked => 0, -override => 1,-label => 'refill spreadsheet from scratch'),$cgi->br);
1769 : overbeek 1.14 }
1770 :    
1771 : overbeek 1.1 push(@$html,$cgi->checkbox(-name => 'show_dups', -value => 1, -checked => 0, -override => 1,-label => 'show duplicates'),$cgi->br);
1772 :     push(@$html,$cgi->checkbox(-name => 'check_problems', -value => 1, -checked => 0, -override => 1,-label => 'show PEGs in roles that do not match precisely'),$cgi->br);
1773 : overbeek 1.14 if ($can_alter)
1774 :     {
1775 : parrello 1.127 push(@$html,$cgi->checkbox(-name => 'add_solid', -value => 1, -checked => 0, -override => 1,-label => 'add genomes with solid hits'),$cgi->br);
1776 : overbeek 1.14 }
1777 :    
1778 : overbeek 1.1 push(@$html,$cgi->checkbox(-name => 'show_coupled_fast', -value => 1, -checked => 0, -override => 1,-label => 'show coupled PEGs fast [depends on existing pins/clusters]'),$cgi->br);
1779 : golsen 1.94
1780 :     push(@$html,$cgi->checkbox(-name => 'show_coupled', -value => 1, -checked => 0, -override => 1,-label => 'show coupled PEGs [figure 2 minutes per PEG in spreadsheet]'),$cgi->br);
1781 :    
1782 : redwards 1.63 # RAE Hide -1 variants
1783 : redwards 1.121 push(@$html,$cgi->checkbox(-name => 'show_minus1', -value=> 1, -label => 'show -1 variants'),$cgi->br);
1784 : golsen 1.94
1785 : overbeek 1.158 # RAE Create excel spreadsheet of tables
1786 : overbeek 1.163 push(@$html, $raelib->excel_file_link, $cgi->checkbox(-name => 'create_excel', -value=> 1, -label => "Create Excel file of tables"), $cgi->br, "\n");
1787 : overbeek 1.158
1788 :    
1789 : golsen 1.94 # Alignment functions:
1790 :    
1791 :     push @$html, $cgi->hr,
1792 : parrello 1.127 # $cgi->br, "Column (specify the number of the column): ",
1793 :     # $cgi->textfield(-name => "col_to_align", -size => 7),
1794 :     "For sequences in a column (i.e., role): ",
1795 : golsen 1.94 $cgi->popup_menu( -name => 'col_to_align',
1796 :     -values => [ map { $_->[0] } @roles ],
1797 :     -labels => { map { ( $_->[0], $_->[1] ) } @roles }
1798 :     ),
1799 : parrello 1.127 $cgi->br,
1800 :     $cgi->submit(-value => "Show Sequences in Column",
1801 :     -name => "show_sequences_in_column"),
1802 :     $cgi->br,
1803 :     $cgi->submit(-value => "Align Sequences in Column",
1804 :     -name => "align_column"),
1805 :     $cgi->br,
1806 :     $cgi->br, "Realign subgroup within a column (adding homologs): ",
1807 :     $cgi->textfield(-name => "subcol_to_realign", -size => 7),
1808 :     $cgi->br, "Include homologs that pass the following threshhold: ",
1809 :     $cgi->textfield(-name => "include_homo", -size => 10)," (leave blank to see just column)",
1810 :     " Max homologous seqs: ",$cgi->textfield(-name => "max_homo", -value => 100, -size => 6),
1811 :     $cgi->br,
1812 :     $cgi->submit(-value => "Realign Sequences in Column",
1813 :     -name => "realign_column"),
1814 :     $cgi->hr;
1815 : golsen 1.94
1816 : golsen 1.186 if ( $time_it ) ## time ##
1817 :     { ## time ##
1818 :     push @times, scalar time(); ## time ##
1819 :     push @$html, "<br>dT = @{[$times[-1]-$times[-2]]}, T = @{[$times[-1]-$times[0]]}<br>"; ## time ##
1820 :     } ## time ##
1821 :    
1822 : redwards 1.22 # RAE: A new function to reannotate a single column
1823 :     # I don't understand how you get CGI.pm to reset (and never have).
1824 :     # $cgi->delete("col_to_annotate"); # this does nothing to my script and there is always the last number in this box
1825 :     #push(@$html, $cgi->br,"Change annotation for column: ", $cgi->textfield(-name => "col_to_annotate", -size => 7));
1826 : hwang 1.204
1827 : redwards 1.22 push(@$html, $cgi->br,"Change annotation for column: ", '<input type="text" name="col_to_annotate" value="" size="7">');
1828 : hwang 1.204 push (@$html, $cgi->hr);
1829 :     push(@$html, $cgi->br,"Curate Literature: ", "<a href=display_subsys.cgi?ssa_name=$ssa> Display Subsys </a>");
1830 : overbeek 1.1 if ($can_alter)
1831 :     {
1832 : parrello 1.127 push(@$html,
1833 : overbeek 1.185 $cgi->p. $cgi->hr,
1834 : parrello 1.127 $cgi->p,
1835 :     $cgi->hr,
1836 :     "You should resynch PEG connections only if you detect PEGs that should be connected to the
1837 : overbeek 1.9 spreadsheet, but do not seem to be. This can only reflect an error in the code. If you find
1838 :     yourself having to use it, send mail to Ross.",
1839 : parrello 1.127 $cgi->br,
1840 :     $cgi->submit(-value => "Resynch PEG Connections",
1841 :     -name => "resynch_peg_connections"),
1842 :     $cgi->br);
1843 : overbeek 1.1 }
1844 : overbeek 1.10
1845 : golsen 1.186 if ( $time_it ) ## time ##
1846 :     { ## time ##
1847 :     push @times, scalar time(); ## time ##
1848 :     push @$html, "<br>dT = @{[$times[-1]-$times[-2]]}, T = @{[$times[-1]-$times[0]]}<br>"; ## time ##
1849 :     } ## time ##
1850 :    
1851 : bartels 1.212 ## as description and notes are now separate, I (DB) put in this for description
1852 :     my $description = $subsystem->get_description();
1853 :     if ($can_alter)
1854 :     {
1855 : bartels 1.213 push(@$html,$cgi->hr,"DESCRIPTION:\n",$cgi->br,$cgi->textarea(-name => 'description', -rows => 30, -cols => 100, -value => $description));
1856 : bartels 1.212 }
1857 :     elsif ($description)
1858 :     {
1859 :     $description =~ s/(.{80}\s+)/$1\n/g;
1860 :     push(@$html,$cgi->h2('Description'),"<pre>$description</pre>");
1861 :     }
1862 :     ## end of added code
1863 :    
1864 : overbeek 1.12 my $notes = $subsystem->get_notes();
1865 : overbeek 1.14 if ($can_alter)
1866 :     {
1867 : bartels 1.212 push(@$html,$cgi->hr,"NOTES:\n",$cgi->br,$cgi->textarea(-name => 'notes', -rows => 30, -cols => 100, -value => $notes));
1868 : overbeek 1.14 }
1869 :     elsif ($notes)
1870 :     {
1871 : overbeek 1.161 $notes =~ s/(.{80}\s+)/$1\n/g;
1872 : bartels 1.212 push(@$html,$cgi->h2('Notes'),"<pre>$notes</pre>");
1873 : overbeek 1.14 }
1874 : bartels 1.212
1875 : olson 1.206 my $hope_curation_notes = $subsystem->get_hope_curation_notes();
1876 :     if ($can_alter)
1877 :     {
1878 :     push(@$html,$cgi->hr,"HOPE CURATION NOTES:\n",$cgi->br,$cgi->textarea(-name => 'hope_curation_notes', -rows => 40, -cols => 100, -value => $hope_curation_notes));
1879 :     }
1880 :     elsif ($hope_curation_notes)
1881 :     {
1882 :     push(@$html,$cgi->h2('hope curation notes'),"<pre width=80>$hope_curation_notes</pre>");
1883 :     }
1884 : overbeek 1.10
1885 : golsen 1.186 if ( $time_it ) ## time ##
1886 :     { ## time ##
1887 :     push @times, scalar time(); ## time ##
1888 :     push @$html, "<br>dT = @{[$times[-1]-$times[-2]]}, T = @{[$times[-1]-$times[0]]}<br>"; ## time ##
1889 :     } ## time ##
1890 :    
1891 : overbeek 1.210 &format_kegg_info($fig,$cgi,$html,$subsystem,$can_alter, $active_genome_list);
1892 :    
1893 : redwards 1.41 # RAE Modified to add a line with the classification
1894 :     my $class=$subsystem->get_classification();
1895 :     if ($can_alter)
1896 :     {
1897 : redwards 1.108 my $menu1; my $menu2; # the two menus for the classification of subsystems
1898 :     # make sure we have empty blanks
1899 :     $menu1->{''}=$menu2->{''}=1;
1900 :     map {$menu1->{$_->[0]}=1; $menu2->{$_->[1]}=1} $fig->all_subsystem_classifications();
1901 :    
1902 :     push(@$html, $cgi->hr, "<table><tr><th colspan=2 style='text-align: center'>Subsystem Classification</th></tr>\n",
1903 :     "<tr><td>Please use ours:</td><td>", $cgi->popup_menu(-name=>"classif1", -values=>[sort {$a cmp $b} keys %$menu1], -default=>$$class[0]), "</td><td>",
1904 : parrello 1.127 $cgi->popup_menu(-name=>"classif2", -values=>[sort {$a cmp $b} keys %$menu2], -default=>$$class[1]), "</td></tr>\n<tr><td>Or make your own:</td><td>",
1905 :     $cgi->textfield(-name=>"classif1t", -size=>50), "</td><td>", $cgi->textfield(-name=>"classif2t", -size=>50), "</td></tr></table>\n"
1906 :     );
1907 : redwards 1.41 }
1908 :     elsif ($class)
1909 :     {
1910 : redwards 1.42 push (@$html, $cgi->h2('Classification'), "<table><tr><td>$$class[0]</td><td>$$class[1]</td></tr></table>\n");
1911 : redwards 1.41 }
1912 :    
1913 : golsen 1.186 if ( $time_it ) ## time ##
1914 :     { ## time ##
1915 :     push @times, scalar time(); ## time ##
1916 :     push @$html, "<br>dT = @{[$times[-1]-$times[-2]]}, T = @{[$times[-1]-$times[0]]}<br>"; ## time ##
1917 :     } ## time ##
1918 :    
1919 : overbeek 1.180 my @orgs = map { "$_->[0]: " . $_->[1] }
1920 : overbeek 1.181 sort { $a->[1] cmp $b->[1] }
1921 : overbeek 1.180 map { [$_,$fig->genus_species($_)] }
1922 :     grep { $subsystem->get_variant_code($subsystem->get_genome_index($_)) ne "-1" }
1923 :     $subsystem->get_genomes;
1924 :     my @roles = $subsystem->get_roles;
1925 :     push(@$html,$cgi->hr,$cgi->h1('Lock PEGs in Cells'));
1926 :     push(@$html, $cgi->scrolling_list( -name => 'genome_to_lock',
1927 :     -values => [ @orgs ],
1928 :     -size => 10,
1929 :     -multiple => 1
1930 : golsen 1.184 ),
1931 :     $cgi->br, # Was unquoted <br>; read from undefined file handle
1932 : overbeek 1.180 $cgi->scrolling_list( -name => 'roles_to_lock',
1933 :     -values => [ @roles ],
1934 :     -size => 10,
1935 :     -multiple => 1
1936 : golsen 1.184 ),
1937 :     $cgi->br
1938 :     );
1939 : overbeek 1.180
1940 :     push(@$html,$cgi->submit('lock annotations')," OR ");
1941 :     push(@$html,$cgi->submit('unlock annotations'),$cgi->br);
1942 :    
1943 : overbeek 1.1 push(@$html, $cgi->end_form);
1944 :    
1945 : overbeek 1.19 my $target = "align$$";
1946 :     my @roles = $subsystem->get_roles;
1947 :     my $i;
1948 :     my $dir = $subsystem->get_dir;
1949 : overbeek 1.76 my $rolesA = &existing_trees($dir,\@roles);
1950 :    
1951 : overbeek 1.19 if (@$rolesA > 0)
1952 :     {
1953 : parrello 1.127 push(@$html, $cgi->hr,
1954 :     $cgi->h1('To Assign Using a Tree'),
1955 :     $cgi->start_form(-action => "assign_using_tree.cgi",
1956 :     -target => $target,
1957 :     -method => 'post'),
1958 :     $cgi->hidden(-name => 'user', -value => $user, -override => 1),
1959 :     $cgi->hidden(-name => 'ali_dir', -value => "$dir/Alignments", -override => 1),
1960 :     $cgi->scrolling_list(-name => 'ali_num',
1961 :     -values => $rolesA,
1962 :     -size => 10,
1963 :     -multiple => 0
1964 :     ),
1965 :     $cgi->br,
1966 :     $cgi->submit(-value => "use_tree",
1967 :     -name => "use_tree"),
1968 :     $cgi->end_form
1969 :     );
1970 : overbeek 1.19 }
1971 :    
1972 : overbeek 1.1 push(@$html, $cgi->hr);
1973 :    
1974 :     if ($cgi->param('show_missing'))
1975 :     {
1976 : parrello 1.127 &format_missing($fig,$cgi,$html,$subsystem);
1977 : overbeek 1.1 }
1978 :    
1979 :     if ($cgi->param('show_missing_including_matches'))
1980 :     {
1981 : parrello 1.127 &format_missing_including_matches($fig,$cgi,$html,$subsystem);
1982 : overbeek 1.1 }
1983 : mkubal 1.36 if ($cgi->param('show_missing_including_matches_in_ss'))
1984 :     {
1985 : parrello 1.127 &format_missing_including_matches_in_ss($fig,$cgi,$html,$subsystem);
1986 : mkubal 1.36 }
1987 :    
1988 : overbeek 1.1
1989 : overbeek 1.3 if ($cgi->param('check_assignments'))
1990 :     {
1991 : parrello 1.127 &format_check_assignments($fig,$cgi,$html,$subsystem);
1992 : overbeek 1.3 }
1993 :    
1994 : overbeek 1.1 if ($cgi->param('show_dups'))
1995 :     {
1996 : parrello 1.127 &format_dups($fig,$cgi,$html,$subsystem);
1997 : overbeek 1.1 }
1998 :    
1999 :     if ($cgi->param('show_coupled'))
2000 :     {
2001 : parrello 1.127 &format_coupled($fig,$cgi,$html,$subsystem,"careful");
2002 : overbeek 1.1 }
2003 :     elsif ($cgi->param('show_coupled_fast'))
2004 :     {
2005 : parrello 1.127 &format_coupled($fig,$cgi,$html,$subsystem,"fast");
2006 : overbeek 1.1 }
2007 :    
2008 :     my $col;
2009 : overbeek 1.76 if ($col = $cgi->param('col_to_annotate'))
2010 : redwards 1.22 {
2011 :     &annotate_column($fig,$cgi,$html,$col,$subsystem);
2012 :     }
2013 : mkubal 1.156
2014 :     if ($cgi->param('ma_data_diagram_action'))
2015 :     {
2016 :     &paint_ma_data($fig,$cgi,$ssa,$subsystem);
2017 : mkubal 1.165 &make_link_to_painted_diagram($fig,$cgi,$html);
2018 : mkubal 1.156 }
2019 :    
2020 : mkubal 1.165 if ($cgi->param('paint_diagram_role_by_attribute_value'))
2021 :     {
2022 : mkubal 1.166 if ($cgi->param('paint_diagram_role_by_attribute_value')){
2023 :     my $diagram_name = $cgi->param('diagram_to_color');
2024 :     my $possible_roles_to_color = &find_roles_to_color($fig,$cgi,$html,$subsystem);
2025 :     &color_diagram_role_by_av($fig,$cgi,$ssa,$subsystem,$possible_roles_to_color,$diagram_name);
2026 :     &make_link_to_painted_diagram($fig,$cgi,$html);
2027 :     }
2028 : mkubal 1.165 }
2029 : golsen 1.186
2030 :     if ( $time_it ) ## time ##
2031 :     { ## time ##
2032 :     push @times, scalar time(); ## time ##
2033 :     push @$html, "<br>dT = @{[$times[-1]-$times[-2]]}, T = @{[$times[-1]-$times[0]]}<br>"; ## time ##
2034 :     } ## time ##
2035 : overbeek 1.1 }
2036 :    
2037 : olson 1.206 ########
2038 :     # Displays the start,end and map relation table to kegg
2039 :     # Kevin Formsma 2006 Hope College
2040 :     #
2041 :     sub format_kegg_info
2042 :     {
2043 :     my ($fig,$cgi,$html,$subsystem,$can_alter,$active_genome_list) = @_;
2044 :     push(@$html, $cgi->hr, $cgi->h2("KEGG Contextual Information"));
2045 :    
2046 :     my @kegg_genomes = sort { lc $a->[1] cmp lc $b->[1] } map { [ $_->[0], "$_->[1] [$_->[0]]" ] } @$active_genome_list;
2047 :     unshift @kegg_genomes, [ '', 'All' ];
2048 :    
2049 :     push(@$html, "<p>Find matching KEGG maps for:&nbsp;&nbsp;",
2050 :     $cgi->popup_menu( -name => 'kegg_genome',
2051 :     -values => [ map { $_->[0] } @kegg_genomes ],
2052 :     -labels => { map { ( $_->[0], $_->[1] ) } @kegg_genomes }
2053 :     )
2054 :     );
2055 :    
2056 :     push(@$html,
2057 :     $cgi->submit(-name => 'show_KGML', -label => 'All roles'),
2058 :     "&nbsp;",
2059 :     $cgi->submit(-name => 'show_KGML', -label => 'Active subset roles'),
2060 :     $cgi->br
2061 :     );
2062 :    
2063 :     if ($cgi->param('show_KGML'))
2064 :     {
2065 : dejongh 1.211 my %reactions = $subsystem->get_hope_reactions;
2066 : olson 1.206 my @roles = ();
2067 :     my $kegg_genome = $cgi->param('kegg_genome');
2068 :     my $active_subsetC = ($cgi->param('active_subsetC') or $subsystem->get_active_subsetC );
2069 :     my @subsetC = $subsystem->get_subsetC_roles($active_subsetC);
2070 :     my %activeC = map { $_ => 1 } @subsetC;
2071 :    
2072 :     foreach my $role ($subsystem->get_roles)
2073 :     {
2074 :     if (($cgi->param('show_KGML') eq "Active subset roles" && ! defined($activeC{$role})) ||
2075 :     ($kegg_genome ne "" && $subsystem->get_pegs_from_cell($kegg_genome,$role) == 0))
2076 :     {
2077 :     delete $reactions{$role};
2078 :     }
2079 :     else
2080 :     {
2081 :     push @roles, $role;
2082 :     }
2083 :     }
2084 :    
2085 :     my $kgml = new KGMLData;
2086 :     push(@$html, "<p>");
2087 :     show_matching_pathways($kgml,\@roles,$cgi,$html, \%reactions);
2088 :     }
2089 :    
2090 : dejongh 1.211 push(@$html, "<p>Go to <a href=\"javascript:void(0)\"onclick=\"window.open('hope_tools.cgi','','height=600,width=800,scrollbars=yes,status=yes,resizable=yes')\">the scenario tools<\/a>");;
2091 : olson 1.206
2092 :     my @hope_scenario_names = $subsystem->get_hope_scenario_names;
2093 :    
2094 :     foreach my $scenario_name (sort @hope_scenario_names)
2095 :     {
2096 : dejongh 1.211 my @hope_input_compounds = $subsystem->get_hope_input_compounds($scenario_name);
2097 :     my @hope_output_compounds = $subsystem->get_hope_output_compounds($scenario_name);
2098 :     my @hope_mapIDs = $subsystem->get_hope_map_ids($scenario_name);
2099 :     my @hope_additional_reactions = $subsystem->get_hope_additional_reactions($scenario_name);
2100 :     my @hope_ignore_reactions = $subsystem->get_hope_ignore_reactions($scenario_name);
2101 : olson 1.206
2102 :     my $display_name = $scenario_name;
2103 :     $display_name =~ s/_/ /g;
2104 :     push(@$html, "<p><b><font size=+1>Scenario: $display_name</font></b>");
2105 :    
2106 :     if($can_alter)
2107 :     {
2108 :     my $scenarioName = $cgi->textfield(-name => $scenario_name."_Name", -size => 30, -value => "", -override => 1);
2109 :     push(@$html, "&nbsp;&nbsp;(Change name:&nbsp;&nbsp;", $scenarioName, ")&nbsp;&nbsp;");
2110 :     push(@$html, $cgi->submit(-name => $scenario_name."_Delete", -label => "Delete scenario"), "<p>");
2111 :     }
2112 :     else
2113 :     {
2114 :     push(@$html, "<p>");
2115 :     }
2116 :    
2117 :     my $edit_kegg_col = '';
2118 :     if ($can_alter)
2119 :     {
2120 :     $edit_kegg_col = "<th>Edit KEGG IDs (comma-separated list, parentheses to group)</th>";
2121 :     }
2122 :     push(@$html,"<table border=1><tr><th>&nbsp;</th><th>KEGG IDs</th>$edit_kegg_col</tr><tr><td><b>Input Compounds<b></td>");
2123 :     my @compound_info;
2124 :    
2125 : dejongh 1.211 foreach my $cpd (@hope_input_compounds)
2126 : olson 1.206 {
2127 :     my @compound_names = $fig->names_of_compound($cpd);
2128 :     my $name = (scalar @compound_names > 0) ? "$compound_names[0]" : "";
2129 :     push @compound_info, &HTML::compound_link($cpd)." ".$name;
2130 :     }
2131 :    
2132 :     my $input_string = join("<br>", @compound_info);
2133 :     push(@$html,"<td>$input_string</td>");
2134 :    
2135 :     if($can_alter)
2136 :     {
2137 :     my $hopeInputCompounds = $cgi->textfield(-name => $scenario_name."_InputCompounds", -size => 50, -value => "", -override => 1);
2138 :     push(@$html,"<td>$hopeInputCompounds</td>");
2139 :     }
2140 :    
2141 :     push(@$html,"</tr>");
2142 :     my @compound_info;
2143 :    
2144 : dejongh 1.211 foreach my $cpd_list (@hope_output_compounds)
2145 : olson 1.206 {
2146 :     my @inner_compound_info;
2147 :    
2148 :     foreach my $cpd (@$cpd_list)
2149 :     {
2150 :     my @compound_names = $fig->names_of_compound($cpd);
2151 :     my $name = (scalar @compound_names > 0) ? "$compound_names[0]" : "";
2152 :     push @inner_compound_info, &HTML::compound_link($cpd)." ".$name;
2153 :     }
2154 :    
2155 :     push @compound_info, join ", ", @inner_compound_info;
2156 :     }
2157 :    
2158 :     my $output_string = join("<br>", @compound_info);
2159 :     push(@$html,"<tr><td><b>Output Compounds</b></td><td>$output_string</td>");
2160 :    
2161 :     if($can_alter)
2162 :     {
2163 :     my $hopeOutputCompounds = $cgi->textfield(-name => $scenario_name."_OutputCompounds", -size => 50, -value => "", -override => 1);
2164 :     push(@$html,"<td>$hopeOutputCompounds</td>");
2165 :     }
2166 :    
2167 :     push(@$html,"</tr>");
2168 :     push(@$html,"<tr><td><b>Pathway Maps</b></td>");
2169 :    
2170 : dejongh 1.211 my %hope_reactions = $subsystem->get_hope_reactions;
2171 : olson 1.206 my %reaction_list;
2172 :     my @roles = $subsystem->get_roles;
2173 :     my %roles;
2174 :     map { $roles{$_} = 1 } @roles;
2175 :    
2176 :     foreach my $role (keys %hope_reactions)
2177 :     {
2178 :     if (defined $roles{$role})
2179 :     {
2180 :     map { $reaction_list{$_} = 1 } @{$hope_reactions{$role}};
2181 :     }
2182 :     }
2183 : dejongh 1.211 map { $reaction_list{$_} = 1 } @hope_additional_reactions;
2184 :     map { delete $reaction_list{$_} } @hope_ignore_reactions;
2185 : olson 1.206
2186 :     my @map_info;
2187 :    
2188 : dejongh 1.211 foreach my $mapid (@hope_mapIDs)
2189 : olson 1.206 {
2190 : dejongh 1.215 my $name = $fig->map_name("map".$mapid);
2191 :     push @map_info, &HTML::reaction_map_link($mapid, keys %reaction_list)." ".$name;
2192 : olson 1.206 }
2193 :    
2194 :     my $ids_string = join("<br>", @map_info);
2195 :     push(@$html,"<td>$ids_string</td>");
2196 :    
2197 :     if($can_alter)
2198 :     {
2199 :     my $hopeMapIDs = $cgi->textfield(-name => $scenario_name."_MapIDs", -size => 50, -value => "", -override => 1);
2200 :     push(@$html,"<td>$hopeMapIDs</td>");
2201 :     }
2202 :     push(@$html,"</tr>");
2203 :    
2204 :     push(@$html,"<tr><td><b>Additional Reactions</b></td>");
2205 : dejongh 1.211 my $add_rxns = join(", ", map { &HTML::reaction_link($_) } @hope_additional_reactions);
2206 : olson 1.206 push(@$html, "<td>$add_rxns</td>");
2207 :    
2208 :     if($can_alter)
2209 :     {
2210 :     my $hopeAddRxns = $cgi->textfield(-name => $scenario_name."_AddRxns", -size => 50, -value => "", -override => 1);
2211 :     push(@$html,"<td>$hopeAddRxns</td>");
2212 :     }
2213 :     push(@$html,"</tr>");
2214 :    
2215 :     push(@$html,"<tr><td><b>Ignore Reactions</b></td>");
2216 : dejongh 1.211 my $ignore_rxns = join(", ", map { &HTML::reaction_link($_) } @hope_ignore_reactions);
2217 : olson 1.206 push(@$html, "<td>$ignore_rxns</td>");
2218 :    
2219 :     if($can_alter)
2220 :     {
2221 :     my $hopeIgnoreRxns = $cgi->textfield(-name => $scenario_name."_IgnoreRxns", -size => 50, -value => "", -override => 1);
2222 :     push(@$html,"<td>$hopeIgnoreRxns</td>");
2223 :     }
2224 :     push(@$html,"</tr>");
2225 :    
2226 :     push(@$html,"</table>");
2227 :    
2228 :     my $ss_name = $subsystem->get_name;
2229 :     push(@$html,
2230 :     "Find reaction paths for&nbsp&nbsp");
2231 :     push(@$html,
2232 :     $cgi->popup_menu( -name => "${scenario_name}_genome",
2233 :     -values => [ map { $_->[0] } @kegg_genomes ],
2234 :     -labels => { map { ( $_->[0], $_->[1] ) } @kegg_genomes }
2235 :     ),
2236 : dejongh 1.211 $cgi->button(-name => "${scenario_name}_One_button", -label => 'Find One Path', -onClick => "window.open('find_reaction_paths.cgi?one_or_all=1&ssa=$ss_name&scenario_name=$scenario_name&genome='+MainForm.${scenario_name}_genome[MainForm.${scenario_name}_genome.selectedIndex].value,'$ss_name (reactions for $scenario_name) '+MainForm.${scenario_name}_genome.selectedIndex,'height=640,width=800,scrollbars=yes,toolbar=yes,status=yes,resizable=yes')"),
2237 :     $cgi->button(-name => "${scenario_name}_All_button", -label => 'Find All Paths', -onClick => "window.open('find_reaction_paths.cgi?one_or_all=0&ssa=$ss_name&scenario_name=$scenario_name&genome='+MainForm.${scenario_name}_genome[MainForm.${scenario_name}_genome.selectedIndex].value,'$ss_name (reactions for $scenario_name) '+MainForm.${scenario_name}_genome.selectedIndex,'height=640,width=800,scrollbars=yes,toolbar=yes,status=yes,resizable=yes')"),
2238 : olson 1.206 $cgi->br,
2239 :     "<p>"
2240 :     );
2241 :     }
2242 :    
2243 :     if($can_alter)
2244 :     {
2245 :     my $scenarioName = $cgi->textfield(-name => "newscenario_Name", -size => 50, -value => "", -override => 1);
2246 :     push(@$html, "<p>New scenario name:&nbsp;&nbsp;", $scenarioName, "<p>");
2247 :     }
2248 :    
2249 :     push(@$html, $cgi->hr);
2250 :     }
2251 :    
2252 :    
2253 :    
2254 :    
2255 :    
2256 :     ###show_matching_pathways###
2257 :     #
2258 :     # Input: KGMLData Object, Subsystem Object, CGI objectm HTML data array
2259 :     #
2260 :     # Output: HTML formating displaying the results of the functin get_matching_pathways
2261 :     ############################
2262 :     sub show_matching_pathways
2263 :     {
2264 :     my($kgml,$roles,$cgi,$html,$hope_reactions) = @_;
2265 :     my $ssa = $cgi->param('ssa_name');
2266 :     #get the subsystem EC numbers
2267 :     my @ecs = $kgml->roles_to_ec(@{$roles});
2268 :     my @rns;
2269 :    
2270 :     if (defined $hope_reactions)
2271 :     {
2272 :     my %hope_rns = %{$hope_reactions};
2273 :     foreach my $role (keys %hope_rns)
2274 :     {
2275 :     push @rns, @{$hope_rns{$role}};
2276 : dejongh 1.211 }
2277 : olson 1.206 }
2278 :    
2279 :     #if defined, lets continue, else print error
2280 :     if(defined @ecs)
2281 :     {
2282 :     #get a list of the pathways with matches, their links, and how many EC's matched.
2283 :     my $matching_array;
2284 :     eval {$matching_array = $kgml->get_matching_pathways($FIG_Config::kgml_dir."/map/",\@ecs,\@rns)};
2285 :     if($@ || !defined $matching_array)
2286 :     {
2287 :     push(@$html, "No Results Found or Error: $@");
2288 :     }
2289 :     else{
2290 :     foreach my $entry (@$matching_array){
2291 :    
2292 :     push(@$html,"$entry->[1] => ","<a href=\"$entry->[2]\">EC numbers in map $entry->[0]</a> and <a href=\"$entry->[3]\">Hope Reactions in map $entry->[0]</a> Count=$entry->[4]",$cgi->br,$cgi->br);
2293 :     }
2294 :     }
2295 :     }
2296 :     else
2297 :     {
2298 :     push(@$html,"No matching EC numbers or Hope Reactions.");
2299 :     }
2300 :     }
2301 :    
2302 : golsen 1.29
2303 :     #-----------------------------------------------------------------------------
2304 :     # Selection list of complete genomes not in spreadsheet:
2305 :     #-----------------------------------------------------------------------------
2306 :    
2307 : overbeek 1.1 sub format_extend_with {
2308 : golsen 1.29 my( $fig, $cgi, $html, $subsystem ) = @_;
2309 : overbeek 1.1
2310 :     my %genomes = map { $_ => 1 } $subsystem->get_genomes();
2311 :    
2312 : golsen 1.44 #
2313 :     # Use $fig->genomes( complete, restricted, domain ) to get org list:
2314 :     #
2315 :     my $req_comp = $cgi->param( 'complete' ) || 'Only "complete"';
2316 :     my $complete = ( $req_comp =~ /^all$/i ) ? undef : "complete";
2317 : overbeek 1.147
2318 : golsen 1.184 # What domains are to be displayed in the genome picker?
2319 :     # These are the canonical domain names defined in compute_genome_counts
2320 :     # and entered in the DBMS:
2321 :    
2322 :     my %maindomain = ( Archaea => 'A',
2323 :     Bacteria => 'B',
2324 :     Eukaryota => 'E',
2325 :     Plasmid => 'P',
2326 :     Virus => 'V',
2327 :     'Environmental Sample' => 'M', # Metagenome
2328 :     unknown => 'U'
2329 :     );
2330 :    
2331 :     my %label = ( Archaea => 'Archaea [A]',
2332 :     Bacteria => 'Bacteria [B]',
2333 :     Eukaryota => 'Eucarya [E]',
2334 :     Plasmid => 'Plasmids [P]',
2335 :     Virus => 'Viruses [V]',
2336 :     'Environmental Sample' => 'Environmental (metagenomes) [M]',
2337 :     unknown => 'unknown [U]'
2338 :     );
2339 :    
2340 :     # Currently, compute_genome_counts marks everything that is not Archae,
2341 :     # Bacteria or Eukcayra to not complete. So, the completeness status must
2342 :     # be ignored on the others.
2343 :    
2344 :     my %honor_complete = ( Archaea => 1, Bacteria => 1, Eukaryota => 1 );
2345 :    
2346 :     # Requested domains or default:
2347 :    
2348 :     my @picker_domains = grep { $maindomain{ $_ } }
2349 :     $cgi->param( 'picker_domains' );
2350 :     if ( ! @picker_domains ) { @picker_domains = qw( Archaea Bacteria Eukaryota ) }
2351 :    
2352 :     my %picker_domains = map { ( $_ => 1 ) } @picker_domains;
2353 :    
2354 :     # Build the domain selection checkboxes:
2355 :    
2356 :     my @domain_checkboxes = ();
2357 :     my %domain_abbrev = reverse %maindomain;
2358 :     foreach ( map { $domain_abbrev{ $_ } } qw( A B E P V M U ) )
2359 :     {
2360 :     push @domain_checkboxes, $cgi->checkbox( -name => 'picker_domains',
2361 :     -value => $_,
2362 :     -checked => ( $picker_domains{ $_ } ? 1 : 0 ),
2363 :     -label => $label{ $_ },
2364 :     -override => 1
2365 :     )
2366 :     }
2367 :    
2368 :     # Assemble the genome list for the picker. This could be optimized for
2369 :     # some special cases, but it is far from rate limiting. Most of the time
2370 :     # is looking up the name and domain, not the call to genomes().
2371 :     # Each org is represented as [ id, genus_species, domain ]
2372 :    
2373 :     my @orgs = ();
2374 :     foreach my $domain ( @picker_domains )
2375 : golsen 1.186 {
2376 :     push @orgs, map { [ $_, $fig->genus_species_domain( $_ ) ] }
2377 : golsen 1.184 grep { ! $genomes{ $_ } }
2378 :     $fig->genomes( $complete && $honor_complete{ $domain }, undef, $domain )
2379 :     }
2380 : golsen 1.29
2381 : golsen 1.44 #
2382 :     # Put it in the order requested by the user:
2383 :     #
2384 : golsen 1.29 my $pick_order = $cgi->param('pick_order') || 'Alphabetic';
2385 :     if ( $pick_order eq "Phylogenetic" )
2386 :     {
2387 : golsen 1.184 @orgs = sort { $a->[-1] cmp $b->[-1] }
2388 :     map { push @$_, lc $fig->taxonomy_of( $_->[0] ); $_ }
2389 : parrello 1.127 @orgs;
2390 : golsen 1.29 }
2391 :     elsif ( $pick_order eq "Genome ID" )
2392 :     {
2393 : golsen 1.184 @orgs = sort { $a->[-1]->[0] <=> $b->[-1]->[0] || $a->[-1]->[1] <=> $b->[-1]->[1] }
2394 :     map { push @$_, [ split /\./, $_->[0] ]; $_ }
2395 : parrello 1.127 @orgs;
2396 : golsen 1.29 }
2397 :     else
2398 :     {
2399 : parrello 1.127 $pick_order = 'Alphabetic';
2400 : golsen 1.184 @orgs = sort { $a->[-1] cmp $b->[-1] }
2401 :     map { push @$_, lc $_->[1]; $_ }
2402 :     @orgs;
2403 : golsen 1.29 }
2404 : overbeek 1.1
2405 : golsen 1.184 # Build the displayed name:
2406 :    
2407 :     @orgs = map { "$_->[1] [$maindomain{$_->[2]}] ($_->[0])" } @orgs;
2408 : golsen 1.29
2409 : golsen 1.44 #
2410 :     # Radio buttons to let the user choose the order they want for the list:
2411 :     #
2412 : golsen 1.29 my @order_opt = $cgi->radio_group( -name => 'pick_order',
2413 :     -values => [ 'Alphabetic', 'Phylogenetic', 'Genome ID' ],
2414 :     -default => $pick_order,
2415 :     -override => 1
2416 :     );
2417 :    
2418 : golsen 1.44 #
2419 :     # Radio buttons to let the user choose to include incomplete genomes:
2420 :     #
2421 :     my @complete = $cgi->radio_group( -name => 'complete',
2422 :     -default => $req_comp,
2423 :     -override => 1,
2424 :     -values => [ 'All', 'Only "complete"' ]
2425 :     );
2426 :    
2427 :     #
2428 :     # Display the pick list, and options:
2429 :     #
2430 : overbeek 1.180 my @roles = $subsystem->get_roles;
2431 : golsen 1.184 push( @$html, $cgi->h2('Pick Genomes to Extend with'), "\n",
2432 : golsen 1.29 "<TABLE>\n",
2433 : golsen 1.184 " <TR VAlign=top>\n",
2434 : golsen 1.29 " <TD>",
2435 : golsen 1.30 $cgi->scrolling_list( -name => 'new_genome',
2436 : golsen 1.29 -values => [ @orgs ],
2437 :     -size => 10,
2438 :     -multiple => 1
2439 :     ),
2440 :     " </TD>\n",
2441 : golsen 1.184
2442 : golsen 1.44 " <TD>",
2443 :     join( "<BR>\n", "<b>Order of selection list:</b>", @order_opt,
2444 :     "<b>Completeness?</b>", @complete
2445 :     ), "\n",
2446 : golsen 1.29 " </TD>\n",
2447 : golsen 1.184
2448 :     " <TD>&nbsp;&nbsp;&nbsp;</TD>\n",
2449 :    
2450 :     " <TD>\n",
2451 :     join( "<BR>\n", "<B>Include in selection list:</B>", @domain_checkboxes ), "\n",
2452 :     " </TD>\n",
2453 :    
2454 : golsen 1.29 " </TR>\n",
2455 :     "</TABLE>\n",
2456 : golsen 1.184
2457 : overbeek 1.136 $cgi->p("Add a specific group of genomes:"),
2458 :     $cgi->checkbox_group( -name=>"moregenomes",
2459 : redwards 1.217 -values=>["NMPDR", "BRC", "Cyanobacteria", "Higher Plants", "Photosynthetic Eukaryotes", "Anoxygenic Phototrophs", "Hundred by a hundred", "Phages"],
2460 : golsen 1.184 )
2461 :     );
2462 :    
2463 : golsen 1.186 if ( $time_it ) ## time ##
2464 :     { ## time ##
2465 :     push @times, scalar time(); ## time ##
2466 :     push @$html, "<br>dT = @{[$times[-1]-$times[-2]]}, T = @{[$times[-1]-$times[0]]}<br>"; ## time ##
2467 :     } ## time ##
2468 : golsen 1.184
2469 :     push @$html, $cgi->hr;
2470 : overbeek 1.1 }
2471 :    
2472 : olson 1.109 #
2473 :     # Write out information about this subsystem as javascript
2474 :     # data structures. Used for the diagram coloring currently.
2475 :     #
2476 :     sub format_js_data
2477 :     {
2478 :     my($fig,$cgi,$html,$subsystem,$can_alter) = @_;
2479 :    
2480 :     push(@$html, qq(<script language="JavaScript">\n),
2481 : parrello 1.127 "subsystemInfo = {\n");
2482 : olson 1.109
2483 : parrello 1.127 my $first = 1;
2484 : olson 1.109 for my $g ($subsystem->get_genomes())
2485 :     {
2486 : parrello 1.127 my $txt = '';
2487 :     #
2488 :     # Determine which roles this genome has.
2489 :     #
2490 :     if (!$first)
2491 :     {
2492 :     $txt .= ", ";
2493 :     }
2494 :     else
2495 :     {
2496 :     $first = 0;
2497 :     }
2498 :    
2499 :     $txt .= "'$g': [";
2500 :    
2501 :     my $gi = $subsystem->get_genome_index($g);
2502 :    
2503 :     my $row = $subsystem->get_row($gi);
2504 :    
2505 :     my @r;
2506 :     for (my $ri = 0; $ri < @$row; $ri++)
2507 :     {
2508 :     my $cell = $row->[$ri];
2509 :     if ($#$cell > -1)
2510 :     {
2511 :     push(@r, "'" . $subsystem->get_role_abbr($ri) . "'");
2512 :     }
2513 :     }
2514 :    
2515 :     $txt .= join(", ", @r);
2516 :     $txt .= "]\n";
2517 :     push(@$html, $txt);
2518 : olson 1.109 }
2519 :     push(@$html, "};\n");
2520 :     push(@$html, "</script>\n");
2521 :     }
2522 : golsen 1.29
2523 : overbeek 1.1 sub format_roles {
2524 : overbeek 1.14 my($fig,$cgi,$html,$subsystem,$can_alter) = @_;
2525 : overbeek 1.1 my($i);
2526 :    
2527 : overbeek 1.97 my @roles = $subsystem->get_roles;
2528 : redwards 1.218 my @genomes = $subsystem->get_genomes;
2529 : overbeek 1.96 my $sub_dir = $subsystem->get_dir;
2530 :    
2531 : overbeek 1.97 my $reactions = $subsystem->get_reactions;
2532 : dejongh 1.211 my %hope_reactions = $subsystem->get_hope_reactions;
2533 :     my %hope_reaction_notes = $subsystem->get_hope_reaction_notes;
2534 :     my %hope_reaction_links = $subsystem->get_hope_reaction_links;
2535 : overbeek 1.97
2536 :     my $n = 1;
2537 : redwards 1.218 my $col_hdrs = ["Column","Abbrev","Functional Role", "Num Genomes"];
2538 : overbeek 1.97
2539 : overbeek 1.99 if ($can_alter)
2540 : overbeek 1.97 {
2541 : olson 1.206 #prehope# push(@$col_hdrs,"KEGG Reactions");
2542 :     #prehope# push(@$col_hdrs,"Edit Reactions");
2543 :     push(@$col_hdrs,"Role Reactions");
2544 : dejongh 1.207 push(@$col_hdrs,"Edit Role Reactions");
2545 : olson 1.206 push(@$col_hdrs,"Hope Reactions");
2546 : dejongh 1.207 # push(@$col_hdrs,"Edit Hope Reactions");
2547 : olson 1.206 push(@$col_hdrs,"Hope Reaction Notes");
2548 :     # push(@$col_hdrs,"Hope_Reaction_Links_Hope_Reaction_Links_Hope_Reaction_Links");
2549 : overbeek 1.99 }
2550 : olson 1.206 else
2551 : overbeek 1.99 {
2552 : olson 1.206 if ($reactions)
2553 :     {
2554 :     push(@$col_hdrs,"Role Reactions");
2555 :     }
2556 : dejongh 1.211 if (%hope_reactions)
2557 : olson 1.206 {
2558 :     push(@$col_hdrs,"Hope Reactions");
2559 :     push(@$col_hdrs,"Hope Reaction Notes");
2560 :     }
2561 : overbeek 1.96 }
2562 :    
2563 : hwang 1.204
2564 : overbeek 1.1 my $tab = [];
2565 :    
2566 : dejongh 1.211 &format_existing_roles($fig,$cgi,$html,$subsystem,$tab,\$n,$can_alter,$reactions,\%hope_reactions,
2567 : redwards 1.218 \%hope_reaction_notes,\%hope_reaction_links,\@roles,\@genomes);
2568 : overbeek 1.1 if ($cgi->param('can_alter'))
2569 :     {
2570 : parrello 1.127 for ($i=0; ($i < 5); $i++)
2571 :     {
2572 :     &format_role($fig,$cgi,$html,$subsystem,$tab,$n,"",$can_alter,undef);
2573 :     $n++;
2574 :     }
2575 : overbeek 1.1 }
2576 : overbeek 1.163 my %options; if ($cgi->param("create_excel")) {%options=(excelfile=>$cgi->param('ssa_name'), no_excel_link=>1)}
2577 :     push(@$html,&HTML::make_table($col_hdrs,$tab,"Functional Roles", %options),
2578 : parrello 1.127 $cgi->hr
2579 :     );
2580 : golsen 1.186
2581 :     if ( $time_it ) ## time ##
2582 :     { ## time ##
2583 :     push @times, scalar time(); ## time ##
2584 :     push @$html, "<br>dT = @{[$times[-1]-$times[-2]]}, T = @{[$times[-1]-$times[0]]}<br>"; ## time ##
2585 :     } ## time ##
2586 : overbeek 1.1 }
2587 :    
2588 :     sub format_existing_roles {
2589 : redwards 1.218 my($fig,$cgi,$html,$subsystem,$tab,$nP,$can_alter,$reactions,$hope_reactions,$hope_reaction_notes,$hope_reaction_links,$roles,$genomes) = @_;
2590 : overbeek 1.1 my($role);
2591 :    
2592 : overbeek 1.97 foreach $role (@$roles)
2593 : overbeek 1.1 {
2594 : redwards 1.218 &format_role($fig,$cgi,$html,$subsystem,$tab,$$nP,$role,$can_alter,$reactions,$hope_reactions,$hope_reaction_notes,$hope_reaction_links,$genomes);
2595 : parrello 1.127 $$nP++;
2596 : overbeek 1.1 }
2597 :     }
2598 :    
2599 :     sub format_role {
2600 : redwards 1.218 my($fig,$cgi,$html,$subsystem,$tab,$n,$role,$can_alter,$reactions,$hope_reactions,$hope_reaction_notes,$hope_reaction_links,$genomes) = @_;
2601 : olson 1.206 my($abbrev,$reactT,$hopeReactT);
2602 : overbeek 1.96
2603 : olson 1.206 my $react = $reactions ? join(", ", map { &HTML::reaction_link($_) } @{$reactions->{$role}}) : "";
2604 :     my $hope_react = $hope_reactions ? join(", ", map { &HTML::reaction_link($_) } @{$hope_reactions->{$role}}) : "";
2605 :     my $hope_reaction_note = $hope_reaction_notes ? $hope_reaction_notes->{$role} : "";
2606 :     my $hope_reaction_link = $hope_reaction_links ? $hope_reaction_links->{$role} : "";
2607 :     $hope_reaction_link =~ s/;/<br>/g;
2608 :    
2609 :     my %reaction_links;
2610 :     while ($hope_reaction_link =~ /(R\d\d\d\d\d)/g)
2611 :     {
2612 :     $reaction_links{$1} = &HTML::reaction_link($1);
2613 :     }
2614 :    
2615 :     foreach my $reaction (keys %reaction_links)
2616 :     {
2617 :     $hope_reaction_link =~ s/$reaction/$reaction_links{$reaction}/g;
2618 :     }
2619 :    
2620 : dejongh 1.211 $hope_reaction_link =~ s/(\w_\w+):(\w+(\.\d)?)/<a href=\"javascript:void(0)\"onclick=\"window.open('get_model_reactions.cgi?org=$1&gene=$2','$&','height=600,width=800,scrollbars=yes,status=yes,resizable=yes')\">$&<\/a>/g;
2621 : overbeek 1.1
2622 :     $abbrev = $role ? $subsystem->get_role_abbr($subsystem->get_role_index($role)) : "";
2623 :    
2624 : olson 1.206 my($posT,$abbrevT,$roleT,$hopeNoteT);
2625 : overbeek 1.14 if ($can_alter)
2626 : overbeek 1.1 {
2627 : parrello 1.127 $posT = $cgi->textfield(-name => "posR$n", -size => 3, -value => $n, -override => 1);
2628 :     $abbrevT = $cgi->textfield(-name => "abbrev$n", -size => 7, -value => $abbrev, -override => 1);
2629 : olson 1.206 $roleT = $cgi->textfield(-name => "role$n", -size => 60, -value => $role, -override => 1);
2630 : dejongh 1.207 $reactT = $cgi->textfield(-name => "react$n", -size => 20, -value => "", -override => 1);
2631 : olson 1.206 $hopeReactT = $cgi->textfield(-name => "hopeReact$n", -size => 20, -value => "", -override => 1);
2632 :     $hopeNoteT = $cgi->textarea(-name => "hopeNote$n", -columns => 60, -rows => 3, -value => $hope_reaction_note, -override => 1);
2633 : overbeek 1.1 }
2634 :     else
2635 :     {
2636 : parrello 1.127 push(@$html,$cgi->hidden(-name => "posR$n", -value => $n, -override => 1),
2637 :     $cgi->hidden(-name => "abbrev$n", -value => $abbrev, -override => 1),
2638 :     $cgi->hidden(-name => "role$n", -value => $role, -override => 1));
2639 :     $posT = $n;
2640 :     $abbrevT = $abbrev;
2641 :     $roleT = $role;
2642 : overbeek 1.1 }
2643 : redwards 1.218
2644 :     my $ngenomes = 0;
2645 :     for (my $genomeIdx=0; $genomeIdx <= $#$genomes; $genomeIdx++) {
2646 :     if (scalar($subsystem->get_pegs_from_cell($genomeIdx, $role)) > 0) {$ngenomes++}
2647 :     }
2648 :    
2649 :    
2650 : overbeek 1.1 #
2651 :     # Wrap the first element in the table with a <A NAME="role_rolename"> tag
2652 :     # so we can zing to it from elsewhere. We remove any non-alphanumeric
2653 :     # chars in the role name.
2654 :     #
2655 : overbeek 1.158 # Is there a reason for doing this ... it is not used.
2656 : overbeek 1.1
2657 :     my $posT_html;
2658 :     {
2659 : parrello 1.127 my $rn = $role;
2660 :     $rn =~ s/[ \/]/_/g;
2661 :     $rn =~ s/\W//g;
2662 : overbeek 1.1
2663 : parrello 1.127 $posT_html = "<a name=\"$rn\">$posT</a>";
2664 : overbeek 1.1 }
2665 :    
2666 : overbeek 1.158 #my $row = [$posT_html,$abbrevT,$roleT];
2667 : redwards 1.218 my $row = [$posT,$abbrevT,$roleT,$ngenomes];
2668 : overbeek 1.99 if ($can_alter)
2669 :     {
2670 : parrello 1.127 push(@$row,$react);
2671 : dejongh 1.207 push(@$row,$reactT);
2672 : olson 1.206 push(@$row,$hope_react);
2673 : dejongh 1.207 # push(@$row,$hopeReactT);
2674 : olson 1.206 push(@$row,$hopeNoteT);
2675 :     # push(@$row,$hope_reaction_link);
2676 : overbeek 1.99 }
2677 : olson 1.206 else
2678 : overbeek 1.97 {
2679 : olson 1.206 if ($reactions)
2680 :     {
2681 :     push(@$row,$react);
2682 :     }
2683 :     if ($hope_reactions)
2684 :     {
2685 :     push(@$row,$hope_react);
2686 :     push(@$row,$hope_reaction_note);
2687 :     }
2688 : overbeek 1.97 }
2689 :     push(@$tab,$row);
2690 : overbeek 1.1
2691 :     if ($cgi->param('check_problems'))
2692 :     {
2693 : parrello 1.127 my @roles = grep { $_->[0] ne $role } &gene_functions_in_col($fig,$role,$subsystem);
2694 :     my($x,$peg);
2695 :     foreach $x (@roles)
2696 :     {
2697 :     push(@$tab,["","",$x->[0]]);
2698 :     push(@$tab,["","",join(",",map { &HTML::fid_link($cgi,$_) } @{$x->[1]})]);
2699 :     }
2700 : overbeek 1.1 }
2701 :     }
2702 :    
2703 :     sub gene_functions_in_col {
2704 :     my($fig,$role,$subsystem) = @_;
2705 :     my(%roles,$peg,$func);
2706 : redwards 1.21
2707 :    
2708 :     # RAE this is dying if $subsystem->get_col($subsystem->get_role_index($role) + 1) is not defined
2709 :     # it is also not returning the right answer, so we need to fix it.
2710 :     # I am not sure why this is incremented by one here (see the note) because it is not right
2711 :     # and if you don't increment it by one it is right.
2712 :    
2713 :     # incr by 1 to get col indexed from 1 (not 0)
2714 :     #my @pegs = map { @$_ } @{$subsystem->get_col($subsystem->get_role_index($role) + 1)};
2715 :    
2716 :     return undef unless ($role); # this takes care of one error
2717 :     my $col_role=$subsystem->get_col($subsystem->get_role_index($role));
2718 :     return undef unless (defined $col_role);
2719 :     my @pegs = map { @$_ } @$col_role;
2720 : overbeek 1.1
2721 :     foreach $peg (@pegs)
2722 :     {
2723 : parrello 1.127 if ($func = $fig->function_of($peg))
2724 :     {
2725 :     push(@{$roles{$func}},$peg);
2726 :     }
2727 : overbeek 1.1 }
2728 :     return map { [$_,$roles{$_}] } sort keys(%roles);
2729 :     }
2730 :    
2731 :     sub format_subsets {
2732 : overbeek 1.14 my($fig,$cgi,$html,$subsystem,$can_alter) = @_;
2733 : overbeek 1.1
2734 : overbeek 1.14 &format_subsetsC($fig,$cgi,$html,$subsystem,$can_alter);
2735 : overbeek 1.115 &format_subsetsR($fig,$cgi,$html,$subsystem,$can_alter);
2736 : overbeek 1.1 }
2737 :    
2738 :     sub format_subsetsC {
2739 : overbeek 1.14 my($fig,$cgi,$html,$subsystem,$can_alter) = @_;
2740 : overbeek 1.1
2741 :     my $col_hdrs = ["Subset","Includes These Roles"];
2742 :     my $tab = [];
2743 :    
2744 :     my $n = 1;
2745 : overbeek 1.14 &format_existing_subsetsC($cgi,$html,$subsystem,$tab,\$n,$can_alter);
2746 : overbeek 1.9
2747 : overbeek 1.14 if ($can_alter)
2748 : overbeek 1.1 {
2749 : parrello 1.127 my $i;
2750 :     for ($i=0; ($i < 5); $i++)
2751 :     {
2752 :     &format_subsetC($cgi,$html,$subsystem,$tab,$n,"");
2753 :     $n++;
2754 :     }
2755 : overbeek 1.1 }
2756 : overbeek 1.9
2757 : overbeek 1.163 my %options; if ($cgi->param("create_excel")) {%options=(excelfile=>$cgi->param('ssa_name'), no_excel_link=>1)}
2758 :     push(@$html,&HTML::make_table($col_hdrs,$tab,"Subsets of Roles", %options),
2759 : parrello 1.127 $cgi->hr
2760 :     );
2761 : overbeek 1.1
2762 : overbeek 1.145 my @subset_names = sort $subsystem->get_subset_namesC;
2763 : overbeek 1.1 if (@subset_names > 1)
2764 :     {
2765 : parrello 1.127 my $active_subsetC = ($cgi->param('active_subsetC') or $subsystem->get_active_subsetC );
2766 :     push(@$html,$cgi->scrolling_list(-name => 'active_subsetC',
2767 :     -values => [@subset_names],
2768 :     -default => $active_subsetC
2769 :     ),
2770 :     $cgi->br, "\n",
2771 :     );
2772 : overbeek 1.1 }
2773 :     else
2774 :     {
2775 : parrello 1.127 push(@$html,$cgi->hidden(-name => 'active_subsetC', -value => 'All', -override => 1));
2776 : overbeek 1.1 }
2777 : golsen 1.186
2778 :     if ( $time_it ) ## time ##
2779 :     { ## time ##
2780 :     push @times, scalar time(); ## time ##
2781 :     push @$html, "<br>dT = @{[$times[-1]-$times[-2]]}, T = @{[$times[-1]-$times[0]]}<br>"; ## time ##
2782 :     } ## time ##
2783 : overbeek 1.1 }
2784 :    
2785 :     sub format_subsetsR {
2786 : overbeek 1.115 my($fig,$cgi,$html,$subsystem,$can_alter) = @_;
2787 : overbeek 1.1 my($i);
2788 :    
2789 :     my $link = &tree_link;
2790 : overbeek 1.147 push(@$html, $cgi->h2("Limit display"), $link,$cgi->br);
2791 : overbeek 1.1
2792 : overbeek 1.115 #
2793 :     # Default to showing All unless you're a curator.
2794 :     #
2795 :    
2796 :     my $active_subsetR;
2797 :    
2798 :     my $default_activeSubsetR = $can_alter ? $subsystem->get_active_subsetR : "All";
2799 :    
2800 :     $active_subsetR = ($cgi->param('active_subsetR') or $default_activeSubsetR);
2801 : overbeek 1.1
2802 :     my @tmp = grep { $_ ne "All" } sort $subsystem->get_subset_namesR;
2803 : overbeek 1.147
2804 :     # RAE: provide some alternative choices, and a little explantion
2805 :     my %options=(
2806 :     "higher_plants" => "Higher Plants",
2807 :     "eukaryotic_ps" => "Photosynthetic Eukaryotes",
2808 :     "nonoxygenic_ps" => "Anoxygenic Phototrophs",
2809 :     "hundred_hundred" => "Hundred by a hundred",
2810 : overbeek 1.152 "functional_coupling_paper" => "Functional Coupling Paper",
2811 : redwards 1.196 "cyano_or_plant" => "Cyanos OR Plants",
2812 : overbeek 1.158 "ecoli_essentiality_paper" => "E. coli Essentiality Paper",
2813 : redwards 1.177 "has_essentiality_data" => "Genomes with essentiality data",
2814 : overbeek 1.147 "" => "All",
2815 :     );
2816 : overbeek 1.151
2817 : overbeek 1.147 push(@$html,
2818 :     $cgi->p("Limit display of the the genomes in the table based on phylogeny or one of the preselected groups:"),
2819 :     "\n<table><tr><td>",
2820 :     $cgi->scrolling_list(-name => 'active_subsetR',
2821 : parrello 1.127 -values => ["All",@tmp],
2822 :     -default => $active_subsetR,
2823 :     -size => 5
2824 :     ),
2825 : overbeek 1.147 "</td><td>\n",
2826 : redwards 1.177 $cgi->radio_group(-name=>"active_key", -values=>[keys %options], -labels=>\%options, -linebreak=>'true', -default=>"", columns=>4),
2827 : overbeek 1.147 "</td></tr>\n</table>",
2828 : parrello 1.127 );
2829 : golsen 1.186
2830 :     if ( $time_it ) ## time ##
2831 :     { ## time ##
2832 :     push @times, scalar time(); ## time ##
2833 :     push @$html, "<br>dT = @{[$times[-1]-$times[-2]]}, T = @{[$times[-1]-$times[0]]}<br>"; ## time ##
2834 :     } ## time ##
2835 : overbeek 1.1 }
2836 :    
2837 :     sub format_existing_subsetsC {
2838 : overbeek 1.14 my($cgi,$html,$subsystem,$tab,$nP,$can_alter) = @_;
2839 : overbeek 1.1 my($nameCS);
2840 :    
2841 :     foreach $nameCS (sort $subsystem->get_subset_namesC)
2842 :     {
2843 : parrello 1.127 if ($nameCS !~ /all/i)
2844 :     {
2845 :     &format_subsetC($cgi,$html,$subsystem,$tab,$$nP,$nameCS);
2846 :     $$nP++;
2847 :     }
2848 : overbeek 1.1 }
2849 :     }
2850 :    
2851 :     sub format_subsetC {
2852 :     my($cgi,$html,$subsystem,$tab,$n,$nameCS) = @_;
2853 :    
2854 :     if ($nameCS ne "All")
2855 :     {
2856 : parrello 1.127 my $subset = $nameCS ? join(",",map { $subsystem->get_role_index($_) + 1 } $subsystem->get_subsetC_roles($nameCS)) : "";
2857 : overbeek 1.9
2858 : parrello 1.127 $nameCS = $subset ? $nameCS : "";
2859 : overbeek 1.9
2860 : parrello 1.127 my($posT,$subsetT);
2861 : overbeek 1.9
2862 : parrello 1.127 $posT = $cgi->textfield(-name => "nameCS$n", -size => 30, -value => $nameCS, -override => 1);
2863 :     $subsetT = $cgi->textfield(-name => "subsetC$n", -size => 80, -value => $subset, -override => 1);
2864 :     push(@$tab,[$posT,$subsetT]);
2865 : overbeek 1.1 }
2866 :     }
2867 :    
2868 : olson 1.104
2869 :     #
2870 :     # Handle changes to diagrams.
2871 :     #
2872 :    
2873 :     sub handle_diagram_changes
2874 :     {
2875 :     my($fig, $subsystem, $cgi, $html) = @_;
2876 :     my $changed;
2877 : olson 1.111 my $sub_name = $subsystem->get_name();
2878 : olson 1.104
2879 :     return unless $cgi->param("diagram_action");
2880 :    
2881 :     my @actions = grep { /^diagram_/ } $cgi->param();
2882 :    
2883 :     for my $action (@actions)
2884 :     {
2885 : parrello 1.127 my $value = $cgi->param($action);
2886 :     if ($action =~ /^diagram_delete_(\S+)/ and $value eq "on")
2887 :     {
2888 :     warn "Delete diagram $sub_name $1\n";
2889 :     $subsystem->delete_diagram($1);
2890 :     $changed++;
2891 :     }
2892 :     elsif ($action =~ /^diagram_rename_(\S+)/ and $value ne "")
2893 :     {
2894 :     warn "Rename diagram $sub_name $1 to $value\n";
2895 :     $subsystem->rename_diagram($1, $value);
2896 :     $changed++;
2897 :     }
2898 :     elsif ($action =~ /^diagram_new_image_(\S+)/ and $value ne '')
2899 :     {
2900 :     my $fh = $cgi->upload($action);
2901 :     warn "Upload new image $fh $value for diagram $sub_name $1\n";
2902 :     $subsystem->upload_new_image($1, $cgi->upload($action));
2903 :     $changed++;
2904 :     }
2905 :     elsif ($action =~ /^diagram_new_html_(\S+)/ and $value ne '')
2906 :     {
2907 :     my $fh = $cgi->upload($action);
2908 :     warn "Upload new html $fh $value for diagram $sub_name $1\n";
2909 :     $subsystem->upload_new_html($1, $cgi->upload($action));
2910 :     $changed++;
2911 :     }
2912 :    
2913 : olson 1.104 }
2914 :    
2915 :     my $fh = $cgi->upload("diagram_image_file");
2916 : olson 1.109 my $html_fh = $cgi->upload("diagram_html_file");
2917 : olson 1.104
2918 :     if ($fh)
2919 :     {
2920 : parrello 1.127 my $name = $cgi->param("diagram_new_name");
2921 :    
2922 :     warn "Create new diagram $fh $html_fh name=$name\n";
2923 :     $subsystem->create_new_diagram($fh, $html_fh, $name);
2924 :     $changed++;
2925 : olson 1.104 }
2926 :    
2927 :     $subsystem->incr_version() if $changed;
2928 :     }
2929 :    
2930 :     #
2931 :     # Format the list of diagrams that a subsystem has.
2932 :     #
2933 :    
2934 :     sub format_diagrams
2935 :     {
2936 :     my($fig, $cgi, $html, $subsystem, $can_alter) = @_;
2937 :    
2938 :     my @diagrams = $subsystem->get_diagrams();
2939 : mkubal 1.166 my @diagram_names;
2940 : olson 1.104
2941 :     if (@diagrams or $can_alter)
2942 :     {
2943 : parrello 1.127 push(@$html, $cgi->hr, $cgi->h2("Subsystem Diagrams"));
2944 : olson 1.104 }
2945 :    
2946 : golsen 1.186 if ( $time_it ) ## time ##
2947 :     { ## time ##
2948 :     push @times, scalar time(); ## time ##
2949 :     push @$html, "<br>dT = @{[$times[-1]-$times[-2]]}, T = @{[$times[-1]-$times[0]]}<br>"; ## time ##
2950 :     } ## time ##
2951 :    
2952 : olson 1.104 if (@diagrams)
2953 :     {
2954 : parrello 1.127 my @hdr = ("Diagram Name");
2955 : olson 1.104
2956 : parrello 1.127 if ($can_alter)
2957 :     {
2958 :     push(@hdr, "Delete", "Rename", "New image", "New html");
2959 :     }
2960 :    
2961 :     my @tbl;
2962 :     for my $dent (@diagrams)
2963 :     {
2964 :     my($id, $name, $link) = @$dent;
2965 : mkubal 1.166 push(@diagram_names,$name);
2966 :    
2967 :     my @row;
2968 : parrello 1.127
2969 :     my $js = "showDiagram('$link', '$id'); return false;";
2970 :    
2971 : paarmann 1.203 if ($subsystem->is_new_diagram($id)) {
2972 :     $link = $subsystem->get_link_for_new_diagram($id);
2973 :     push(@row, qq(<a href="$link" target="_new_diagram">$name</a>));
2974 :     }
2975 :     else {
2976 :     push(@row, qq(<a href="$link" onclick="$js" target="show_ss_diagram_$id">$name</a>));
2977 :     }
2978 : parrello 1.127
2979 :     if ($can_alter)
2980 :     {
2981 :     push(@row, $cgi->checkbox(-name => "diagram_delete_$id", -label => "",
2982 :     -value => undef,
2983 :     -override => 1));
2984 :     push(@row, $cgi->textfield(-name => "diagram_rename_$id",
2985 :     -value => "",
2986 :     -override => 1));
2987 :     push(@row, $cgi->filefield(-name => "diagram_new_image_$id",
2988 :     -value => "",
2989 :     -override => 1,
2990 :     -size => 30));
2991 :     push(@row, $cgi->filefield(-name => "diagram_new_html_$id",
2992 :     -value => "",
2993 :     -override => 1,
2994 :     -size => 30));
2995 :     }
2996 :    
2997 :     push(@tbl, \@row);
2998 :     }
2999 :     push(@$html, &HTML::make_table(\@hdr, \@tbl));
3000 : olson 1.104 }
3001 :    
3002 : mkubal 1.169
3003 : parrello 1.127 my @tbl;
3004 : mkubal 1.156 my @tbl_ma;
3005 : mkubal 1.165 my @tbl_attribute;
3006 : parrello 1.127 push(@tbl, ["Diagram name:", $cgi->textfield(-name => "diagram_new_name",
3007 :     -value => "",
3008 :     -override => 1,
3009 :     -size => 30)]);
3010 :     push(@tbl, ["Diagram image file:", $cgi->filefield(-name => "diagram_image_file",
3011 :     -size => 50)]);
3012 :     push(@tbl, ["Diagram html file:", $cgi->filefield(-name => "diagram_html_file",
3013 :     -size => 50)]);
3014 :     push(@$html, $cgi->h3("Upload a new diagram"));
3015 :     push(@$html, &HTML::make_table(undef, \@tbl));
3016 :     push(@$html, $cgi->submit(-name => 'diagram_action',
3017 :     -label => 'Process diagram actions'));
3018 : mkubal 1.156 push(@tbl_ma, ["Genome ID:", $cgi->textfield(-name => "ma_data_genome_id",
3019 :     -value => "",
3020 :     -override => 1,
3021 :     -size => 30)]);
3022 :     push(@tbl_ma, ["Image File Width:", $cgi->textfield(-name => "image_file_width",
3023 :     -value => "",
3024 :     -override => 1,
3025 :     -size => 30)]);
3026 :    
3027 :     push(@tbl_ma, ["Image File Height:", $cgi->textfield(-name => "image_file_height",
3028 :     -value => "",
3029 :     -override => 1,
3030 :     -size => 30)]);
3031 :     push(@tbl_ma, ["Microarray data file:", $cgi->filefield(-name => "ma_data_file",
3032 :     -size => 50)]);
3033 :     push(@$html, $cgi->h3("View microarray data on diagram"));
3034 :     push(@$html, &HTML::make_table(undef, \@tbl_ma));
3035 :    
3036 :     push(@$html, $cgi->submit(-name => 'ma_data_diagram_action',
3037 :     -label => 'View microarray data on diagram'));
3038 : golsen 1.186
3039 :     my @select_keys = ( undef, sort { uc($a) cmp uc($b) }
3040 :     grep { /(Essential|fitness)/i }
3041 :     $fig->get_peg_keys()
3042 :     );
3043 :    
3044 : mkubal 1.165 push(@tbl_attribute, ["Genome ID:", $cgi->textfield(-name => "att_data_genome_id",
3045 :     -value => "",
3046 :     -override => 1,
3047 :     -size => 30)]);
3048 :     push(@tbl_attribute,["Select attribute", $cgi->popup_menu(-name => 'color_diagram_by_peg_tag', -values=>\@select_keys), $cgi->br]);
3049 : mkubal 1.168 my @values = ("all","essential","nonessential","potential_essential","undetermined");
3050 : mkubal 1.165
3051 : mkubal 1.169 push(@tbl_attribute,["Select diagram", $cgi->popup_menu(-name => 'diagram_to_color', -values=>\@diagram_names), $cgi->br]);
3052 : mkubal 1.165 push(@tbl_attribute,["Select value", $cgi->popup_menu(-name => 'value_to_color', -values=>\@values), $cgi->br]);
3053 :    
3054 :     push(@$html, $cgi->h3("Color Diagram Roles by Essentiality Attribute Value"));
3055 : mkubal 1.173 push(@$html, $cgi->p("red=essential, blue=nonessential, gray=undetermined white=gene with matching value not present"));
3056 : mkubal 1.165 push(@$html, &HTML::make_table(undef, \@tbl_attribute));
3057 :    
3058 :     push(@$html, $cgi->submit(-name => 'paint_diagram_role_by_attribute_value',
3059 :     -label => 'Color Matching Roles'));
3060 : mkubal 1.169
3061 : golsen 1.186 if ( $time_it ) ## time ##
3062 :     { ## time ##
3063 :     push @times, scalar time(); ## time ##
3064 :     push @$html, "<br>dT = @{[$times[-1]-$times[-2]]}, T = @{[$times[-1]-$times[0]]}<br>"; ## time ##
3065 :     } ## time ##
3066 :    
3067 : overbeek 1.115 return @diagrams > 0;
3068 : olson 1.104 }
3069 :    
3070 : overbeek 1.1 sub tree_link {
3071 :     my $target = "window$$";
3072 :     my $url = &FIG::cgi_url . "/subsys.cgi?request=show_tree";
3073 : overbeek 1.147 return "<a href=$url target=$target>Show Phylogenetic Tree</a> (Shows the tree for all organisms in the SEED)";
3074 : overbeek 1.1 }
3075 :    
3076 : golsen 1.91
3077 :     # There is a lot of blood, sweat and tears that go into computing the active
3078 :     # set of rows. This is useful information to have later, when the user can
3079 :     # select genomes to be checked. We will return the genome list as a reference
3080 :     # to a list of [ genomme_number => name ] pairs. -- GJO
3081 :    
3082 : overbeek 1.1 sub format_rows {
3083 : overbeek 1.115 my($fig,$cgi,$html,$subsystem, $tagvalcolor, $have_diagrams) = @_;
3084 : overbeek 1.1 my($i,%alternatives);
3085 : golsen 1.91 my $active_genome_list = [];
3086 : overbeek 1.1
3087 :     my $ignore_alt = $cgi->param('ignore_alt');
3088 :    
3089 :     my $active_subsetC = ($cgi->param('active_subsetC') or $subsystem->get_active_subsetC );
3090 :     my $active_subsetR = ($cgi->param('active_subsetR') or $subsystem->get_active_subsetR );
3091 :    
3092 : redwards 1.59 # RAE:
3093 :     # added this to allow determination of an active_subsetR based on a tag value pair
3094 :     if ($cgi->param('active_key'))
3095 :     {
3096 :     $active_subsetR = $cgi->param('active_key');
3097 : parrello 1.127 my $active_value = undef;
3098 :     $active_value = $cgi->param('active_value') if ($cgi->param('active_value'));
3099 :     $subsystem->load_row_subsets_by_kv($active_subsetR, $active_value);
3100 :     $subsystem->set_active_subsetR($active_subsetR);
3101 : redwards 1.59 }
3102 :    
3103 : overbeek 1.4 my @subsetC = $subsystem->get_subsetC_roles($active_subsetC);
3104 : overbeek 1.1 my %activeC = map { $_ => 1 } @subsetC;
3105 :    
3106 :     my @subsetR = $subsystem->get_subsetR($active_subsetR);
3107 :     my %activeR = map { $_ => 1 } @subsetR;
3108 :    
3109 :     if (! $ignore_alt)
3110 :     {
3111 : parrello 1.127 my $subset;
3112 : overbeek 1.145 foreach $subset (grep { $_ =~ /^\*/ } sort $subsystem->get_subset_namesC)
3113 : parrello 1.127 {
3114 :     my @mem = grep { $activeC{$_} } $subsystem->get_subsetC_roles($subset);
3115 :     if (@mem > 1)
3116 :     {
3117 :     my $mem = [@mem];
3118 :     foreach $_ (@mem)
3119 :     {
3120 : overbeek 1.145 $alternatives{$_}->{$subset} = $mem;
3121 : parrello 1.127 }
3122 :     }
3123 :     }
3124 : overbeek 1.1 }
3125 :    
3126 :     my @in = $subsystem->get_genomes;
3127 : redwards 1.32
3128 : overbeek 1.1 if (@in > 0)
3129 :     {
3130 : overbeek 1.148 my $col_hdrs = ["Genome ID","Organism"];
3131 :    
3132 :     if ($cgi->param('can_alter') && $user && ($user eq $subsystem->get_curator))
3133 :     {
3134 :     my $ssa = $cgi->param('ssa_name');
3135 :     $ssa =~ s/[ \/]/_/g;
3136 : olson 1.195 my $esc_ssa = uri_escape($ssa);
3137 :     push @$col_hdrs, "<a href=\"set_variants.cgi?user=$user&subsystem=$esc_ssa&request=show_variants\">Variant Code</a>";
3138 : overbeek 1.148 }
3139 :     else
3140 :     {
3141 :     push @$col_hdrs, "Variant Code";
3142 :     }
3143 : parrello 1.127
3144 : overbeek 1.148
3145 : parrello 1.127 if ($cgi->param('color_by_ga')) {push @{$col_hdrs}, "Attribute"}
3146 :    
3147 :     my @row_guide = ();
3148 :    
3149 :     # Add pop-up tool tip with role name to abbreviations in column header
3150 :     # (a wonderful suggestion from Carl Woese). -- GJO
3151 :    
3152 : overbeek 1.145 my( $role, %in_col, %set_shown, $abbrev, $mem, $abbrev_html );
3153 : parrello 1.127 foreach $role (grep { $activeC{$_} } $subsystem->get_roles)
3154 :     {
3155 : overbeek 1.145 if ( $_ = $alternatives{ $role } )
3156 :     {
3157 :     my @in = grep { ! $set_shown{$_} } sort keys(%$_);
3158 :     foreach $abbrev (@in)
3159 :     {
3160 :     $set_shown{$abbrev} = 1;
3161 :     $mem = $_->{$abbrev};
3162 :    
3163 :     push( @row_guide, [ map { [ $_, "-" . ($subsystem->get_role_index($_) + 1) ] } @$mem ] );
3164 :     foreach $_ ( @$mem ) { $in_col{ $_ } = 1 }; # Mark the roles that are done
3165 :     my $rolelist = join '<br>', map { substr($_->[1],1) . ". $_->[0]" } @{$row_guide[-1]};
3166 :     $abbrev_html = "<a " . FIGjs::mouseover("Roles of $abbrev", $rolelist, '') . ">$abbrev</a>";
3167 :     push( @$col_hdrs, $abbrev_html );
3168 :     }
3169 :     }
3170 :     elsif (! $in_col{$role})
3171 :     {
3172 :     push( @row_guide, [ [ $role, "" ] ] ); # No suffix on peg number
3173 :     $abbrev = $subsystem->get_role_abbr( $subsystem->get_role_index( $role ) );
3174 :     $abbrev_html = "<a " . FIGjs::mouseover("Role of $abbrev", $role, '') . ">$abbrev</a>";
3175 :     push( @$col_hdrs, $abbrev_html );
3176 :     }
3177 : parrello 1.127 }
3178 :    
3179 :     my $tab = [];
3180 :     my($genome,@pegs,@cells,$set,$peg_set,$pair,$role,$suffix,$row,$peg,$color_of,$cell,%count,$color,@colors);
3181 :    
3182 :     #
3183 :     # Simplified code for checking variants -- GJO
3184 :     # If specific variants are requested, make a hash of those to keep:
3185 :     #
3186 :     my $variant_list = undef;
3187 :     if ( $cgi->param( 'include_these_variants' ) )
3188 :     {
3189 :     $variant_list = { map { ($_, 1) } split( /\s*,\s*/, $cgi->param( 'include_these_variants' ) ) };
3190 :     }
3191 :    
3192 :     foreach $genome (grep { $activeR{$_} } @in)
3193 :     {
3194 :     my($genomeV,$vcodeV,$vcode_value);
3195 : overbeek 1.1
3196 : parrello 1.127 # Get (and if necessary check) the variant code:
3197 : redwards 1.84
3198 : parrello 1.127 $vcode_value = $subsystem->get_variant_code( $subsystem->get_genome_index( $genome ) );
3199 :     next if ( $variant_list && ( ! $variant_list->{ $vcode_value } ) );
3200 : overbeek 1.1
3201 : parrello 1.127 $row = [ $genome, &ext_genus_species($fig,$genome), $vcode_value ];
3202 :     push @$active_genome_list, [ $row->[0], $row->[1] ]; # Save a list of the active genomes
3203 : golsen 1.98
3204 : parrello 1.127 @pegs = ();
3205 :     @cells = ();
3206 :    
3207 :     foreach $set (@row_guide)
3208 :     {
3209 :     $peg_set = [];
3210 :     foreach $pair (@$set)
3211 :     {
3212 :     ($role,$suffix) = @$pair;
3213 :     foreach $peg ($subsystem->get_pegs_from_cell($genome,$role))
3214 :     {
3215 :     push(@$peg_set,[$peg,$suffix]);
3216 :     }
3217 :     }
3218 :     push(@pegs,map { $_->[0] } @$peg_set);
3219 :     push(@cells,$peg_set);
3220 :     }
3221 :     $color_of = &group_by_clusters($fig,\@pegs);
3222 :     # RAE added a new call to get tag/value pairs
3223 :     # Note that $color_of is not overwritten.
3224 :     my $superscript;
3225 :     if ($cgi->param('color_by_ga'))
3226 :     {
3227 : redwards 1.52 # add colors based on the genome attributes
3228 : parrello 1.127 # get the value
3229 :     my $ga=$cgi->param('color_by_ga');
3230 :     my $valuetype=$fig->guess_value_format($ga);
3231 :     my @array=$fig->get_attributes($genome, $ga);
3232 :     unless ($array[0]) {$array[0]=[]}
3233 :     # for the purposes of this page, we are going to color on the
3234 :     # value of the last attribute
3235 :     my ($gotpeg, $gottag, $value, $url)=@{$array[0]};
3236 : redwards 1.52 if (defined $value) # we don't want to color undefined values
3237 : parrello 1.127 {
3238 :     my @color=&cool_colors();
3239 :     my $colval; # what we are basing the color on.
3240 :     if ($valuetype->[0] eq "float")
3241 :     {
3242 :     # Initially spllit numbers into groups of 10.
3243 :     # $valuetype->[2] is the maximum number for this value
3244 :     # but I don't like this
3245 :     # $colval = int($value/$valuetype->[2]*10);
3246 :    
3247 :     # we want something like 0-1, 1-2, 2-3, 3-4 as the labels.
3248 :     # so we will do it in groups of ten
3249 :     my ($type, $min, $max)=@$valuetype;
3250 :     for (my $i=$min; $i<$max; $i+=$max/10) {
3251 :     if ($value >= $i && $value < $i+$max/10) {$colval = $i . "-" . ($i+($max/10))}
3252 :     }
3253 :     }
3254 :     else {$colval=$value}
3255 : redwards 1.58
3256 : parrello 1.127 if (!$tagvalcolor->{$colval}) {
3257 :     # figure out the highest number used in the array
3258 :     $tagvalcolor->{$colval}=0;
3259 :     foreach my $t (keys %$tagvalcolor) {
3260 :     ($tagvalcolor->{$t} > $tagvalcolor->{$colval}) ? $tagvalcolor->{$colval}=$tagvalcolor->{$t} : 1;
3261 :     }
3262 :     $tagvalcolor->{$colval}++;
3263 :     }
3264 :     # RAE Add a column for the description
3265 :     splice @$row, 3, 0, $colval;
3266 :    
3267 :     foreach my $cell (@cells) {
3268 :     foreach $_ (@$cell)
3269 :     {
3270 :     $color_of->{$_->[0]} = $color[$tagvalcolor->{$colval}]
3271 :     }
3272 :     }
3273 :     }
3274 :     else
3275 :     {
3276 :     # RAE Add a column for the description
3277 :     splice @$row, 3, 0, " &nbsp; ";
3278 :     }
3279 :     }
3280 : redwards 1.54 if ($cgi->param("color_by_peg_tag"))
3281 : parrello 1.127 {
3282 :     ($color_of, $superscript, $tagvalcolor) = color_by_tag($fig, \@pegs, $color_of, $tagvalcolor, $cgi->param("color_by_peg_tag"));
3283 :     }
3284 :     foreach $cell ( @cells ) # $cell = [peg, suffix]
3285 :     {
3286 :     # Deal with the trivial case (no pegs) at the start
3287 :    
3288 :     if ( ! @$cell )
3289 :     {
3290 :     # Push an empty cell onto the row
3291 :    
3292 : overbeek 1.158 push @$row, [" &nbsp; ", "td bgcolor='#FFFFFF'"];
3293 : parrello 1.127 next;
3294 :     }
3295 :    
3296 :     # Figure out html text for each peg and cluster by color.
3297 :    
3298 :     my ( $peg, $suffix, $txt, $color );
3299 :     my @colors = ();
3300 :     my %text_by_color; # Gather like-colored peg text
3301 :     foreach ( @$cell )
3302 :     {
3303 :     ( $peg, $suffix ) = @$_;
3304 :     # Hyperlink each peg, and add its suffix:
3305 :     $txt = ( $cgi->param('ext_ids') ? external_id($fig,$cgi,$peg)
3306 :     : HTML::fid_link($cgi,$peg, "local") )
3307 :     . ( $suffix ? $suffix : '' );
3308 :     $color = $color_of->{ $peg };
3309 :     defined( $text_by_color{ $color } ) or push @colors, $color;
3310 :     push @{ $text_by_color{ $color } }, $txt;
3311 :     }
3312 :     my $ncolors = @colors;
3313 :    
3314 :     # Join text strings within a color (and remove last comma):
3315 :    
3316 :     my @str_by_color = map { [ $_, join( ', ', @{ $text_by_color{$_} }, '' ) ] } @colors;
3317 :     $str_by_color[-1]->[1] =~ s/, $//;
3318 :    
3319 :     # Build the "superscript" string:
3320 :    
3321 :     my $sscript = "";
3322 :     if ( $superscript && @$cell )
3323 :     {
3324 :     my ( %sscript, $ss );
3325 :     foreach my $cv ( @$cell ) # Should this be flattened across all pegs?
3326 :     {
3327 :     next unless ( $ss = $superscript->{ $cv->[0] } );
3328 :     # my %flatten = map { ( $_, 1 ) } @$ss;
3329 :     # $sscript{ join ",", sort { $a <=> $b } keys %flatten } = 1; # string of all values for peg
3330 :     foreach ( @$ss ) { $sscript{ $_ } = 1 }
3331 :     }
3332 :     if (scalar keys %sscript) # order by number, and format
3333 :     {
3334 :     my @ss = map { $_->[0] }
3335 :     sort { $a->[1] <=> $b->[1] }
3336 :     map { my ( $num ) = $_ =~ /\>(\d+)\</; [ $_, $num || 0 ] } keys %sscript;
3337 :     $sscript = "&nbsp;<sup>[" . join( ", ", @ss ) . "]</sup>"
3338 :     }
3339 :     }
3340 :    
3341 :     my $cell_data;
3342 :    
3343 :     # If there is one color, just write a unicolor cell.
3344 :    
3345 :     if ( $ncolors == 1 )
3346 :     {
3347 :     my ( $color, $txt ) = @{ shift @str_by_color };
3348 : overbeek 1.158 #$cell_data = qq(\@bgcolor="$color":) . $txt . $sscript;
3349 :     # using this format allows other things (like excel writing to easily parse out data and formatting)
3350 :     # the cell is a reference to an array. The first element is the data, and the second the formatting options
3351 :     $cell_data = [$txt . $sscript, "td bgcolor=\"$color\""];
3352 : parrello 1.127 }
3353 :    
3354 :     # Otherwise, write pegs into a subtable with one cell per color.
3355 : overbeek 1.135 # RAE: used style for this rather than a separate table per cell. All the small tables are crap
3356 :     # for rendering, especially if you have a lot of pegs in a ss
3357 : parrello 1.127
3358 : overbeek 1.135 elsif(0)
3359 : parrello 1.127 {
3360 : overbeek 1.135 # original way
3361 : parrello 1.127 $cell_data = '<table><tr valign=bottom>'
3362 :     . join( '', map { ( $color, $txt ) = @$_ ; qq(<td bgcolor="$color">$txt</td>) } @str_by_color )
3363 :     . ( $sscript ? "<td>$sscript</td>" : '' )
3364 :     . '</tr></table>';
3365 :     }
3366 :    
3367 : overbeek 1.135 else
3368 :     {
3369 :     $cell_data = join( '', map { ( $color, $txt ) = @$_ ; qq(<span style="background-color: $color">$txt</span>) } @str_by_color )
3370 :     . ( $sscript ? $sscript : '' );
3371 :     }
3372 :    
3373 :    
3374 :    
3375 : parrello 1.127 # Push the cell data onto the row:
3376 :    
3377 :     push(@$row, $cell_data);
3378 :     }
3379 :     push(@$tab,$row);
3380 :     }
3381 :    
3382 :    
3383 : golsen 1.183 my $sort = $cgi->param('sort') || 'by_phylo';
3384 :     if ($sort eq "by_pattern")
3385 : parrello 1.127 {
3386 : golsen 1.183 my @tmp = ();
3387 :     my $row;
3388 :     foreach $row (@$tab)
3389 :     {
3390 :     my @var = ();
3391 :     my $i;
3392 :     for ($i=3; ($i < @$row); $i++)
3393 : parrello 1.127 {
3394 : golsen 1.183 if (ref($row->[$i]) eq "ARRAY")
3395 :     {
3396 :     push(@var, ($row->[$i]->[0] =~ /\|/) ? 1 : 0);
3397 :     }
3398 :     else
3399 : parrello 1.127 {
3400 : golsen 1.183 push(@var, ($row->[$i] =~ /\|/) ? 1 : 0);
3401 : parrello 1.127 }
3402 :     }
3403 : golsen 1.183 push(@tmp,[join("",@var),$row]);
3404 : parrello 1.127 }
3405 : golsen 1.183 $tab = [map { $_->[1] } sort { $a->[0] cmp $b->[0] } @tmp];
3406 :     }
3407 :     elsif ($sort eq "by_phylo")
3408 :     {
3409 :     $tab = [map { $_->[0] }
3410 :     sort { ($a->[1] cmp $b->[1]) or ($a->[0]->[1] cmp $b->[0]->[1]) }
3411 :     map { [$_, $fig->taxonomy_of($_->[0])] }
3412 :     @$tab];
3413 :     }
3414 :     elsif ($sort eq "by_tax_id")
3415 :     {
3416 :     $tab = [sort { $a->[0] <=> $b->[0] } @$tab];
3417 :     }
3418 :     elsif ($sort eq "alphabetic")
3419 :     {
3420 :     $tab = [sort { ($a->[1] cmp $b->[1]) or ($a->[0] <=> $b->[0]) } @$tab];
3421 :     }
3422 :     elsif ($sort eq "by_variant")
3423 :     {
3424 : overbeek 1.214 $tab = [sort { ($a->[2] cmp $b->[2]) or ($a->[1] cmp $b->[1]) } @$tab];
3425 : parrello 1.127 }
3426 : redwards 1.121
3427 : parrello 1.127 foreach $row (@$tab)
3428 :     {
3429 :     next if ($row->[2] == -1 && !$cgi->param('show_minus1')); # RAE don't show -1 variants if checked
3430 :     my($genomeV,$vcodeV,$vcode_value);
3431 :     $genome = $row->[0];
3432 :     $vcode_value = $row->[2];
3433 :     if ($cgi->param('can_alter'))
3434 :     {
3435 :     $genomeV = $cgi->textfield(-name => "genome$genome", -size => 15, -value => $genome, -override => 1);
3436 :     $vcodeV = $cgi->textfield(-name => "vcode$genome", -value => $vcode_value, -size => 10);
3437 :     }
3438 :     else
3439 :     {
3440 :     push(@$html,$cgi->hidden(-name => "genome$genome", -value => $genome, -override => 1),
3441 :     $cgi->hidden(-name => "vcode$genome", -value => $vcode_value), "\n");
3442 :     $genomeV = $genome;
3443 :     $vcodeV = $vcode_value;
3444 :     }
3445 :    
3446 :     $row->[0] = $genomeV;
3447 :     $row->[2] = $vcodeV;
3448 : overbeek 1.1
3449 : parrello 1.127 #
3450 :     # JS link for coloring diagrams.
3451 :     #
3452 : redwards 1.121
3453 : parrello 1.127 if ($have_diagrams)
3454 :     {
3455 : mkubal 1.165 #my @roles = ("aspA");
3456 :     #my $colorJS = qq(<a href="" onclick="colorAttributeValue(@roles); return false;">Color</a>);
3457 : parrello 1.127 my $colorJS = qq(<a href="" onclick="colorGenome('$genome'); return false;">Color</a>);
3458 :     $row->[0] .= " " . $colorJS;
3459 :     }
3460 :     }
3461 :    
3462 :     my $tab1 = [];
3463 :    
3464 :     foreach $row (@$tab)
3465 :     {
3466 :     next if ($row->[2] == -1 && !$cgi->param('show_minus1')); # RAE don't show -1 variants if checked
3467 :     if ((@$tab1 > 0) && ((@$tab1 % 10) == 0))
3468 :     {
3469 : overbeek 1.158 #push(@$tab1,[map { "<b>$_</b>" } @$col_hdrs]) ;
3470 :     # set this up using the table format feature so that we know it is a header
3471 :     push(@$tab1,[map { [$_, "th"] } @$col_hdrs]) ;
3472 : parrello 1.127 }
3473 :     push(@$tab1,$row);
3474 :     }
3475 :    
3476 : overbeek 1.163 my %options; if ($cgi->param("create_excel")) {%options=(excelfile=>$cgi->param('ssa_name'), no_excel_link=>1)}
3477 :     $options{"class"}="white";
3478 :     push(@$html,$cgi->div({class=>"spreadsheet"}, &HTML::make_table($col_hdrs,$tab1,"Basic Spreadsheet", %options), $cgi->br),
3479 : parrello 1.127 $cgi->hr
3480 :     );
3481 :    
3482 :    
3483 :     my %sortmenu = (
3484 : golsen 1.123 unsorted => "None",
3485 :     alphabetic => "Alphabetical",
3486 : parrello 1.127 by_pattern => "Patterns",
3487 :     by_phylo => "Phylogeny",
3488 :     by_tax_id => "Taxonomy",
3489 :     by_variant => "Variant Code",
3490 : redwards 1.121 );
3491 : golsen 1.123
3492 : parrello 1.127 push @$html, "Sort spreadsheet genomes by ",
3493 : golsen 1.183 $cgi->popup_menu( -name => 'sort',
3494 :     -values => [sort keys %sortmenu],
3495 :     -labels => \%sortmenu,
3496 :     -default => $sort,
3497 :     -override => 1
3498 : parrello 1.127 );
3499 : mkubal 1.47
3500 :     push(@$html,'<br><br>Enter comma-separated list of variants to display in spreadsheet<br>',
3501 :     $cgi->textfield(-name => "include_these_variants", -size => 50)
3502 : parrello 1.127 );
3503 : mkubal 1.47 }
3504 : redwards 1.52
3505 : golsen 1.186 if ( $time_it ) ## time ##
3506 :     { ## time ##
3507 :     push @times, scalar time(); ## time ##
3508 :     push @$html, "<br>dT = @{[$times[-1]-$times[-2]]}, T = @{[$times[-1]-$times[0]]}<br>"; ## time ##
3509 :     } ## time ##
3510 :    
3511 : redwards 1.52 # add an explanation for the colors if we want one.
3512 :     if ($cgi->param('color_by_ga'))
3513 :     {
3514 : redwards 1.59 push(@$html, &HTML::make_table(undef,&describe_colors($tagvalcolor),"Color Descriptions<br><small>Link limits display to those organisms</small>"));
3515 : redwards 1.52 }
3516 : golsen 1.91
3517 :     return $active_genome_list; # [ [ id1, gs1 ], [ id2, gs2 ], ... ]
3518 : overbeek 1.1 }
3519 :    
3520 : golsen 1.91
3521 : overbeek 1.1 sub group_by_clusters {
3522 :     my($fig,$pegs) = @_;
3523 :     my($peg,@clusters,@cluster,@colors,$color,%seen,%conn,$x,$peg1,@pegs,$i);
3524 :    
3525 :     my $color_of = {};
3526 :     foreach $peg (@$pegs) { $color_of->{$peg} = '#FFFFFF' }
3527 :    
3528 :     if ($cgi->param('show_clusters'))
3529 :     {
3530 : parrello 1.127 @pegs = keys(%$color_of); # Use of keys makes @pegs entries unique
3531 : overbeek 1.144 @clusters = $fig->compute_clusters(\@pegs,undef,5000);
3532 : parrello 1.127 @colors = &cool_colors();
3533 :    
3534 :     if (@clusters > @colors) { splice(@clusters,0,(@clusters - @colors)) } # make sure we have enough colors
3535 : overbeek 1.1
3536 : parrello 1.127 my($cluster);
3537 :     foreach $cluster (@clusters)
3538 :     {
3539 : redwards 1.179 # RAE only color pegs if we have > 1 functional role involved in the cluster
3540 :     my %countfunctions=map{(scalar $fig->function_of($_)=>1)} @$cluster;
3541 :     next unless (scalar(keys %countfunctions) > 1);
3542 :    
3543 : parrello 1.127 $color = shift @colors;
3544 :     foreach $peg (@$cluster)
3545 :     {
3546 :     $color_of->{$peg} = $color;
3547 :     }
3548 :     }
3549 : overbeek 1.1 }
3550 :     return $color_of;
3551 :     }
3552 :    
3553 : redwards 1.32
3554 :     =head1 color_by_tag
3555 :    
3556 :     Change the color of cells by the pir superfamily. This is taken from the key/value pair
3557 :     Note that we will not change the color if $cgi->param('show_clusters') is set.
3558 :    
3559 :     This is gneric and takes the following arguments:
3560 :     fig,
3561 :     pointer to list of pegs,
3562 :     pointer to hash of colors by peg,
3563 :     pointer to a hash that retains numbers across rows. The number is based on the value.
3564 :     tag to use in encoding
3565 :    
3566 :     eg. ($color_of, $superscript, $tagvalcolor) = color_by_tag($fig, $pegs, $color_of, $tagvalcolor, "PIRSF");
3567 :    
3568 :     =cut
3569 :    
3570 :     sub color_by_tag {
3571 : redwards 1.35 # RAE added this so we can color individual cells across a column
3572 : redwards 1.32 my ($fig, $pegs, $color_of, $tagvalcolor, $want)=@_;
3573 :     # figure out the colors and the superscripts for the pirsf
3574 :     # superscript will be a number
3575 :     # color will be related to the number somehow
3576 :     # url will be the url for each number
3577 :     my $number; my $url;
3578 : redwards 1.33 my $count=0;
3579 : redwards 1.32 #count has to be the highest number if we increment it
3580 : redwards 1.33 foreach my $t (keys %$tagvalcolor) {($tagvalcolor->{$t} > $count) ? $count=$tagvalcolor->{$t} : 1}
3581 :     $count++; # this should now be the next number to assign
3582 : redwards 1.32 foreach my $peg (@$pegs) {
3583 : redwards 1.54 next unless (my @attr=$fig->get_attributes($peg));
3584 : redwards 1.32 foreach my $attr (@attr) {
3585 : redwards 1.54 next unless (defined $attr);
3586 : redwards 1.67 my ($gotpeg, $tag, $val, $link)=@$attr;
3587 : redwards 1.32 next unless ($tag eq $want);
3588 :     if ($tagvalcolor->{$val}) {
3589 :     $number->{$peg}=$tagvalcolor->{$val};
3590 : overbeek 1.129 push (@{$url->{$peg}}, "<a " . FIGjs::mouseover($tag, $val) . " href='$link'>" . $number->{$peg} . "</a>");
3591 : redwards 1.32 }
3592 :     else {
3593 :     $number->{$peg}=$tagvalcolor->{$val}=$count++;
3594 : overbeek 1.129 push (@{$url->{$peg}}, "<a " . FIGjs::mouseover($tag, $val) . "href='$link'>" . $number->{$peg} . "</a>");
3595 : redwards 1.32 }
3596 :     #### This is a botch at the moment. I want PIRSF to go to my page that I am working on, not PIR
3597 :     #### so I am just correcting those. This is not good, and I should change the urls in the tag/value pairs or something
3598 :     if ($want eq "PIRSF") {
3599 : redwards 1.66 pop @{$url->{$peg}};
3600 : redwards 1.32 $val =~ /(^PIRSF\d+)/;
3601 : redwards 1.66 push (@{$url->{$peg}}, $cgi->a({href => "pir.cgi?&user=$user&pirsf=$1"}, $number->{$peg}));
3602 : redwards 1.32 }
3603 :     }
3604 :     }
3605 :    
3606 :    
3607 :     # if we want to assign some colors, lets do so now
3608 : redwards 1.52 my @colors = &cool_colors();
3609 : redwards 1.32 unless ($cgi->param('show_clusters')) {
3610 :     foreach my $peg (@$pegs) { $color_of->{$peg} = '#FFFFFF' }
3611 :     foreach my $peg (keys %$number) {
3612 :     # the color is going to be the location in @colors
3613 :     unless ($number->{$peg} > @colors) {$color_of->{$peg}=$colors[$number->{$peg}-1]}
3614 :     }
3615 :     }
3616 :     return ($color_of, $url, $tagvalcolor);
3617 :     }
3618 :    
3619 :    
3620 : overbeek 1.1 sub format_ssa_table {
3621 :     my($cgi,$html,$user,$ssaP) = @_;
3622 :     my($ssa,$curator);
3623 :     my($url1,$link1);
3624 :    
3625 :     my $can_alter = $cgi->param('can_alter');
3626 :     push(@$html, $cgi->start_form(-action => "subsys.cgi",
3627 : parrello 1.127 -method => 'post'),
3628 :     $cgi->hidden(-name => 'user', -value => $user, -override => 1),
3629 :     $cgi->hidden(-name => 'can_alter', -value => $can_alter, -override => 1),
3630 :     $cgi->hidden(-name => 'request', -value => 'delete_or_export_ssa', -override => 1)
3631 :     );
3632 : overbeek 1.1 push(@$html,"<font size=\"+2\">Please do not ever edit someone else\'s spreadsheet (by using their
3633 : parrello 1.127 user ID), and <b>never open multiple windows to
3634 : overbeek 1.1 process the same spreadsheet</b></font>. It is, of course, standard practice to open a subsystem
3635 :     spreadsheet and then to have multiple other SEED windows to access data and modify annotations. Further,
3636 : parrello 1.127 you can access someone else's subsystem spreadsheet using your ID (which will make it impossible
3637 : overbeek 1.1 for you to edit the spreadsheet).
3638 : redwards 1.46 Just do not open the same subsystem spreadsheet for editing in multiple windows simultaneously.
3639 : parrello 1.127 A gray color means that the subsystem has no genomes attached to it. Go ahead and make these your own\n",
3640 :     "<a href=\"Html/conflict_resolution.html\" class=\"help\" target=\"help\">Help on conflict resolution</a>\n",
3641 :     $cgi->br,
3642 :     $cgi->br
3643 : overbeek 1.1 );
3644 :    
3645 : redwards 1.65 # RAE: removed this from above push because VV want's it kept secret
3646 : parrello 1.127 # "<a href=\"/FIG/Html/seedtips.html#change_ownership\" class=\"help\" target=\"help\">Help on changing subsystem ownership</a>\n",
3647 : redwards 1.65
3648 : redwards 1.81 # RAE: Added a new cgi param colsort for sort by column. This url will just recall the script with username to allow column sorting.
3649 : redwards 1.88 # RAE: Added a column to allow indexing of one subsystem. This is also going to be used in the renaming of a subsystem, too
3650 : redwards 1.81
3651 : overbeek 1.1 my $col_hdrs = [
3652 : overbeek 1.128 "<a href='" . &FIG::cgi_url . "/subsys.cgi?user=$user&request=manage_ss'>Name</a><br><small>Sort by Subsystem</small>",
3653 :     "<a href='" . &FIG::cgi_url . "/subsys.cgi?user=$user&colsort=curator&request=manage_ss'>Curator</a><br><small>Sort by curator</small>",
3654 : redwards 1.176 "NMPDR<br>Subsystem", "Distributable<br>Subsystem", "OK to Automatically<br>Extend", "Exchangable","Version",
3655 : parrello 1.127 "Reset to Previous Timestamp","Delete",
3656 :     "Export Full Subsystem","Export Just Assignments", "Publish to Clearinghouse", "Reindex Subsystem",
3657 :     ];
3658 : overbeek 1.1 my $title = "Existing Subsystem Annotations";
3659 :     my $tab = [];
3660 : overbeek 1.139 my $userss; # this is a reference to a hash of all the subsystems the user can edit.
3661 : overbeek 1.1 foreach $_ (@$ssaP)
3662 :     {
3663 : parrello 1.127 my($publish_checkbox, $index_checkbox);
3664 :     ($ssa,$curator) = @$_;
3665 : overbeek 1.1
3666 : parrello 1.127 my $esc_ssa = uri_escape($ssa);
3667 : overbeek 1.139 if ($curator eq $user) {push @$userss, $ssa}
3668 : olson 1.74
3669 : parrello 1.127 my($url,$link);
3670 :     if ((-d "$FIG_Config::data/Subsystems/$ssa/Backup") && ($curator eq $user))
3671 :     {
3672 :     $url = &FIG::cgi_url . "/subsys.cgi?user=$user&ssa_name=$esc_ssa&request=reset";
3673 :     $link = "<a href=$url>reset</a>";
3674 :     }
3675 :     else
3676 :     {
3677 :     $link = "";
3678 :     }
3679 :    
3680 : overbeek 1.139 # do we want to allow this in the NMPDR
3681 :     my $nmpdr;
3682 :     if ($curator eq $user)
3683 :     {
3684 : overbeek 1.140 $nmpdr=$cgi->checkbox(-name=> "nmpdr_ss", -value=>$ssa, -label=>"", -checked=>$fig->nmpdr_subsystem($ssa));
3685 :     }
3686 :     # do we want to allow this to be shared
3687 :     my $dist;
3688 :     if ($curator eq $user)
3689 :     {
3690 : overbeek 1.142 $dist=$cgi->checkbox(-name=> "dist_ss", -value=>$ssa, -label=>"", -checked=>$fig->distributable_subsystem($ssa));
3691 : overbeek 1.139 }
3692 : redwards 1.176
3693 :     # do we want to allow this to be automatically updated
3694 :     my $auto_update;
3695 :     if ($curator eq $user)
3696 :     {
3697 :     $auto_update=$cgi->checkbox(-name=> "auto_update_ok", -value=>$ssa, -label=>"", -checked=>$fig->ok_to_auto_update_subsys($ssa));
3698 :     }
3699 : overbeek 1.139
3700 : parrello 1.127 if (($fig->is_exchangable_subsystem($ssa)) && ($curator eq $user))
3701 :     {
3702 :     $url1 = &FIG::cgi_url . "/subsys.cgi?user=$user&ssa_name=$esc_ssa&request=make_unexchangable";
3703 :     $link1 = "Exchangable<br><a href=$url1>Make not exchangable</a>";
3704 :     }
3705 :     elsif ($curator eq $user)
3706 :     {
3707 :     $url1 = &FIG::cgi_url . "/subsys.cgi?user=$user&ssa_name=$esc_ssa&request=make_exchangable";
3708 :     $link1 = "Not exchangable<br><a href=$url1>Make exchangable</a>";
3709 :     }
3710 :     else
3711 :     {
3712 :     $link1 = "";
3713 :     }
3714 :    
3715 :     #
3716 :     # Only allow publish for subsystems we are curating?
3717 :     #
3718 :     if ($curator eq $user)
3719 :     {
3720 :     $publish_checkbox = $cgi->checkbox(-name => "publish_to_clearinghouse",
3721 :     -value => $ssa,
3722 :     -label => "Publish");
3723 :    
3724 :     }
3725 :    
3726 : redwards 1.217 # Allow the user to set the variants
3727 :     my $set_variant_link = " &nbsp; ";
3728 :     if ($curator eq $user)
3729 :     {
3730 :     $set_variant_link = $cgi->a({href => "set_variants.cgi?subsystem=$esc_ssa&user=$user&request=show_variants"}, "Set variants");
3731 :     }
3732 :    
3733 : parrello 1.127 #
3734 :     # Initially I am going to allow indexing of any subsystem since you may want to index it to allow
3735 :     # better searhing on a local system
3736 :     $index_checkbox=$cgi->checkbox(-name => "index_subsystem", -value=> $ssa, -label => "Index");
3737 :    
3738 :     # RAE color the background if the subsystem is empty
3739 :     # this uses a modification to HTML.pm that I made earlier to accept refs to arrays as cell data
3740 :     my $cell1=&ssa_link($fig,$ssa,$user);
3741 :     #unless (scalar $fig->subsystem_to_roles($ssa)) {$cell1 = [$cell1, 'td bgcolor="Dark grey"']} ## THIS IS DOG SLOW, BUT WORKS
3742 :     #unless (scalar $fig->get_subsystem($ssa)->get_genomes()) {$cell1 = [$cell1, 'td bgcolor="#A9A9A9"']} ## WORKS PERFECTLY, but sort of slow
3743 :     unless (scalar @{$fig->subsystem_genomes($ssa, 1)}) {$cell1 = [$cell1, 'td bgcolor="silver"']}
3744 :    
3745 :     push(@$tab,[
3746 :     $cell1,
3747 :     $curator,
3748 : overbeek 1.139 $nmpdr,
3749 : overbeek 1.140 $dist,
3750 : redwards 1.176 $auto_update,
3751 : parrello 1.127 $link1,
3752 : redwards 1.217 $set_variant_link,
3753 : parrello 1.127 $fig->subsystem_version($ssa),
3754 :     $link,
3755 :     ($curator eq $user) ? $cgi->checkbox(-name => "delete", -value => $ssa) : "",
3756 :     $cgi->checkbox(-name => "export", -value => $ssa, -label => "Export full"),
3757 :     $cgi->checkbox(-name => "export_assignments", -value => $ssa, -label => "Export assignments"),
3758 :     $publish_checkbox, $index_checkbox,
3759 :     ]);
3760 : overbeek 1.1 }
3761 :     push(@$html,
3762 : parrello 1.127 &HTML::make_table($col_hdrs,$tab,$title),
3763 : overbeek 1.139 $cgi->hidden(-name => "users_ss",
3764 :     -value=> $userss),
3765 :     $cgi->hidden(-name => "manage"),
3766 : redwards 1.176 $cgi->submit(-name => "save_clicks",
3767 :     -label => "Process Choices"),
3768 : parrello 1.127 $cgi->submit(-name => 'delete_export',
3769 :     -label => 'Process marked deletions and exports'),
3770 :     $cgi->submit(-name => 'publish',
3771 :     -label => "Publish marked subsystems"),
3772 : redwards 1.88 $cgi->submit(-name => 'reindex',
3773 : parrello 1.127 -label => "Reindex selected subsystems"),
3774 :     $cgi->end_form
3775 :     );
3776 : overbeek 1.1 }
3777 :    
3778 : redwards 1.25 # RAE: I think this should be placed as a method in
3779 :     # Subsystems.pm and called subsystems I know about or something.
3780 :     # Cowardly didn't do though :-)
3781 : overbeek 1.1 sub existing_subsystem_annotations {
3782 : overbeek 1.51 my($fig) = @_;
3783 : overbeek 1.1 my($ssa,$name);
3784 :     my @ssa = ();
3785 :     if (opendir(SSA,"$FIG_Config::data/Subsystems"))
3786 :     {
3787 : overbeek 1.154 @ssa = map { $ssa = $_; $name = $ssa; $ssa =~ s/[ \/]/_/g; [$name,&subsystem_curator($ssa)] } grep { $_ !~ /^\./ } readdir(SSA);
3788 : parrello 1.127 closedir(SSA);
3789 : overbeek 1.1 }
3790 : redwards 1.81 # RAE Adding sort of current subsystems
3791 :     if ($cgi->param('colsort') && $cgi->param('colsort') eq "curator")
3792 :     {
3793 :     # sort by the ss curator
3794 :     return sort { (lc $a->[1]) cmp (lc $b->[1]) || (lc $a->[0]) cmp (lc $b->[0]) } @ssa;
3795 :     }
3796 :     else
3797 :     {
3798 :     return sort { (lc $a->[0]) cmp (lc $b->[0]) } @ssa;
3799 :     }
3800 : overbeek 1.1 }
3801 :    
3802 :     sub ssa_link {
3803 : overbeek 1.51 my($fig,$ssa,$user) = @_;
3804 : overbeek 1.1 my $name = $ssa; $name =~ s/_/ /g;
3805 : dejongh 1.211 my $target = "window$$.$ssa";
3806 : overbeek 1.9
3807 : overbeek 1.80 my $check;
3808 : overbeek 1.154 my $can_alter = $check = &subsystem_curator($ssa) eq $user;
3809 : redwards 1.108 my $sort=$cgi->param('sort');
3810 :     my $show_clusters=$cgi->param('show_clusters');
3811 : redwards 1.121 my $minus=$cgi->param('show_minus1');
3812 : redwards 1.108
3813 : olson 1.74 my $esc_ssa = uri_escape($ssa);
3814 : redwards 1.121 my $url = &FIG::cgi_url . "/subsys.cgi?user=$user&ssa_name=$esc_ssa&request=show_ssa&can_alter=$can_alter&check=$check&sort=$sort&show_clusters=$show_clusters&show_minus1=$minus";
3815 : overbeek 1.1 return "<a href=$url target=$target>$name</a>";
3816 :     }
3817 :    
3818 :     sub log_update {
3819 :     my($ssa,$user) = @_;
3820 :    
3821 :     $ssa =~ s/[ \/]/_/g;
3822 :    
3823 :     if (open(LOG,">>$FIG_Config::data/Subsystems/$ssa/curation.log"))
3824 :     {
3825 : parrello 1.127 my $time = time;
3826 :     print LOG "$time\t$user\tupdated\n";
3827 :     close(LOG);
3828 : overbeek 1.1 }
3829 :     else
3830 :     {
3831 : parrello 1.127 print STDERR "failed to open $FIG_Config::data/Subsystems/$ssa/curation.log\n";
3832 : overbeek 1.1 }
3833 :     }
3834 :    
3835 :     sub export {
3836 :     my($fig,$cgi,$ssa) = @_;
3837 :     my($line);
3838 :    
3839 :     my ($exportable,$notes) = $fig->exportable_subsystem($ssa);
3840 :     foreach $line (@$exportable,@$notes)
3841 :     {
3842 : parrello 1.127 print $line;
3843 : overbeek 1.1 }
3844 :     }
3845 : parrello 1.127
3846 : overbeek 1.1 sub export_assignments {
3847 :     my($fig,$cgi,$ssa) = @_;
3848 :     my(@roles,$i,$entry,$id,$user);
3849 :    
3850 : redwards 1.121 if ($user && open(SSA,"<$FIG_Config::data/Subsystems/$ssa/spreadsheet"))
3851 : overbeek 1.1 {
3852 : parrello 1.127 $user =~ s/^master://;
3853 :     &FIG::verify_dir("$FIG_Config::data/Assignments/$user");
3854 : overbeek 1.154 my $who = &subsystem_curator($ssa);
3855 : parrello 1.127 my $file = &FIG::epoch_to_readable(time) . ":$who:generated_from_subsystem_$ssa";
3856 :    
3857 :     if (open(OUT,">$FIG_Config::data/Assignments/$user/$file"))
3858 :     {
3859 :     while (defined($_ = <SSA>) && ($_ !~ /^\/\//))
3860 :     {
3861 :     chop;
3862 :     push(@roles,$_);
3863 :     }
3864 :     while (defined($_ = <SSA>) && ($_ !~ /^\/\//)) {}
3865 :     while (defined($_ = <SSA>))
3866 :     {
3867 :     chop;
3868 :     my @flds = split(/\t/,$_);
3869 :     my $genome = $flds[0];
3870 :     for ($i=2; ($i < @flds); $i++)
3871 :     {
3872 :     my @entries = split(/,/,$flds[$i]);
3873 :     foreach $id (@entries)
3874 :     {
3875 :     my $peg = "fig|$genome.peg.$id";
3876 :     my $func = $fig->function_of($peg);
3877 :     print OUT "$peg\t$func\n";
3878 :     }
3879 :     }
3880 :     }
3881 :     close(OUT);
3882 :     }
3883 :     close(SSA);
3884 : overbeek 1.1 }
3885 :     }
3886 :    
3887 :     sub format_missing {
3888 :     my($fig,$cgi,$html,$subsystem) = @_;
3889 :     my($org,$abr,$role,$missing);
3890 :    
3891 :     my $active_subsetC = ($cgi->param('active_subsetC') or $subsystem->get_active_subsetC );
3892 :     my $active_subsetR = ($cgi->param('active_subsetR') or $subsystem->get_active_subsetR );
3893 :    
3894 : overbeek 1.4 my @subsetC = $subsystem->get_subsetC_roles($active_subsetC);
3895 : overbeek 1.1 my %activeC = map { $_ => 1 } @subsetC;
3896 :    
3897 :     my @subsetR = $subsystem->get_subsetR($active_subsetR);
3898 :    
3899 : overbeek 1.145 my @alt_sets = grep { ($_ =~ /^\*/) } sort $subsystem->get_subset_namesC;
3900 : overbeek 1.1 my($set,$col,%in);
3901 :     foreach $set (@alt_sets)
3902 :     {
3903 : parrello 1.127 my @mem = grep { $activeC{$_} } $subsystem->get_subsetC_roles($set);
3904 :     foreach $col (@mem)
3905 :     {
3906 :     $in{$col} = $set;
3907 :     }
3908 : overbeek 1.1 }
3909 :     push(@$html,$cgi->h1('To Check Missing Entries:'));
3910 :    
3911 :     foreach $org (@subsetR)
3912 :     {
3913 : parrello 1.127 my @missing = &columns_missing_entries($cgi,$subsystem,$org,\@subsetC,\%in);
3914 : overbeek 1.1
3915 : parrello 1.127 $missing = [];
3916 :     foreach $role (@missing)
3917 :     {
3918 :     $abr = $subsystem->get_role_abbr($subsystem->get_role_index($role));
3919 :     my $roleE = $cgi->escape($role);
3920 :    
3921 :     my $link = "<a href=" . &FIG::cgi_url . "/pom.cgi?user=$user&request=find_in_org&role=$roleE&org=$org>$abr $role</a>";
3922 :     push(@$missing,$link);
3923 :     }
3924 :    
3925 :     if (@$missing > 0)
3926 :     {
3927 :     my $genus_species = &ext_genus_species($fig,$org);
3928 :     push(@$html,$cgi->h2("$org: $genus_species"));
3929 :     push(@$html,$cgi->ul($cgi->li($missing)));
3930 :     }
3931 : overbeek 1.1 }
3932 :     }
3933 :    
3934 :     sub columns_missing_entries {
3935 :     my($cgi,$subsystem,$org,$roles,$in) = @_;
3936 :    
3937 : overbeek 1.71 my $just_genome = $cgi->param('just_genome');
3938 : overbeek 1.72 if ($just_genome && ($just_genome =~ /(\d+\.\d+)/) && ($org != $1)) { return () }
3939 : overbeek 1.71
3940 : overbeek 1.1 my $just_col = $cgi->param('just_col');
3941 :     my(@really_missing) = ();
3942 :    
3943 :     my($role,%missing_cols);
3944 :     foreach $role (@$roles)
3945 :     {
3946 : parrello 1.127 next if ($just_col && ($role ne $just_col));
3947 :     if ($subsystem->get_pegs_from_cell($org,$role) == 0)
3948 :     {
3949 :     $missing_cols{$role} = 1;
3950 :     }
3951 : overbeek 1.1 }
3952 :    
3953 :     foreach $role (@$roles)
3954 :     {
3955 : parrello 1.127 if ($missing_cols{$role})
3956 :     {
3957 :     my($set);
3958 :     if (($set = $in->{$role}) && (! $cgi->param('ignore_alt')))
3959 :     {
3960 :     my @set = $subsystem->get_subsetC_roles($set);
3961 :    
3962 :     my($k);
3963 :     for ($k=0; ($k < @set) && $missing_cols{$set[$k]}; $k++) {}
3964 :     if ($k == @set)
3965 :     {
3966 :     push(@really_missing,$role);
3967 :     }
3968 :     }
3969 :     else
3970 :     {
3971 :     push(@really_missing,$role);
3972 :     }
3973 :     }
3974 : overbeek 1.1 }
3975 :     return @really_missing;
3976 :     }
3977 :    
3978 :     sub format_missing_including_matches
3979 :     {
3980 :     my($fig,$cgi,$html,$subsystem) = @_;
3981 :     my($org,$abr,$role,$missing);
3982 :    
3983 :     my $active_subsetC = ($cgi->param('active_subsetC') or $subsystem->get_active_subsetC );
3984 :     my $active_subsetR = ($cgi->param('active_subsetR') or $subsystem->get_active_subsetR );
3985 :    
3986 : overbeek 1.4 my @subsetC = $subsystem->get_subsetC_roles($active_subsetC);
3987 : overbeek 1.1 my %activeC = map { $_ => 1 } @subsetC;
3988 :    
3989 :     my @subsetR = $subsystem->get_subsetR($active_subsetR);
3990 :    
3991 : overbeek 1.145 my @alt_sets = grep { ($_ =~ /^\*/) } sort $subsystem->get_subset_namesC;
3992 : overbeek 1.1 my($set,$col,%in);
3993 :     foreach $set (@alt_sets)
3994 :     {
3995 : parrello 1.127 my @mem = grep { $activeC{$_} } $subsystem->get_subsetC_roles($set);
3996 :     foreach $col (@mem)
3997 :     {
3998 :     $in{$col} = $set;
3999 :     }
4000 : overbeek 1.1 }
4001 :     push(@$html,$cgi->h1('To Check Missing Entries:'));
4002 :    
4003 :     push(@$html, $cgi->start_form(-action=> "fid_checked.cgi"));
4004 :    
4005 :     my $can_alter = $cgi->param('can_alter');
4006 :     push(@$html,
4007 : parrello 1.127 $cgi->hidden(-name => 'user', -value => $user, -override => 1),
4008 :     $cgi->hidden(-name => 'can_alter', -value => $can_alter, -override => 1));
4009 : overbeek 1.11
4010 : overbeek 1.14 my $just_role = &which_role($subsystem,$cgi->param('just_role'));
4011 : overbeek 1.70 # print STDERR "There are ", scalar @subsetR, " organisms to check\n";
4012 : overbeek 1.1 foreach $org (@subsetR)
4013 :     {
4014 : parrello 1.127 my @missing = &columns_missing_entries($cgi,$subsystem,$org,\@subsetC,\%in);
4015 :     $missing = [];
4016 :     foreach $role (@missing)
4017 :     {
4018 :     # next if (($_ = $cgi->param('just_role')) && ($_ != ($subsystem->get_role_index($role) + 1)));
4019 :     next if ($just_role && ($just_role ne $role));
4020 :    
4021 :     my @hits = $fig->find_role_in_org($role, $org, $user, $cgi->param("sims_cutoff"));
4022 :     push(@$missing,@hits);
4023 :     }
4024 : overbeek 1.70 # print STDERR "Found ", scalar @$missing, " for $org\n";
4025 : parrello 1.127 if (@$missing > 0)
4026 :     {
4027 :     my $genus_species = &ext_genus_species($fig,$org);
4028 :     push(@$html,$cgi->h2("$org: $genus_species"));
4029 :    
4030 :     my $colhdr = ["Assign", "P-Sc", "PEG", "Len", "Current fn", "Matched peg", "Len", "Function"];
4031 :     my $tbl = [];
4032 :    
4033 :     for my $hit (@$missing)
4034 :     {
4035 :     my($psc, $my_peg, $my_len, $my_fn, $match_peg, $match_len, $match_fn) = @$hit;
4036 :    
4037 :     my $my_peg_link = &HTML::fid_link($cgi, $my_peg, 1);
4038 :     my $match_peg_link = &HTML::fid_link($cgi, $match_peg, 0);
4039 :    
4040 :     my $checkbox = $cgi->checkbox(-name => "checked",
4041 :     -value => "to=$my_peg,from=$match_peg",
4042 :     -label => "");
4043 :    
4044 :     push(@$tbl, [$checkbox,
4045 :     $psc,
4046 :     $my_peg_link, $my_len, $my_fn,
4047 :     $match_peg_link, $match_len, $match_fn]);
4048 :     }
4049 : overbeek 1.1
4050 : parrello 1.127 push(@$html, &HTML::make_table($colhdr, $tbl, ""));
4051 :     }
4052 : overbeek 1.1 }
4053 :     push(@$html,
4054 : parrello 1.127 $cgi->submit(-value => "Process assignments",
4055 :     -name => "batch_assign"),
4056 :     $cgi->end_form);
4057 : overbeek 1.1 }
4058 :    
4059 : mkubal 1.36
4060 :    
4061 :     sub columns_missing_entries {
4062 :     my($cgi,$subsystem,$org,$roles,$in) = @_;
4063 :    
4064 :     next if (($_ = $cgi->param('just_genome')) && ($org != $_));
4065 :     my $just_col = $cgi->param('just_col');
4066 :     my(@really_missing) = ();
4067 :    
4068 :     my($role,%missing_cols);
4069 :     foreach $role (@$roles)
4070 :     {
4071 : parrello 1.127 next if ($just_col && ($role ne $just_col));
4072 :     if ($subsystem->get_pegs_from_cell($org,$role) == 0)
4073 :     {
4074 :     $missing_cols{$role} = 1;
4075 :     }
4076 : mkubal 1.36 }
4077 :    
4078 :     foreach $role (@$roles)
4079 :     {
4080 : parrello 1.127 if ($missing_cols{$role})
4081 :     {
4082 :     my($set);
4083 :     if (($set = $in->{$role}) && (! $cgi->param('ignore_alt')))
4084 :     {
4085 :     my @set = $subsystem->get_subsetC_roles($set);
4086 :    
4087 :     my($k);
4088 :     for ($k=0; ($k < @set) && $missing_cols{$set[$k]}; $k++) {}
4089 :     if ($k == @set)
4090 :     {
4091 :     push(@really_missing,$role);
4092 :     }
4093 :     }
4094 :     else
4095 :     {
4096 :     push(@really_missing,$role);
4097 :     }
4098 :     }
4099 : mkubal 1.36 }
4100 :     return @really_missing;
4101 :     }
4102 :    
4103 :     sub format_missing_including_matches_in_ss
4104 :     {
4105 :     my($fig,$cgi,$html,$subsystem) = @_;
4106 :     my($org,$abr,$role,$missing);
4107 :    
4108 :     my $active_subsetC = ($cgi->param('active_subsetC') or $subsystem->get_active_subsetC );
4109 :     my $active_subsetR = ($cgi->param('active_subsetR') or $subsystem->get_active_subsetR );
4110 :    
4111 :     my @subsetC = $subsystem->get_subsetC_roles($active_subsetC);
4112 :     my %activeC = map { $_ => 1 } @subsetC;
4113 :    
4114 :     my @subsetR = $subsystem->get_subsetR($active_subsetR);
4115 :    
4116 : overbeek 1.145 my @alt_sets = grep { ($_ =~ /^\*/) } sort $subsystem->get_subset_namesC;
4117 : mkubal 1.36 my($set,$col,%in);
4118 :     foreach $set (@alt_sets)
4119 :