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

Annotation of /FigWebServices/protein.cgi

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.209 - (view) (download)

1 : redwards 1.94 # -*- perl -*-
2 : olson 1.170 #
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.117 use InterfaceRoutines;
20 :    
21 : efrank 1.1 use FIG;
22 : olson 1.56
23 :     my $sproutAvail = eval {
24 :     require SproutFIG;
25 :     require PageBuilder;
26 :     };
27 :    
28 : olson 1.92 #if (!$sproutAvail) {
29 :     # warn "Sprout library not available: $@\n";
30 :     #}
31 : olson 1.56
32 : heiko 1.45 use FIGGenDB;
33 : olson 1.48 use FIGjs;
34 : efrank 1.1
35 : golsen 1.107 use URI::Escape; # uri_escape
36 : efrank 1.1 use HTML;
37 : olson 1.48 use Data::Dumper;
38 :    
39 : efrank 1.1 use strict;
40 :     use GenoGraphics;
41 :     use CGI;
42 : parrello 1.60 use Tracer;
43 : overbeek 1.184 use BasicLocation;
44 : parrello 1.60
45 : efrank 1.1 my $cgi = new CGI;
46 :    
47 : olson 1.57 use Carp 'cluck';
48 : parrello 1.60 my $traceData = $cgi->param('trace');
49 :     if ($traceData) {
50 : parrello 1.120 TSetup($traceData, "QUEUE");
51 : parrello 1.60 $traceData = 1;
52 :     } else {
53 :     TSetup(0, "NONE");
54 :     $traceData = 0;
55 :     }
56 : olson 1.57
57 : overbeek 1.66 if (0) {
58 : overbeek 1.40 my $VAR1;
59 :     eval(join("",`cat /tmp/protein_parms`));
60 :     $cgi = $VAR1;
61 :     # print STDERR &Dumper($cgi);
62 :     }
63 :    
64 : parrello 1.60 if (0) {
65 : efrank 1.1 print $cgi->header;
66 :     my @params = $cgi->param;
67 :     print "<pre>\n";
68 : parrello 1.60 foreach $_ (@params) {
69 :     print "$_\t:",join(",",$cgi->param($_)),":\n";
70 : efrank 1.1 }
71 : overbeek 1.40
72 : parrello 1.60 if (0) {
73 :     if (open(TMP,">/tmp/protein_parms")) {
74 :     print TMP &Dumper($cgi);
75 :     close(TMP);
76 :     }
77 : overbeek 1.40 }
78 : efrank 1.1 exit;
79 :     }
80 :    
81 : overbeek 1.206 if ($cgi->param('new_framework'))
82 :     {
83 :     $ENV{'METHOD'} = 'GET';
84 :     # $ENV{'QUERY_STRING'} = join("&","new_framework=1",
85 :     # map { my $k = $_; my $v = $cgi->param($k); "$k=$v" } $cgi->@param);
86 :     $ENV{'QUERY_STRING'} .= "&new_framwork=1";
87 :     my @out = `./frame.cgi`;
88 :     print @out;
89 :     exit;
90 :     }
91 :    
92 :    
93 : overbeek 1.53 my($fig_or_sprout);
94 : olson 1.83
95 :     my $is_sprout;
96 :    
97 :     my $html = [];
98 :    
99 : parrello 1.60 if ($cgi->param('SPROUT')) {
100 : olson 1.83 $is_sprout = 1;
101 : olson 1.56 $fig_or_sprout = new SproutFIG($FIG_Config::sproutDB, $FIG_Config::sproutData);
102 : olson 1.83 unshift @$html, "<TITLE>The NMPDR Protein Page</TITLE>\n";
103 : parrello 1.60 } else {
104 : olson 1.83 $is_sprout = 0;
105 : overbeek 1.53 $fig_or_sprout = new FIG;
106 : olson 1.83 unshift @$html, "<TITLE>The SEED Protein Page</TITLE>\n";
107 : overbeek 1.53 }
108 :    
109 : efrank 1.1
110 :     my $prot = $cgi->param('prot');
111 : parrello 1.60 if (! $prot) {
112 : golsen 1.19 unshift @$html, "<TITLE>The SEED: Protein Page</TITLE>\n";
113 : efrank 1.1 push(@$html,"<h1>Sorry, you need to specify a protein</h1>\n");
114 : overbeek 1.53 &display_page($fig_or_sprout,$cgi,$html);
115 : efrank 1.1 exit;
116 :     }
117 : golsen 1.34
118 : parrello 1.60 if ($prot !~ /^fig\|/) {
119 : overbeek 1.53 my @poss = &by_alias($fig_or_sprout,$prot);
120 :    
121 : parrello 1.60 if (@poss > 0) {
122 :     $prot = $poss[0];
123 :     } else {
124 :     unshift @$html, "<TITLE>The SEED: Protein Page</TITLE>\n";
125 :     push(@$html,"<h1>Sorry, $prot appears not to have a FIG id at this point</h1>\n");
126 :     &display_page($fig_or_sprout,$cgi,$html);
127 :     exit;
128 : overbeek 1.16 }
129 :     }
130 : efrank 1.1
131 : overbeek 1.53
132 : golsen 1.34 #
133 :     # Allow previous and next actions in calls to the script -- GJO
134 :     #
135 :    
136 :     my $adjust = $cgi->param('previous PEG') ? -1 : $cgi->param('next PEG') ? 1 : 0;
137 :     if ( $adjust ) {
138 :     my ( $prefix, $protnum ) = $prot =~ /^(.*\.)(\d+)$/;
139 :     if ( $prefix && $protnum ) {
140 :     my $prot2 = $prefix . ($protnum + $adjust);
141 : overbeek 1.53 if ( &translatable($fig_or_sprout, $prot2 ) ) {
142 : golsen 1.34 $prot = $prot2;
143 :     $cgi->delete('prot');
144 :     $cgi->param(-name => 'prot', -value => $prot);
145 :     }
146 :     }
147 :     ( $adjust < 0 ) && $cgi->delete('previous PEG');
148 :     ( $adjust > 0 ) && $cgi->delete('next PEG');
149 :     }
150 :    
151 :     my $request = $cgi->param("request") || "";
152 : overbeek 1.63 #my $compute_ok = eval {
153 :    
154 : olson 1.58
155 : overbeek 1.68 if ($request eq "use_protein_tool") { &use_protein_tool($fig_or_sprout,$cgi,$html,$prot); }
156 : parrello 1.60 elsif ($request eq "view_annotations") { &view_annotations($fig_or_sprout,$cgi,$html,$prot); }
157 :     elsif ($request eq "view_all_annotations") { &view_all_annotations($fig_or_sprout,$cgi,$html,$prot); }
158 : overbeek 1.68 elsif ($request eq "aa_sequence") { &aa_sequence($fig_or_sprout,$cgi,$html,$prot); }
159 : parrello 1.60 elsif ($request eq "dna_sequence") { &dna_sequence($fig_or_sprout,$cgi,$html,$prot); }
160 : overbeek 1.173 elsif ($request eq "dna_sequence_adjacent") { &dna_sequence_adjacent($fig_or_sprout,$cgi,$html,$prot); }
161 : parrello 1.60 elsif ($request eq "fast_assign") { $html = &make_assignment($fig_or_sprout,$cgi,$html,$prot); }
162 :     elsif ($request eq "show_coupling_evidence") { &show_coupling_evidence($fig_or_sprout,$cgi,$html,$prot); }
163 : overbeek 1.171 elsif ($request eq "abstract_coupling") { &show_abstract_coupling_evidence($fig_or_sprout,$cgi,$html,$prot); }
164 : parrello 1.60 elsif ($request eq "ec_to_maps") { &show_ec_to_maps($fig_or_sprout,$cgi,$html); }
165 :     elsif ($request eq "link_to_map") { &link_to_map($fig_or_sprout,$cgi,$html); }
166 :     elsif ($request eq "fusions") { &show_fusions($fig_or_sprout,$cgi,$html,$prot); }
167 :     else {
168 :     $html = &show_html_followed_by_initial($fig_or_sprout,$cgi,$html,$prot);
169 :     }
170 : overbeek 1.68
171 :     if ($cgi->param('SPROUT') && (ref($html) eq "ARRAY"))
172 :     {
173 :     $_ = {};
174 :     $_->{kv_pairs} = $html;
175 :     $html = $_;
176 :     }
177 : overbeek 1.63 #};
178 : olson 1.58
179 : overbeek 1.63 #if (!$compute_ok) {
180 :     # Trace($@);
181 :     #}
182 : overbeek 1.68
183 : overbeek 1.53 &display_page($fig_or_sprout,$cgi,$html);
184 : overbeek 1.11 exit;
185 :    
186 :     #==============================================================================
187 : hwang 1.203 # flat_array
188 :     #==============================================================================
189 :     sub flat_array {
190 :    
191 :     my @kv_pairs = @_;
192 :     my @return_args=();
193 :     my @args;
194 :    
195 :     foreach my $x (@kv_pairs)
196 :     {
197 :     #cannot be a nested array to be passed in to gather
198 :    
199 :     my @args = ($x->[0], $x->[1]);
200 :     push(@return_args, "$x->[0]\t$x->[1]");
201 :     }
202 :    
203 :     return @return_args;
204 :     }
205 :    
206 :    
207 :     #==============================================================================
208 : overbeek 1.11 # use_protein_tool
209 :     #==============================================================================
210 : efrank 1.1
211 :     sub use_protein_tool {
212 : overbeek 1.53 my($fig_or_sprout,$cgi,$html,$prot) = @_;
213 : efrank 1.1 my($url,$method,@args,$line,$name,$val);
214 :    
215 : overbeek 1.53 my $seq = &get_translation($fig_or_sprout,$prot);
216 : parrello 1.60 if (! $seq) {
217 :     unshift @$html, "<TITLE>The SEED: Protein Page</TITLE>\n";
218 :     push(@$html,$cgi->h1("Sorry, $prot does not have a translation"));
219 :     return;
220 : efrank 1.1 }
221 :     my $protQ = quotemeta $prot;
222 :    
223 :     my $tool = $cgi->param('tool');
224 :     $/ = "\n//\n";
225 :     my @tools = grep { $_ =~ /^$tool\n/ } `cat $FIG_Config::global/LinksToTools`;
226 : parrello 1.60 if (@tools == 1) {
227 :     chomp $tools[0];
228 :     (undef,undef,$url,$method,@args) = split(/\n/,$tools[0]);
229 :     my $args = [];
230 : overbeek 1.200 foreach $line (@args)
231 :     {
232 :     next if ($line =~ /^\#/); # ignore comments
233 :     ($name,$val) = split(/\t/,$line);
234 :     $val =~ s/FIGID/$prot/;
235 :     $val =~ s/FIGSEQ/$seq/;
236 :     $val =~ s/\\n/\n/g;
237 :     push(@$args,[$name,$val]);
238 :     }
239 : hwang 1.203
240 :     my @result;
241 :    
242 :     if ($method =~/internal/i)
243 :     {
244 :     my $pegid;
245 :     #If method is internal, then the url is actually a perl script
246 :     my $script = $url;
247 :     $script=~ s/\.pl//g;
248 :    
249 :     my @script_array = &flat_array(@$args);
250 :     my $out = &FIG::run_gathering_output("$FIG_Config::bin/$script", @script_array);
251 : hwang 1.204 @result = split(/[\012\015]+/,$out);
252 : hwang 1.203
253 :     }
254 :     else
255 :     {
256 :     @result = &HTML::get_html($url,$method,$args);
257 :     }
258 : overbeek 1.200
259 : overbeek 1.202 # some pages are setting the base
260 :     #@result = grep {$_ !~ /base href/} @result;
261 : overbeek 1.200
262 :     # and some pages have the audactiy to add <head> and <body tags>
263 :     # first remove them by regexp:
264 :     map {$_ =~ s/^.*<\/head>//i; $_ =~ s/^.*<body>//i} @result;
265 :     map {$_ =~ s/<\/body>.*$//i; $_ =~ s/<\/html>.*$//i} @result;
266 :    
267 :     # now try looping through
268 :     my $splice=0; my $splast=0;
269 :     foreach my $i (0..$#result)
270 :     {
271 :     if ($result[$i] =~ /<body>/i || $result[$i] =~ /<\/head>/i) {$splice=$i}
272 :     if ($result[$i] =~ /<\/body>/i) {$splast=$i}
273 :     }
274 :     if ($splast) {splice(@result, -$splast)}
275 :     if ($splice) {splice(@result, 0, $splice)}
276 :    
277 :    
278 : overbeek 1.190
279 :    
280 : overbeek 1.200 #
281 :     # The extra form in the Sprout header causes some problems with javascript-containing
282 :     # pages. So if we're in sprout, and there's javascript in the page, just show the
283 : overbeek 1.190 # output and exit.
284 :     #
285 :    
286 :     if ($is_sprout)
287 :     {
288 :     for my $rl (@result)
289 :     {
290 :     if ($rl =~ /javascript/i)
291 :     {
292 :     print $cgi->header;
293 :     print join("", @result);
294 :     exit 0;
295 :     }
296 :     }
297 :     }
298 : overbeek 1.200
299 :     push(@$html, @result);
300 : hwang 1.204 }
301 : efrank 1.1 }
302 :    
303 : overbeek 1.11 #==============================================================================
304 :     # make_assignment
305 :     #==============================================================================
306 :    
307 : efrank 1.1 sub make_assignment {
308 : overbeek 1.53 my($fig_or_sprout,$cgi,$html,$prot) = @_;
309 : efrank 1.1 my($userR);
310 :    
311 :     my $function = $cgi->param('func');
312 :     my $user = $cgi->param('user');
313 :    
314 : parrello 1.60 if ($function && $user && $prot) {
315 :     if ($user =~ /master:(.*)/) {
316 :     $userR = $1;
317 :     &assign_function($fig_or_sprout,$prot,"master",$function,"");
318 : overbeek 1.68 &add_annotation($fig_or_sprout,$cgi,$prot,$userR,"Set master function to\n$function\n");
319 : parrello 1.60 } else {
320 : overbeek 1.68 &assign_function($fig_or_sprout,$prot,$user,$function,"");
321 :     &add_annotation($fig_or_sprout,$cgi,$prot,$user,"Set function to\n$function\n");
322 :     }
323 : efrank 1.1 }
324 :     $cgi->delete("request");
325 :     $cgi->delete("func");
326 : overbeek 1.53 $html = &show_html_followed_by_initial($fig_or_sprout,$cgi,$html,$prot);
327 :     return $html;
328 : efrank 1.1 }
329 :    
330 : overbeek 1.11 #==============================================================================
331 :     # view_annotations
332 :     #==============================================================================
333 :    
334 : efrank 1.1 sub view_annotations {
335 : overbeek 1.53 my($fig_or_sprout,$cgi,$html,$prot) = @_;
336 : efrank 1.1
337 : golsen 1.19 unshift @$html, "<TITLE>The SEED: Protein Annotations</TITLE>\n";
338 : efrank 1.1 my $col_hdrs = ["who","when","annotation"];
339 : overbeek 1.69
340 : overbeek 1.68 my $tab = [ map { [$_->[2],$_->[1],"<pre>" . $_->[3] . "<\/pre>"] } &feature_annotations($fig_or_sprout,$cgi,$prot) ];
341 : parrello 1.60 if (@$tab > 0) {
342 :     push(@$html,&HTML::make_table($col_hdrs,$tab,"Annotations for $prot"));
343 :     } else {
344 :     push(@$html,"<h1>No Annotations for $prot</h1>\n");
345 : efrank 1.1 }
346 :     }
347 :    
348 : overbeek 1.15 sub view_all_annotations {
349 : overbeek 1.53 my($fig_or_sprout,$cgi,$html,$peg) = @_;
350 : overbeek 1.15 my($ann);
351 :    
352 : golsen 1.19 unshift @$html, "<TITLE>The SEED: Protein Annotations</TITLE>\n";
353 : parrello 1.60 if (&is_real_feature($fig_or_sprout,$peg)) {
354 :     my $col_hdrs = ["who","when","PEG","genome","annotation"];
355 : overbeek 1.68 my @related = &related_by_func_sim($fig_or_sprout,$cgi,$peg,$cgi->param('user'));
356 : parrello 1.60 push(@related,$peg);
357 :    
358 :     my @annotations = &merged_related_annotations($fig_or_sprout,\@related);
359 :    
360 :     my $tab = [ map { $ann = $_;
361 :     [$ann->[2],$ann->[1],&HTML::fid_link($cgi,$ann->[0]),
362 :     &genus_species($fig_or_sprout,&genome_of($ann->[0])),
363 :     "<pre>" . $ann->[3] . "</pre>"
364 :     ] } @annotations];
365 :     if (@$tab > 0) {
366 :     push(@$html,&HTML::make_table($col_hdrs,$tab,"All Related Annotations for $peg"));
367 :     } else {
368 :     push(@$html,"<h1>No Annotations for $peg</h1>\n");
369 :     }
370 : overbeek 1.15 }
371 :     }
372 :    
373 : overbeek 1.11 #==============================================================================
374 :     # show_coupling_evidence
375 :     #==============================================================================
376 :    
377 : overbeek 1.171 sub show_abstract_coupling_evidence {
378 :     my($fig_or_sprout,$cgi,$html,$prot) = @_;
379 :    
380 :     my @coupling = $fig_or_sprout->abstract_coupled_to($prot);
381 :     if (@coupling > 0)
382 :     {
383 : overbeek 1.172 push(@$html,&HTML::abstract_coupling_table($cgi,$prot,\@coupling));
384 : overbeek 1.171 }
385 :     else
386 :     {
387 :     push(@$html,$cgi->h1("sorry, no abstract coupling data for $prot"));
388 :     }
389 :     }
390 :    
391 : efrank 1.1 sub show_coupling_evidence {
392 : overbeek 1.53 my($fig_or_sprout,$cgi,$html,$peg) = @_;
393 : efrank 1.1 my($pair,$peg1,$peg2,$link1,$link2);
394 :    
395 : golsen 1.19 unshift @$html, "<TITLE>The SEED: Functional Coupling</TITLE>\n";
396 : efrank 1.1 my $user = $cgi->param('user');
397 :     my $to = $cgi->param('to');
398 : overbeek 1.115 my @coup = grep { $_->[1] eq $to } &coupling_and_evidence($fig_or_sprout,$peg,5000,1.0e-10,4,1);
399 : efrank 1.1
400 : parrello 1.60 if (@coup != 1) {
401 :     push(@$html,"<h1>Sorry, no evidence that $peg is coupled to $to</h1>\n");
402 :     } else {
403 : overbeek 1.91 my $col_hdrs = ["Peg1","Function1","Peg2","Function2","Organism"];
404 : parrello 1.60 my $tab = [];
405 :     foreach $pair (@{$coup[0]->[2]}) {
406 :     ($peg1,$peg2) = @$pair;
407 :     $link1 = &HTML::fid_link($cgi,$peg1);
408 :     $link2 = &HTML::fid_link($cgi,$peg2);
409 :     push( @$tab, [ $link1,
410 : overbeek 1.91 scalar &function_ofS($fig_or_sprout,$peg1,$user),
411 :     $link2,
412 :     scalar &function_ofS($fig_or_sprout,$peg2,$user),
413 :     &org_of($fig_or_sprout,$peg1)
414 : parrello 1.60 ]
415 : overbeek 1.11 );
416 : parrello 1.60 }
417 :     push(@$html,&HTML::make_table($col_hdrs,$tab,"Evidence that $peg Is Coupled To $to"));
418 : efrank 1.1 }
419 :     }
420 :    
421 : overbeek 1.11 #==============================================================================
422 :     # psi_blast_prot_sequence
423 :     #==============================================================================
424 :    
425 : efrank 1.1 sub psi_blast_prot_sequence {
426 : overbeek 1.53 my($fig_or_sprout,$cgi,$prot_id) = @_;
427 : efrank 1.1 }
428 :    
429 : overbeek 1.11 #==============================================================================
430 :     # show_initial
431 :     #==============================================================================
432 :    
433 : efrank 1.1 sub show_initial {
434 : overbeek 1.53 my($fig_or_sprout,$cgi,$html,$prot) = @_;
435 :    
436 :     unshift @{$html->{general}}, "<TITLE>The SEED: Protein Page</TITLE>\n";
437 : efrank 1.1
438 : overbeek 1.53 my $gs = &org_of($fig_or_sprout,$prot);
439 : parrello 1.60 Trace("got gs=$gs prot=$prot $fig_or_sprout\n") if T(2);
440 :     if ($prot =~ /^fig\|\d+\.\d+\.peg/) {
441 :     if (! &is_real_feature($fig_or_sprout,$prot)) {
442 :     push(@{$html->{general}},"<h1>Sorry, $prot is an unknown identifier</h1>\n");
443 :     } else {
444 :     push(@{$html->{general}},"<h1>Protein $prot: $gs</h1>\n");
445 : efrank 1.187
446 :     # caBIG insists on explicitly displaying the taxon ID rather
447 :     # than learning how to read the figID, so display it.
448 :     # ...please don't delete this without consulting with Ed
449 :    
450 :     my $taxon;
451 :     if ($prot =~ /^fig\|(\d+)\.(\d+)/) {
452 :     push(@{$html->{general}},"<h2>Taxon=$1 (NCBI TaxonId, if one exists)</h2>\n");
453 :     }
454 :    
455 : parrello 1.60 &translation_piece($fig_or_sprout,$cgi,$html->{translate_status});
456 :     &display_peg($fig_or_sprout,$cgi,$html,$prot);
457 :     }
458 :     } else {
459 :     # &display_external($fig_or_sprout,$cgi,$html,$prot);
460 : efrank 1.1 }
461 :     }
462 :    
463 : overbeek 1.11 #==============================================================================
464 :     # display_peg
465 :     #==============================================================================
466 :    
467 : efrank 1.1 sub display_peg {
468 : overbeek 1.53 my($fig_or_sprout,$cgi,$html,$peg) = @_;
469 : efrank 1.1 my $loc;
470 : overbeek 1.104
471 : overbeek 1.53 my $user = $cgi->param('user');
472 : overbeek 1.104 my $org = &genome_of($peg);
473 : overbeek 1.116 my $domain = &genome_domain($fig_or_sprout,$org);
474 : overbeek 1.104
475 :     #...set default minimum size for euk or non-euk display region...
476 :     my $half_sz = ($domain =~ m/^euk/i) ? 50000 : 5000;
477 :    
478 : overbeek 1.10 my $fc = $cgi->param('fc');
479 :     my @fc_data;
480 : parrello 1.60 if ($fc) {
481 : redwards 1.49 # RAE Added the following lines so that you can define this in the URL
482 : parrello 1.60 # but the default behavior remains unchanged. I doubt anyone will ever
483 :     # see this, but I use it sometimes to see what happens
484 :     my ($bound,$sim_cutoff,$coupling_cutoff)=(5000, 1.0e-10, 4);
485 :     if ($cgi->param('fcbound')) {$bound=$cgi->param('fcbound')}
486 :     if ($cgi->param('fcsim')) {$sim_cutoff=$cgi->param('fcsim')}
487 :     if ($cgi->param('fccoup')) {$coupling_cutoff=$cgi->param('fccoup')}
488 : overbeek 1.104
489 : overbeek 1.115 @fc_data = &coupling_and_evidence($fig_or_sprout,$peg,$bound,$sim_cutoff,$coupling_cutoff,1);
490 : parrello 1.60 } else {
491 :     @fc_data = ();
492 :     }
493 : overbeek 1.104
494 : parrello 1.60 if ($loc = &feature_locationS($fig_or_sprout,$peg)) {
495 : overbeek 1.146 if ($loc =~ /^(\d+\.\d+:(\S+)) \2$/)
496 :     {
497 :     #
498 :     # REMOVE ME.
499 :     #
500 :     # Patch a sprout bug that returns spurious gunk in feature locations.
501 :     #
502 :    
503 :     $loc = $1;
504 :     }
505 :    
506 : parrello 1.60 my($contig,$beg,$end) = &boundaries_of($fig_or_sprout,$loc);
507 : overbeek 1.104
508 :     my $len = abs($end-$beg) + 1;
509 : overbeek 1.112 if ($len > $half_sz)
510 :     {
511 :     $half_sz = $len;
512 :     }
513 :     else
514 :     {
515 :     $half_sz = $half_sz * (1 + 3*int($len/$half_sz)); #...set scale of region...
516 :     }
517 : overbeek 1.104 # print STDERR "half_sz = $half_sz\n";
518 :    
519 :     my $min = &max(0,&min($beg,$end) - $half_sz);
520 :     my $max = &max($beg,$end) + $half_sz;
521 : parrello 1.60 Trace("display_peg: min=$min max=$max beg=$beg end=$end") if T(2);
522 : overbeek 1.104
523 : mkubal 1.166 my $feat;
524 :     ($feat,$min,$max) = &genes_in_region($fig_or_sprout,$cgi,&genome_of($peg),$contig,$min,$max);
525 :    
526 : parrello 1.60 Trace("beg=$beg end=$end New min = $min, max = $max, features = " . join(", ", @{$feat})) if T(3);
527 :    
528 :     my ($beg,$end,$genes) = &print_context($fig_or_sprout,$cgi,$html->{contig_context},$peg,$feat,$min,$max);
529 :     Trace("Print context returned: beg=$beg, end=$end, genes = " . join(", ", @{$genes})) if T(3);
530 :     &print_graphics_context($beg,$end,$genes,$html->{context_graphic});
531 :    
532 : overbeek 1.68 &print_assignments($fig_or_sprout,$cgi,$html->{assign_for_equiv_prots},$peg);
533 : redwards 1.99 &print_kv_pairs($is_sprout, $fig_or_sprout,$cgi,$html->{kv_pairs},$peg);
534 : redwards 1.125 &print_protein_fams($is_sprout, $fig_or_sprout,$cgi,$html->{kv_pairs},$peg,$user);
535 : parrello 1.60 &print_subsys_connections($fig_or_sprout,$cgi,$html->{subsys_connections},$peg,$user);
536 :     &print_links($fig_or_sprout,$cgi,$html->{links},$peg);
537 :    
538 :    
539 :     my $has_translation = &translatable($fig_or_sprout,$peg);
540 :     &print_services($fig_or_sprout,$cgi,$html->{services},$peg,$has_translation,\@fc_data);
541 : overbeek 1.63
542 : parrello 1.60 &print_sims_block($fig_or_sprout,$cgi,$html->{similarities},$peg,$user,$has_translation);
543 :    
544 :     if ($has_translation) {
545 :     &show_tools($fig_or_sprout,$cgi,$html->{tools},$peg);
546 :     }
547 : efrank 1.1 }
548 :     }
549 :    
550 :     ################# Table-Driven Show Tools ############################
551 :    
552 :     sub show_tools {
553 : overbeek 1.53 my($fig_or_sprout,$cgi,$html,$peg) = @_;
554 : efrank 1.1
555 : redwards 1.80 # generate the link to turn tools on or off
556 : overbeek 1.161 my $toollink = $cgi->url(-relative => 1, -query => 1, -path_info => 1);
557 :    
558 : redwards 1.80 $toollink =~ s/[\&\;]fulltools.*[^\;\&]/\&/;
559 : redwards 1.125 my $fulltoolbutton = $cgi->a({href=> $toollink . "&fulltools='1'"}, "> Show tool descriptions"); # define this here before we mess with ourself!
560 :     my $brieftoolbutton = $cgi->a({href=> $toollink}, "< Hide tool descriptions");
561 : parrello 1.108
562 : efrank 1.1 $cgi->param(-name => "request",
563 :     -value => "use_protein_tool");
564 : overbeek 1.161 my $url = $cgi->url(-relative => 1, -query => 1, -path_info => 1);
565 : efrank 1.1
566 : parrello 1.60 if (open(TMP,"<$FIG_Config::global/LinksToTools")) {
567 :     my $col_hdrs = ["Tool","Description"];
568 :     my $tab = [];
569 :    
570 :     $/ = "\n//\n";
571 : redwards 1.80 my $brieftools; # in case we don't want descriptions and whatnot
572 : parrello 1.60 while (defined($_ = <TMP>)) {
573 : overbeek 1.72 # allow comment lines in the file
574 :     next if (/^#/);
575 : parrello 1.60 my($tool,$desc) = split(/\n/,$_);
576 : overbeek 1.72 # RAE modified this so we can include column headers.
577 :     undef($desc) if ($desc eq "//"); # it is a separator
578 : redwards 1.80 # RAE modified again so that we only get a short tool list instead of the big table if that is what we want.
579 :     if ($cgi->param('fulltools')) {
580 :     if ($desc) {push(@$tab,["<a href=\"$url\&tool=$tool\">$tool</a>",$desc])}
581 : parrello 1.108 else {push(@$tab, [["<strong>$tool</strong>", "td colspan=2 align=center"]])}
582 : redwards 1.80 }
583 :     else {
584 :     # Why doesn't this work $brieftools .= "<span class=\"tool\" style=\"border: 0 1px solid gray\"><a href=\"$url\&tool=$tool\">$tool</a></span>";
585 :     if ($desc) {$brieftools .= " &nbsp; <a href=\"$url\&tool=$tool\">$tool</a> &nbsp;|"}
586 :     }
587 : parrello 1.60 }
588 :     close(TMP);
589 :     $/ = "\n";
590 : redwards 1.80 if ($brieftools) {push(@$html, $cgi->p("|" . $brieftools), $fulltoolbutton)}
591 :     else {push(@$html,&HTML::make_table($col_hdrs,$tab,"Tools to Analyze Protein Sequences"), $brieftoolbutton)}
592 : efrank 1.1 }
593 :     $cgi->delete('request');
594 :     }
595 :    
596 :     ################# Functional Coupling ############################
597 :    
598 :     sub print_fc {
599 : overbeek 1.53 my($fig_or_sprout,$cgi,$html,$peg,$fc_data) = @_;
600 : efrank 1.1 my($sc,$neigh);
601 : parrello 1.60
602 : efrank 1.1 my $user = $cgi->param('user');
603 :     my @tab = map { ($sc,$neigh) = @$_;
604 : parrello 1.60 [&ev_link($cgi,$neigh,$sc),$neigh,scalar &function_ofS($fig_or_sprout,$neigh,$user)]
605 :     } @$fc_data;
606 :     if (@tab > 0) {
607 :     push(@$html,"<hr>\n");
608 :     my $col_hdrs = ["Score","Peg","Function"];
609 :     push(@$html,&HTML::make_table($col_hdrs,\@tab,"Functional Coupling"));
610 : efrank 1.1 }
611 :     }
612 :    
613 :     sub ev_link {
614 :     my($cgi,$neigh,$sc) = @_;
615 :    
616 :     my $prot = $cgi->param('prot');
617 : overbeek 1.121 my $sprout = $cgi->param('SPROUT');
618 : overbeek 1.199 my $user = $cgi->param('user');
619 :     if (! defined($user)) { $user = "" }
620 :     my $link = $cgi->url(-relative => 1) . "?user=$user&request=show_coupling_evidence&prot=$prot&to=$neigh&SPROUT=$sprout";
621 : efrank 1.1 return "<a href=$link>$sc</a>";
622 :     }
623 :    
624 :     ################# Assignments ############################
625 :    
626 :     sub trans_function_of {
627 : overbeek 1.53 my($cgi,$fig_or_sprout,$peg,$user) = @_;
628 : efrank 1.1
629 : parrello 1.60 if (wantarray()) {
630 :     my $x;
631 : overbeek 1.68 my @funcs = &function_ofL($fig_or_sprout,$peg,$user);
632 :    
633 : parrello 1.60 if ($cgi->param('translate')) {
634 :     @funcs = map { $x = $_; $x->[1] = &translate_function($fig_or_sprout,$x->[1]); $x } @funcs;
635 :     }
636 :     return @funcs;
637 :     } else {
638 :     my $func = &function_ofS($fig_or_sprout,$peg,$user);
639 :     if ($cgi->param('translate')) {
640 :     $func = &translate_function($fig_or_sprout,$func);
641 :     }
642 :     return $func;
643 : efrank 1.1 }
644 :     }
645 :    
646 : overbeek 1.53 ########################## Routines that build pieces of HTML ######################
647 :    
648 :    
649 :     sub print_sims_block {
650 :     my($fig_or_sprout,$cgi,$html,$peg,$user,$has_translation) = @_;
651 :    
652 :     my $sims = $cgi->param('sims');
653 : overbeek 1.122 if ( (! $sims ) && $has_translation)
654 : golsen 1.76 {
655 :     my $short_form = 1;
656 :     sims_request_form( $fig_or_sprout, $cgi, $html, $peg, $user, $short_form );
657 :     }
658 : overbeek 1.53
659 : golsen 1.76 # Added test $has_translation && (...) -- GJO
660 : overbeek 1.122 elsif ( $has_translation && $sims)
661 : golsen 1.76 {
662 : golsen 1.100 print_similarities( $fig_or_sprout, $cgi, $html, $peg );
663 : overbeek 1.53 }
664 :     }
665 :    
666 :    
667 :     sub print_services {
668 :     my($fig_or_sprout,$cgi,$html,$peg,$has_translation,$fc_data) = @_;
669 :    
670 : overbeek 1.161 # my $baseurl=$FIG_Config::cgi_base;
671 :     # Old base my $base = $cgi->self_url();
672 :    
673 :     my $baseurl = ".";
674 :    
675 :     my $base = $cgi->url(-relative => 1, -query => 1, -path_info => 1);
676 :     my $link1 = "$base&request=view_annotations";
677 :     my $link2 = "$base&request=view_all_annotations";
678 : overbeek 1.150
679 :     #
680 :     # Since one cannot annotate in SPROUT, don't show this help.
681 :     #
682 :    
683 :     if (not $is_sprout)
684 :     {
685 :     push(@$html, "<a href='$baseurl/Html/seedtips.html#gene_names' class='help' target='help'>Help on Annotations</a><br>\n");
686 :     }
687 :    
688 : mkubal 1.166
689 : redwards 1.134 push(@$html,"<a href=$link1>To View Annotations</a> / <a href=$link2>To View All Related Annotations</a>\n");
690 : mkubal 1.166 my $user = $cgi->param('user');
691 : overbeek 1.181
692 :     #
693 :     # Controlled vocabulary is SEED-only
694 :     #
695 :     if (not $is_sprout)
696 :     {
697 :     my $cv_link = "cv.cgi?prot=$peg&user=$user";
698 :     push(@$html,"<br><a href=$cv_link>Edit Controlled Vocabulary</a>\n");
699 :     }
700 : mkubal 1.166
701 : overbeek 1.116 if ((! $cgi->param('SPROUT')) && &peg_in_gendb($fig_or_sprout,$cgi,$peg))
702 : overbeek 1.63 {
703 :     push(@$html, "<br/>".&FIGGenDB::linkPEGGenDB($peg));
704 :     push(@$html, "<br/>".&FIGGenDB::importOrganismGenDB($peg));
705 :     }
706 : overbeek 1.53
707 : overbeek 1.161 my $link = $cgi->url(-relative => 1, -query => 1, -path_info => 1) . "&request=aa_sequence";
708 : overbeek 1.53 push(@$html,"<br><a href=$link>Protein Sequence</a>\n");
709 :    
710 : overbeek 1.161 $link = $cgi->url(-relative => 1, -query => 1, -path_info => 1) . "&request=dna_sequence";
711 : overbeek 1.173 push(@$html,"<br><a href=$link>DNA Sequence</a>\n");
712 :     $link = $cgi->url(-relative => 1, -query => 1, -path_info => 1) . "&request=dna_sequence_adjacent";
713 :     push(@$html," [<a href=$link>with flanking sequence</a>]<br>\n");
714 : overbeek 1.53
715 : overbeek 1.161 $link = $cgi->url(-relative => 1);
716 : overbeek 1.53 $link =~ s/protein.cgi/fid_checked.cgi/;
717 :     my $sprout = $cgi->param('SPROUT') ? 1 : "";
718 :     my $user = $cgi->param('user');
719 : parrello 1.60 if (! $user) {
720 :     $user = "";
721 :     } else {
722 : overbeek 1.195 if (not $is_sprout)
723 :     {
724 :     push(@$html, "<a href='$baseurl/Html/seedtips.html#gene_names' class='help' target='help'>Help on Annotations</a><br>\n");
725 :     }
726 :     my $nlink = $link . "?SPROUT=$sprout&fid=$prot&user=$user&checked=$prot&assign/annotate=assign/annotate";
727 :     my $notlink = $link . "?SPROUT=$sprout&fid=$prot&user=$user&checked=$prot&assign/annotate=assign/annotate&negate=1";
728 :     push(@$html,"<a href='$nlink' target='checked_window'>To Make an Annotation</a> [<a href='$notlink' target='checked_window'>Negate annotation</a>]\n");
729 : overbeek 1.53 }
730 :    
731 : overbeek 1.146 if (! $sprout)
732 : overbeek 1.145 {
733 : overbeek 1.146 my($cid,@fams);
734 : overbeek 1.145
735 : overbeek 1.63 my $fc = $cgi->param('fc');
736 :     if ((! $fc) && (&feature_locationS($fig_or_sprout,$peg))) {
737 : overbeek 1.161 my $link = $cgi->url(-relative => 1, -query => 1, -path_info => 1) . "&fc=1";
738 : overbeek 1.63 push(@$html,"<br><a href=$link>To Get Detailed Functional Coupling Data</a>\n");
739 :     } elsif ($fc) {
740 :     &print_fc($fig_or_sprout,$cgi,$html,$peg,$fc_data);
741 :     }
742 : overbeek 1.53
743 : overbeek 1.161 my $link = $cgi->url(-relative => 1, -query => 1, -path_info => 1) . "&request=fusions";
744 : overbeek 1.63 push(@$html,"<br><a href=$link>To Get Fusion Data</a>\n");
745 : overbeek 1.53
746 : overbeek 1.63 my $link = &cgi_url . "/homologs_in_clusters.cgi?prot=$peg&user=$user\n";
747 :     push(@$html,"<br><a href=$link>To Find Homologs in Clusters</a>\n");
748 : overbeek 1.171
749 :     my @coup = $fig_or_sprout->abstract_coupled_to($peg);
750 :     if (@coup > 0)
751 :     {
752 : overbeek 1.207 my $new_framework = $cgi->param('new_framework') ? 1 : 0;
753 :     my $link = &cgi_url . "/protein.cgi?prot=$peg&user=$user&request=abstract_coupling&new_framework=$new_framework\n";
754 : overbeek 1.172 push(@$html,"<br><a href=$link>Show Abstract Coupling Data</a>\n");
755 : overbeek 1.171 }
756 : overbeek 1.63 }
757 : overbeek 1.53
758 : parrello 1.60 if ((! $cgi->param('compare_region')) && $has_translation) {
759 : overbeek 1.161 my $link = $cgi->url(-relative => 1, -query => 1, -path_info => 1) . "&compare_region=1";
760 : overbeek 1.165 push(@$html,"<A href=\"Html/compare_regions.html\" class='help' target=\"SEED_or_SPROUT_help\">Help on compare regions</A>\n");
761 : overbeek 1.168 push(@$html,"<a href=$link>To Compare Region</a> &nbsp;\n<br>");
762 :     push(@$html, "<a href='proteinfamilies.cgi?user=$user&prot=$peg&equivalence=1'>Explore Protein Families for $peg</a></br>\n");
763 : parrello 1.60 } elsif ($cgi->param('compare_region')) {
764 :     &print_compared_regions($fig_or_sprout,$cgi,$html,$peg);
765 : overbeek 1.53 }
766 :     }
767 :    
768 : efrank 1.1 sub print_assignments {
769 : overbeek 1.53 my($fig_or_sprout,$cgi,$html,$peg) = @_;
770 : efrank 1.1 my($who,$func,$ec,@ecs,@tmp,$id,$i,$master_func,$user_func,$x);
771 :    
772 :     my $user = $cgi->param('user');
773 : overbeek 1.68 $user = defined($user) ? $user : "";
774 :    
775 : overbeek 1.53 my @funcs = map { [$peg,@$_] } &trans_function_of($cgi,$fig_or_sprout,$peg);
776 : overbeek 1.68 $user_func = &trans_function_of($cgi,$fig_or_sprout,$peg);
777 :    
778 :     push(@$html,$cgi->h2("Current Assignment: $peg: $user_func"));
779 : parrello 1.108
780 : overbeek 1.163 my @maps_to = grep { $_ ne $peg and $_ !~ /^xxx/ } map { $_->[0] } &mapped_prot_ids($fig_or_sprout,$cgi,$peg);
781 : efrank 1.1
782 : parrello 1.60 foreach $id (@maps_to) {
783 : overbeek 1.68 my $tmp;
784 :     if (($id ne $peg) && ($tmp = &trans_function_of($cgi,$fig_or_sprout,$id)))
785 :     {
786 :     push(@funcs, [$id,&who($id),$tmp]);
787 : parrello 1.60 }
788 : efrank 1.1 }
789 :     @funcs = map { ($_->[1] eq "master") ? [$_->[0],"",$_->[2]] : $_ } @funcs;
790 : overbeek 1.68
791 :    
792 : efrank 1.1 push(@$html,"<hr>\n");
793 :    
794 : parrello 1.60 if ((@funcs == 0) && (! $user_func)) {
795 :     push(@$html,$cgi->h1("No function has been assigned"));
796 : efrank 1.1 }
797 : overbeek 1.25
798 : parrello 1.108 my $tab = [ map { ($id,$who,$func) = @$_;
799 : overbeek 1.68 [ &HTML::set_prot_links($cgi,$id),
800 :     &org_of($fig_or_sprout,$id),
801 : overbeek 1.75 $who ? $who : "&nbsp;",
802 : parrello 1.108 ($user ? &assign_link($cgi,$func,$user_func) : "&nbsp;"),
803 : golsen 1.169 &set_ec_and_tc_links($fig_or_sprout,$cgi,&genome_of($peg),$func)] } @funcs ];
804 : parrello 1.60 if (@$tab > 0) {
805 :     my $col_hdrs = ["Id","Organism","Who","ASSIGN","Assignment"];
806 :     my $title = "Assignments for Essentially Identical Proteins";
807 : overbeek 1.180 push @$html, "<a href=\"javascript:toggleOffLayer('identicalproteins');\" title=\"Show Identicals\">Show/Hide Assignments for Essentially Identical Proteins</a>";
808 : redwards 1.134 push(@$html,$cgi->div({id=>"identicalproteins"}, &HTML::make_table($col_hdrs,$tab,$title)));
809 : efrank 1.1 }
810 : overbeek 1.53 }
811 : parrello 1.60
812 : overbeek 1.53 sub print_kv_pairs {
813 : redwards 1.99 my($is_sprout, $fig_or_sprout,$cgi,$html,$peg) = @_;
814 : overbeek 1.140 my $baseurl=$FIG_Config::cgi_base;
815 : overbeek 1.161 $baseurl = "./"; # Relative url fix
816 : parrello 1.108
817 : redwards 1.99 # we don't want to do this for SPROUT
818 : olson 1.129 if ($is_sprout)
819 :     {
820 :     return print_kv_pairs_sprout($fig_or_sprout,$cgi,$html,$peg);
821 :     }
822 : parrello 1.108
823 : redwards 1.94 # RAE: modified this to allow the users to edit the key/value pairs.
824 :     # there will be two choices: when the "Edit Attributes" button is pressed
825 :     # we will redraw the table with input fields and what not.
826 :    
827 :     # If the Add Changes button is pressed we will save the changes
828 :     # we will do this first before displaying the results
829 : parrello 1.108
830 : overbeek 1.141 my @attr = sort { ($a->[1] cmp $b->[1]) or ($a->[2] cmp $b->[2]) } $fig_or_sprout->get_attributes($peg);
831 : redwards 1.94 if ($cgi->param('Add Changes')) {
832 :     my ($deleted, $added, $changed)=(undef, undef, undef);
833 : parrello 1.108
834 : redwards 1.94 foreach my $key (@attr) {
835 : redwards 1.105 unless ($cgi->param("key.".$key->[1])) {
836 : redwards 1.138 if (&delete_attribute($fig_or_sprout, $peg, $key->[1], $cgi->param("value.".$key->[1]), $cgi->param("url.".$key->[1]))) {
837 : redwards 1.99 push @$deleted, [@$key, ["deleted", "td colspan=2 style=\"text-align: center\""]];
838 :     }
839 : redwards 1.94 }
840 : redwards 1.105 if (($cgi->param("value.".$key->[1]) ne $key->[2]) || ($cgi->param("url.".$key->[1]) ne $key->[3])) {
841 : redwards 1.138 if (&change_attribute($fig_or_sprout,$peg, $key->[1], $key->[2], $key->[3], $cgi->param("value.".$key->[1]), $cgi->param("url.".$key->[1]))) {
842 : redwards 1.105 push @$changed, [@$key, $cgi->param("value.".$key->[1]), $cgi->param("url.".$key->[1])];
843 : redwards 1.99 }
844 : redwards 1.94 }
845 :     }
846 :     for (my $i=0; $i<=5; $i++) {
847 :     if ($cgi->param("key.$i")) {
848 : redwards 1.99 if (&add_attribute($fig_or_sprout,$peg, $cgi->param("key.$i"), $cgi->param("value.$i"), $cgi->param("url.$i"))) {
849 : redwards 1.138 push @$added, [$cgi->param("key.$i"), ["added", "td colspan=3 style=\"text-align: center\""], $cgi->param("value.$i"), $cgi->param("url.$i")];
850 : redwards 1.99 }
851 :     else {
852 :     print STDERR $peg, " and ", $cgi->param("key.$i"), " not added\n";
853 :     }
854 : redwards 1.134 }
855 : redwards 1.94 }
856 : parrello 1.108
857 : redwards 1.134 if ($changed || $deleted || $added) {
858 :     my $tab = [];
859 :     my $col_hdrs=["Peg", "Attribute", "Original Value", "Original URL", "New Value", "New URL"];
860 : redwards 1.138 if ($changed) {push @$tab, [["<strong>Changed Attributes", "td colspan=6 bgcolor=gray style=\"text-align: center\""]], @$changed}
861 :     if ($deleted) {push @$tab, [["<strong>Deleted Attributes", "td colspan=6 bgcolor=gray style=\"text-align: center\""]], @$deleted}
862 :     if ($added) {push @$tab, [["<strong>Added Attributes", "td colspan=6 bgcolor=gray style=\"text-align: center\""]], @$added}
863 : redwards 1.94
864 : redwards 1.134 push(@$html,&HTML::make_table($col_hdrs,$tab,"Changed Data"));
865 : overbeek 1.141 @attr = sort { ($a->[1] cmp $b->[1]) or ($a->[2] cmp $b->[2]) } $fig_or_sprout->get_attributes($peg);
866 : redwards 1.134 }
867 :     # now get the explanations and save those
868 :     my $explanations;
869 :     foreach my $key (@attr) {
870 :     if ($cgi->param("explanation.".$key->[1])) {
871 : overbeek 1.162 if (&key_info($fig_or_sprout, $key->[1], {"description"=>$cgi->param("explanation.".$key->[1])})) {
872 : redwards 1.134 push @$explanations, [@$key, $cgi->param("explanation.".$key->[1])];
873 :     }
874 :     }
875 :     }
876 :     for (my $i=0; $i<=5; $i++) {
877 :     if ($cgi->param("key.$i") && $cgi->param("value.$i") && $cgi->param("explanation.".$i)) {
878 : overbeek 1.162 if (&key_info($fig_or_sprout, $cgi->param("key.$i"), {"description"=>$cgi->param("explanation.".$i)})) {
879 : redwards 1.134 push @$explanations, [$cgi->param("key.$i"), $cgi->param("value.$i"), $cgi->param("url.$i"), $cgi->param("explanation.".$i)];
880 :     }
881 :     }
882 :     }
883 : redwards 1.138 if ($explanations) {
884 : redwards 1.134 my $col_hdrs=["Peg", "Attribute", "Value", "URL", "Explanation"];
885 :     push(@$html,&HTML::make_table($col_hdrs,$explanations,"Explanations"));
886 :     }
887 : redwards 1.94 }
888 :    
889 : redwards 1.134 my $col_hdrs=["Key<br><span style='font-size: smaller'>Link Explains Key</span>","Value"];
890 : redwards 1.94
891 : redwards 1.95 my $tab = [];
892 :     if ($cgi->param('Edit Attributes') && $cgi->param('user')) {
893 : redwards 1.134 push @$col_hdrs, "URL", "Explanation";
894 : redwards 1.105 foreach my $key (sort {$a->[1] cmp $b->[1]} @attr) {
895 : mkubal 1.166 my $data=$fig_or_sprout->key_info($key->[1]);
896 :     if ($data->{"is_cv"} == 1){next}
897 : redwards 1.95 push @$tab,
898 :     [
899 : redwards 1.105 $cgi->textfield(-name=>"key.".$key->[1], -default=>$key->[1], -size=>30),
900 :     $cgi->textfield(-name=>"value.".$key->[1], -default=>$key->[2], -size=>30),
901 :     $cgi->textfield(-name=>"url.".$key->[1], -default=>$key->[3], -size=>30),
902 : overbeek 1.162 $cgi->textfield(-name=>"explanation.".$key->[1], -default=>$data->{"description"}, -size=>30),
903 : redwards 1.95 ];
904 :     }
905 :     for (my $i=0; $i<=5; $i++) {
906 :     push @$tab,
907 :     [
908 :     $cgi->textfield(-name=>"key.$i", -size=>30),
909 :     $cgi->textfield(-name=>"value.$i", -size=>30),
910 :     $cgi->textfield(-name=>"url.$i", -size=>30),
911 : redwards 1.134 $cgi->textfield(-name=>"explanation.$i", -default=>'', -size=>30),
912 : redwards 1.95 ];
913 :     }
914 :     }
915 : redwards 1.99 #RAE we need to check that this is a scalar
916 :     elsif (ref($attr[0]) eq "ARRAY") {
917 : overbeek 1.161 my $link=$cgi->url(-relative => 1, -query => 1, -path_info => 1);
918 : redwards 1.95 foreach $_ (sort {$a->[0] cmp $b->[0]} @attr) {
919 : redwards 1.105 my($peg,$tag,$val,$url) = @$_;
920 : mkubal 1.166 push(@$tab,["<a href='$link&showtag=$tag'>$tag</a>",$url ? "<a href=\"$url\">$val</a>" : $val]);
921 : redwards 1.134 if ($cgi->param("showtag") && $cgi->param("showtag") eq $tag) {
922 :     my $data=&key_info($fig_or_sprout, $tag);
923 :     my $info="No Information Known about $tag";
924 : overbeek 1.162 if ($data->{"description"}) {$info=$data->{"description"}}
925 : redwards 1.134 push(@$tab, [["Key", "th"], ["Explanation", "th"]], [$tag, $info]);
926 :     }
927 : redwards 1.95 }
928 :     }
929 : parrello 1.108
930 : redwards 1.95 # Add the appropriate submit button to the table
931 :     if ($cgi->param('user') && $cgi->param('Edit Attributes')) {
932 :     # we want a Add button
933 :     push @$tab, [[$cgi->submit('Add Changes'), "td colspan=3 style=\"text-align: center\""]];
934 :     }
935 :     elsif ($cgi->param('user')) {
936 : overbeek 1.168 # RAE:
937 :     # I have turned off editing attributes at the moment. I think it is debateable that it has any value
938 :     # I am not aware of anyone editing attributes on a per-protein basis, although I know that people have
939 :     # edited them in bulk. The code is not working properly, and should be rewritten, so for now
940 :     # I have disabled them.
941 :    
942 :     #push @$tab, [[$cgi->submit('Edit Attributes'), "td colspan=2 style=\"text-align: center\""]];
943 : overbeek 1.38 }
944 : overbeek 1.207 push(@$html,$cgi->start_form(-action=>"protein.cgi"),
945 :     $cgi->hidden("prot"),
946 :     $cgi->hidden("user"),
947 :     $cgi->hidden('new_framework'));
948 : redwards 1.134 if (($cgi->param('user') && $cgi->param('Edit Attributes')) || $cgi->param("showtag")) {
949 :     # these are the cases where we automatically want this shown
950 :     push(@$html,$cgi->br,$cgi->hr,&HTML::make_table($col_hdrs, $tab,"Attributes"),$cgi->hr);
951 :     }
952 :     else {
953 :     # otherwise we set the javascript section to hide this.
954 :     push @$html, "<a href=\"javascript:toggleLayer('attributes');\" title=\"Show Attributes\">Show/Hide Attributes</a>",
955 : overbeek 1.140 "\n<div id='attributes'>\n<a href='$baseurl/Html/Attributes.html' class='help' target='help'>Help on Attributes</a>\n",
956 : redwards 1.134 &HTML::make_table($col_hdrs, $tab,"Attributes"), "</div>";
957 :     }
958 : golsen 1.100 # Add end of form -- GJO
959 : redwards 1.105 # RAE: sorry about that Gary.
960 : golsen 1.100 push( @$html, $cgi->end_form );
961 : overbeek 1.53 }
962 :    
963 : olson 1.129 sub print_kv_pairs_sprout
964 :     {
965 :     my($fig_or_sprout, $cgi, $html, $peg) = @_;
966 :    
967 : overbeek 1.141 my @props = sort { ($a->[1] cmp $b->[1]) or ($a->[2] cmp $b->[2]) } $fig_or_sprout->get_attributes($peg);
968 : olson 1.129
969 :     my @col_hdrs = ("Key", "Value");
970 :    
971 :     my @tab;
972 :    
973 :     for my $prop (@props)
974 :     {
975 : overbeek 1.146 my($fid, $name, $value, $evidence) = @$prop;
976 : olson 1.129 my $txt;
977 :     if ($evidence =~ /^http/)
978 :     {
979 :     $txt = qq(<a href="$evidence">$value</a>);
980 :     }
981 :     else
982 :     {
983 :     $txt = $value;
984 :     }
985 :     push(@tab, [$name, $txt]);
986 :     }
987 :    
988 :     push(@$html, &HTML::make_table(\@col_hdrs, \@tab, "Attributes"), $cgi->hr);
989 :    
990 :     print STDERR Dumper($html);
991 :     }
992 :    
993 :    
994 : redwards 1.125 sub print_protein_fams {
995 : redwards 1.126
996 :     ############## RAE
997 :     # This code adds the protein family table to the page. This can be shown/hidden at the discretion of the viewer. Hopefully.
998 :    
999 :     my($is_sprout, $fig_or_sprout,$cgi,$html,$peg,$user) = @_;
1000 :     # we don't want to do this for SPROUT
1001 :     return if ($is_sprout);
1002 :    
1003 :     # get the families and other information
1004 :     my $tab=[];
1005 :     my @families=&families_for_protein($fig_or_sprout,$peg);
1006 : redwards 1.128 unless (scalar @families) {
1007 :     push @$html, "No protein families found\n";
1008 :     return;
1009 :     }
1010 : redwards 1.136
1011 : overbeek 1.140 my $baseurl=$FIG_Config::cgi_base;
1012 : overbeek 1.161
1013 : overbeek 1.168 push @$html, "<a href=\"javascript:toggleLayer('proteinfamilies');\" title=\"Show Protein Families\">Show/Hide Protein Families</a>";
1014 : redwards 1.126 foreach my $fam (@families)
1015 :     {
1016 : overbeek 1.164 my $link="<a href='proteinfamilies.cgi?user=$user&family=$fam'>$fam</a>";
1017 : redwards 1.126 push @$tab, [$link, &family_function($fig_or_sprout, $fam), &sz_family($fig_or_sprout, $fam)];
1018 :     }
1019 :     my $col_hdrs=["Family ID<br><small>Link Investigates Family</small>", "Family Function", "Family Size"];
1020 : redwards 1.136 push @$html, $cgi->br, $cgi->div({id=>"proteinfamilies"},
1021 : overbeek 1.165 "\n<a href='Html/ProteinFamilies.html' class='help' target='help'>Help on Protein Families</a>\n",
1022 : redwards 1.136 &HTML::make_table($col_hdrs, $tab, "Protein Families")
1023 :     );
1024 : redwards 1.126 }
1025 :    
1026 :    
1027 :     sub old_print_protein_fams {
1028 :    
1029 :     ############## RAE
1030 :     # This is functional code that displays the protein families, but I want to try it using
1031 :     # the CSS method. Therefore, I am keeping this code just for now, rather than munging it and being
1032 :     # stuck with nothing working. Just rename this method and it will be fine!
1033 :    
1034 : redwards 1.125 my($is_sprout, $fig_or_sprout,$cgi,$html,$peg,$user) = @_;
1035 :    
1036 :     # we don't want to do this for SPROUT
1037 :     return if ($is_sprout);
1038 :    
1039 :     # generate the link to turn protein fams on or off
1040 : overbeek 1.161 my $link=$cgi->url(-relative => 1, -query => 1, -path_info => 1);
1041 : redwards 1.125 if ($link =~ /showproteinfams/) {
1042 :     $link =~ s/[\&\;]showproteinfams.*[^\;\&]/\&/;
1043 :     push @$html, "< &nbsp; " . $cgi->a({href=> $link}, "Hide Protein Families");
1044 :    
1045 :     # get the families and other information
1046 :     my $tab=[];
1047 :     my @families=&families_for_protein($fig_or_sprout,$peg);
1048 :     return unless (scalar @families);
1049 :     foreach my $fam (@families)
1050 :     {
1051 : overbeek 1.140 my $baseurl=$FIG_Config::cgi_base;
1052 : overbeek 1.161 $baseurl = './'; # Relative url fix
1053 : overbeek 1.140 my $link="<a href='$baseurl/proteinfamilies.cgi?user=$user&family=$fam'>$fam</a>";
1054 : redwards 1.125 push @$tab, [$link, &family_function($fig_or_sprout, $fam), &sz_family($fig_or_sprout, $fam)];
1055 :     }
1056 :     my $col_hdrs=["Family ID<br><small>Link Investigates Family</small>", "Family Function", "Family Size"];
1057 :     push @$html, $cgi->br, &HTML::make_table($col_hdrs, $tab, "Protein Families"), $cgi->hr;
1058 :     }
1059 :     else
1060 :     {
1061 :     push @$html, "> &nbsp; " . $cgi->a({href=> $link . "&showproteinfams='1'"}, "Show Protein Families"); # define this here before we mess with ourself!
1062 :     }
1063 :     }
1064 :    
1065 : overbeek 1.68 sub who {
1066 :     my($id) = @_;
1067 :    
1068 :     if ($id =~ /^fig\|/) { return "FIG" }
1069 :     if ($id =~ /^gi\|/) { return "" }
1070 :     if ($id =~ /^^[NXYZA]P_/) { return "RefSeq" }
1071 :     if ($id =~ /^sp\|/) { return "SwissProt" }
1072 :     if ($id =~ /^uni\|/) { return "UniProt" }
1073 : overbeek 1.123 if ($id =~ /^tigr\|/) { return "TIGR" }
1074 : overbeek 1.68 if ($id =~ /^pir\|/) { return "PIR" }
1075 :     if ($id =~ /^kegg\|/) { return "KEGG" }
1076 :     }
1077 :    
1078 : overbeek 1.53 sub print_subsys_connections {
1079 :     my($fig_or_sprout,$cgi,$html,$peg,$user) = @_;
1080 : overbeek 1.38
1081 : olson 1.28 #
1082 :     # Show the subsystems in which this protein participates.
1083 :     #
1084 :    
1085 : parrello 1.60 if (my @subsystems = &subsystems_for_peg($fig_or_sprout,$peg)) {
1086 :     push(@$html,
1087 :     $cgi->h2("Subsystems in which this peg is present"));
1088 :    
1089 :     my(@hdrs);
1090 :     my(@table);
1091 :    
1092 : overbeek 1.147 @hdrs = ("Subsystem", "Curator", "Role");
1093 : parrello 1.60
1094 : overbeek 1.122 my $sprout = $cgi->param('SPROUT') ? 1 : "";
1095 : parrello 1.60
1096 :     for my $ent (@subsystems) {
1097 :     my($sub, $role) = @$ent;
1098 : overbeek 1.147 my $curator = &subsystem_curator($fig_or_sprout,$sub);
1099 : overbeek 1.149 my $can_alter;
1100 :    
1101 : golsen 1.107 my $esc_sub = uri_escape($sub); # in URI::Escape
1102 : overbeek 1.156 my $genome = &FIG::genome_of($peg);
1103 : overbeek 1.149 my %opts = (SPROUT => $sprout,
1104 :     user => $user,
1105 :     ssa_name => $esc_sub,
1106 : overbeek 1.156 focus => $genome,
1107 :     request => 'show_ssa',
1108 :     show_clusters => 1,
1109 : overbeek 1.149 sort => 'by_phylo'
1110 :     );
1111 :    
1112 :     my $opts = join("&", map { "$_=$opts{$_}" } keys(%opts));
1113 : overbeek 1.155 my $url = $cgi->a({href => "display_subsys.cgi?$opts"}, $sub);
1114 : overbeek 1.89
1115 : overbeek 1.147 push(@table, [$url, $curator, $role]);
1116 : parrello 1.60 }
1117 :     push(@$html, &HTML::make_table(\@hdrs, \@table));
1118 : olson 1.28 }
1119 : overbeek 1.53 }
1120 :    
1121 :     sub print_links {
1122 :     my($fig_or_sprout,$cgi,$html,$peg) = @_;
1123 : overbeek 1.31
1124 : parrello 1.60 my @links = &peg_links($fig_or_sprout,$peg);
1125 :     if (@links > 0) {
1126 :     my $col_hdrs = [1,2,3,4,5];
1127 :     my $title = "Links to Related Entries in Other Sites";
1128 :     my $tab = [];
1129 :     my ($n,$i);
1130 :     for ($i=0; ($i < @links); $i += 5) {
1131 :     $n = (($i + (5-1)) < @links) ? $i+(5-1) : $i+(@links - $i);
1132 :     push(@$tab,[@links[$i..$n]]);
1133 :     }
1134 : redwards 1.134 push @$html, "<a href=\"javascript:toggleLayer('linkselsewhere');\" title=\"Show Links\">Show/Hide Links to Related Entries in Other Sites</a>";
1135 : overbeek 1.188 push(@$html,$cgi->div({id=>"linkselsewhere"}, &HTML::make_table($col_hdrs,$tab,$title)));
1136 :     }
1137 :     if (! $cgi->param('SPROUT'))
1138 :     {
1139 :     my $url = &cgi_url . "/add_links.cgi?peg=$peg";
1140 :     push @$html, $cgi->br("<a href=$url>To Add New Links to this Gene</a>\n");
1141 : overbeek 1.53 }
1142 : efrank 1.1 }
1143 :    
1144 :    
1145 :    
1146 :     ################# Similarities ############################
1147 :    
1148 :    
1149 :     sub print_similarities {
1150 : overbeek 1.53 my( $fig_or_sprout, $cgi, $html, $peg ) = @_;
1151 : overbeek 1.63
1152 :     if ($cgi->param('SPROUT'))
1153 :     {
1154 :     &print_similarities_SPROUT($fig_or_sprout, $cgi, $html, $peg );
1155 :     }
1156 :     else
1157 :     {
1158 :     &print_similarities_SEED($fig_or_sprout, $cgi, $html, $peg );
1159 :     }
1160 :     }
1161 :    
1162 : golsen 1.76
1163 : overbeek 1.63 sub print_similarities_SPROUT {
1164 :     my($fig_or_sprout, $cgi, $html, $peg ) = @_;
1165 :    
1166 : overbeek 1.122 $cgi->delete('sims');
1167 :    
1168 : overbeek 1.63 my $user = $cgi->param('user') || "";
1169 : overbeek 1.122
1170 : overbeek 1.63 my $current_func = &trans_function_of($cgi,$fig_or_sprout,$peg,$user);
1171 :    
1172 :     push( @$html, $cgi->hr,
1173 :     "<a name=Similarities>",
1174 : overbeek 1.68 $cgi->h1(''),
1175 : overbeek 1.63 "</a>\n"
1176 :     );
1177 :    
1178 : overbeek 1.116 my @sims = sort { $a->[1] <=> $b->[1] } &bbhs($fig_or_sprout,$peg,1.0e-10);
1179 : overbeek 1.63
1180 :     my @from = $cgi->radio_group(-name => 'from',
1181 :     -nolabels => 1,
1182 :     -override => 1,
1183 : overbeek 1.65 -values => ["",$peg,map { $_->[0] } @sims]);
1184 : overbeek 1.63
1185 :     my $target = "window$$";
1186 :     # RAE: added a name to the form so tha the javascript works
1187 :     push( @$html, $cgi->start_form( -method => 'post',
1188 :     -target => $target,
1189 :     -action => 'fid_checked.cgi',
1190 :     -name => 'fid_checked'
1191 :     ),
1192 :     $cgi->hidden(-name => 'SPROUT', -value => 1),
1193 :     $cgi->hidden(-name => 'fid', -value => $peg),
1194 :     $cgi->hidden(-name => 'user', -value => $user),
1195 :     $cgi->br,
1196 :     "For Selected (checked) sequences: ",
1197 :     $cgi->submit('align'),
1198 :     );
1199 :    
1200 :     if ($user) {
1201 :     my $help_url = "Html/help_for_assignments_and_rules.html";
1202 : golsen 1.100 push ( @$html, $cgi->br, $cgi->br,
1203 :     "<a href=$help_url target=\"SEED_or_SPROUT_help\">Help on Assignments, Rules, and Checkboxes</a>",
1204 : overbeek 1.63 $cgi->br, $cgi->br,
1205 :     $cgi->submit('assign/annotate')
1206 :     );
1207 :    
1208 :     if ($cgi->param('translate')) {
1209 :     push( @$html, $cgi->submit('add rules'),
1210 :     $cgi->submit('check rules'),
1211 :     $cgi->br
1212 :     );
1213 :     }
1214 :     }
1215 :    
1216 :     push( @$html, $cgi->br,
1217 :     $cgi->checkbox( -name => 'checked',
1218 :     -value => $peg,
1219 :     -override => 1,
1220 :     -checked => 1,
1221 :     -label => ""
1222 :     )
1223 :     );
1224 :    
1225 :     my $col_hdrs;
1226 :     if ($user && $cgi->param('translate')) {
1227 :     push( @$html, " ASSIGN to/Translate from/SELECT current PEG", $cgi->br,
1228 :     "ASSIGN/annotate with form: ", shift @from, $cgi->br,
1229 :     "ASSIGN from/Translate to current PEG: ", shift @from
1230 :     );
1231 :     $col_hdrs = [ "ASSIGN to<hr>Translate from",
1232 :     "Similar sequence",
1233 :     "E-val",
1234 : overbeek 1.65 "In Sub",
1235 : overbeek 1.63 "ASSIGN from<hr>Translate to",
1236 :     "Function",
1237 :     "Organism",
1238 :     "Aliases"
1239 :     ];
1240 :     } elsif ($user) {
1241 :     push( @$html, " ASSIGN to/SELECT current PEG", $cgi->br,
1242 :     "ASSIGN/annotate with form: ", shift @from, $cgi->br,
1243 :     "ASSIGN from current PEG: ", shift @from
1244 :     );
1245 :     $col_hdrs = [ "ASSIGN to<hr>SELECT",
1246 :     "Similar sequence",
1247 :     "E-val",
1248 : overbeek 1.65 "In Sub",
1249 : overbeek 1.63 "ASSIGN from",
1250 :     "Function",
1251 :     "Organism",
1252 :     "Aliases"
1253 :     ];
1254 :     } else {
1255 :     push(@$html, " SELECT current PEG", $cgi->br );
1256 :     $col_hdrs = [ "SELECT",
1257 :     "Similar sequence",
1258 :     "E-val",
1259 :     "In Sub",
1260 :     "Function",
1261 :     "Organism",
1262 :     "Aliases"
1263 :     ];
1264 :     }
1265 :    
1266 :     my $ncol = @$col_hdrs;
1267 :     push( @$html, "<TABLE border cols=$ncol>\n",
1268 : overbeek 1.68 "\t<Caption><h2>Bidirectional Best Hits</h2></Caption>\n",
1269 : overbeek 1.63 "\t<TR>\n\t\t<TH>",
1270 :     join( "</TH>\n\t\t<TH>", @$col_hdrs ),
1271 :     "</TH>\n\t</TR>\n"
1272 :     );
1273 :    
1274 :     # Add the table data, row-by-row
1275 :    
1276 :     my $sim;
1277 :     foreach $sim ( @sims ) {
1278 :     my($id2,$psc) = @$sim;
1279 :     my $cbox = &translatable($fig_or_sprout,$id2) ?
1280 :     qq(<input type=checkbox name=checked value="$id2">) : "";
1281 :     my $id2_link = &HTML::set_prot_links($cgi,$id2);
1282 :     chomp $id2_link;
1283 :    
1284 :     my @in_sub = &peg_to_subsystems($fig_or_sprout,$id2);
1285 :     my $in_sub;
1286 :     if (@in_sub > 0) {
1287 :     $in_sub = @in_sub;
1288 :     } else {
1289 : overbeek 1.74 $in_sub = "&nbsp;";
1290 : overbeek 1.63 }
1291 :    
1292 :     my $radio = $user ? shift @from : undef;
1293 :     my $func2 = html_enc( scalar &trans_function_of( $cgi, $fig_or_sprout, $id2, $user ) );
1294 :     ## RAE Added color3. This will color function tables that do not match the original
1295 :     ## annotation. This makes is a lot easier to see what is different (e.g. caps/spaces, etc)
1296 :     my $color3="#FFFFFF";
1297 :     unless ($func2 eq $current_func) {$color3="#FFDEAD"}
1298 :    
1299 :     #
1300 :     # Colorize organisms:
1301 :     #
1302 :     # my $org = html_enc( &org_of($fig_or_sprout, $id2 ) );
1303 :     my ($org,$oc) = &org_and_color_of($fig_or_sprout, $id2 );
1304 :     $org = html_enc( $org );
1305 :    
1306 :     my $aliases = html_enc( join( ", ", &feature_aliasesL($fig_or_sprout,$id2) ) );
1307 : overbeek 1.68
1308 : overbeek 1.64 $aliases = &HTML::set_prot_links($cgi,$aliases);
1309 : overbeek 1.63
1310 :     # Okay, everything is calculated, let's "print" the row datum-by-datum:
1311 :    
1312 : overbeek 1.74 $func2 = $func2 ? $func2 : "&nbsp;";
1313 :     $aliases = $aliases ? $aliases : "&nbsp;";
1314 : overbeek 1.63 push( @$html, "\t<TR>\n",
1315 :     #
1316 :     # Colorize check box by Domain
1317 :     #
1318 :     "\t\t<TD Align=center Bgcolor=$oc>$cbox</TD>\n",
1319 :     "\t\t<TD Nowrap>$id2_link</TD>\n",
1320 :     "\t\t<TD Nowrap>$psc</TD>\n",
1321 : overbeek 1.65 "\t\t<TD>$in_sub</TD>",
1322 : overbeek 1.63 $user ? "\t\t<TD Align=center>$radio</TD>\n" : (),
1323 :     "\t\t<TD Bgcolor=$color3>$func2</TD>\n",
1324 :     #
1325 :     # Colorize organism by Domain
1326 :     #
1327 :     # "\t\t<TD>$org</TD>\n",
1328 :     "\t\t<TD Bgcolor=$oc>$org</TD>\n",
1329 :     "\t\t<TD>$aliases</TD>\n",
1330 :     "\t</TR>\n"
1331 :     );
1332 :     }
1333 :     push( @$html, "</TABLE>\n" );
1334 :     push( @$html, $cgi->end_form );
1335 :     }
1336 :    
1337 :    
1338 :     sub print_similarities_SEED {
1339 :     my( $fig_or_sprout, $cgi, $html, $peg ) = @_;
1340 : efrank 1.1
1341 : golsen 1.18 my $user = $cgi->param('user') || "";
1342 : golsen 1.76 my $current_func = &trans_function_of( $cgi, $fig_or_sprout, $peg, $user );
1343 : efrank 1.1
1344 : golsen 1.100 push @$html, $cgi->hr,
1345 :     "<a name=Similarities>", # Put an anchor on the heading
1346 :     $cgi->h2('Similarities'),
1347 :     "</a>\n";
1348 : golsen 1.34
1349 : golsen 1.76 # Generate the request form, and return current option values in hash
1350 : efrank 1.1
1351 : golsen 1.76 my $short_form = 0;
1352 : golsen 1.98 my $SimParams = sims_request_form( $fig_or_sprout, $cgi, $html, $peg, $user, $short_form );
1353 : overbeek 1.51
1354 : golsen 1.76 my $maxN = $SimParams->{ maxN };
1355 :     my $maxP = $SimParams->{ maxP };
1356 :     my $max_expand = $SimParams->{ max_expand };
1357 : golsen 1.98 my $select = $SimParams->{ select };
1358 : golsen 1.76 my $show_env = $SimParams->{ show_env };
1359 :     my $hide_alias = $SimParams->{ hide_alias };
1360 : overbeek 1.90 my $group_by_genome = $SimParams->{ group_by_genome };
1361 : golsen 1.98
1362 :     # These are active, but the values are only used in sims()
1363 :     # my $extra_opt = $SimParams->{ extra_opt };
1364 :     # my $min_q_cov = $SimParams->{ min_q_cov };
1365 :     # my $min_s_cov = $SimParams->{ min_s_cov };
1366 :     # my $min_sim = $SimParams->{ min_sim };
1367 :     # my $sim_meas = $SimParams->{ sim_meas };
1368 :     # my $sort_by = $SimParams->{ sort_by };
1369 :    
1370 : golsen 1.76 # None of these are currently active: -- GJO
1371 : golsen 1.98 # my $show_rep = $SimParams->{ show_rep };
1372 :     # my $max_sim = $SimParams->{ max_sim };
1373 :     # my $dyn_thrsh = $SimParams->{ dyn_thrsh };
1374 :     # my $save_dist = $SimParams->{ save_dist };
1375 :     # my $chk_which = $SimParams->{ chk_which };
1376 : efrank 1.1
1377 : golsen 1.76 # There is currently no control to turn this on! -- GJO
1378 : parrello 1.108 my $expand_groups = $SimParams->{ expand_groups };
1379 : efrank 1.1
1380 : golsen 1.76 # Move filtering of sims list out of display loop. Avoids many problems,
1381 :     # including display of table with no entries. Anticipate more filters.
1382 :     # -- GJO
1383 : golsen 1.97 #
1384 : golsen 1.98 # All the filtering is now done in get_raw_sims and expand_raw_sims. -- GJO
1385 : golsen 1.76
1386 : golsen 1.98 my @sims = sims( $fig_or_sprout,
1387 :     $peg,
1388 :     $maxN,
1389 :     $maxP,
1390 :     $select,
1391 :     $max_expand,
1392 :     $group_by_genome,
1393 :     $SimParams
1394 :     );
1395 : golsen 1.77
1396 : golsen 1.76 if ( @sims ) {
1397 :     push( @$html, $cgi->hr );
1398 :     my @from = $cgi->radio_group( -name => 'from',
1399 :     -nolabels => 1,
1400 :     -override => 1,
1401 :     -values => [ "", $peg, map { $_->id2 } @sims ]
1402 :     );
1403 : parrello 1.60
1404 :     my $target = "window$$";
1405 :     # RAE: added a name to the form so tha the javascript works
1406 :     push( @$html, $cgi->start_form( -method => 'post',
1407 : golsen 1.76 -target => $target,
1408 :     -action => 'fid_checked.cgi',
1409 :     -name => 'fid_checked'
1410 : parrello 1.60 ),
1411 :     $cgi->hidden(-name => 'fid', -value => $peg),
1412 :     $cgi->hidden(-name => 'user', -value => $user),
1413 :     $cgi->br,
1414 :     "For Selected (checked) sequences: ",
1415 :     $cgi->submit('align'),
1416 :     $cgi->submit('view annotations'),
1417 : golsen 1.106 $cgi->submit('get sequences'),
1418 : parrello 1.60 $cgi->submit('show regions')
1419 :     );
1420 :    
1421 :     if ($user) {
1422 :     my $help_url = "Html/help_for_assignments_and_rules.html";
1423 :     push ( @$html, $cgi->br, $cgi->br,
1424 : golsen 1.100 "<a href=$help_url target=\"SEED_or_SPROUT_help\">Help on Assignments, Rules, and Checkboxes</a>",
1425 : parrello 1.60 $cgi->br, $cgi->br,
1426 :     $cgi->submit('assign/annotate')
1427 :     );
1428 :    
1429 :     if ($cgi->param('translate')) {
1430 :     push( @$html, $cgi->submit('add rules'),
1431 :     $cgi->submit('check rules'),
1432 :     $cgi->br
1433 :     );
1434 :     }
1435 :     }
1436 : efrank 1.1
1437 : parrello 1.60 push( @$html, $cgi->br,
1438 :     $cgi->checkbox( -name => 'checked',
1439 :     -value => $peg,
1440 :     -override => 1,
1441 :     -checked => 1,
1442 :     -label => ""
1443 :     )
1444 :     );
1445 :    
1446 :     my $col_hdrs;
1447 : overbeek 1.176 my $color_help = "(<A href=\"Html/similarity_region_colors.html\" target=\"SEED_or_SPROUT_help\">colors</A>)";
1448 :     my $func_clr_help = "(<A href=\"Html/function_colors.html\" target=\"SEED_or_SPROUT_help\">function colors</A>)";
1449 : golsen 1.97
1450 : parrello 1.60 if ($user && $cgi->param('translate')) {
1451 :     push( @$html, " ASSIGN to/Translate from/SELECT current PEG", $cgi->br,
1452 :     "ASSIGN/annotate with form: ", shift @from, $cgi->br,
1453 : golsen 1.97 "ASSIGN from/Translate to current PEG: ", shift @from
1454 : parrello 1.60 );
1455 :     $col_hdrs = [ "ASSIGN to<hr>Translate from",
1456 :     $expand_groups ? "family" : (),
1457 :     $expand_groups ? "size" : (),
1458 :     "Similar sequence",
1459 :     "E-val<br>% iden",
1460 : overbeek 1.177 "region in<br>sim seq<br>$color_help",
1461 :     "region in<br>peg<br>$color_help",
1462 : parrello 1.60 "ASSIGN from<hr>Translate to",
1463 : overbeek 1.90 "In Sub",
1464 : overbeek 1.143 &evidence_codes_link($cgi),
1465 : golsen 1.97 "Function<br>$func_clr_help",
1466 : parrello 1.60 "Organism",
1467 : overbeek 1.90 (! $hide_alias) ? "Aliases" : ()
1468 : parrello 1.60 ];
1469 :     } elsif ($user) {
1470 :     push( @$html, " ASSIGN to/SELECT current PEG", $cgi->br,
1471 :     "ASSIGN/annotate with form: ", shift @from, $cgi->br,
1472 : golsen 1.97 "ASSIGN from current PEG: ", shift @from
1473 : parrello 1.60 );
1474 :     $col_hdrs = [ "ASSIGN to<hr>SELECT",
1475 :     $expand_groups ? "family" : (),
1476 :     $expand_groups ? "size" : (),
1477 :     "Similar sequence",
1478 :     "E-val<br>% iden",
1479 : overbeek 1.178 "region in<br>sim seq<br>$color_help",
1480 :     "region in<br>peg<br>$color_help",
1481 : overbeek 1.179 "Assign from",
1482 : parrello 1.60 "In Sub",
1483 : overbeek 1.143 &evidence_codes_link($cgi),
1484 : golsen 1.97 "Function<br>$func_clr_help",
1485 : parrello 1.60 "Organism",
1486 : overbeek 1.90 (! $hide_alias) ? "Aliases" : ()
1487 : parrello 1.60 ];
1488 :     } else {
1489 :     push(@$html, " SELECT current PEG", $cgi->br );
1490 :     $col_hdrs = [ "SELECT",
1491 :     $expand_groups ? "family" : (),
1492 :     $expand_groups ? "size" : (),
1493 :     "Similar sequence",
1494 :     "E-val<br>% iden",
1495 :     "region in<br>similar sequence<br>$color_help",
1496 :     "region in<br>$peg<br>$color_help",
1497 : golsen 1.97 "In Sub",
1498 : overbeek 1.143 &evidence_codes_link($cgi),
1499 : golsen 1.97 "Function<br>$func_clr_help",
1500 : parrello 1.60 "Organism",
1501 : overbeek 1.90 (! $hide_alias) ? "Aliases" : ()
1502 : parrello 1.60 ];
1503 :     }
1504 : efrank 1.1
1505 : redwards 1.37 # RAE Add the check all/uncheck all boxes.
1506 :     push (@$html, $cgi->br, &HTML::java_buttons("fid_checked", "checked"), $cgi->br);
1507 :    
1508 : parrello 1.60 #
1509 :     # Total rewrite of sim table code: cleaner program flow; omitting
1510 :     # empty columns; colorizing region-of-similarity cells -- GJO
1511 :     #
1512 :     # Start the similarity table with "Caption" and header row
1513 :    
1514 :     my $ncol = @$col_hdrs;
1515 :     push( @$html, "<TABLE border cols=$ncol>\n",
1516 :     "\t<Caption><h2>Similarities</h2></Caption>\n",
1517 :     "\t<TR>\n\t\t<TH>",
1518 :     join( "</TH>\n\t\t<TH>", @$col_hdrs ),
1519 :     "</TH>\n\t</TR>\n"
1520 :     );
1521 :    
1522 : golsen 1.97 #
1523 : golsen 1.93 # Grouping by genome is hard to see. This is an attempt to make it more obvious
1524 :     # by consolidating the "Organism" for all rows in which it is repeated. -- GJO
1525 : golsen 1.97 #
1526 :     # Let's figure out the function here too. This will allow color to be
1527 :     # specific for more than one function. For example, we can color:
1528 :     #
1529 :     # Identical function white
1530 :     # Most common alternative brown
1531 :     # Next most common alternatives red, orange, yellow, green, blue, and violet
1532 :     # Any additional alternatives gray
1533 :     #
1534 : golsen 1.93
1535 :     my $sim;
1536 : golsen 1.97 my ( $id2, $func, $genome, $org, $color, $info, $prev_genome, $prev_sim );
1537 :     my %func_cnt = ();
1538 :    
1539 : golsen 1.93 foreach $sim ( @sims ) {
1540 :     $id2 = $sim->id2;
1541 : golsen 1.97
1542 :     $func = html_enc( scalar trans_function_of( $cgi, $fig_or_sprout, $id2, $user ) );
1543 :     $func && $func_cnt{ $func }++;
1544 :    
1545 : golsen 1.93 if ( $group_by_genome && ( ( $genome ) = $id2 =~ /fig\|(\d+\.\d+)\./ )
1546 :     && ( $genome eq $prev_genome ) )
1547 :     {
1548 : golsen 1.97 $prev_sim->[-1]->[3]++; # Increase row span of org
1549 :     push @$sim, [ $func, "", $color, 0 ]; # No org name, prev_color, no row span
1550 : golsen 1.93 }
1551 :     else
1552 :     {
1553 :     ( $org, $color ) = org_and_color_of( $fig_or_sprout, $id2 );
1554 : golsen 1.97 push @$sim, [ $func, html_enc( $org ), $color, 1 ];
1555 : golsen 1.93 $prev_genome = $genome || "";
1556 :     $prev_sim = $sim;
1557 :     }
1558 :     }
1559 :    
1560 : golsen 1.97 # Build a function to color translation table based on frequence of function.
1561 :     # Reserve white for the current function.
1562 :    
1563 :     my %func_color;
1564 :     $func_cnt{ $current_func } && delete $func_cnt{ $current_func };
1565 :     $func_color{ $current_func } = "#FFFFFF";
1566 : parrello 1.108
1567 : golsen 1.97 # Assign other colors until we run out:
1568 :    
1569 :     my @colors = qw( #EECCAA #FFAAAA #FFCC66 #FFFF00 #AAFFAA #BBBBFF #FFAAFF );
1570 :     for ( sort { $func_cnt{ $b } <=> $func_cnt{ $a } } keys %func_cnt )
1571 :     {
1572 :     $func_color{ $_ } = ( shift @colors ) || "#DDDDDD";
1573 :     }
1574 :    
1575 : parrello 1.60 # Add the table data, row-by-row
1576 :    
1577 : overbeek 1.90 my $alia = (! $hide_alias);
1578 : parrello 1.60 foreach $sim ( @sims ) {
1579 :     my $id2 = $sim->id2;
1580 : golsen 1.76
1581 : parrello 1.60 my $cbox = &translatable($fig_or_sprout,$id2) ?
1582 :     qq(<input type=checkbox name=checked value="$id2">) : "";
1583 :    
1584 :     my( $family, $sz, $funcF, $fam_link );
1585 : overbeek 1.118 $family = $sz = $funcF = $fam_link = "";
1586 : parrello 1.60
1587 :     my $id2_link = &HTML::set_prot_links($cgi,$id2);
1588 :     chomp $id2_link;
1589 :    
1590 :     my @in_sub = &peg_to_subsystems($fig_or_sprout,$id2);
1591 :     my $in_sub;
1592 : overbeek 1.141
1593 : parrello 1.60 if (@in_sub > 0) {
1594 :     $in_sub = @in_sub;
1595 : overbeek 1.158 # RAE: add a javascript popup with all the subsystems
1596 :     my $ss_list=join "<br>", map { my $g = $_; $g =~ s/\_/ /g; $_ = $g } sort {$a cmp $b} @in_sub;
1597 :     $in_sub = $cgi->a(
1598 : redwards 1.160 {id=>"subsystems", onMouseover=>"javascript:if(!this.tooltip) this.tooltip=new Popup_Tooltip(this, 'Subsystems', '$ss_list', ''); this.tooltip.addHandler(); return false;"}, $in_sub);
1599 : parrello 1.60 } else {
1600 : overbeek 1.74 $in_sub = "&nbsp;";
1601 : parrello 1.60 }
1602 :    
1603 : redwards 1.160 # evidence codes moved here so I can add a tool tip for them
1604 :     my $ev_codes=" &nbsp; ";
1605 :     my @ev_codes=&evidence_codes($fig_or_sprout,$id2);
1606 :     if (scalar(@ev_codes) && $ev_codes[0])
1607 :     {
1608 :     my $ev_code_help=join("<br />", map {&evidence_codes_explain($_)} @ev_codes);
1609 :     $ev_codes = $cgi->a(
1610 :     {id=>"evidence_codes", onMouseover=>"javascript:if(!this.tooltip) this.tooltip=new Popup_Tooltip(this, 'Evidence Codes', '$ev_code_help', ''); this.tooltip.addHandler(); return false;"}, join("<br />", @ev_codes));
1611 :     }
1612 :    
1613 : parrello 1.60 my $psc = $sim->psc;
1614 :     my $iden = $sim->iden;
1615 :     my $ln1 = $sim->ln1;
1616 :     my $ln2 = $sim->ln2;
1617 :     my $b1 = $sim->b1;
1618 :     my $e1 = $sim->e1;
1619 :     my $b2 = $sim->b2;
1620 :     my $e2 = $sim->e2;
1621 :     my $d1 = abs($e1 - $b1) + 1;
1622 :     my $d2 = abs($e2 - $b2) + 1;
1623 :     my $reg1 = "$b1-$e1 (<b>$d1/$ln1</b>)";
1624 :     my $color1 = match_color( $b1, $e1, $ln1 );
1625 :     my $reg2 = "$b2-$e2 (<b>$d2/$ln2</b>)";
1626 :     my $color2 = match_color( $b2, $e2, $ln2 );
1627 :     my $radio = $user ? shift @from : undef;
1628 : golsen 1.97
1629 :     # Retrieve the Function and Organism data that was pushed on the end of the sim:
1630 :    
1631 :     my ( $func2, $org, $oc, $rowspan ) = @{$sim->[-1]};
1632 : golsen 1.93
1633 :     ## RAE Added color3. This will color function cells that do not match the original
1634 : parrello 1.60 ## annotation. This makes is a lot easier to see what is different (e.g. caps/spaces, etc)
1635 : golsen 1.97
1636 :     my $color3 = $func2 && $func_color{ $func2 } || "#DDDDDD";
1637 : parrello 1.60
1638 : golsen 1.93 if ( $funcF && ( $funcF ne $func2 ) ) { $func2 = "$funcF<br>$func2" }
1639 : golsen 1.97 $func2 ||= "&nbsp;";
1640 : parrello 1.60
1641 : golsen 1.97 my $aliases = undef;
1642 :     if ( $alia )
1643 :     {
1644 :     $aliases = html_enc( join( ", ", &feature_aliasesL($fig_or_sprout,$id2) ) );
1645 :     $aliases = &HTML::set_prot_links( $cgi, $aliases );
1646 :     $aliases ||= "&nbsp;";
1647 :     }
1648 : parrello 1.60
1649 :     # Okay, everything is calculated, let's "print" the row datum-by-datum:
1650 :    
1651 :     push( @$html, "\t<TR>\n",
1652 :     #
1653 :     # Colorize check box by Domain
1654 :     #
1655 :     "\t\t<TD Align=center Bgcolor=$oc>$cbox</TD>\n",
1656 :     $expand_groups ? "\t\t<TD>$fam_link</TD>/n" : (),
1657 :     $expand_groups ? "\t\t<TD>$sz</TD>\n" : (),
1658 :     "\t\t<TD Nowrap>$id2_link</TD>\n",
1659 :     "\t\t<TD Nowrap>$psc<br>$iden\%</TD>\n",
1660 :     "\t\t<TD Nowrap Bgcolor=$color2>$reg2</TD>\n",
1661 :     "\t\t<TD Nowrap Bgcolor=$color1>$reg1</TD>\n",
1662 :     $user ? "\t\t<TD Align=center>$radio</TD>\n" : (),
1663 : golsen 1.100 "\t\t<TD Align=center>$in_sub</TD>",
1664 : redwards 1.160 "\t\t<TD Align=center>$ev_codes</TD>",
1665 : parrello 1.60 "\t\t<TD Bgcolor=$color3>$func2</TD>\n",
1666 :     #
1667 :     # Colorize organism by Domain
1668 :     #
1669 : golsen 1.93 $rowspan ? "\t\t<TD Rowspan=$rowspan Bgcolor=$oc>$org</TD>\n" : (),
1670 : parrello 1.60 $alia ? "\t\t<TD>$aliases</TD>\n" : (),
1671 :     "\t</TR>\n"
1672 :     );
1673 :     }
1674 : overbeek 1.11
1675 : parrello 1.60 push( @$html, "</TABLE>\n" );
1676 :     push( @$html, $cgi->end_form );
1677 : efrank 1.1 }
1678 :     }
1679 :    
1680 : golsen 1.18 #
1681 :     # Support functions for writing the similarities
1682 :     #
1683 :     # This is a sufficient set of escaping for text in HTML:
1684 :     #
1685 :    
1686 :     sub html_enc { $_ = $_[0]; s/\&/&amp;/g; s/\>/&gt;/g; s/\</&lt;/g; $_ }
1687 :    
1688 :     #
1689 :     # Make a background color that reflects the position and extent of a
1690 :     # matching region.
1691 :     #
1692 :     # Left side is red; right side is blue.
1693 :     # Long match is white or pastel; short match is saturated color.
1694 :     #
1695 :    
1696 :     sub match_color {
1697 :     my ( $b, $e, $n ) = @_;
1698 :     my ( $l, $r ) = ( $e > $b ) ? ( $b, $e ) : ( $e, $b );
1699 :     # my $hue = 3/4 * 0.5*($l+$r)/$n - 1/24;
1700 :     my $hue = 5/6 * 0.5*($l+$r)/$n - 1/12;
1701 :     my $cov = ( $r - $l + 1 ) / $n;
1702 :     my $sat = 1 - 10 * $cov / 9;
1703 :     my $br = 1;
1704 :     rgb2html( hsb2rgb( $hue, $sat, $br ) );
1705 :     }
1706 :    
1707 :     #
1708 :     # Convert HSB to RGB. Hue is taken to be in range 0 - 1 (red to red);
1709 :     #
1710 :    
1711 :     sub hsb2rgb {
1712 :     my ( $h, $s, $br ) = @_;
1713 :     $h = 6 * ($h - floor($h)); # Hue is made cyclic modulo 1
1714 :     if ( $s > 1 ) { $s = 1 } elsif ( $s < 0 ) { $s = 0 }
1715 :     if ( $br > 1 ) { $br = 1 } elsif ( $br < 0 ) { $br = 0 }
1716 :     my ( $r, $g, $b ) = ( $h <= 3 ) ? ( ( $h <= 1 ) ? ( 1, $h, 0 )
1717 :     : ( $h <= 2 ) ? ( 2 - $h, 1, 0 )
1718 :     : ( 0, 1, $h - 2 )
1719 :     )
1720 :     : ( ( $h <= 4 ) ? ( 0, 4 - $h, 1 )
1721 :     : ( $h <= 5 ) ? ( $h - 4, 0, 1 )
1722 :     : ( 1, 0, 6 - $h )
1723 :     );
1724 :     ( ( $r * $s + 1 - $s ) * $br,
1725 :     ( $g * $s + 1 - $s ) * $br,
1726 :     ( $b * $s + 1 - $s ) * $br
1727 :     )
1728 :     }
1729 :    
1730 :     #
1731 :     # Convert an RGB value to an HTML color string:
1732 :     #
1733 :    
1734 :     sub rgb2html {
1735 :     my ( $r, $g, $b ) = @_;
1736 :     if ( $r > 1 ) { $r = 1 } elsif ( $r < 0 ) { $r = 0 }
1737 :     if ( $g > 1 ) { $g = 1 } elsif ( $g < 0 ) { $g = 0 }
1738 :     if ( $b > 1 ) { $b = 1 } elsif ( $b < 0 ) { $b = 0 }
1739 :     sprintf("\"#%02x%02x%02x\"", int(255.999*$r), int(255.999*$g), int(255.999*$b) )
1740 :     }
1741 :    
1742 :     #
1743 :     # floor could be gotten from POSIX::, but why bother?
1744 :     #
1745 :    
1746 :     sub floor {
1747 :     my $x = $_[0];
1748 :     defined( $x ) || return undef;
1749 :     ( $x >= 0 ) || ( int($x) == $x ) ? int( $x ) : -1 - int( - $x )
1750 :     }
1751 :    
1752 :    
1753 : golsen 1.76 #------------------------------------------------------------------------
1754 :     # Generate similarity query forms for the SEED. Consolidates things like
1755 :     # style and defaults in one place.
1756 :     #
1757 :     # my $user = $cgi->param('user') || "";
1758 :     # my $short_form = 0;
1759 :     # my $SimParam = sims_request_form( $fig, $cgi, $html, $peg, $user, $short_form );
1760 :     #------------------------------------------------------------------------
1761 :    
1762 :     sub sims_request_form {
1763 :     my ( $fig, $cgi, $html, $peg, $user, $short_form ) = @_;
1764 :    
1765 : overbeek 1.122 my $trans_role = $cgi->param('translate') || 0;
1766 :    
1767 :     if ($cgi->param('SPROUT'))
1768 :     {
1769 :     &sprout_sims_request_form($cgi,$html,$peg,$trans_role,$user);
1770 :     return;
1771 :     }
1772 :    
1773 : golsen 1.76 # Read available parameters, and fill in defaults:
1774 :    
1775 :     my $maxN = defined( $cgi->param('maxN') ) ? $cgi->param('maxN') : 50;
1776 :     my $max_expand = defined( $cgi->param('max_expand') ) ? $cgi->param('max_expand') : 5;
1777 :     my $maxP = defined( $cgi->param('maxP') ) ? $cgi->param('maxP') : 1.0e-5;
1778 : golsen 1.98 my $select = $cgi->param('select') || 'all';
1779 :     my $show_env = $cgi->param('show_env') || 0;
1780 :     my $hide_alias = $cgi->param('hide_alias') || 0;
1781 : golsen 1.100 my $sort_by = $cgi->param('sort_by') || 'bits';
1782 : golsen 1.98 my $group_by_genome = $cgi->param('group_by_genome') || 0;
1783 :     my $expand_groups = $cgi->param('expand_groups') || 0;
1784 : golsen 1.76
1785 : golsen 1.77 # New similarity options
1786 :    
1787 :     # Act on request for more or fewer sim options
1788 : golsen 1.76
1789 :     my $extra_opt = defined( $cgi->param('extra_opt') ) ? $cgi->param('extra_opt') : 0;
1790 : golsen 1.77 if ( $cgi->param('more sim options') ) {
1791 :     $extra_opt = 1;
1792 :     $cgi->delete('more sim options');
1793 :     }
1794 :     if ( $cgi->param('fewer sim options') ) {
1795 :     $extra_opt = 0;
1796 :     $cgi->delete('fewer sim options');
1797 :     }
1798 :    
1799 :     # Make defaults completely open (match original behavior)
1800 :    
1801 :     my $min_sim = $extra_opt && defined( $cgi->param('min_sim') ) ? $cgi->param('min_sim') : 0;
1802 : golsen 1.100 my $sim_meas = $extra_opt && defined( $cgi->param('sim_meas') ) ? $cgi->param('sim_meas') : 'id';
1803 : golsen 1.77 my $min_q_cov = $extra_opt && defined( $cgi->param('min_q_cov') ) ? $cgi->param('min_q_cov') : 0;
1804 :     my $min_s_cov = $extra_opt && defined( $cgi->param('min_s_cov') ) ? $cgi->param('min_s_cov') : 0;
1805 : golsen 1.76
1806 : golsen 1.77 # New parameters. Not yet implimented.
1807 : golsen 1.76 # The defaults for representative sequences might be tuned:
1808 :    
1809 : golsen 1.77 my $show_rep = $extra_opt && defined( $cgi->param('show_rep') ) ? $cgi->param('show_rep') : 0;
1810 :     my $max_sim = $extra_opt && defined( $cgi->param('max_sim') ) ? $cgi->param('max_sim') : 0.70;
1811 :     my $dyn_thrsh = $extra_opt && defined( $cgi->param('dyn_thrsh') ) ? $cgi->param('dyn_thrsh') : 0;
1812 :     my $save_dist = $extra_opt && defined( $cgi->param('save_dist') ) ? $cgi->param('save_dist') : 0.80;
1813 : golsen 1.76
1814 :     # Mark some of the sequences automatically?
1815 :    
1816 : golsen 1.77 my $chk_which = $extra_opt && defined( $cgi->param('chk_which') ) ? $cgi->param('chk_which') : 'none';
1817 :    
1818 : golsen 1.76 # Use $cgi->param('more similarities') to drive increase in maxN and max_expand
1819 :    
1820 :     if ( $cgi->param('more similarities') ) {
1821 :     $maxN *= 2;
1822 :     $max_expand *= 2;
1823 :     $cgi->delete('more similarities');
1824 :     }
1825 :    
1826 : golsen 1.100 # Sanity checks on fixed vocabulary parameter values:
1827 : golsen 1.76
1828 : golsen 1.102 my %select_opts = map { ( $_, 1 ) } qw( all fig figx fig_pref figx_pref );
1829 :     my %sort_opts = map { ( $_, 1 ) } qw( bits id id2 bpp bpp2 );
1830 :     my %sim_meas_opts = map { ( $_, 1 ) } qw( id bpp );
1831 :     my %chk_which_opts = map { ( $_, 1 ) } qw( none all rep );
1832 :    
1833 :     $select = 'all' unless $select_opts{ $select };
1834 :     $sort_by = 'bits' unless $sort_opts{ $sort_by };
1835 :     $sim_meas = 'id' unless $sim_meas_opts{ $sim_meas };
1836 :     $chk_which = 'none' unless $chk_which_opts{ $chk_which };
1837 : golsen 1.76
1838 : golsen 1.100 # We have processed all options. Use them to build forms.
1839 : golsen 1.76
1840 :     # Checkmarks for input tags
1841 :    
1842 : golsen 1.102 my $chk_select_all = select_if( $select eq 'all' );
1843 :     my $chk_select_figp = select_if( $select eq 'fig_pref' );
1844 :     my $chk_select_figxp = select_if( $select eq 'figx_pref' );
1845 :     my $chk_select_fig = select_if( $select eq 'fig' );
1846 :     my $chk_select_figx = select_if( $select eq 'figx' );
1847 :     my $chk_show_env = chked_if( $show_env );
1848 :     my $chk_hide_alias = chked_if( $hide_alias );
1849 : overbeek 1.90 my $chk_group_by_genome = chked_if( $group_by_genome );
1850 : golsen 1.102 my $chk_sort_by_id = select_if( $sort_by eq 'id' );
1851 :     my $chk_sort_by_id2 = select_if( $sort_by eq 'id2' );
1852 :     my $chk_sort_by_bits = select_if( $sort_by eq 'bits' );
1853 :     my $chk_sort_by_bpp = select_if( $sort_by eq 'bpp' );
1854 :     my $chk_sort_by_bpp2 = select_if( $sort_by eq 'bpp2' );
1855 : overbeek 1.207 my $new_framework = $cgi->param('new_framework') ? 1 : 0;
1856 : golsen 1.76
1857 :     # Features unique to the long form:
1858 :    
1859 :     if ( $short_form )
1860 :     {
1861 :     # Use a here document to push the short version of the similarities form
1862 :     # on @$html (many values are passed as hidden inputs).
1863 :    
1864 :     push @$html, <<"End_Short_Form";
1865 :    
1866 :     <FORM Action=\"protein.cgi#Similarities\">
1867 :     <input type=hidden name=prot value=\"$peg\">
1868 :     <input type=hidden name=sims value=1>
1869 :     <input type=hidden name=fid value=\"$peg\">
1870 :     <input type=hidden name=user value=\"$user\">
1871 :     <input type=hidden name=translate value=$trans_role>
1872 : overbeek 1.206 <input type=hidden name=new_framework value=\"$new_framework\">
1873 : golsen 1.76
1874 : golsen 1.103 &nbsp;&nbsp;&nbsp; Max sims:<input type=text name=maxN size=5 value=$maxN> &nbsp;&nbsp;
1875 : golsen 1.100 Max expand:<input type=text name=max_expand size=5 value=$max_expand> &nbsp;&nbsp;
1876 :     Max E-val:<input type=text name=maxP size=8 value=$maxP> &nbsp;&nbsp;
1877 : golsen 1.98 <select name=select>
1878 : golsen 1.102 <option value=all $chk_select_all>Show all databases</option>
1879 :     <option value=fig_pref $chk_select_figp>Prefer FIG IDs (to max exp)</option>
1880 :     <option value=figx_pref $chk_select_figxp>Prefer FIG IDs (all)</option>
1881 :     <option value=fig $chk_select_fig>Just FIG IDs (to max exp)</option>
1882 :     <option value=figx $chk_select_figx>Just FIG IDs (all)</option>
1883 : golsen 1.100 </select> &nbsp;&nbsp;
1884 :     Show Env. samples:<input type=checkbox name=show_env value=1 $chk_show_env> &nbsp;&nbsp;
1885 : golsen 1.98 Hide aliases:<input type=checkbox name=hide_alias value=1 $chk_hide_alias><br />
1886 :    
1887 : golsen 1.103 <input type=submit name=Similarities value=Similarities> &nbsp;&nbsp;
1888 : golsen 1.98 Sort by
1889 :     <select name=sort_by>
1890 : golsen 1.101 <option value=bits $chk_sort_by_bits>score</option>
1891 :     <option value=id2 $chk_sort_by_id2>percent identity*</option>
1892 :     <option value=bpp2 $chk_sort_by_bpp2>score per position*</option>
1893 : golsen 1.98 <option value=id $chk_sort_by_id>percent identity</option>
1894 :     <option value=bpp $chk_sort_by_bpp>score per position</option>
1895 : golsen 1.100 </select> &nbsp;&nbsp;
1896 :     Group by genome:<input type=checkbox name=group_by_genome value=1 $chk_group_by_genome>
1897 :     &nbsp;&nbsp;&nbsp;
1898 : overbeek 1.168 <A href=\"Html/similarities_options.html\" target=\"SEED_or_SPROUT_help\" class=\"help\">Help with SEED similarities options</A><BR />
1899 : golsen 1.76 </FORM>
1900 : golsen 1.100
1901 : golsen 1.76 End_Short_Form
1902 :    
1903 :     }
1904 :     else
1905 :     {
1906 :     # Navigation buttons
1907 :    
1908 :     my ( $prev_peg_btn, $next_peg_btn ) = ( "", "" );
1909 :     my ( $prefix, $protnum ) = $peg =~ /^(.*\.)(\d+)$/;
1910 :     if ( $prefix && $protnum ) {
1911 :     if ( ( $protnum > 1 ) && &translatable( $fig_or_sprout, $prefix . ($protnum-1) ) )
1912 :     {
1913 :     $prev_peg_btn = $cgi->submit('previous PEG');
1914 :     }
1915 :     if ( &translatable( $fig_or_sprout, $prefix . ($protnum+1) ) )
1916 :     {
1917 :     $next_peg_btn = $cgi->submit('next PEG');
1918 :     }
1919 :     }
1920 :    
1921 :     # Add/remove extra options button
1922 :    
1923 :     my $extra_opt_btn = $extra_opt ? $cgi->submit('fewer sim options')
1924 :     : $cgi->submit('more sim options');
1925 :    
1926 :     # Checkmarks for input tags
1927 :    
1928 :     my $chk_sim_meas_id = select_if( $sim_meas eq 'id' );
1929 :     my $chk_sim_meas_bpp = select_if( $sim_meas eq 'bpp' );
1930 :     my $chk_show_rep = chked_if( $show_rep );
1931 :     my $chk_dyn_thrsh = chked_if( $dyn_thrsh );
1932 :     my $chk_chk_none = select_if( $chk_which eq 'none' );
1933 :     my $chk_chk_all = select_if( $chk_which eq 'all' );
1934 :     my $chk_chk_rep = select_if( $chk_which eq 'rep' );
1935 :    
1936 : golsen 1.77 # Finally time to write some HTML
1937 :     #
1938 : golsen 1.76 # Default options
1939 :    
1940 :     push @$html, <<"End_Default_Options";
1941 : golsen 1.98
1942 : golsen 1.76 <FORM Action=\"protein.cgi#Similarities\">
1943 :     <input type=hidden name=prot value=\"$peg\">
1944 :     <input type=hidden name=sims value=1>
1945 :     <input type=hidden name=fid value=\"$peg\">
1946 :     <input type=hidden name=user value=\"$user\">
1947 :     <input type=hidden name=translate value=$trans_role>
1948 : overbeek 1.206 <input type=hidden name=new_framework value=\"$new_framework\">
1949 : golsen 1.76
1950 : golsen 1.100 Max sims:<input type=text name=maxN size=5 value=$maxN> &nbsp;&nbsp;
1951 :     Max expand:<input type=text name=max_expand size=5 value=$max_expand> &nbsp;&nbsp;
1952 :     Max E-val:<input type=text name=maxP size=8 value=$maxP> &nbsp;&nbsp;
1953 : golsen 1.98 <select name=select>
1954 : golsen 1.102 <option value=all $chk_select_all>Show all databases</option>
1955 :     <option value=fig_pref $chk_select_figp>Prefer FIG IDs (to max exp)</option>
1956 :     <option value=figx_pref $chk_select_figxp>Prefer FIG IDs (all)</option>
1957 :     <option value=fig $chk_select_fig>Just FIG IDs (to max exp)</option>
1958 :     <option value=figx $chk_select_figx>Just FIG IDs (all)</option>
1959 : golsen 1.100 </select> &nbsp;&nbsp;
1960 :     Show Env. samples:<input type=checkbox name=show_env value=1 $chk_show_env> &nbsp;&nbsp;
1961 : golsen 1.98 Hide aliases:<input type=checkbox name=hide_alias value=1 $chk_hide_alias><br />
1962 :    
1963 :     Sort by
1964 :     <select name=sort_by>
1965 : golsen 1.101 <option value=bits $chk_sort_by_bits>score</option>
1966 :     <option value=id2 $chk_sort_by_id2>percent identity*</option>
1967 :     <option value=bpp2 $chk_sort_by_bpp2>score per position*</option>
1968 : golsen 1.98 <option value=id $chk_sort_by_id>percent identity</option>
1969 :     <option value=bpp $chk_sort_by_bpp>score per position</option>
1970 : golsen 1.100 </select> &nbsp;&nbsp;
1971 :     Group by genome:<input type=checkbox name=group_by_genome value=1 $chk_group_by_genome> &nbsp;&nbsp;&nbsp;
1972 : overbeek 1.168 <A href=\"Html/similarities_options.html\" target=\"SEED_or_SPROUT_help\" class=\"help\">Help with SEED similarities options</A><br />
1973 : golsen 1.76 End_Default_Options
1974 :    
1975 :     # Extra options
1976 :    
1977 :     push @$html, <<"End_Extra_Options" if $extra_opt;
1978 : golsen 1.77 <input type=hidden name=extra_opt value=\"$extra_opt\">
1979 :    
1980 : golsen 1.76 Min similarity:<input type=text name=min_sim size=5 value=$min_sim>
1981 : golsen 1.98 defined by
1982 : golsen 1.76 <select name=sim_meas>
1983 : golsen 1.98 <option value=id $chk_sim_meas_id>identities (0-100%)</option>
1984 :     <option value=bpp $chk_sim_meas_bpp>score per position (0-2 bits)</option>
1985 : golsen 1.100 </select> &nbsp;&nbsp;
1986 :     Min query cover (%):<input type=text name=min_q_cov size=5 value=$min_q_cov> &nbsp;&nbsp;
1987 : golsen 1.98 Min subject cover (%):<input type=text name=min_s_cov size=5 value=$min_s_cov><br />
1988 : golsen 1.76
1989 : golsen 1.77 <!-- Hide unimplimented options
1990 : golsen 1.76 <TABLE Cols=2>
1991 :     <TR>
1992 :     <TD Valign=top><input type=checkbox name=show_rep $chk_show_rep></TD>
1993 :     <TD> Show only representative sequences whose similarities to one another
1994 :     are less than <input type=text size=5 name=max_sim value=$max_sim>
1995 :     <br />
1996 :     <input type=checkbox name=dyn_thrsh value=1 $chk_dyn_thrsh> But keep sequences
1997 :     that are at least <input type=text size=5 name=save_dist value=$save_dist>
1998 :     times as distant from one another as from the query</TD>
1999 :     </TR>
2000 :     </TABLE>
2001 :    
2002 : golsen 1.77 <input type=hidden name=chk_which value=\"$chk_which\">
2003 :    
2004 : golsen 1.76 Automatically Select (check) which sequences:<select name=chk_which>
2005 :     <option value=none $chk_chk_none>none</option>
2006 :     <option value=all $chk_chk_all>all shown</option>
2007 :     <option value=rep $chk_chk_rep>representative set</option>
2008 :     </select><br />
2009 : golsen 1.77 -->
2010 : golsen 1.76 End_Extra_Options
2011 :    
2012 :     # Submit buttons
2013 :    
2014 :     push @$html, <<"End_of_Buttons";
2015 :     <input type=submit name='resubmit' value='resubmit'>
2016 :     <input type=submit name='more similarities' value='more similarities'>
2017 :     $prev_peg_btn
2018 :     $next_peg_btn
2019 : golsen 1.77 $extra_opt_btn
2020 : golsen 1.76 </FORM>
2021 : golsen 1.100
2022 : golsen 1.76 End_of_Buttons
2023 :    
2024 :     }
2025 :    
2026 :     # Return the current parameter values in a hash
2027 :    
2028 :     { maxN => $maxN,
2029 :     maxP => $maxP,
2030 :     max_expand => $max_expand,
2031 : golsen 1.98 select => $select,
2032 : golsen 1.76 show_env => $show_env,
2033 :     hide_alias => $hide_alias,
2034 : overbeek 1.90 group_by_genome => $group_by_genome,
2035 : golsen 1.76 trans_role => $trans_role,
2036 :     extra_opt => $extra_opt,
2037 :     min_sim => $min_sim,
2038 :     min_q_cov => $min_q_cov,
2039 :     min_s_cov => $min_s_cov,
2040 :     sim_meas => $sim_meas,
2041 : golsen 1.98 sort_by => $sort_by,
2042 : golsen 1.76 show_rep => $show_rep,
2043 :     max_sim => $max_sim,
2044 :     dyn_thrsh => $dyn_thrsh,
2045 :     save_dist => $save_dist,
2046 :     chk_which => $chk_which,
2047 :     expand_groups => $expand_groups
2048 :     }
2049 :     }
2050 :    
2051 : overbeek 1.122 sub sprout_sims_request_form {
2052 :     my($cgi,$html,$peg,$trans_role,$user) = @_;
2053 :    
2054 :     push @$html, <<"End_Short_Form";
2055 :    
2056 :     <FORM Action=\"protein.cgi\">
2057 :     <input type=hidden name=prot value=\"$peg\">
2058 :     <input type=hidden name=sims value=1>
2059 :     <input type=hidden name=SPROUT value=1>
2060 :     <input type=hidden name=user value=\"$user\">
2061 :     <input type=hidden name=translate value=$trans_role>
2062 :     <input type=submit name='Bidirectional Best Hits' value='Bidirectional Best Hits'>
2063 :    
2064 :     </FORM>
2065 :    
2066 :     End_Short_Form
2067 :     }
2068 :    
2069 : golsen 1.76
2070 :     #------------------------------------------------------------------------
2071 :     # Auxilliary function to acivate checkmark for input fields
2072 :     #------------------------------------------------------------------------
2073 :     sub chked_if { $_[0] ? 'checked ' : '' }
2074 :    
2075 :     sub select_if { $_[0] ? 'selected ' : '' }
2076 :    
2077 :    
2078 :    
2079 : efrank 1.1 ################# Context on the Chromosome ############################
2080 :    
2081 :     sub print_context {
2082 : overbeek 1.53 my($fig_or_sprout,$cgi,$html,$peg,$feat,$beg,$end) = @_;
2083 : olson 1.56
2084 : olson 1.57 if ($beg eq $end) { cluck "Have zero len"; }
2085 : efrank 1.1 my($contig1,$beg1,$end1,$strand,$max_so_far,$gap,$comment,$fc,$aliases);
2086 : overbeek 1.81 my($fid1,$sz,$color,$map,$gg,$n,$link,$in_neighborhood);
2087 : efrank 1.1
2088 : overbeek 1.41
2089 :     my $user = $cgi->param('user');
2090 : overbeek 1.53 my $sprout = $cgi->param('SPROUT') ? 1 : "";
2091 :     push(@$html,$cgi->start_form(-action => &cgi_url . "/chromosomal_clusters.cgi"),
2092 :     $cgi->hidden(-name => 'SPROUT', -value => $sprout),
2093 : overbeek 1.41 $cgi->hidden(-name => "prot", -value => $peg),
2094 : overbeek 1.44 $cgi->hidden(-name => "uni", -value => 1),
2095 : overbeek 1.41 $cgi->hidden(-name => "user", -value => $user));
2096 :    
2097 : overbeek 1.109 my $in_cluster = &in_cluster_with($fig_or_sprout,$cgi,$peg);
2098 : overbeek 1.73 my $col_hdrs;
2099 : overbeek 1.112
2100 : redwards 1.130 # RAE Added Subsys col headers
2101 : parrello 1.197 # BDP removed extra button columns per request by LKM
2102 :     # if ($cgi->param('SPROUT'))
2103 :     # {
2104 :     # $col_hdrs = ["fid","starts","ends","size","","gap","find<br>best<br>clusters","pins","fc-sc","SS",&evidence_codes_link($cgi),"comment","","","aliases"];
2105 :     # }
2106 :     # else
2107 :     # {
2108 : overbeek 1.143 $col_hdrs = ["fid","starts","ends","size","","gap","find<br>best<br>clusters","pins","fc-sc","SS",&evidence_codes_link($cgi),"comment","aliases"];
2109 : parrello 1.197 # }
2110 : overbeek 1.73
2111 : efrank 1.1 my($tab) = [];
2112 :     my $genes = [];
2113 : parrello 1.60
2114 : overbeek 1.109 my %coupled;
2115 : olson 1.148
2116 :     #
2117 :     # Make a pass over the features, determining what subsystems they appear in. Assign
2118 :     # unique numbers (names?) for them.
2119 :     #
2120 :    
2121 :     my %fid_to_subs;
2122 :     my %subs;
2123 :     for my $fid (@$feat)
2124 :     {
2125 :     my $subs = [&peg_to_subsystems($fig_or_sprout, $fid)];
2126 :     map { $subs{$_}++ } @$subs;
2127 :     $fid_to_subs{$fid} = $subs;
2128 :     }
2129 :    
2130 :     my $sub_idx = 1;
2131 :     my %sub_names;
2132 :     for my $sub (sort { $subs{$b} <=> $subs{$a} } keys %subs)
2133 :     {
2134 :     $sub_names{$sub} = $sub_idx++;
2135 :     }
2136 : overbeek 1.109
2137 :     my $fc_sc;
2138 : parrello 1.60 foreach $fid1 (@$feat) {
2139 : overbeek 1.119 my $best_clusters_link = "<a href=" . &cgi_url . "/homologs_in_clusters.cgi?prot=$fid1&user=$user&SPROUT=$sprout><img src=\"Html/button-cl.png\" border=\"0\"></a>";
2140 : overbeek 1.110 if (defined($fc_sc = $in_cluster->{$fid1}))
2141 : overbeek 1.109 {
2142 :     $fc = &pin_link($cgi,$fid1);
2143 :     }
2144 :     else
2145 :     {
2146 :     $fc = "";
2147 :     $fc_sc = "";
2148 :     }
2149 : efrank 1.1
2150 : parrello 1.60 my $aliases = join( ', ', &feature_aliasesL($fig_or_sprout,$fid1) );
2151 : olson 1.48 my $uniprot;
2152 :     if ($aliases =~ /(uni[^,]+)/) {
2153 :     # print STDERR "$1\n";
2154 :     $uniprot = $1;
2155 :     }
2156 : overbeek 1.68 $aliases = &HTML::set_prot_links($cgi,$aliases),
2157 :     $aliases =~ s/SPROUT=1/SPROUT=0/g;
2158 :     $aliases =~ s/[&;]user=[^&;]+[;&]/;/g;
2159 : overbeek 1.74 $aliases = $aliases ? $aliases : "&nbsp;";
2160 : overbeek 1.68
2161 : overbeek 1.73 my($to_seed,$to_gbrowse);
2162 :     $to_seed = $to_gbrowse = "";
2163 : parrello 1.197 # BDP: removed extra columns per request by LKM
2164 :     # if ($cgi->param('SPROUT') && ($fid1 =~ /peg/))
2165 :     # {
2166 :     # $to_seed = &cgi_url . "/protein.cgi?prot=$fid1";
2167 :     # $to_gbrowse = &cgi_url . $fig_or_sprout->get_gbrowse_feature_link($fid1);
2168 :     # }
2169 : overbeek 1.73
2170 :    
2171 : overbeek 1.68 ($contig1,$beg1,$end1) = &boundaries_of($fig_or_sprout,&feature_locationS($fig_or_sprout,$fid1));;
2172 :     $strand = ($beg1 < $end1) ? "+" : "-";
2173 :    
2174 :     my $function = &function_ofS($fig_or_sprout,$fid1);
2175 : olson 1.48 my $info = join ('<br/>', "<b>PEG:</b> ".$fid1, "<b>Contig:</b> ".$contig1, "<b>Begin:</b> ".$beg1, "<b>End:</b> ".$end1,$function ? "<b>Function:</b> ".$function : '', $uniprot ? "<b>Uniprot ID:</b> ".$uniprot : '');
2176 :    
2177 : parrello 1.60 if ($fid1 eq $peg) { $color = "green" }
2178 :     elsif ($fc) { $color = "blue" }
2179 :     else { $color = "red" }
2180 :    
2181 :     if ($fid1 =~ /peg\.(\d+)$/) {
2182 :     $n = $1;
2183 : overbeek 1.63 my $sprout = $cgi->param('SPROUT');
2184 :     $sprout = $sprout ? $sprout : "";
2185 : overbeek 1.161 $link = $cgi->url(-relative => 1) . "?prot=$fid1&user=$user&SPROUT=$sprout";
2186 : parrello 1.60 } elsif ($fid1 =~ /\.([a-z]+)\.\d+$/) {
2187 :     $n = uc $1;
2188 :     $link = "";
2189 :     } else {
2190 :     $n ="";
2191 :     $link = "";
2192 :     }
2193 :    
2194 :     push(@$genes,[&min($beg1,$end1),&max($beg1,$end1),($strand eq "+") ? "rightArrow" : "leftArrow", $color,$n,$link,$info]);
2195 :     if ($max_so_far) {
2196 :     $gap = (&min($beg1,$end1) - $max_so_far) - 1;
2197 :     } else {
2198 :     $gap = "";
2199 :     }
2200 :     $max_so_far = &max($beg1,$end1);
2201 : olson 1.48
2202 : efrank 1.1
2203 : parrello 1.60 if (&ftype($fid1) eq "peg") {
2204 :     $comment = &trans_function_of($cgi,$fig_or_sprout,$fid1,$user);
2205 :     } else {
2206 :     $comment = "";
2207 :     }
2208 : golsen 1.169 $comment = &set_ec_and_tc_links($fig_or_sprout,$cgi,&genome_of($fid1),$comment);
2209 : parrello 1.60 if ($fid1 eq $peg) {
2210 :     $comment = "\@bgcolor=\"#00FF00\":$comment";
2211 :     }
2212 :     $sz = abs($end1-$beg1)+1;
2213 :    
2214 : overbeek 1.74 $comment = $comment ? $comment : "&nbsp;";
2215 : redwards 1.130 # RAE Count the number of subsystems. This is just copied from elsewhere
2216 : olson 1.148 #my @in_sub = &peg_to_subsystems($fig_or_sprout,$fid1);
2217 :     my @in_sub = @{$fid_to_subs{$fid1}};
2218 : overbeek 1.154
2219 : redwards 1.130 my $in_sub;
2220 :     if (@in_sub > 0) {
2221 : overbeek 1.154 if ($is_sprout)
2222 :     {
2223 :     $in_sub = @in_sub;
2224 :     }
2225 :     else
2226 :     {
2227 :     $in_sub = @in_sub;
2228 : overbeek 1.158 $in_sub .= ": " . join(" ", map { $sub_names{$_} } sort {$b cmp $a} @in_sub);
2229 :     # RAE: add a javascript popup with all the subsystems
2230 :     # RAE: unless you assign $_ to $g,the map operates on the result of s///, i.e. the number of substitutions made. I think there is a cleaner
2231 :     # way to do this, eh Gary?
2232 :     my $ss_list=join "<br>", map { my $g = "$sub_names{$_} : $_"; $g =~ s/_/ /g; $_=$g } sort {$b cmp $a} @in_sub;
2233 :     $in_sub = $cgi->a(
2234 :     {id=>"subsystems", onMouseover=>"javascript:if(!this.tooltip) this.tooltip=new Popup_Tooltip(this, 'Subsystems', '$ss_list', ''); this.tooltip.addHandler(); return false;"}, $in_sub),
2235 : overbeek 1.154 }
2236 : redwards 1.130 } else {
2237 :     $in_sub = "&nbsp;";
2238 :     }
2239 : redwards 1.160
2240 :     # Generate the text for the evidence codes so we can have the popup tool tips
2241 :     my $ev_codes=" &nbsp; ";
2242 :     my @ev_codes=&evidence_codes($fig_or_sprout,$fid1);
2243 :     if (scalar(@ev_codes) && $ev_codes[0])
2244 :     {
2245 :     my $ev_code_help=join("<br />", map {&evidence_codes_explain($_)} @ev_codes);
2246 :     $ev_codes = $cgi->a(
2247 :     {id=>"evidence_codes", onMouseover=>"javascript:if(!this.tooltip) this.tooltip=new Popup_Tooltip(this, 'Evidence Codes', '$ev_code_help', ''); this.tooltip.addHandler(); return false;"}, join("<br />", @ev_codes));
2248 :     }
2249 :    
2250 :    
2251 : redwards 1.130
2252 : overbeek 1.73 if ($cgi->param('SPROUT'))
2253 :     {
2254 : parrello 1.198 # BDP: removed Sprout and GBrowse columns
2255 :     # my($s_link, $g_link);
2256 :     # if (0)
2257 :     # {
2258 :     # $s_link = "<a href=$to_seed>S</a>";
2259 :     # $g_link = "<a href=$to_gbrowse>G</a>";
2260 :     # }
2261 :     # else
2262 :     # {
2263 :     # $s_link = "<a href=$to_seed><img src=\"Html/button-s.png\" border=\"0\"></a>";
2264 :     # $g_link = "<a href=$to_gbrowse><img src=\"Html/button-g.png\" border=\"0\"></a>";
2265 :     # }
2266 : overbeek 1.73 push(@$tab,[&HTML::fid_link($cgi,$fid1,"local"),$beg1,$end1,$sz,$strand,$gap,
2267 : overbeek 1.112 $best_clusters_link,
2268 : overbeek 1.124 $fc ? $fc : "&nbsp;",
2269 :     $fc_sc ? $fc_sc : "&nbsp;",
2270 : redwards 1.130 $in_sub,
2271 : overbeek 1.141 join("<br>",&evidence_codes($fig_or_sprout,$fid1)),
2272 : overbeek 1.73 $comment,
2273 : parrello 1.198 # $s_link,
2274 :     # $g_link,
2275 : overbeek 1.81 $aliases]);
2276 : overbeek 1.73 }
2277 :     else
2278 :     {
2279 :     push(@$tab,[&HTML::fid_link($cgi,$fid1,"local"),$beg1,$end1,$sz,$strand,$gap,
2280 : overbeek 1.112 $best_clusters_link,
2281 : overbeek 1.109 $fc,$fc_sc,
2282 : redwards 1.130 $in_sub,
2283 : redwards 1.160 $ev_codes,
2284 : overbeek 1.73 $comment,
2285 : overbeek 1.81 $aliases]);
2286 : overbeek 1.73 }
2287 : efrank 1.1 }
2288 : overbeek 1.104 push(@$html,&HTML::make_table($col_hdrs,$tab,"Context on contig $contig1 from base $beg to $end (".(abs($end-$beg)+1)." bp)"));
2289 : overbeek 1.113 push(@$html,$cgi->end_form);
2290 : overbeek 1.53 return ($beg,$end,$genes);
2291 :     }
2292 :    
2293 :     sub print_graphics_context {
2294 :     my($beg,$end,$genes,$html) = @_;
2295 :    
2296 :     my $map = ["",$beg,$end,$genes];
2297 :     my $gg = [$map];
2298 : overbeek 1.2 push(@$html,@{ &GenoGraphics::render($gg,700,4,0,1) });
2299 : efrank 1.1 return;
2300 :     }
2301 :    
2302 :     sub assign_link {
2303 :     my($cgi,$func,$existing_func) = @_;
2304 :     my($assign_url,$assign_link);
2305 :    
2306 : parrello 1.60 if ($func && ((! $existing_func) || ($existing_func ne $func))) {
2307 :     $cgi->delete('request');
2308 : overbeek 1.161 $assign_url = $cgi->url(-relative => 1, -query => 1, -path_info => 1) . "&request=fast_assign&func=$func"; ## must encode
2309 : parrello 1.60 $assign_link = "<a href=\"$assign_url\">&nbsp;<=&nbsp;</a>";
2310 :     } else {
2311 :     $assign_link = "";
2312 : efrank 1.1 }
2313 :     return $assign_link;
2314 :     }
2315 :    
2316 :     sub pin_link {
2317 :     my($cgi,$peg) = @_;
2318 :     my $user = $cgi->param('user');
2319 :     $user = defined($user) ? $user : "";
2320 :    
2321 : overbeek 1.207 my $new_framework = $cgi->param('new_framework') ? 1 : 0;
2322 : overbeek 1.53 my $sprout = $cgi->param('SPROUT') ? 1 : "";
2323 : overbeek 1.207 my $cluster_url = "chromosomal_clusters.cgi?new_framework=$new_framework&prot=$peg&user=$user&uni=1&SPROUT=$sprout";
2324 : olson 1.83
2325 : overbeek 1.112 my $cluster_img = 0 ? "*" : '<img src="Html/button-pins-1.png" border="0">';
2326 : overbeek 1.114 my $cluster_link = "<a href=\"$cluster_url\" target=pinned_region.$$>$cluster_img</a>";
2327 : efrank 1.1 return $cluster_link;
2328 :     }
2329 :    
2330 : overbeek 1.84 sub set_ec_and_tc_links {
2331 : golsen 1.169 my($fig_or_sprout,$cgi,$org,$func) = @_;
2332 : parrello 1.167 Trace("Incoming functional assignment is \"$func\".") if T(EClink => 4);
2333 : parrello 1.60 if ($func =~ /^(.*)(\d+\.\d+\.\d+\.\d+)(.*)$/) {
2334 :     my $before = $1;
2335 :     my $ec = $2;
2336 :     my $after = $3;
2337 : parrello 1.167 Trace("Matched EC case: ID = $ec.") if T(EClink => 4);
2338 : golsen 1.169 return &set_ec_and_tc_links($fig_or_sprout,$cgi,$org,$before) . &set_ec_to_maps($fig_or_sprout,$cgi,$org,$ec) . &set_ec_and_tc_links($fig_or_sprout,$cgi,$org,$after);
2339 : overbeek 1.84 }
2340 :     elsif ($func =~ /^(.*)(TC \d+(\.[0-9A-Z]+){3,6})(.*)$/) {
2341 :     my $before = $1;
2342 :     my $tc = $2;
2343 :     my $after = $4;
2344 : parrello 1.167 Trace("Matched TC case: ID = $tc.") if T(EClink => 4);
2345 : golsen 1.169 return &set_ec_and_tc_links($fig_or_sprout,$cgi,$org,$before) . &set_tc_link($fig_or_sprout,$org,$tc) . &set_ec_and_tc_links($fig_or_sprout,$cgi,$org,$after);
2346 : efrank 1.1 }
2347 :     return $func;
2348 :     }
2349 :    
2350 : overbeek 1.84 sub set_tc_link {
2351 :     my($fig_or_sprout,$org,$tc) = @_;
2352 :    
2353 :     if ($tc =~ /^TC\s+(\S+)$/)
2354 :     {
2355 : olson 1.159 return "<a href=http://www.tcdb.org/tcdb/index.php?tc=$1&Submit=Lookup>$tc</a>";
2356 : overbeek 1.84 }
2357 :     return $tc;
2358 :     }
2359 : parrello 1.108
2360 : overbeek 1.84
2361 : efrank 1.1 sub set_ec_to_maps {
2362 : golsen 1.169 my($fig_or_sprout,$cgi,$org,$ec) = @_;
2363 : efrank 1.1
2364 : overbeek 1.53 my @maps = &ec_to_maps($fig_or_sprout,$ec);
2365 : parrello 1.60 if (@maps > 0) {
2366 :     $cgi->delete('request');
2367 : overbeek 1.161 my $url = $cgi->url(-relative => 1, -query => 1, -path_info => 1) . "&request=ec_to_maps&ec=$ec&org=$org";
2368 : parrello 1.60 my $link = "<a href=\"$url\">$ec</a>";
2369 :     return $link;
2370 : efrank 1.1 }
2371 :     return $ec;
2372 :     }
2373 :    
2374 :     sub show_ec_to_maps {
2375 : overbeek 1.53 my($fig_or_sprout,$cgi,$html,$ec) = @_;
2376 : efrank 1.1
2377 :     my $ec = $cgi->param('ec');
2378 : parrello 1.60 if (! $ec) {
2379 :     push(@$html,$cgi->h1("Missing EC number"));
2380 :     return;
2381 : efrank 1.1 }
2382 :    
2383 : overbeek 1.53 my @maps = &ec_to_maps($fig_or_sprout,$ec);
2384 : parrello 1.60 if (@maps > 0) {
2385 :     my $col_hdrs = ["map","metabolic topic"];
2386 :     my $map;
2387 :     my $tab = [map { $map = $_; [&map_link($cgi,$map),&map_name($fig_or_sprout,$map)] } @maps];
2388 :     push(@$html,&HTML::make_table($col_hdrs,$tab,"$ec: " . &ec_name($fig_or_sprout,$ec)));
2389 : efrank 1.1 }
2390 :     }
2391 :    
2392 :     sub map_link {
2393 :     my($cgi,$map) = @_;
2394 :    
2395 :     $cgi->delete('request');
2396 : overbeek 1.161 my $url = $cgi->url(-relative => 1, -query => 1, -path_info => 1) . "&request=link_to_map&map=$map";
2397 : efrank 1.1 my $link = "<a href=\"$url\">$map</a>";
2398 :     return $link;
2399 :     }
2400 :    
2401 :     sub link_to_map {
2402 : overbeek 1.53 my($fig_or_sprout,$cgi,$html) = @_;
2403 : efrank 1.1
2404 :     my $map = $cgi->param('map');
2405 : parrello 1.60 if (! $map) {
2406 :     push(@$html,$cgi->h1("Missing Map"));
2407 :     return;
2408 : efrank 1.1 }
2409 :    
2410 :     my $org = $cgi->param('org');
2411 : parrello 1.60 if (! $org) {
2412 :     push(@$html,$cgi->h1("Missing Org Parameter"));
2413 :     return;
2414 : efrank 1.1 }
2415 :     my$user = $cgi->param('user');
2416 :     $user = $user ? $user : "";
2417 :    
2418 :     $ENV{"REQUEST_METHOD"} = "GET";
2419 :     $ENV{"QUERY_STRING"} = "user=$user&map=$map&org=$org";
2420 :     my @out = `./show_kegg_map.cgi`;
2421 :     &HTML::trim_output(\@out);
2422 :     push(@$html,@out);
2423 :     }
2424 : parrello 1.60
2425 : efrank 1.1 sub aa_sequence {
2426 : overbeek 1.53 my($fig_or_sprout,$cgi,$html,$prot) = @_;
2427 : efrank 1.1 my($seq,$func,$i);
2428 :    
2429 : golsen 1.19 unshift @$html, "<TITLE>The SEED: Protein Sequence</TITLE>\n";
2430 : parrello 1.60 if ($seq = &get_translation($fig_or_sprout,$prot)) {
2431 :     $func = &function_ofS($fig_or_sprout,$prot,$cgi->param('user'));
2432 :     push(@$html,$cgi->pre,">$prot $func\n");
2433 :     for ($i=0; ($i < length($seq)); $i += 60) {
2434 :     if ($i > (length($seq) - 60)) {
2435 :     push(@$html,substr($seq,$i) . "\n");
2436 :     } else {
2437 :     push(@$html,substr($seq,$i,60) . "\n");
2438 :     }
2439 :     }
2440 :     push(@$html,$cgi->end_pre);
2441 :     } else {
2442 :     push(@$html,$cgi->h1("No translation available for $prot"));
2443 : efrank 1.1 }
2444 :     }
2445 :    
2446 :     sub dna_sequence {
2447 : overbeek 1.53 my($fig_or_sprout,$cgi,$html,$fid) = @_;
2448 : efrank 1.1 my($seq,$func,$i);
2449 :    
2450 : golsen 1.19 unshift @$html, "<TITLE>The SEED: Nucleotide Sequence</TITLE>\n";
2451 : parrello 1.60 if ($seq = &dna_seq($fig_or_sprout,&genome_of($fid),&feature_locationS($fig_or_sprout,$fid))) {
2452 :     $func = &function_ofS($fig_or_sprout,$prot,$cgi->param('user'));
2453 :     push(@$html,$cgi->pre,">$fid $func\n");
2454 :     for ($i=0; ($i < length($seq)); $i += 60) {
2455 :     if ($i > (length($seq) - 60)) {
2456 :     push(@$html,substr($seq,$i) . "\n");
2457 :     } else {
2458 :     push(@$html,substr($seq,$i,60) . "\n");
2459 :     }
2460 :     }
2461 :     push(@$html,$cgi->end_pre);
2462 :     } else {
2463 :     push(@$html,$cgi->h1("No DNA sequence available for $fid"));
2464 : efrank 1.1 }
2465 :     }
2466 : parrello 1.60
2467 : overbeek 1.173 # RAE: Added this routine to get the adjacent sequence. The default is to get 500 bp on either side of the
2468 :     # gene, but you can (secretly) change this to get more or less sequence by setting additional_sequence
2469 :     # in the URL. Also, I changed the way that the display is generated above so that I can used the s///
2470 :     # to add the color and new lines.
2471 : golsen 1.175 #
2472 :     # Fixed off-by-one errors in the end of coloring (which started this all).
2473 :     # Modified to detect end of contig (otherwise it fails when it runs off an end).
2474 :     # Modified to handle multisegment locations. -- GJO
2475 : overbeek 1.173
2476 :     sub dna_sequence_adjacent {
2477 : golsen 1.175 my( $fig_or_sprout,$cgi, $html, $fid ) = @_;
2478 :     my( $contig, $beg, $end, $seq, $func, $i );
2479 : overbeek 1.173
2480 :     unshift @$html, "<TITLE>The SEED: Nucleotide Sequence</TITLE>\n";
2481 : golsen 1.175 my $additional = $cgi->param("additional_sequence");
2482 :     defined( $additional ) or ( $additional = 500 );
2483 :    
2484 :     # Now handles segmented location and running off an end. -- GJO
2485 :    
2486 : overbeek 1.184 my $genome = &genome_of( $fid );
2487 :     my $loc = &feature_locationS($fig_or_sprout,$fid);
2488 :     # my $loc = $fig_or_sprout->feature_location( $fid );
2489 : golsen 1.175 my @loc = split /,/, $loc;
2490 :    
2491 : overbeek 1.184
2492 : golsen 1.175 # Add to beginning of the first segment:
2493 :    
2494 : overbeek 1.182 # NOTE the difference
2495 :     # Sprout returns locations in the form contig_start-stop
2496 :    
2497 : overbeek 1.184 # ( $contig, $beg, $end ) = $loc[0] =~ /^(.*)_(\d+)\D(\d+)$/;
2498 :    
2499 :     ($contig, $beg, $end) = BasicLocation::Parse($loc[0]);
2500 : overbeek 1.182
2501 : golsen 1.175 if ( ! ( $contig && $beg && $end ) )
2502 :     {
2503 :     push @$html, $cgi->h2( "Bad location information for $fid" );
2504 :     print STDERR "SEED Error: Bad location information ($loc) for $fid in dna_sequence_adjacent\n";
2505 :     return;
2506 :     }
2507 :     my ( $n1, $npre );
2508 :     if ( $beg < $end )
2509 :     {
2510 :     $n1 = $beg - $additional;
2511 :     $n1 = 1 if $n1 < 1;
2512 :     $npre = $beg - $n1;
2513 :     }
2514 :     else
2515 :     {
2516 :     $n1 = $beg + $additional;
2517 :     my $clen = $fig_or_sprout->contig_ln( $genome, $contig );
2518 :     $n1 = $clen if $n1 > $clen;
2519 :     $npre = $n1 - $beg;
2520 :     }
2521 :     $loc[0] = join( '_', $contig, $n1, $end );
2522 :    
2523 :     # Add to the end of the last segment:
2524 :    
2525 : overbeek 1.186 ( $contig, $beg, $end ) = BasicLocation::Parse($loc[-1]);
2526 :    
2527 : golsen 1.175 if ( ! ( $contig && $beg && $end ) )
2528 :     {
2529 :     push @$html, $cgi->h2( "Bad location information for $fid" );
2530 :     print STDERR "SEED Error: Bad location information ($loc) for $fid in dna_sequence_adjacent\n";
2531 :     return;
2532 :     }
2533 :     my ( $n2, $npost );
2534 :     if ( $beg < $end )
2535 :     {
2536 :     $n2 = $end + $additional;
2537 :     my $clen = $fig_or_sprout->contig_ln( $genome, $contig );
2538 :     $n2 = $clen if $n2 > $clen;
2539 :     $npost = $n2 - $end;
2540 :     }
2541 :     else
2542 :     {
2543 :     $n2 = $end - $additional;
2544 :     $n2 = 1 if $n2 < 1;
2545 :     $npost = $end - $n2;
2546 :     }
2547 :     $loc[-1] = join( '_', $contig, $beg, $n2 );
2548 :    
2549 :     $seq = $fig_or_sprout->dna_seq( $genome, join( ',', @loc ) );
2550 :     if ( ! $seq )
2551 :     {
2552 :     push @$html, $cgi->h2( "No DNA sequence available for $fid" );
2553 :     return;
2554 : overbeek 1.173 }
2555 : golsen 1.175
2556 :     my $len = length( $seq ); # Get length before adding newlines
2557 :     $seq =~ s/(.{60})/$1\n/g; # Cleaver way to wrap the sequence
2558 :     my $p1 = $npre + int( $npre/60 ); # End of prefix, adjusted for newlines
2559 :     my $p2 = $len - $npost; # End of data,
2560 :     $p2 += int( $p2/60 ); # adjusted for newlines
2561 :     my $diff = $p2 - $p1; # Characters of data
2562 :     # Integrate the HTML codes
2563 :     $seq =~ s/^(.{$p1})(.{$diff})(.*)$/$1<SPAN Style="color:red">$2<\/SPAN>$3/s;
2564 :    
2565 :     $func = $fig_or_sprout->function_of( $fid, $cgi->param('user') );
2566 :    
2567 :     push @$html, $cgi->pre, ">$fid $func\n$seq\n", $cgi->end_pre;
2568 : overbeek 1.173 }
2569 :    
2570 : golsen 1.175
2571 : efrank 1.1 sub show_fusions {
2572 : overbeek 1.53 my($fig_or_sprout,$cgi,$html,$prot) = @_;
2573 : efrank 1.1
2574 : overbeek 1.22 my $user = $cgi->param('user');
2575 :     $user = $user ? $user : "";
2576 : overbeek 1.53 my $sprout = $cgi->param('SPROUT') ? 1 : "";
2577 :    
2578 : efrank 1.1 $ENV{"REQUEST_METHOD"} = "GET";
2579 : overbeek 1.53 $ENV{"QUERY_STRING"} = "peg=$prot&user=$user&SPROUT=$sprout";
2580 : efrank 1.1 my @out = `./fusions.cgi`;
2581 :     print join("",@out);
2582 :     exit;
2583 : overbeek 1.2 }
2584 :    
2585 : overbeek 1.53 ###########################################################################
2586 : overbeek 1.2 sub print_compared_regions {
2587 : overbeek 1.53 my($fig_or_sprout,$cgi,$html,$peg) = @_;
2588 :    
2589 : overbeek 1.207 my $new_framework = $cgi->param('new_framework') ? 1 : 0;
2590 :    
2591 : overbeek 1.53 my $sz_region = $cgi->param('sz_region');
2592 :     $sz_region = $sz_region ? $sz_region : 16000;
2593 :    
2594 :     my $num_close = $cgi->param('num_close');
2595 :     $num_close = $num_close ? $num_close : 5;
2596 : overbeek 1.153
2597 : overbeek 1.189 my $user = $cgi->param('user');
2598 : overbeek 1.65 my @closest_pegs = &closest_pegs($fig_or_sprout,$cgi,$peg,$num_close);
2599 : overbeek 1.40
2600 : parrello 1.60 if (@closest_pegs > 0) {
2601 :     if (&possibly_truncated($fig_or_sprout,$peg)) {
2602 :     push(@closest_pegs,&possible_extensions($peg,\@closest_pegs));
2603 :     }
2604 :     @closest_pegs = &sort_fids_by_taxonomy($fig_or_sprout,@closest_pegs);
2605 :     unshift(@closest_pegs,$peg);
2606 :     my @all_pegs = ();
2607 : overbeek 1.119
2608 : parrello 1.60 my $gg = &build_maps($fig_or_sprout,\@closest_pegs,\@all_pegs,$sz_region);
2609 :     #warn Dumper($gg);
2610 : overbeek 1.68 my $color_sets = &cluster_genes($fig_or_sprout,$cgi,\@all_pegs,$peg);
2611 : parrello 1.60 &set_colors_text_and_links($gg,\@all_pegs,$color_sets);
2612 :     ################################### add commentary capability
2613 :     my $sprout = $cgi->param('SPROUT') ? 1 : "";
2614 :    
2615 :     my($gene,$n,%how_many,$val,@vals,$x);
2616 :     my($i,$map);
2617 :     @vals = ();
2618 :     for ($i=(@$gg - 1); ($i >= 0); $i--) {
2619 :     my @vals1 = ();
2620 :     $map = $gg->[$i];
2621 :     my $found = 0;
2622 :     my $got_red = 0;
2623 :     undef %how_many;
2624 :     foreach $gene (@{$map->[3]}) {
2625 :     if (($x = $gene->[3]) ne "grey") {
2626 :     $n = $gene->[4];
2627 :     if ($n == 1) { $got_red = 1 }
2628 :     $how_many{$n}++;
2629 :     $gene->[5] =~ /(fig\|\d+\.\d+\.peg\.\d+)/;
2630 : overbeek 1.194 $val = join("@",($n,$i,$1,$map->[0]->[0],$how_many{$n}));
2631 : parrello 1.60 push(@vals1,$val);
2632 :     $found++;
2633 :     }
2634 :     }
2635 :    
2636 :     if (! $got_red) {
2637 :     splice(@$gg,$i,1);
2638 :     } else {
2639 :     push(@vals,@vals1);
2640 :     }
2641 :     }
2642 : overbeek 1.35
2643 : overbeek 1.151 if (@$gg < 2) {
2644 :     push(@$html,$cgi->h3("No alignable regions in close genomes"));
2645 : overbeek 1.189 &add_previous_next($html,undef,undef,$fig_or_sprout,$peg,$user,$sz_region,$num_close);
2646 : parrello 1.60 } else {
2647 : overbeek 1.151
2648 :     my @parm_reset_form = ($cgi->hr);
2649 : overbeek 1.207 push(@parm_reset_form,$cgi->start_form(-action => &cgi_url . "/protein.cgi" ),
2650 :     $cgi->hidden(-name => 'new_framework', -value => $new_framework));
2651 : overbeek 1.151 my $param;
2652 :     foreach $param ($cgi->param()) {
2653 :     next if (($param eq "sz_region") || ($param eq "num_close"));
2654 :     push(@parm_reset_form,$cgi->hidden(-name => $param, -value => $cgi->param($param)));
2655 :     }
2656 :     push(@parm_reset_form,
2657 :     "size region: ",
2658 :     $cgi->textfield(-name => 'sz_region', -size => 10, -value => $sz_region, -override => 1),
2659 :     "&nbsp; &nbsp; &nbsp; &nbsp; &nbsp; ",
2660 :     "Number genomes: ",
2661 :     $cgi->textfield(-name => 'num_close', -size => 4, -value => $num_close, -override => 1),
2662 :     $cgi->br,
2663 :     $cgi->submit('Resubmit')
2664 :     );
2665 :     push(@parm_reset_form,$cgi->end_form);
2666 :     push(@$html,@parm_reset_form);
2667 : overbeek 1.189
2668 : overbeek 1.151 my @commentary_form = ();
2669 :     my $ctarget = "window$$";
2670 :     push(@commentary_form,$cgi->start_form(-target => $ctarget,
2671 :     -action => &cgi_url . "/chromosomal_clusters.cgi"
2672 :     ));
2673 :    
2674 :     push(@commentary_form,$cgi->hidden(-name => 'SPROUT', -value => $sprout),
2675 : overbeek 1.207 $cgi->hidden(-name => "request", -value => "show_commentary"),
2676 :     $cgi->hidden(-name => "new_framework", -value => $new_framework));
2677 : overbeek 1.151 push(@commentary_form,$cgi->hidden(-name => "prot", -value => $peg));
2678 :     push(@commentary_form,$cgi->hidden(-name => "uni", -value => 1));
2679 :     push(@commentary_form,$cgi->hidden(-name => "user", -value => $user));
2680 : parrello 1.60 push(@commentary_form,$cgi->hidden(-name => "show", -value => [@vals]));
2681 :     push(@commentary_form,$cgi->submit('commentary'));
2682 :     push(@commentary_form,$cgi->end_form());
2683 :     push(@$html,@commentary_form);
2684 : overbeek 1.151 push(@$html,@{ &GenoGraphics::render($gg,700,4,0,2) });
2685 : overbeek 1.189
2686 :     my($prev,$next);
2687 :     my $map1 = $gg->[0]->[3];
2688 :     if (($map1->[0]->[5] =~ /(fig\|\d+\.\d+\.peg\.\d+)/) && ($1 ne $peg))
2689 :     {
2690 :     $prev = $1;
2691 :     }
2692 :     if (($map1->[$#{$map1}]->[5] =~ /(fig\|\d+\.\d+\.peg\.\d+)/) && ($1 ne $peg))
2693 :     {
2694 :     $next = $1;
2695 :     }
2696 :     &add_previous_next($html,$prev,$next,$fig_or_sprout,$peg,$user,$sz_region,$num_close);
2697 : parrello 1.60 }
2698 : overbeek 1.151
2699 : parrello 1.120 if (! $cgi->param('SPROUT'))
2700 :     {
2701 :     push @$html, &FIGGenDB::linkClusterGenDB($peg);
2702 :     }
2703 : overbeek 1.2 }
2704 : overbeek 1.151 else
2705 :     {
2706 :     push(@$html,$cgi->h3("No alignable regions in close genomes"));
2707 : overbeek 1.189 &add_previous_next($html,undef,undef,$fig_or_sprout,$peg,$user,$sz_region,$num_close);
2708 :     }
2709 :     }
2710 :    
2711 :     sub add_previous_next {
2712 :     my($html,$prev,$next,$fig_or_sprout,$peg,$user,$sz_region,$num_close) = @_;
2713 :    
2714 : overbeek 1.207 my $new_framework = $cgi->param('new_framework') ? 1 : 0;
2715 : overbeek 1.206
2716 : overbeek 1.189 push(@$html,$cgi->br);
2717 :     if ($prev)
2718 :     {
2719 : overbeek 1.206 push(@$html,"<a href=protein.cgi?prot=$prev&compare_region=1&user=$user&sz_region=$sz_region&num_close=$num_close&new_framework=$new_framework>previous</a>");
2720 : overbeek 1.189 }
2721 :     else
2722 :     {
2723 :     my $genome = &FIG::genome_of($peg);
2724 :     my @contigs = $fig_or_sprout->contigs_of($genome);
2725 :     my @loc = $fig_or_sprout->feature_location($peg);
2726 :     my $contig;
2727 :     if ((@loc > 0) && ($loc[0] =~ /^(\S+)_\d+_\d+$/))
2728 :     {
2729 :     $contig = $1;
2730 :     }
2731 :     my $i;
2732 :     for ($i=0; ($i < @contigs) && ($contig ne $contigs[$i]); $i++) {}
2733 :     if (($i > 0) && ($i < @contigs))
2734 :     {
2735 :     $contig = $contigs[$i-1];
2736 :     my($genes,undef,undef) = $fig_or_sprout->genes_in_region($genome,$contig,1,10000);
2737 :     my @genes = grep { $fig_or_sprout->ftype($_) eq "peg" } @$genes;
2738 :    
2739 :     if (@genes > 0)
2740 :     {
2741 :     my $gene = $genes[0];
2742 : overbeek 1.206 push(@$html,"<a href=protein.cgi?prot=$gene&compare_region=1&user=$user&sz_region=$sz_region&num_close=$num_close&new_framework=$new_framework>previous</a>");
2743 : overbeek 1.189 }
2744 :     }
2745 :     }
2746 :    
2747 :    
2748 :     if ($next)
2749 :     {
2750 : overbeek 1.206 push(@$html,"&nbsp;&nbsp;&nbsp;&nbsp;&nbsp; <a href=protein.cgi?prot=$next&compare_region=1&user=$user&sz_region=$sz_region&num_close=$num_close&new_framework=$new_framework>next</a>");
2751 : overbeek 1.189 }
2752 :     else
2753 :     {
2754 :     my $genome = &FIG::genome_of($peg);
2755 :     my @contigs = $fig_or_sprout->contigs_of($genome);
2756 :     my @loc = $fig_or_sprout->feature_location($peg);
2757 :     my $contig;
2758 :     if ((@loc > 0) && ($loc[0] =~ /^(\S+)_\d+_\d+$/))
2759 :     {
2760 :     $contig = $1;
2761 :     }
2762 :     my $i;
2763 :     for ($i=0; ($i < @contigs) && ($contig ne $contigs[$i]); $i++) {}
2764 :     if (($i >= 0) && ($i < $#contigs))
2765 :     {
2766 :     $contig = $contigs[$i+1];
2767 :     my($genes,undef,undef) = $fig_or_sprout->genes_in_region($genome,$contig,1,10000);
2768 :     my @genes = grep { $fig_or_sprout->ftype($_) eq "peg" } @$genes;
2769 :    
2770 :     if (@genes > 0)
2771 :     {
2772 :     my $gene = $genes[0];
2773 : overbeek 1.206 push(@$html,"&nbsp;&nbsp;&nbsp;&nbsp;&nbsp; <a href=protein.cgi?prot=$gene&compare_region=1&user=$user&sz_region=$sz_region&num_close=$num_close&new_framework=$new_framework>next</a>");
2774 : overbeek 1.189 }
2775 :     }
2776 : overbeek 1.151 }
2777 : overbeek 1.2 }
2778 :    
2779 : overbeek 1.189
2780 : overbeek 1.2 sub closest_pegs {
2781 : overbeek 1.65 my($fig_or_sprout,$cgi,$peg,$n) = @_;
2782 : overbeek 1.2 my($id2,$d,$peg2,$i);
2783 :    
2784 : overbeek 1.65 my @closest;
2785 :     if ($cgi->param('SPROUT'))
2786 :     {
2787 : parrello 1.120 @closest = map { $_->[0] } sort { $a->[1] <=> $b->[1] } &bbhs($fig_or_sprout,$peg, 1.0e-10);
2788 : overbeek 1.65 }
2789 :     else
2790 :     {
2791 : parrello 1.120 @closest = map { $id2 = $_->id2; ($id2 =~ /^fig\|/) ? $id2 : () } &sims($fig_or_sprout,$peg,&FIG::max(20,$n*4),1.0e-20,"fig",&FIG::max(20,$n*4));
2792 : overbeek 1.65 }
2793 : overbeek 1.152
2794 : overbeek 1.151 if (@closest >= ($n-1))
2795 :     {
2796 :     $#closest = $n-2 ;
2797 :     }
2798 : overbeek 1.152 my %closest = map { $_ => 1 } @closest;
2799 : overbeek 1.2
2800 : overbeek 1.152 my @pinned_to = grep { ($_ ne $peg) && (! $closest{$_}) } &in_pch_pin_with($fig_or_sprout,$peg);
2801 :     my $g1 = &genome_of($peg);
2802 :     @pinned_to = map {$_->[1] }
2803 :     sort { $a->[0] <=> $b->[0] }
2804 :     map { $peg2 = $_; $d = &crude_estimate_of_distance($fig_or_sprout,$g1,&genome_of($peg2)); [$d,$peg2] }
2805 :     @pinned_to;
2806 : overbeek 1.2
2807 : overbeek 1.152 if (@closest == ($n-1))
2808 :     {
2809 :     $#closest = ($n - 2) - &FIG::min(scalar @pinned_to,int($n/2));
2810 :     for ($i=0; ($i < @pinned_to) && (@closest < ($n-1)); $i++)
2811 :     {
2812 : overbeek 1.151 if (! $closest{$pinned_to[$i]})
2813 :     {
2814 :     $closest{$pinned_to[$i]} = 1;
2815 :     push(@closest,$pinned_to[$i]);
2816 :     }
2817 :     }
2818 : overbeek 1.2 }
2819 : overbeek 1.151 return @closest;
2820 : overbeek 1.2 }
2821 :    
2822 :     sub build_maps {
2823 : overbeek 1.53 my($fig_or_sprout,$pinned_pegs,$all_pegs,$sz_region) = @_;
2824 : overbeek 1.2 my($gg,$loc,$contig,$beg,$end,$mid,$min,$max,$genes,$feat,$fid);
2825 :     my($contig1,$beg1,$end1,$map,$peg);
2826 :    
2827 :     $gg = [];
2828 : parrello 1.60 foreach $peg (@$pinned_pegs) {
2829 :     $loc = &feature_locationS($fig_or_sprout,$peg);
2830 :     ($contig,$beg,$end) = &boundaries_of($fig_or_sprout,$loc);
2831 :     if ($contig && $beg && $end) {
2832 :     $mid = int(($beg + $end) / 2);
2833 :     $min = int($mid - ($sz_region / 2));
2834 :     $max = int($mid + ($sz_region / 2));
2835 :     $genes = [];
2836 : overbeek 1.81 ($feat,undef,undef) = &genes_in_region($fig_or_sprout,$cgi,&genome_of($peg),$contig,$min,$max);
2837 : parrello 1.60 foreach $fid (@$feat) {
2838 :     ($contig1,$beg1,$end1) = &boundaries_of($fig_or_sprout,&feature_locationS($fig_or_sprout,$fid));
2839 :     $beg1 = &in_bounds($min,$max,$beg1);
2840 :     $end1 = &in_bounds($min,$max,$end1);
2841 :     my $aliases = join( ', ', &feature_aliasesL($fig_or_sprout,$fid) );
2842 :     my $function = &function_ofS($fig_or_sprout,$fid);
2843 : golsen 1.192 my ( $uniprot ) = $aliases =~ /(uni\|[^,]+)/;
2844 :     my $user = $cgi->param('user');
2845 :     my $info = join('<br/>', "<b>PEG:</b> $fid",
2846 :     "<b>Contig:</b> $contig1",
2847 :     "<b>Begin:</b> $beg1",
2848 :     "<b>End:</b> $end1",
2849 :     $function ? "<b>Function:</b> $function" : (),
2850 :     $uniprot ? "<b>Uniprot ID:</b> $uniprot" : ()
2851 :     );
2852 : parrello 1.60
2853 :     my $sprout = $cgi->param('SPROUT') ? 1 : "";
2854 : overbeek 1.207 my $new_framework = $cgi->param('new_framework') ? 1 : 0;
2855 : overbeek 1.206
2856 : parrello 1.120 my $fmg;
2857 :     if ($sprout)
2858 :     {
2859 : overbeek 1.206 $fmg = "<a href=\&quot;protein.cgi?SPROUT=$sprout&compare_region=1\&num_close=".$cgi->param('num_close'). "\&prot=$fid\&user=$user&new_framework=$new_framework\&quot>show</a>";
2860 : parrello 1.120 }
2861 :     else
2862 :     {
2863 : overbeek 1.206 $fmg = join ('<br/>', "<a href=\&quot;protein.cgi?SPROUT=$sprout&compare_region=1\&num_close=".$cgi->param('num_close'). "\&prot=$fid\&user=$user&new_framework=$new_framework\&quot>show</a>",
2864 : parrello 1.60 "<a onClick=\&quot;setValue('bound1', '$fid'); return false;\&quot;>set bound 1</a>",
2865 :     "<a onClick=\&quot;setValue('bound2', '$fid'); return false;\&quot;>set bound 2</a>",
2866 :     "<a onClick=\&quot;setValue('candidates', '$fid'); return false;\&quot;>set candidate</a>");
2867 : parrello 1.120 }
2868 : parrello 1.60 push(@$genes,[&min($beg1,$end1),
2869 :     &max($beg1,$end1),
2870 :     ($beg1 < $end1) ? "rightArrow" : "leftArrow",
2871 :     "grey",
2872 :     "",
2873 :     $fid,
2874 :     $info, $fmg]);
2875 :    
2876 :     if ($fid =~ /peg/) {
2877 :     push(@$all_pegs,$fid);
2878 :     }
2879 :     }
2880 : golsen 1.192
2881 :     # Sequence title can be replaced by [ title, url, popup_text, menu, popup_title ]
2882 :    
2883 :     my $org = org_of( $fig_or_sprout, $peg );
2884 : golsen 1.193 my $desc = "Genome: $org<br />Contig: $contig";
2885 :     $map = [ [ FIG::abbrev( $org ), undef, $desc, undef, 'Contig' ],
2886 : golsen 1.192 0,
2887 :     $max+1 - $min,
2888 :     ($beg < $end) ? &decr_coords($genes,$min) : &flip_map($genes,$min,$max)
2889 :     ];
2890 : parrello 1.60 push(@$gg,$map);
2891 :     }
2892 : overbeek 1.2 }
2893 : overbeek 1.55 &GenoGraphics::disambiguate_maps($gg);
2894 : overbeek 1.2 return $gg;
2895 :     }
2896 :    
2897 :     sub in {
2898 :     my($x,$xL) = @_;
2899 :     my($i);
2900 :    
2901 :     for ($i=0; ($i < @$xL) && ($x != $xL->[$i]); $i++) {}
2902 :     return ($i < @$xL);
2903 :     }
2904 :    
2905 :     sub in_bounds {
2906 :     my($min,$max,$x) = @_;
2907 :    
2908 :     if ($x < $min) { return $min }
2909 :     elsif ($x > $max) { return $max }
2910 :     else { return $x }
2911 :     }
2912 :    
2913 :     sub decr_coords {
2914 :     my($genes,$min) = @_;
2915 :     my($gene);
2916 :    
2917 : parrello 1.60 foreach $gene (@$genes) {
2918 :     $gene->[0] -= $min;
2919 :     $gene->[1] -= $min;
2920 : overbeek 1.2 }
2921 :     return $genes;
2922 :     }
2923 :    
2924 :     sub flip_map {
2925 :     my($genes,$min,$max) = @_;
2926 :     my($gene);
2927 : parrello 1.60
2928 :     foreach $gene (@$genes) {
2929 :     ($gene->[0],$gene->[1]) = ($max - $gene->[1],$max - $gene->[0]);
2930 :     $gene->[2] = ($gene->[2] eq "rightArrow") ? "leftArrow" : "rightArrow";
2931 : overbeek 1.2 }
2932 :     return $genes;
2933 :     }
2934 :    
2935 :     sub cluster_genes {
2936 : overbeek 1.68 my($fig_or_sprout,$cgi,$all_pegs,$peg) = @_;
2937 : overbeek 1.2 my(%seen,$i,$j,$k,$x,$cluster,$conn,$pegI,$red_set);
2938 :    
2939 :     my @color_sets = ();
2940 :    
2941 : overbeek 1.68 $conn = &get_connections_by_similarity($fig_or_sprout,$cgi,$all_pegs);
2942 :    
2943 : parrello 1.60 for ($i=0; ($i < @$all_pegs); $i++) {
2944 :     if ($all_pegs->[$i] eq $peg) { $pegI = $i }
2945 :     if (! $seen{$i}) {
2946 :     $cluster = [$i];
2947 :     $seen{$i} = 1;
2948 :     for ($j=0; ($j < @$cluster); $j++) {
2949 :     $x = $conn->{$cluster->[$j]};
2950 :     foreach $k (@$x) {
2951 :     if (! $seen{$k}) {
2952 :     push(@$cluster,$k);
2953 :     $seen{$k} = 1;
2954 :     }
2955 :     }
2956 :     }
2957 :    
2958 :     if ((@$cluster > 1) || ($cluster->[0] eq $pegI)) {
2959 :     push(@color_sets,$cluster);
2960 :     }
2961 :     }
2962 : overbeek 1.2 }
2963 :     for ($i=0; ($i < @color_sets) && (! &in($pegI,$color_sets[$i])); $i++) {}
2964 :     $red_set = $color_sets[$i];
2965 :     splice(@color_sets,$i,1);
2966 :     @color_sets = sort { @$b <=> @$a } @color_sets;
2967 :     unshift(@color_sets,$red_set);
2968 :    
2969 :     my $color_sets = {};
2970 : parrello 1.60 for ($i=0; ($i < @color_sets); $i++) {
2971 :     foreach $x (@{$color_sets[$i]}) {
2972 :     $color_sets->{$all_pegs->[$x]} = $i;
2973 :     }
2974 : overbeek 1.2 }
2975 :     return $color_sets;
2976 :     }
2977 :    
2978 :     sub get_connections_by_similarity {
2979 : overbeek 1.68 my($fig_or_sprout,$cgi,$all_pegs) = @_;
2980 : parrello 1.108
2981 : overbeek 1.68 if ($cgi->param('SPROUT'))
2982 :     {
2983 :     return &get_connections_by_similarity_SPROUT($fig_or_sprout,$all_pegs);
2984 :     }
2985 :     else
2986 :     {
2987 :     return &get_connections_by_similarity_SEED($fig_or_sprout,$all_pegs);
2988 :     }
2989 :     }
2990 :    
2991 :     sub get_connections_by_similarity_SPROUT {
2992 :     my($fig_or_sprout,$all_pegs) = @_;
2993 :     my(%in,$i,$j,$peg1,$peg2);
2994 :    
2995 :     my $conn = {};
2996 :    
2997 :     for ($i=0; $i < @$all_pegs; $i++)
2998 :     {
2999 :     $in{$all_pegs->[$i]} = $i;
3000 :     }
3001 : parrello 1.108
3002 : overbeek 1.68 foreach $peg1 (@$all_pegs)
3003 :     {
3004 :     $i = $in{$peg1};
3005 : overbeek 1.116 foreach $peg2 (map { $_->[0] } bbhs($fig_or_sprout,$peg1,1.0e-10))
3006 : overbeek 1.68 {
3007 :     $j = $in{$peg2};
3008 :     if (defined($i) && defined($j))
3009 :     {
3010 :     push(@{$conn->{$i}},$j);
3011 :     }
3012 :     }
3013 :     }
3014 :     return $conn;
3015 :     }
3016 :    
3017 :     sub get_connections_by_similarity_SEED {
3018 :     my($fig_or_sprout,$all_pegs) = @_;
3019 : overbeek 1.40 my($i,$j,$tmp,$peg,%pos_of);
3020 :     my($sim,%conn,$x,$y);
3021 : overbeek 1.2
3022 : parrello 1.60 for ($i=0; ($i < @$all_pegs); $i++) {
3023 :     $tmp = &maps_to_id($fig_or_sprout,$all_pegs->[$i]);
3024 :     push(@{$pos_of{$tmp}},$i); # map the representative in nr to subscript in all_pegs
3025 :     if ($tmp ne $all_pegs->[$i]) {
3026 :     push(@{$pos_of{$all_pegs->[$i]}},$i);
3027 :     }
3028 : overbeek 1.2 }
3029 :    
3030 : parrello 1.60 foreach $y (keys(%pos_of)) {
3031 :     $x = $pos_of{$y};
3032 :     for ($i=0; ($i < @$x); $i++) {
3033 :     for ($j=$i+1; ($j < @$x); $j++) {
3034 :     push(@{$conn{$x->[$i]}},$x->[$j]);
3035 :     push(@{$conn{$x->[$j]}},$x->[$i]);
3036 :     }
3037 :     }
3038 : overbeek 1.40 }
3039 :    
3040 : parrello 1.60 for ($i=0; ($i < @$all_pegs); $i++) {
3041 :     foreach $sim (&sims($fig_or_sprout,$all_pegs->[$i],500,1.0e-5,"raw")) {
3042 :     if (defined($x = $pos_of{$sim->id2})) {
3043 :     foreach $y (@$x) {
3044 :     push(@{$conn{$i}},$y);
3045 :     }
3046 :     }
3047 :     }
3048 : overbeek 1.2 }
3049 :     return \%conn;
3050 :     }
3051 :    
3052 :     sub set_colors_text_and_links {
3053 :     my($gg,$all_pegs,$color_sets) = @_;
3054 :     my($map,$gene,$peg,$color);
3055 :    
3056 : parrello 1.60 foreach $map (@$gg) {
3057 :     foreach $gene (@{$map->[3]}) {
3058 :     $peg = $gene->[5];
3059 :     if (defined($color = $color_sets->{$peg})) {
3060 :     $gene->[3] = ($color == 0) ? "red" : "color$color";
3061 :     $gene->[4] = $color + 1;
3062 :     }
3063 :     $gene->[5] = &peg_url($cgi,$peg);
3064 :     }
3065 : overbeek 1.2 }
3066 :     }
3067 :    
3068 :     sub peg_url {
3069 :     my($cgi,$peg) = @_;
3070 :    
3071 :     my $prot = $cgi->param('prot');
3072 :     $cgi->delete('prot');
3073 : overbeek 1.161 my $url = $cgi->url(-relative => 1, -query => 1, -path_info => 1) . "&prot=$peg&compare_region=1";
3074 : overbeek 1.2 $cgi->delete('prot');
3075 :     $cgi->param(-name => 'prot', -value => $prot);
3076 :    
3077 :     return $url;
3078 : parrello 1.60 }
3079 : overbeek 1.2
3080 :     sub possible_extensions {
3081 :     my($peg,$closest_pegs) = @_;
3082 :     my($g,$sim,$id2,$peg1,%poss);
3083 :    
3084 : overbeek 1.53 $g = &genome_of($peg);
3085 : overbeek 1.2
3086 : parrello 1.60 foreach $peg1 (@$closest_pegs) {
3087 :     if ($g ne &genome_of($peg1)) {
3088 :     foreach $sim (&sims($fig_or_sprout,$peg1,500,1.0e-5,"all")) {
3089 :     $id2 = $sim->id2;
3090 :     if (($id2 ne $peg) && ($id2 =~ /^fig\|$g\./) && &possibly_truncated($fig_or_sprout,$id2)) {
3091 :     $poss{$id2} = 1;
3092 :     }
3093 :     }
3094 :     }
3095 : overbeek 1.2 }
3096 :     return keys(%poss);
3097 : efrank 1.1 }
3098 : overbeek 1.53
3099 :     sub display_page {
3100 :     my($fig_or_sprout,$cgi,$html) = @_;
3101 :    
3102 : parrello 1.60 if (ref($html) eq "ARRAY") {
3103 :     if ($traceData) {
3104 :     push @$html, QTrace('html');
3105 :     }
3106 :     &HTML::show_page($cgi,$html);
3107 :     } else {
3108 :     Trace(Dumper($html)) if T(2);
3109 :     if ($cgi->param('SPROUT')) {
3110 :     if ($traceData) {
3111 :     $html->{tracings} = "<h3>Trace Messages</h3>\n" . QTrace('html');
3112 :     } else {
3113 :     $html->{tracings} = "\n";
3114 :     }
3115 :     print "Content-Type: text/html\n";
3116 :     print "\n";
3117 : parrello 1.208 my $templ;
3118 :     if ($FIG_Config::template_url) {
3119 :     $templ = "$FIG_Config::template_url/Protein_tmpl.html";
3120 :     } else {
3121 : parrello 1.209 $templ = "<$FIG_Config::fig/CGI/Html/Protein_tmpl.html";
3122 : parrello 1.208 }
3123 : parrello 1.209 print PageBuilder::Build($templ, $html,"Html");
3124 : parrello 1.60 } else {
3125 :     my $gathered = [];
3126 :    
3127 :     my $section;
3128 :     foreach $section (qw( javascript
3129 :     general
3130 :     translate_status
3131 :     contig_context
3132 :     context_graphic
3133 :     subsys_connections
3134 : overbeek 1.68 assign_for_equiv_prots
3135 : parrello 1.60 links
3136 :     services
3137 :     kv_pairs
3138 :     compare_region
3139 :     similarities
3140 :     tools
3141 :     ) ) {
3142 :     if (@{$html->{$section}} > 0) {
3143 :     push(@$gathered,@{$html->{$section}});
3144 :     push(@$gathered,$cgi->hr);
3145 :     }
3146 :     }
3147 :     pop @$gathered;
3148 :     &HTML::show_page($cgi,$gathered);
3149 :     }
3150 : overbeek 1.53 }
3151 :     }
3152 :    
3153 :     sub show_html_followed_by_initial {
3154 :     my($fig_or_sprout,$cgi,$html,$prot) = @_;
3155 :    
3156 : overbeek 1.191 my $loc_url = $cgi->url(-absolute => 1, -full => 1, -query => 1, -path_info => 1);
3157 :    
3158 :     #
3159 :     # Truncate it in case the url is humongous (like it will be for the pins commentary page).
3160 :     #
3161 :    
3162 :     $loc_url = substr($loc_url, 0, 100);
3163 :    
3164 : overbeek 1.53 my %html = ( general => [],
3165 :     contig_context => [],
3166 :     context_graphic => [],
3167 :     subsys_connections => [],
3168 :     links => [],
3169 :     services => [],
3170 :     translate_status => [],
3171 :     tools => [],
3172 :     kv_pairs => [],
3173 :     similarities => [],
3174 : overbeek 1.68 assign_for_equiv_prots => [],
3175 : overbeek 1.53 javascript => [],
3176 : overbeek 1.157 compare_region => [],
3177 : overbeek 1.191 location_tag => [uri_escape($loc_url)],
3178 : overbeek 1.53 );
3179 :    
3180 :     push(@{$html{general}},@$html);
3181 :     $html = \%html;
3182 : parrello 1.60 &show_initial($fig_or_sprout,$cgi,$html,$prot);
3183 : overbeek 1.53 return $html;
3184 :     }
3185 :    
3186 :     sub translation_piece {
3187 :     my($fig_or_sprout,$cgi,$html) = @_;
3188 :    
3189 :     my $msg;
3190 : overbeek 1.161 my $url = $cgi->url(-relative => 1, -query => 1, -path_info => 1);
3191 : overbeek 1.53 if ($cgi->param('translate')) {
3192 : parrello 1.60 $url =~ s/[;&]translate(=[^;&])?//i or $url =~ s/translate(=[^;&])?[;&]//i;
3193 :     $msg = "Turn Off Function Translation";
3194 :     } else {
3195 : golsen 1.169 $url .= "&translate=1";
3196 : parrello 1.60 $msg = "Translate Function Assignments";
3197 : overbeek 1.53 }
3198 :     push(@$html, "<a href=\"$url\">$msg</a><br>\n");
3199 :     }
3200 :    
3201 :    
3202 :     #######################################################################################
3203 : overbeek 1.119 sub sims {
3204 :     my( $fig_or_sprout, $peg, $max, $cutoff, $select, $expand, $group_by_genome, $filters ) = @_;
3205 :     my( @tmp, $id, $genome, @genomes, %sims, $sim );
3206 :    
3207 :     @tmp = $fig_or_sprout->sims( $peg, $max, $cutoff, $select, $expand, $filters );
3208 :     if (! $group_by_genome) { return @tmp };
3209 :    
3210 :     # Collect all sims from genome with the first occurance of the genome:
3211 :    
3212 :     foreach $sim ( @tmp )
3213 :     {
3214 :     $id = $sim->id2;
3215 :     $genome = ($id =~ /^fig\|(\d+\.\d+)\.peg\.\d+/) ? $1 : $id;
3216 :     if (! defined( $sims{ $genome } ) ) { push @genomes, $genome }
3217 :     push @{ $sims{ $genome } }, $sim;
3218 :     }
3219 :     return map { @{ $sims{$_} } } @genomes;
3220 :     }
3221 : overbeek 1.121
3222 :     sub in_cluster_with {
3223 :     my($fig_or_sprout,$cgi,$peg) = @_;
3224 :     my %in_cluster;
3225 :    
3226 :     if ($fig_or_sprout->table_exists('fc_pegs') && $fig_or_sprout->is_complete(&FIG::genome_of($peg)))
3227 :     {
3228 :     %in_cluster = map { $_->[0] => &ev_link($cgi,$_->[0],$_->[1]) } $fig_or_sprout->coupled_to($peg);
3229 :     if (keys(%in_cluster) > 0)
3230 :     {
3231 :     $in_cluster{$peg} = "";
3232 :     }
3233 :     elsif ($cgi->param('fc'))
3234 :     {
3235 :     %in_cluster = map { $_ => "" } $fig_or_sprout->in_cluster_with($peg);
3236 : overbeek 1.127 if (keys(%in_cluster) == 1)
3237 :     {
3238 :     my @tmp = keys(%in_cluster);
3239 :     delete $in_cluster{$tmp[0]};
3240 :     }
3241 : overbeek 1.121 }
3242 :     }
3243 :     return \%in_cluster;
3244 :     }
3245 :    
3246 : overbeek 1.141 sub evidence_codes {
3247 :     my($fig_or_sprout,$peg) = @_;
3248 :    
3249 :     if ($peg !~ /^fig\|\d+\.\d+\.peg\.\d+$/) { return "" }
3250 :    
3251 : overbeek 1.142 my @codes = grep { $_->[1] =~ /^evidence_code/i } $fig_or_sprout->get_attributes($peg);
3252 : overbeek 1.141 return (@codes > 0) ? map { $_->[2] } @codes : ();
3253 :     }
3254 :    
3255 : overbeek 1.143 sub evidence_codes_link {
3256 : redwards 1.160 my($cgi) = @_;
3257 :     return "<A href=\"Html/evidence_codes.html\" target=\"SEED_or_SPROUT_help\">Ev</A>";
3258 :     }
3259 :    
3260 : overbeek 1.141
3261 : redwards 1.160 sub evidence_codes_explain {
3262 :     my($ec)=@_;
3263 :     return unless ($ec);
3264 :    
3265 :     $ec=uc($ec);
3266 :     return "IDA: Inferred from Direct Assay" if ($ec eq "IDA");
3267 :     return "IGI: Inferred from Genetic Interaction" if ($ec eq "IGI");
3268 :     return "TAS: Traceable Author Statement" if ($ec eq "TAS");
3269 :     return "ISU: in subsystem unique" if ($ec eq "ISU");
3270 :     return "$ec: in subsystem duplicates" if ($ec =~ /IDU/);
3271 :     return "$ec: in cluster with" if ($ec =~ /ICW/);
3272 :     return "$ec: unknown!";
3273 : overbeek 1.141 }

MCS Webmaster
ViewVC Help
Powered by ViewVC 1.0.3