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

Annotation of /FigWebServices/subsys.cgi

Parent Directory Parent Directory | Revision Log Revision Log


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