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

Annotation of /FigWebServices/protein.cgi

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.92 - (view) (download)

1 : overbeek 1.71
2 : efrank 1.1 use FIG;
3 : olson 1.56
4 :     my $sproutAvail = eval {
5 :     require SproutFIG;
6 :     require PageBuilder;
7 :     };
8 :    
9 : olson 1.92 #if (!$sproutAvail) {
10 :     # warn "Sprout library not available: $@\n";
11 :     #}
12 : olson 1.56
13 : heiko 1.45 use FIGGenDB;
14 : olson 1.48 use FIGjs;
15 : efrank 1.1
16 :     use HTML;
17 : olson 1.48 use Data::Dumper;
18 :    
19 : efrank 1.1 use strict;
20 :     use GenoGraphics;
21 :     use CGI;
22 : parrello 1.60 use Tracer;
23 :    
24 : efrank 1.1 my $cgi = new CGI;
25 :    
26 : olson 1.57 use Carp 'cluck';
27 : parrello 1.60 my $traceData = $cgi->param('trace');
28 :     if ($traceData) {
29 :     TSetup($cgi, "QUEUE");
30 :     $traceData = 1;
31 :     } else {
32 :     TSetup(0, "NONE");
33 :     $traceData = 0;
34 :     }
35 : olson 1.57
36 : overbeek 1.66 if (0) {
37 : overbeek 1.40 my $VAR1;
38 :     eval(join("",`cat /tmp/protein_parms`));
39 :     $cgi = $VAR1;
40 :     # print STDERR &Dumper($cgi);
41 :     }
42 :    
43 : parrello 1.60 if (0) {
44 : efrank 1.1 print $cgi->header;
45 :     my @params = $cgi->param;
46 :     print "<pre>\n";
47 : parrello 1.60 foreach $_ (@params) {
48 :     print "$_\t:",join(",",$cgi->param($_)),":\n";
49 : efrank 1.1 }
50 : overbeek 1.40
51 : parrello 1.60 if (0) {
52 :     if (open(TMP,">/tmp/protein_parms")) {
53 :     print TMP &Dumper($cgi);
54 :     close(TMP);
55 :     }
56 : overbeek 1.40 }
57 : efrank 1.1 exit;
58 :     }
59 :    
60 : overbeek 1.53 my($fig_or_sprout);
61 : olson 1.83
62 :     my $is_sprout;
63 :    
64 :     my $html = [];
65 :    
66 : parrello 1.60 if ($cgi->param('SPROUT')) {
67 : olson 1.83 $is_sprout = 1;
68 : olson 1.56 $fig_or_sprout = new SproutFIG($FIG_Config::sproutDB, $FIG_Config::sproutData);
69 : olson 1.83 unshift @$html, "<TITLE>The NMPDR Protein Page</TITLE>\n";
70 : parrello 1.60 } else {
71 : olson 1.83 $is_sprout = 0;
72 : overbeek 1.53 $fig_or_sprout = new FIG;
73 : olson 1.83 unshift @$html, "<TITLE>The SEED Protein Page</TITLE>\n";
74 : overbeek 1.53 }
75 :    
76 : efrank 1.1
77 :     my $prot = $cgi->param('prot');
78 : parrello 1.60 if (! $prot) {
79 : golsen 1.19 unshift @$html, "<TITLE>The SEED: Protein Page</TITLE>\n";
80 : efrank 1.1 push(@$html,"<h1>Sorry, you need to specify a protein</h1>\n");
81 : overbeek 1.53 &display_page($fig_or_sprout,$cgi,$html);
82 : efrank 1.1 exit;
83 :     }
84 : golsen 1.34
85 : parrello 1.60 if ($prot !~ /^fig\|/) {
86 : overbeek 1.53 my @poss = &by_alias($fig_or_sprout,$prot);
87 :    
88 : parrello 1.60 if (@poss > 0) {
89 :     $prot = $poss[0];
90 :     } else {
91 :     unshift @$html, "<TITLE>The SEED: Protein Page</TITLE>\n";
92 :     push(@$html,"<h1>Sorry, $prot appears not to have a FIG id at this point</h1>\n");
93 :     &display_page($fig_or_sprout,$cgi,$html);
94 :     exit;
95 : overbeek 1.16 }
96 :     }
97 : efrank 1.1
98 : overbeek 1.53
99 : golsen 1.34 #
100 :     # Allow previous and next actions in calls to the script -- GJO
101 :     #
102 :    
103 :     my $adjust = $cgi->param('previous PEG') ? -1 : $cgi->param('next PEG') ? 1 : 0;
104 :     if ( $adjust ) {
105 :     my ( $prefix, $protnum ) = $prot =~ /^(.*\.)(\d+)$/;
106 :     if ( $prefix && $protnum ) {
107 :     my $prot2 = $prefix . ($protnum + $adjust);
108 : overbeek 1.53 if ( &translatable($fig_or_sprout, $prot2 ) ) {
109 : golsen 1.34 $prot = $prot2;
110 :     $cgi->delete('prot');
111 :     $cgi->param(-name => 'prot', -value => $prot);
112 :     }
113 :     }
114 :     ( $adjust < 0 ) && $cgi->delete('previous PEG');
115 :     ( $adjust > 0 ) && $cgi->delete('next PEG');
116 :     }
117 :    
118 :     my $request = $cgi->param("request") || "";
119 : overbeek 1.63 #my $compute_ok = eval {
120 :    
121 : olson 1.58
122 : overbeek 1.68 if ($request eq "use_protein_tool") { &use_protein_tool($fig_or_sprout,$cgi,$html,$prot); }
123 : parrello 1.60 elsif ($request eq "view_annotations") { &view_annotations($fig_or_sprout,$cgi,$html,$prot); }
124 :     elsif ($request eq "view_all_annotations") { &view_all_annotations($fig_or_sprout,$cgi,$html,$prot); }
125 : overbeek 1.68 elsif ($request eq "aa_sequence") { &aa_sequence($fig_or_sprout,$cgi,$html,$prot); }
126 : parrello 1.60 elsif ($request eq "dna_sequence") { &dna_sequence($fig_or_sprout,$cgi,$html,$prot); }
127 :     elsif ($request eq "fast_assign") { $html = &make_assignment($fig_or_sprout,$cgi,$html,$prot); }
128 :     elsif ($request eq "show_coupling_evidence") { &show_coupling_evidence($fig_or_sprout,$cgi,$html,$prot); }
129 :     elsif ($request eq "ec_to_maps") { &show_ec_to_maps($fig_or_sprout,$cgi,$html); }
130 :     elsif ($request eq "link_to_map") { &link_to_map($fig_or_sprout,$cgi,$html); }
131 :     elsif ($request eq "fusions") { &show_fusions($fig_or_sprout,$cgi,$html,$prot); }
132 :     else {
133 :     $html = &show_html_followed_by_initial($fig_or_sprout,$cgi,$html,$prot);
134 :     }
135 : overbeek 1.68
136 :     if ($cgi->param('SPROUT') && (ref($html) eq "ARRAY"))
137 :     {
138 :     $_ = {};
139 :     $_->{kv_pairs} = $html;
140 :     $html = $_;
141 :     }
142 : overbeek 1.63 #};
143 : olson 1.58
144 : overbeek 1.63 #if (!$compute_ok) {
145 :     # Trace($@);
146 :     #}
147 : overbeek 1.68
148 : overbeek 1.53 &display_page($fig_or_sprout,$cgi,$html);
149 : overbeek 1.11 exit;
150 :    
151 :     #==============================================================================
152 :     # use_protein_tool
153 :     #==============================================================================
154 : efrank 1.1
155 :     sub use_protein_tool {
156 : overbeek 1.53 my($fig_or_sprout,$cgi,$html,$prot) = @_;
157 : efrank 1.1 my($url,$method,@args,$line,$name,$val);
158 :    
159 : overbeek 1.53 my $seq = &get_translation($fig_or_sprout,$prot);
160 : parrello 1.60 if (! $seq) {
161 :     unshift @$html, "<TITLE>The SEED: Protein Page</TITLE>\n";
162 :     push(@$html,$cgi->h1("Sorry, $prot does not have a translation"));
163 :     return;
164 : efrank 1.1 }
165 :     my $protQ = quotemeta $prot;
166 :    
167 :     my $tool = $cgi->param('tool');
168 :     $/ = "\n//\n";
169 :     my @tools = grep { $_ =~ /^$tool\n/ } `cat $FIG_Config::global/LinksToTools`;
170 : parrello 1.60 if (@tools == 1) {
171 :     chomp $tools[0];
172 :     (undef,undef,$url,$method,@args) = split(/\n/,$tools[0]);
173 :     my $args = [];
174 :     foreach $line (@args) {
175 :     ($name,$val) = split(/\t/,$line);
176 :     $val =~ s/FIGID/$prot/;
177 :     $val =~ s/FIGSEQ/$seq/;
178 :     $val =~ s/\\n/\n/g;
179 :     push(@$args,[$name,$val]);
180 :     }
181 :     unshift @$html, "<TITLE>The SEED: Protein Tool</TITLE>\n";
182 : overbeek 1.72 #$url='http://localhost/cgi-bin/extract_params.cgi'; in case I forget to delete this, it is just a script that grabs params from cgis RAE
183 : parrello 1.60 push(@$html,&HTML::get_html($url,$method,$args));
184 : efrank 1.1 }
185 :     }
186 :    
187 : overbeek 1.11 #==============================================================================
188 :     # make_assignment
189 :     #==============================================================================
190 :    
191 : efrank 1.1 sub make_assignment {
192 : overbeek 1.53 my($fig_or_sprout,$cgi,$html,$prot) = @_;
193 : efrank 1.1 my($userR);
194 :    
195 :     my $function = $cgi->param('func');
196 :     my $user = $cgi->param('user');
197 :    
198 : parrello 1.60 if ($function && $user && $prot) {
199 :     if ($user =~ /master:(.*)/) {
200 :     $userR = $1;
201 :     &assign_function($fig_or_sprout,$prot,"master",$function,"");
202 : overbeek 1.68 &add_annotation($fig_or_sprout,$cgi,$prot,$userR,"Set master function to\n$function\n");
203 : parrello 1.60 } else {
204 : overbeek 1.68 &assign_function($fig_or_sprout,$prot,$user,$function,"");
205 :     &add_annotation($fig_or_sprout,$cgi,$prot,$user,"Set function to\n$function\n");
206 :     }
207 : efrank 1.1 }
208 :     $cgi->delete("request");
209 :     $cgi->delete("func");
210 : overbeek 1.53 $html = &show_html_followed_by_initial($fig_or_sprout,$cgi,$html,$prot);
211 :     return $html;
212 : efrank 1.1 }
213 :    
214 : overbeek 1.11 #==============================================================================
215 :     # view_annotations
216 :     #==============================================================================
217 :    
218 : efrank 1.1 sub view_annotations {
219 : overbeek 1.53 my($fig_or_sprout,$cgi,$html,$prot) = @_;
220 : efrank 1.1
221 : golsen 1.19 unshift @$html, "<TITLE>The SEED: Protein Annotations</TITLE>\n";
222 : efrank 1.1 my $col_hdrs = ["who","when","annotation"];
223 : overbeek 1.69
224 : overbeek 1.68 my $tab = [ map { [$_->[2],$_->[1],"<pre>" . $_->[3] . "<\/pre>"] } &feature_annotations($fig_or_sprout,$cgi,$prot) ];
225 : parrello 1.60 if (@$tab > 0) {
226 :     push(@$html,&HTML::make_table($col_hdrs,$tab,"Annotations for $prot"));
227 :     } else {
228 :     push(@$html,"<h1>No Annotations for $prot</h1>\n");
229 : efrank 1.1 }
230 :     }
231 :    
232 : overbeek 1.15 sub view_all_annotations {
233 : overbeek 1.53 my($fig_or_sprout,$cgi,$html,$peg) = @_;
234 : overbeek 1.15 my($ann);
235 :    
236 : golsen 1.19 unshift @$html, "<TITLE>The SEED: Protein Annotations</TITLE>\n";
237 : parrello 1.60 if (&is_real_feature($fig_or_sprout,$peg)) {
238 :     my $col_hdrs = ["who","when","PEG","genome","annotation"];
239 : overbeek 1.68 my @related = &related_by_func_sim($fig_or_sprout,$cgi,$peg,$cgi->param('user'));
240 : parrello 1.60 push(@related,$peg);
241 :    
242 :     my @annotations = &merged_related_annotations($fig_or_sprout,\@related);
243 :    
244 :     my $tab = [ map { $ann = $_;
245 :     [$ann->[2],$ann->[1],&HTML::fid_link($cgi,$ann->[0]),
246 :     &genus_species($fig_or_sprout,&genome_of($ann->[0])),
247 :     "<pre>" . $ann->[3] . "</pre>"
248 :     ] } @annotations];
249 :     if (@$tab > 0) {
250 :     push(@$html,&HTML::make_table($col_hdrs,$tab,"All Related Annotations for $peg"));
251 :     } else {
252 :     push(@$html,"<h1>No Annotations for $peg</h1>\n");
253 :     }
254 : overbeek 1.15 }
255 :     }
256 :    
257 : overbeek 1.11 #==============================================================================
258 :     # show_coupling_evidence
259 :     #==============================================================================
260 :    
261 : efrank 1.1 sub show_coupling_evidence {
262 : overbeek 1.53 my($fig_or_sprout,$cgi,$html,$peg) = @_;
263 : efrank 1.1 my($pair,$peg1,$peg2,$link1,$link2);
264 :    
265 : golsen 1.19 unshift @$html, "<TITLE>The SEED: Functional Coupling</TITLE>\n";
266 : efrank 1.1 my $user = $cgi->param('user');
267 :     my $to = $cgi->param('to');
268 : overbeek 1.53 my @coup = grep { $_->[1] eq $to } &coupling_and_evidence($fig_or_sprout,$peg,5000,1.0e-10,4);
269 : efrank 1.1
270 : parrello 1.60 if (@coup != 1) {
271 :     push(@$html,"<h1>Sorry, no evidence that $peg is coupled to $to</h1>\n");
272 :     } else {
273 : overbeek 1.91 my $col_hdrs = ["Peg1","Function1","Peg2","Function2","Organism"];
274 : parrello 1.60 my $tab = [];
275 :     foreach $pair (@{$coup[0]->[2]}) {
276 :     ($peg1,$peg2) = @$pair;
277 :     $link1 = &HTML::fid_link($cgi,$peg1);
278 :     $link2 = &HTML::fid_link($cgi,$peg2);
279 :     push( @$tab, [ $link1,
280 : overbeek 1.91 scalar &function_ofS($fig_or_sprout,$peg1,$user),
281 :     $link2,
282 :     scalar &function_ofS($fig_or_sprout,$peg2,$user),
283 :     &org_of($fig_or_sprout,$peg1)
284 : parrello 1.60 ]
285 : overbeek 1.11 );
286 : parrello 1.60 }
287 :     push(@$html,&HTML::make_table($col_hdrs,$tab,"Evidence that $peg Is Coupled To $to"));
288 : efrank 1.1 }
289 :     }
290 :    
291 : overbeek 1.11 #==============================================================================
292 :     # psi_blast_prot_sequence
293 :     #==============================================================================
294 :    
295 : efrank 1.1 sub psi_blast_prot_sequence {
296 : overbeek 1.53 my($fig_or_sprout,$cgi,$prot_id) = @_;
297 : efrank 1.1 }
298 :    
299 : overbeek 1.11 #==============================================================================
300 :     # show_initial
301 :     #==============================================================================
302 :    
303 : efrank 1.1 sub show_initial {
304 : overbeek 1.53 my($fig_or_sprout,$cgi,$html,$prot) = @_;
305 :    
306 :     unshift @{$html->{general}}, "<TITLE>The SEED: Protein Page</TITLE>\n";
307 : efrank 1.1
308 : overbeek 1.53 my $gs = &org_of($fig_or_sprout,$prot);
309 : parrello 1.60 Trace("got gs=$gs prot=$prot $fig_or_sprout\n") if T(2);
310 :     if ($prot =~ /^fig\|\d+\.\d+\.peg/) {
311 :     if (! &is_real_feature($fig_or_sprout,$prot)) {
312 :     push(@{$html->{general}},"<h1>Sorry, $prot is an unknown identifier</h1>\n");
313 :     } else {
314 :     push(@{$html->{general}},"<h1>Protein $prot: $gs</h1>\n");
315 :     &translation_piece($fig_or_sprout,$cgi,$html->{translate_status});
316 :     &display_peg($fig_or_sprout,$cgi,$html,$prot);
317 :     }
318 :     } else {
319 :     # &display_external($fig_or_sprout,$cgi,$html,$prot);
320 : efrank 1.1 }
321 :     }
322 :    
323 : overbeek 1.11 #==============================================================================
324 :     # display_peg
325 :     #==============================================================================
326 :    
327 : efrank 1.1 sub display_peg {
328 : overbeek 1.53 my($fig_or_sprout,$cgi,$html,$peg) = @_;
329 : efrank 1.1 my $loc;
330 :    
331 : overbeek 1.53 my $user = $cgi->param('user');
332 :    
333 : efrank 1.1 my $half_sz = 5000;
334 : overbeek 1.10 my $fc = $cgi->param('fc');
335 :     my @fc_data;
336 : parrello 1.60 if ($fc) {
337 : redwards 1.49 # RAE Added the following lines so that you can define this in the URL
338 : parrello 1.60 # but the default behavior remains unchanged. I doubt anyone will ever
339 :     # see this, but I use it sometimes to see what happens
340 :     my ($bound,$sim_cutoff,$coupling_cutoff)=(5000, 1.0e-10, 4);
341 :     if ($cgi->param('fcbound')) {$bound=$cgi->param('fcbound')}
342 :     if ($cgi->param('fcsim')) {$sim_cutoff=$cgi->param('fcsim')}
343 :     if ($cgi->param('fccoup')) {$coupling_cutoff=$cgi->param('fccoup')}
344 :    
345 :     @fc_data = &coupling_and_evidence($fig_or_sprout,$peg,$bound,$sim_cutoff,$coupling_cutoff);
346 :     } else {
347 :     @fc_data = ();
348 :     }
349 :    
350 :     if ($loc = &feature_locationS($fig_or_sprout,$peg)) {
351 :     my($contig,$beg,$end) = &boundaries_of($fig_or_sprout,$loc);
352 :     my $min = &max(0,&min($beg,$end) - $half_sz);
353 :     my $max = &max($beg,$end) + $half_sz;
354 :     Trace("display_peg: min=$min max=$max beg=$beg end=$end") if T(2);
355 : overbeek 1.81 my($feat,$min,$max) = &genes_in_region($fig_or_sprout,$cgi,&genome_of($peg),$contig,$min,$max);
356 : parrello 1.60 Trace("beg=$beg end=$end New min = $min, max = $max, features = " . join(", ", @{$feat})) if T(3);
357 :    
358 :     my ($beg,$end,$genes) = &print_context($fig_or_sprout,$cgi,$html->{contig_context},$peg,$feat,$min,$max);
359 :     Trace("Print context returned: beg=$beg, end=$end, genes = " . join(", ", @{$genes})) if T(3);
360 :     &print_graphics_context($beg,$end,$genes,$html->{context_graphic});
361 :    
362 : overbeek 1.68 &print_assignments($fig_or_sprout,$cgi,$html->{assign_for_equiv_prots},$peg);
363 : parrello 1.60 &print_kv_pairs($fig_or_sprout,$cgi,$html->{kv_pairs},$peg);
364 :     &print_subsys_connections($fig_or_sprout,$cgi,$html->{subsys_connections},$peg,$user);
365 :     &print_links($fig_or_sprout,$cgi,$html->{links},$peg);
366 :    
367 :     push @{$html->{javascript}}, "\n", &FIGjs::toolTipScript();
368 :    
369 :     my $has_translation = &translatable($fig_or_sprout,$peg);
370 :     &print_services($fig_or_sprout,$cgi,$html->{services},$peg,$has_translation,\@fc_data);
371 : overbeek 1.63
372 : parrello 1.60 &print_sims_block($fig_or_sprout,$cgi,$html->{similarities},$peg,$user,$has_translation);
373 :    
374 :     if ($has_translation) {
375 :     &show_tools($fig_or_sprout,$cgi,$html->{tools},$peg);
376 :     }
377 : efrank 1.1 }
378 :     }
379 :    
380 :     ################# Table-Driven Show Tools ############################
381 :    
382 :     sub show_tools {
383 : overbeek 1.53 my($fig_or_sprout,$cgi,$html,$peg) = @_;
384 : efrank 1.1
385 : redwards 1.80 # generate the link to turn tools on or off
386 :     my $toollink=$cgi->self_url;
387 :     $toollink =~ s/[\&\;]fulltools.*[^\;\&]/\&/;
388 :     my $fulltoolbutton = $cgi->a({href=> $toollink . "&fulltools='1'"}, "Show tool descriptions"); # define this here before we mess with ourself!
389 :     my $brieftoolbutton = $cgi->a({href=> $toollink}, "Hide tool descriptions");
390 :    
391 : efrank 1.1 $cgi->param(-name => "request",
392 :     -value => "use_protein_tool");
393 :     my $url = $cgi->self_url();
394 :    
395 : parrello 1.60 if (open(TMP,"<$FIG_Config::global/LinksToTools")) {
396 :     my $col_hdrs = ["Tool","Description"];
397 :     my $tab = [];
398 :    
399 :     $/ = "\n//\n";
400 : redwards 1.80 my $brieftools; # in case we don't want descriptions and whatnot
401 : parrello 1.60 while (defined($_ = <TMP>)) {
402 : overbeek 1.72 # allow comment lines in the file
403 :     next if (/^#/);
404 : parrello 1.60 my($tool,$desc) = split(/\n/,$_);
405 : overbeek 1.72 # RAE modified this so we can include column headers.
406 :     undef($desc) if ($desc eq "//"); # it is a separator
407 : 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.
408 :     if ($cgi->param('fulltools')) {
409 :     if ($desc) {push(@$tab,["<a href=\"$url\&tool=$tool\">$tool</a>",$desc])}
410 :     else {push(@$tab, [["<strong>$tool</strong>", "td colspan=2 align=center"]])}
411 :     }
412 :     else {
413 :     # Why doesn't this work $brieftools .= "<span class=\"tool\" style=\"border: 0 1px solid gray\"><a href=\"$url\&tool=$tool\">$tool</a></span>";
414 :     if ($desc) {$brieftools .= " &nbsp; <a href=\"$url\&tool=$tool\">$tool</a> &nbsp;|"}
415 :     }
416 : parrello 1.60 }
417 :     close(TMP);
418 :     $/ = "\n";
419 : redwards 1.80 if ($brieftools) {push(@$html, $cgi->p("|" . $brieftools), $fulltoolbutton)}
420 :     else {push(@$html,&HTML::make_table($col_hdrs,$tab,"Tools to Analyze Protein Sequences"), $brieftoolbutton)}
421 : efrank 1.1 }
422 :     $cgi->delete('request');
423 :     }
424 :    
425 :     ################# Functional Coupling ############################
426 :    
427 :     sub print_fc {
428 : overbeek 1.53 my($fig_or_sprout,$cgi,$html,$peg,$fc_data) = @_;
429 : efrank 1.1 my($sc,$neigh);
430 : parrello 1.60
431 : efrank 1.1 my $user = $cgi->param('user');
432 :     my @tab = map { ($sc,$neigh) = @$_;
433 : parrello 1.60 [&ev_link($cgi,$neigh,$sc),$neigh,scalar &function_ofS($fig_or_sprout,$neigh,$user)]
434 :     } @$fc_data;
435 :     if (@tab > 0) {
436 :     push(@$html,"<hr>\n");
437 :     my $col_hdrs = ["Score","Peg","Function"];
438 :     push(@$html,&HTML::make_table($col_hdrs,\@tab,"Functional Coupling"));
439 : efrank 1.1 }
440 :     }
441 :    
442 :     sub ev_link {
443 :     my($cgi,$neigh,$sc) = @_;
444 :    
445 :     my $prot = $cgi->param('prot');
446 :     my $link = $cgi->url() . "?request=show_coupling_evidence&prot=$prot&to=$neigh";
447 :     return "<a href=$link>$sc</a>";
448 :     }
449 :    
450 :     ################# Assignments ############################
451 :    
452 :     sub trans_function_of {
453 : overbeek 1.53 my($cgi,$fig_or_sprout,$peg,$user) = @_;
454 : efrank 1.1
455 : parrello 1.60 if (wantarray()) {
456 :     my $x;
457 : overbeek 1.68 my @funcs = &function_ofL($fig_or_sprout,$peg,$user);
458 :    
459 : parrello 1.60 if ($cgi->param('translate')) {
460 :     @funcs = map { $x = $_; $x->[1] = &translate_function($fig_or_sprout,$x->[1]); $x } @funcs;
461 :     }
462 :     return @funcs;
463 :     } else {
464 :     my $func = &function_ofS($fig_or_sprout,$peg,$user);
465 :     if ($cgi->param('translate')) {
466 :     $func = &translate_function($fig_or_sprout,$func);
467 :     }
468 :     return $func;
469 : efrank 1.1 }
470 :     }
471 :    
472 : overbeek 1.53 ########################## Routines that build pieces of HTML ######################
473 :    
474 :    
475 :     sub print_sims_block {
476 :     my($fig_or_sprout,$cgi,$html,$peg,$user,$has_translation) = @_;
477 :    
478 :     my $sims = $cgi->param('sims');
479 : golsen 1.76 if ( (! $sims ) && $has_translation && ( ! $cgi->param('SPROUT') ) )
480 :     {
481 :     my $short_form = 1;
482 :     sims_request_form( $fig_or_sprout, $cgi, $html, $peg, $user, $short_form );
483 :     }
484 : overbeek 1.53
485 : golsen 1.76 # Added test $has_translation && (...) -- GJO
486 :     elsif ( $has_translation && ( $sims || $cgi->param('SPROUT') ) )
487 :     {
488 : parrello 1.60 &print_similarities($fig_or_sprout,$cgi,$html,$peg);
489 : overbeek 1.53 }
490 :     }
491 :    
492 :    
493 :     sub print_services {
494 :     my($fig_or_sprout,$cgi,$html,$peg,$has_translation,$fc_data) = @_;
495 :    
496 :     my $link1 = $cgi->self_url() . "&request=view_annotations";
497 :     my $link2 = $cgi->self_url() . "&request=view_all_annotations";
498 :     push(@$html,"<br><a href=$link1>To View Annotations</a>/<a href=$link2>To View All Related Annotations</a>\n");
499 : parrello 1.60
500 : overbeek 1.63 if ((! $cgi->param('SPROUT')) && $fig_or_sprout->peg_in_gendb($peg))
501 :     {
502 :     push(@$html, "<br/>".&FIGGenDB::linkPEGGenDB($peg));
503 :     push(@$html, "<br/>".&FIGGenDB::importOrganismGenDB($peg));
504 :     }
505 : overbeek 1.53
506 :     my $link = $cgi->self_url() . "&request=aa_sequence";
507 :     push(@$html,"<br><a href=$link>Protein Sequence</a>\n");
508 :    
509 :     $link = $cgi->self_url() . "&request=dna_sequence";
510 :     push(@$html,"<br><a href=$link>DNA Sequence</a>\n");
511 :    
512 :     $link = $cgi->url();
513 :     $link =~ s/protein.cgi/fid_checked.cgi/;
514 :     my $sprout = $cgi->param('SPROUT') ? 1 : "";
515 :     my $user = $cgi->param('user');
516 : parrello 1.60 if (! $user) {
517 :     $user = "";
518 :     } else {
519 :     $link = $link . "?SPROUT=$sprout&fid=$prot&user=$user&checked=$prot&assign/annotate=assign/annotate";
520 :     push(@$html,"<br><a href=$link target=checked_window>To Make an Annotation</a>\n");
521 : overbeek 1.53 }
522 :    
523 : golsen 1.76 # Isn't this redundant? Look up about 9 lines. -- GJO
524 :    
525 : overbeek 1.63 my $sprout = $cgi->param('SPROUT') ? 1 : "";
526 :     if (! $sprout)
527 :     {
528 :     my $fc = $cgi->param('fc');
529 :     if ((! $fc) && (&feature_locationS($fig_or_sprout,$peg))) {
530 :     my $link = $cgi->self_url() . "&fc=1";
531 :     push(@$html,"<br><a href=$link>To Get Detailed Functional Coupling Data</a>\n");
532 :     } elsif ($fc) {
533 :     &print_fc($fig_or_sprout,$cgi,$html,$peg,$fc_data);
534 :     }
535 : overbeek 1.53
536 : overbeek 1.63 my $link = $cgi->self_url() . "&request=fusions";
537 :     push(@$html,"<br><a href=$link>To Get Fusion Data</a>\n");
538 : overbeek 1.53
539 : overbeek 1.63 my $link = &cgi_url . "/homologs_in_clusters.cgi?prot=$peg&user=$user\n";
540 :     push(@$html,"<br><a href=$link>To Find Homologs in Clusters</a>\n");
541 :     }
542 : overbeek 1.53
543 : parrello 1.60 if ((! $cgi->param('compare_region')) && $has_translation) {
544 :     my $link = $cgi->self_url() . "&compare_region=1";
545 :     push(@$html,"<br><a href=$link>To Compare Region</a>\n");
546 :     } elsif ($cgi->param('compare_region')) {
547 :     &print_compared_regions($fig_or_sprout,$cgi,$html,$peg);
548 : overbeek 1.53 }
549 :     }
550 :    
551 : efrank 1.1 sub print_assignments {
552 : overbeek 1.53 my($fig_or_sprout,$cgi,$html,$peg) = @_;
553 : efrank 1.1 my($who,$func,$ec,@ecs,@tmp,$id,$i,$master_func,$user_func,$x);
554 :    
555 :     my $user = $cgi->param('user');
556 : overbeek 1.68 $user = defined($user) ? $user : "";
557 :    
558 : overbeek 1.53 my @funcs = map { [$peg,@$_] } &trans_function_of($cgi,$fig_or_sprout,$peg);
559 : overbeek 1.68 $user_func = &trans_function_of($cgi,$fig_or_sprout,$peg);
560 :    
561 :     push(@$html,$cgi->h2("Current Assignment: $peg: $user_func"));
562 :    
563 :     my @maps_to = grep { $_ ne $peg } map { $_->[0] } &mapped_prot_ids($fig_or_sprout,$cgi,$peg);
564 : efrank 1.1
565 : parrello 1.60 foreach $id (@maps_to) {
566 : overbeek 1.68 my $tmp;
567 :     if (($id ne $peg) && ($tmp = &trans_function_of($cgi,$fig_or_sprout,$id)))
568 :     {
569 :     push(@funcs, [$id,&who($id),$tmp]);
570 : parrello 1.60 }
571 : efrank 1.1 }
572 :     @funcs = map { ($_->[1] eq "master") ? [$_->[0],"",$_->[2]] : $_ } @funcs;
573 : overbeek 1.68
574 :    
575 : efrank 1.1 push(@$html,"<hr>\n");
576 :    
577 : parrello 1.60 if ((@funcs == 0) && (! $user_func)) {
578 :     push(@$html,$cgi->h1("No function has been assigned"));
579 : efrank 1.1 }
580 : overbeek 1.25
581 : overbeek 1.68 my $tab = [ map { ($id,$who,$func) = @$_;
582 :     [ &HTML::set_prot_links($cgi,$id),
583 :     &org_of($fig_or_sprout,$id),
584 : overbeek 1.75 $who ? $who : "&nbsp;",
585 :     ($user ? &assign_link($cgi,$func,$user_func) : "&nbsp;"),
586 : overbeek 1.84 &set_ec_and_tc_links($fig_or_sprout,&genome_of($peg),$func)] } @funcs ];
587 : parrello 1.60 if (@$tab > 0) {
588 :     my $col_hdrs = ["Id","Organism","Who","ASSIGN","Assignment"];
589 :     my $title = "Assignments for Essentially Identical Proteins";
590 : efrank 1.1 push(@$html,&HTML::make_table($col_hdrs,$tab,$title));
591 :     }
592 : overbeek 1.53 }
593 : parrello 1.60
594 : overbeek 1.53 sub print_kv_pairs {
595 :     my($fig_or_sprout,$cgi,$html,$peg) = @_;
596 : efrank 1.1
597 : overbeek 1.53 my @attr = &feature_attributes($fig_or_sprout,$peg);
598 : parrello 1.60 if (@attr > 0) {
599 :     my $tab = [];
600 :     foreach $_ (@attr) {
601 :     my($tag,$val,$url) = @$_;
602 : redwards 1.79 next unless ($url =~ /^http/);
603 : overbeek 1.78 push(@$tab,[$tag,$url ? "<a href=\"$url\">$val</a>" : $val]);
604 : parrello 1.60 }
605 : overbeek 1.78 push(@$html,$cgi->br,$cgi->hr,&HTML::make_table(["Key","Value"],[sort { $a->[0] cmp $b->[0] } @$tab],"Attributes"),$cgi->hr);
606 : overbeek 1.38 }
607 : overbeek 1.53 }
608 :    
609 : overbeek 1.68 sub who {
610 :     my($id) = @_;
611 :    
612 :     if ($id =~ /^fig\|/) { return "FIG" }
613 :     if ($id =~ /^gi\|/) { return "" }
614 :     if ($id =~ /^^[NXYZA]P_/) { return "RefSeq" }
615 :     if ($id =~ /^sp\|/) { return "SwissProt" }
616 :     if ($id =~ /^uni\|/) { return "UniProt" }
617 :     if ($id =~ /^pir\|/) { return "PIR" }
618 :     if ($id =~ /^kegg\|/) { return "KEGG" }
619 :     }
620 :    
621 : overbeek 1.53 sub print_subsys_connections {
622 :     my($fig_or_sprout,$cgi,$html,$peg,$user) = @_;
623 : overbeek 1.38
624 : olson 1.28 #
625 :     # Show the subsystems in which this protein participates.
626 :     #
627 :    
628 : parrello 1.60 if (my @subsystems = &subsystems_for_peg($fig_or_sprout,$peg)) {
629 :     push(@$html,
630 :     $cgi->h2("Subsystems in which this peg is present"));
631 :    
632 :     my(@hdrs);
633 :     my(@table);
634 :    
635 :     @hdrs = ("Subsystem", "Role");
636 :    
637 : overbeek 1.65 my $sprout = ""; # $cgi->param('SPROUT') ? 1 : "";
638 : parrello 1.60
639 :     for my $ent (@subsystems) {
640 :     my($sub, $role) = @$ent;
641 : overbeek 1.89 my $can_alter = (($user = $cgi->param('user')) && ($user eq $fig_or_sprout->subsystem_curator($sub)));
642 :     my $url = $cgi->a({href => "subsys.cgi?can_alter=$can_alter&SPROUT=$sprout&user=$user&ssa_name=$sub&request=show_ssa"}, $sub);
643 :    
644 : parrello 1.60 push(@table, [$url, $role]);
645 :     }
646 :     push(@$html, &HTML::make_table(\@hdrs, \@table));
647 : olson 1.28 }
648 : overbeek 1.53 }
649 :    
650 :     sub print_links {
651 :     my($fig_or_sprout,$cgi,$html,$peg) = @_;
652 : overbeek 1.31
653 : parrello 1.60 my @links = &peg_links($fig_or_sprout,$peg);
654 :     if (@links > 0) {
655 :     my $col_hdrs = [1,2,3,4,5];
656 :     my $title = "Links to Related Entries in Other Sites";
657 :     my $tab = [];
658 :     my ($n,$i);
659 :     for ($i=0; ($i < @links); $i += 5) {
660 :     $n = (($i + (5-1)) < @links) ? $i+(5-1) : $i+(@links - $i);
661 :     push(@$tab,[@links[$i..$n]]);
662 :     }
663 : overbeek 1.26 push(@$html,&HTML::make_table($col_hdrs,$tab,$title));
664 : overbeek 1.25 }
665 :    
666 : parrello 1.60 if (! $cgi->param('SPROUT')) {
667 :     my $url = &cgi_url . "/add_links.cgi?peg=$peg";
668 :     push(@$html,"<a href=$url>To Add New Links to this Gene</a>\n");
669 : overbeek 1.53 }
670 : efrank 1.1 }
671 :    
672 :    
673 :    
674 :     ################# Similarities ############################
675 :    
676 :    
677 :     sub print_similarities {
678 : overbeek 1.53 my( $fig_or_sprout, $cgi, $html, $peg ) = @_;
679 : overbeek 1.63
680 :     if ($cgi->param('SPROUT'))
681 :     {
682 :     &print_similarities_SPROUT($fig_or_sprout, $cgi, $html, $peg );
683 :     }
684 :     else
685 :     {
686 :     &print_similarities_SEED($fig_or_sprout, $cgi, $html, $peg );
687 :     }
688 :     }
689 :    
690 : golsen 1.76
691 : overbeek 1.63 sub print_similarities_SPROUT {
692 :     my($fig_or_sprout, $cgi, $html, $peg ) = @_;
693 :    
694 :     my $user = $cgi->param('user') || "";
695 :     my $current_func = &trans_function_of($cgi,$fig_or_sprout,$peg,$user);
696 :    
697 :     push( @$html, $cgi->hr,
698 :     "<a name=Similarities>",
699 : overbeek 1.68 $cgi->h1(''),
700 : overbeek 1.63 "</a>\n"
701 :     );
702 :    
703 : overbeek 1.65 my @sims = sort { $a->[1] <=> $b->[1] } $fig_or_sprout->bbhs($peg, 1.0e-10, 0);
704 : overbeek 1.63
705 :     my @from = $cgi->radio_group(-name => 'from',
706 :     -nolabels => 1,
707 :     -override => 1,
708 : overbeek 1.65 -values => ["",$peg,map { $_->[0] } @sims]);
709 : overbeek 1.63
710 :     my $target = "window$$";
711 :     # RAE: added a name to the form so tha the javascript works
712 :     push( @$html, $cgi->start_form( -method => 'post',
713 :     -target => $target,
714 :     -action => 'fid_checked.cgi',
715 :     -name => 'fid_checked'
716 :     ),
717 :     $cgi->hidden(-name => 'SPROUT', -value => 1),
718 :     $cgi->hidden(-name => 'fid', -value => $peg),
719 :     $cgi->hidden(-name => 'user', -value => $user),
720 :     $cgi->br,
721 :     "For Selected (checked) sequences: ",
722 :     $cgi->submit('align'),
723 :     );
724 :    
725 :     if ($user) {
726 :     my $help_url = "Html/help_for_assignments_and_rules.html";
727 :     push ( @$html, $cgi->br, $cgi->br,
728 :     "<a href=$help_url>Help on Assignments, Rules, and Checkboxes</a>",
729 :     $cgi->br, $cgi->br,
730 :     $cgi->submit('assign/annotate')
731 :     );
732 :    
733 :     if ($cgi->param('translate')) {
734 :     push( @$html, $cgi->submit('add rules'),
735 :     $cgi->submit('check rules'),
736 :     $cgi->br
737 :     );
738 :     }
739 :     }
740 :    
741 :     push( @$html, $cgi->br,
742 :     $cgi->checkbox( -name => 'checked',
743 :     -value => $peg,
744 :     -override => 1,
745 :     -checked => 1,
746 :     -label => ""
747 :     )
748 :     );
749 :    
750 :     my $col_hdrs;
751 :     if ($user && $cgi->param('translate')) {
752 :     push( @$html, " ASSIGN to/Translate from/SELECT current PEG", $cgi->br,
753 :     "ASSIGN/annotate with form: ", shift @from, $cgi->br,
754 :     "ASSIGN from/Translate to current PEG: ", shift @from
755 :     );
756 :     $col_hdrs = [ "ASSIGN to<hr>Translate from",
757 :     "Similar sequence",
758 :     "E-val",
759 : overbeek 1.65 "In Sub",
760 : overbeek 1.63 "ASSIGN from<hr>Translate to",
761 :     "Function",
762 :     "Organism",
763 :     "Aliases"
764 :     ];
765 :     } elsif ($user) {
766 :     push( @$html, " ASSIGN to/SELECT current PEG", $cgi->br,
767 :     "ASSIGN/annotate with form: ", shift @from, $cgi->br,
768 :     "ASSIGN from current PEG: ", shift @from
769 :     );
770 :     $col_hdrs = [ "ASSIGN to<hr>SELECT",
771 :     "Similar sequence",
772 :     "E-val",
773 : overbeek 1.65 "In Sub",
774 : overbeek 1.63 "ASSIGN from",
775 :     "Function",
776 :     "Organism",
777 :     "Aliases"
778 :     ];
779 :     } else {
780 :     push(@$html, " SELECT current PEG", $cgi->br );
781 :     $col_hdrs = [ "SELECT",
782 :     "Similar sequence",
783 :     "E-val",
784 :     "In Sub",
785 :     "Function",
786 :     "Organism",
787 :     "Aliases"
788 :     ];
789 :     }
790 :    
791 :     my $ncol = @$col_hdrs;
792 :     push( @$html, "<TABLE border cols=$ncol>\n",
793 : overbeek 1.68 "\t<Caption><h2>Bidirectional Best Hits</h2></Caption>\n",
794 : overbeek 1.63 "\t<TR>\n\t\t<TH>",
795 :     join( "</TH>\n\t\t<TH>", @$col_hdrs ),
796 :     "</TH>\n\t</TR>\n"
797 :     );
798 :    
799 :     # Add the table data, row-by-row
800 :    
801 :     my $sim;
802 :     foreach $sim ( @sims ) {
803 :     my($id2,$psc) = @$sim;
804 :     my $cbox = &translatable($fig_or_sprout,$id2) ?
805 :     qq(<input type=checkbox name=checked value="$id2">) : "";
806 :     my $id2_link = &HTML::set_prot_links($cgi,$id2);
807 :     chomp $id2_link;
808 :    
809 :     my @in_sub = &peg_to_subsystems($fig_or_sprout,$id2);
810 :     my $in_sub;
811 :     if (@in_sub > 0) {
812 :     $in_sub = @in_sub;
813 :     } else {
814 : overbeek 1.74 $in_sub = "&nbsp;";
815 : overbeek 1.63 }
816 :    
817 :     my $radio = $user ? shift @from : undef;
818 :     my $func2 = html_enc( scalar &trans_function_of( $cgi, $fig_or_sprout, $id2, $user ) );
819 :     ## RAE Added color3. This will color function tables that do not match the original
820 :     ## annotation. This makes is a lot easier to see what is different (e.g. caps/spaces, etc)
821 :     my $color3="#FFFFFF";
822 :     unless ($func2 eq $current_func) {$color3="#FFDEAD"}
823 :    
824 :     #
825 :     # Colorize organisms:
826 :     #
827 :     # my $org = html_enc( &org_of($fig_or_sprout, $id2 ) );
828 :     my ($org,$oc) = &org_and_color_of($fig_or_sprout, $id2 );
829 :     $org = html_enc( $org );
830 :    
831 :     my $aliases = html_enc( join( ", ", &feature_aliasesL($fig_or_sprout,$id2) ) );
832 : overbeek 1.68
833 : overbeek 1.64 $aliases = &HTML::set_prot_links($cgi,$aliases);
834 : overbeek 1.63
835 :     # Okay, everything is calculated, let's "print" the row datum-by-datum:
836 :    
837 : overbeek 1.74 $func2 = $func2 ? $func2 : "&nbsp;";
838 :     $aliases = $aliases ? $aliases : "&nbsp;";
839 :    
840 : overbeek 1.63 push( @$html, "\t<TR>\n",
841 :     #
842 :     # Colorize check box by Domain
843 :     #
844 :     "\t\t<TD Align=center Bgcolor=$oc>$cbox</TD>\n",
845 :     "\t\t<TD Nowrap>$id2_link</TD>\n",
846 :     "\t\t<TD Nowrap>$psc</TD>\n",
847 : overbeek 1.65 "\t\t<TD>$in_sub</TD>",
848 : overbeek 1.63 $user ? "\t\t<TD Align=center>$radio</TD>\n" : (),
849 :     "\t\t<TD Bgcolor=$color3>$func2</TD>\n",
850 :     #
851 :     # Colorize organism by Domain
852 :     #
853 :     # "\t\t<TD>$org</TD>\n",
854 :     "\t\t<TD Bgcolor=$oc>$org</TD>\n",
855 :     "\t\t<TD>$aliases</TD>\n",
856 :     "\t</TR>\n"
857 :     );
858 :     }
859 :     push( @$html, "</TABLE>\n" );
860 :     push( @$html, $cgi->end_form );
861 :     }
862 :    
863 :    
864 :     sub print_similarities_SEED {
865 :     my( $fig_or_sprout, $cgi, $html, $peg ) = @_;
866 : efrank 1.1
867 : golsen 1.18 my $user = $cgi->param('user') || "";
868 : golsen 1.76 my $current_func = &trans_function_of( $cgi, $fig_or_sprout, $peg, $user );
869 : efrank 1.1
870 : golsen 1.34 push( @$html, $cgi->hr,
871 : golsen 1.76 "<a name=Similarities>", $cgi->h1('Similarities'), "</a>\n"
872 : golsen 1.34 );
873 :    
874 : golsen 1.76 # Generate the request form, and return current option values in hash
875 : efrank 1.1
876 : golsen 1.76 my $short_form = 0;
877 :     my $SimParams = sims_request_form( $fig_or_sprout, $cgi, $html, $peg, $user, $short_form );
878 : overbeek 1.51
879 : golsen 1.76 my $maxN = $SimParams->{ maxN };
880 :     my $maxP = $SimParams->{ maxP };
881 :     my $max_expand = $SimParams->{ max_expand };
882 :     my $just_fig = $SimParams->{ just_fig };
883 :     my $show_env = $SimParams->{ show_env };
884 :     my $hide_alias = $SimParams->{ hide_alias };
885 : overbeek 1.90 my $group_by_genome = $SimParams->{ group_by_genome };
886 : golsen 1.76 # None of these are currently active: -- GJO
887 :     my $extra_opt = $SimParams->{ extra_opt };
888 :     my $min_q_cov = $SimParams->{ min_q_cov };
889 :     my $min_s_cov = $SimParams->{ min_s_cov };
890 :     my $min_sim = $SimParams->{ min_sim };
891 :     my $sim_meas = $SimParams->{ sim_meas };
892 :     my $show_rep = $SimParams->{ show_rep };
893 :     my $max_sim = $SimParams->{ max_sim };
894 :     my $dyn_thrsh = $SimParams->{ dyn_thrsh };
895 :     my $save_dist = $SimParams->{ save_dist };
896 :     my $chk_which = $SimParams->{ chk_which };
897 : efrank 1.1
898 : golsen 1.76 # There is currently no control to turn this on! -- GJO
899 :     my $expand_groups = $SimParams->{ expand_groups };
900 : efrank 1.1
901 : golsen 1.18 my $select = $just_fig ? "fig" : "all";
902 : efrank 1.1
903 : golsen 1.76 # Move filtering of sims list out of display loop. Avoids many problems,
904 :     # including display of table with no entries. Anticipate more filters.
905 :     # -- GJO
906 :    
907 :     my @sims = grep { $show_env || ( $_->id2 !~ /^fig\|999999/ ) }
908 : overbeek 1.90 &sims( $fig_or_sprout, $peg, $maxN, $maxP, $select, $max_expand, $group_by_genome );
909 : golsen 1.76
910 : golsen 1.77 # Similarity filter
911 :    
912 :     if ( defined( $min_sim ) && ( $min_sim > 0 ) && ( $sim_meas eq 'id' ) ) {
913 :     @sims = grep { $_->iden >= $min_sim } @sims;
914 :     }
915 :    
916 :     # Query sequence coverage filter
917 :    
918 :     if ( defined( $min_q_cov ) && ( $min_q_cov > 0 ) ) {
919 :     my $thresh = 0.01 * $min_q_cov;
920 :     @sims = grep { ( abs( $_->e1 - $_->b1 ) + 1 ) >= ( $thresh * $_->ln1 ) } @sims;
921 :     }
922 :    
923 :     # Subject sequence coverage filter
924 :    
925 :     if ( defined( $min_s_cov ) && ( $min_s_cov > 0 ) ) {
926 :     my $thresh = 0.01 * $min_s_cov;
927 :     @sims = grep { ( abs( $_->e2 - $_->b2 ) + 1 ) >= ( $thresh * $_->ln2 ) } @sims;
928 :     }
929 :    
930 : golsen 1.76 if ( @sims ) {
931 :     push( @$html, $cgi->hr );
932 :     my @from = $cgi->radio_group( -name => 'from',
933 :     -nolabels => 1,
934 :     -override => 1,
935 :     -values => [ "", $peg, map { $_->id2 } @sims ]
936 :     );
937 : parrello 1.60
938 :     my $target = "window$$";
939 :     # RAE: added a name to the form so tha the javascript works
940 :     push( @$html, $cgi->start_form( -method => 'post',
941 : golsen 1.76 -target => $target,
942 :     -action => 'fid_checked.cgi',
943 :     -name => 'fid_checked'
944 : parrello 1.60 ),
945 :     $cgi->hidden(-name => 'fid', -value => $peg),
946 :     $cgi->hidden(-name => 'user', -value => $user),
947 :     $cgi->br,
948 :     "For Selected (checked) sequences: ",
949 :     $cgi->submit('align'),
950 :     $cgi->submit('view annotations'),
951 :     $cgi->submit('show regions')
952 :     );
953 :    
954 :     if ($user) {
955 :     my $help_url = "Html/help_for_assignments_and_rules.html";
956 :     push ( @$html, $cgi->br, $cgi->br,
957 :     "<a href=$help_url>Help on Assignments, Rules, and Checkboxes</a>",
958 :     $cgi->br, $cgi->br,
959 :     $cgi->submit('assign/annotate')
960 :     );
961 :    
962 :     if ($cgi->param('translate')) {
963 :     push( @$html, $cgi->submit('add rules'),
964 :     $cgi->submit('check rules'),
965 :     $cgi->br
966 :     );
967 :     }
968 :     }
969 : efrank 1.1
970 : parrello 1.60 push( @$html, $cgi->br,
971 :     $cgi->checkbox( -name => 'checked',
972 :     -value => $peg,
973 :     -override => 1,
974 :     -checked => 1,
975 :     -label => ""
976 :     )
977 :     );
978 :    
979 :     my $col_hdrs;
980 :     my $color_help = "(<A href=\"Html/similarity_region_colors.html\">colors explained</A>)";
981 :     if ($user && $cgi->param('translate')) {
982 :     push( @$html, " ASSIGN to/Translate from/SELECT current PEG", $cgi->br,
983 :     "ASSIGN/annotate with form: ", shift @from, $cgi->br,
984 :     "ASSIGN from/Translate to current PEG: ", shift @from
985 :     );
986 :     $col_hdrs = [ "ASSIGN to<hr>Translate from",
987 :     $expand_groups ? "family" : (),
988 :     $expand_groups ? "size" : (),
989 :     "Similar sequence",
990 :     "E-val<br>% iden",
991 :     "region in<br>similar sequence<br>$color_help",
992 :     "region in<br>$peg<br>$color_help",
993 :     "ASSIGN from<hr>Translate to",
994 : overbeek 1.90 "In Sub",
995 : parrello 1.60 "Function",
996 :     "Organism",
997 : overbeek 1.90 (! $hide_alias) ? "Aliases" : ()
998 : parrello 1.60 ];
999 :     } elsif ($user) {
1000 :     push( @$html, " ASSIGN to/SELECT current PEG", $cgi->br,
1001 :     "ASSIGN/annotate with form: ", shift @from, $cgi->br,
1002 :     "ASSIGN from current PEG: ", shift @from
1003 :     );
1004 :     $col_hdrs = [ "ASSIGN to<hr>SELECT",
1005 :     $expand_groups ? "family" : (),
1006 :     $expand_groups ? "size" : (),
1007 :     "Similar sequence",
1008 :     "E-val<br>% iden",
1009 :     "region in<br>similar sequence<br>$color_help",
1010 :     "region in<br>$peg<br>$color_help",
1011 :     "ASSIGN from",
1012 :     "In Sub",
1013 :     "Function",
1014 :     "Organism",
1015 : overbeek 1.90 (! $hide_alias) ? "Aliases" : ()
1016 : parrello 1.60 ];
1017 :     } else {
1018 :     push(@$html, " SELECT current PEG", $cgi->br );
1019 :     $col_hdrs = [ "SELECT",
1020 :     $expand_groups ? "family" : (),
1021 :     $expand_groups ? "size" : (),
1022 :     "Similar sequence",
1023 :     "E-val<br>% iden",
1024 :     "region in<br>similar sequence<br>$color_help",
1025 :     "region in<br>$peg<br>$color_help",
1026 : overbeek 1.90 "In Sub",
1027 : parrello 1.60 "Function",
1028 :     "Organism",
1029 : overbeek 1.90 (! $hide_alias) ? "Aliases" : ()
1030 : parrello 1.60 ];
1031 :     }
1032 : efrank 1.1
1033 : redwards 1.37 # RAE Add the check all/uncheck all boxes.
1034 :     push (@$html, $cgi->br, &HTML::java_buttons("fid_checked", "checked"), $cgi->br);
1035 :    
1036 : parrello 1.60
1037 :     #
1038 :     # Total rewrite of sim table code: cleaner program flow; omitting
1039 :     # empty columns; colorizing region-of-similarity cells -- GJO
1040 :     #
1041 :     # Start the similarity table with "Caption" and header row
1042 :    
1043 :     my $ncol = @$col_hdrs;
1044 :     push( @$html, "<TABLE border cols=$ncol>\n",
1045 :     "\t<Caption><h2>Similarities</h2></Caption>\n",
1046 :     "\t<TR>\n\t\t<TH>",
1047 :     join( "</TH>\n\t\t<TH>", @$col_hdrs ),
1048 :     "</TH>\n\t</TR>\n"
1049 :     );
1050 :    
1051 :     # Add the table data, row-by-row
1052 :    
1053 : overbeek 1.90 my $alia = (! $hide_alias);
1054 : parrello 1.60 my $sim;
1055 :     foreach $sim ( @sims ) {
1056 :     my $id2 = $sim->id2;
1057 : golsen 1.76
1058 :     # # Filtering moved outside of "if ( @sims ) {" -- GJO
1059 :     #
1060 :     # if ((! $show_env) && ($id2 =~ /^fig\|99999/)) {
1061 :     # shift @from;
1062 :     # next;
1063 :     # }
1064 :    
1065 : parrello 1.60 my $cbox = &translatable($fig_or_sprout,$id2) ?
1066 :     qq(<input type=checkbox name=checked value="$id2">) : "";
1067 :    
1068 :     my( $family, $sz, $funcF, $fam_link );
1069 :     if ($expand_groups && ($id2 =~ /^fig\|/) && ($family = &in_family($fig_or_sprout,$id2))) {
1070 :     $sz = &sz_family($fig_or_sprout,$family);
1071 :     $funcF = html_enc( &family_function($fig_or_sprout,$family) );
1072 :     $fam_link = scalar &HTML::family_link( $family, $user );
1073 :     } else {
1074 :     $family = $sz = $funcF = $fam_link = "";
1075 :     }
1076 :    
1077 :     my $id2_link = &HTML::set_prot_links($cgi,$id2);
1078 :     chomp $id2_link;
1079 :    
1080 :     my @in_sub = &peg_to_subsystems($fig_or_sprout,$id2);
1081 :     my $in_sub;
1082 :     if (@in_sub > 0) {
1083 :     $in_sub = @in_sub;
1084 :     } else {
1085 : overbeek 1.74 $in_sub = "&nbsp;";
1086 : parrello 1.60 }
1087 :    
1088 :     my $psc = $sim->psc;
1089 :     my $iden = $sim->iden;
1090 :     my $ln1 = $sim->ln1;
1091 :     my $ln2 = $sim->ln2;
1092 :     my $b1 = $sim->b1;
1093 :     my $e1 = $sim->e1;
1094 :     my $b2 = $sim->b2;
1095 :     my $e2 = $sim->e2;
1096 :     my $d1 = abs($e1 - $b1) + 1;
1097 :     my $d2 = abs($e2 - $b2) + 1;
1098 :     my $reg1 = "$b1-$e1 (<b>$d1/$ln1</b>)";
1099 :     my $color1 = match_color( $b1, $e1, $ln1 );
1100 :     my $reg2 = "$b2-$e2 (<b>$d2/$ln2</b>)";
1101 :     my $color2 = match_color( $b2, $e2, $ln2 );
1102 :     my $radio = $user ? shift @from : undef;
1103 : overbeek 1.53 my $func2 = html_enc( scalar &trans_function_of( $cgi, $fig_or_sprout, $id2, $user ) );
1104 : parrello 1.60 ## RAE Added color3. This will color function tables that do not match the original
1105 :     ## annotation. This makes is a lot easier to see what is different (e.g. caps/spaces, etc)
1106 : overbeek 1.68 my $color3="#FFFFFF";
1107 :     unless ($func2 eq $current_func) {$color3="#FFDEAD"}
1108 : parrello 1.60
1109 :     if ($funcF && $funcF ne $func2) { $func2 = "$funcF<br>$func2" }
1110 :    
1111 :     #
1112 :     # Colorize organisms:
1113 :     #
1114 :     # my $org = html_enc( &org_of($fig_or_sprout, $id2 ) );
1115 :     my ($org,$oc) = &org_and_color_of($fig_or_sprout, $id2 );
1116 :     $org = html_enc( $org );
1117 :    
1118 :     my $aliases = $alia ? html_enc( join( ", ", &feature_aliasesL($fig_or_sprout,$id2) ) )
1119 :     : undef;
1120 : overbeek 1.64 $aliases = &HTML::set_prot_links($cgi,$aliases);
1121 : parrello 1.60 # Okay, everything is calculated, let's "print" the row datum-by-datum:
1122 :    
1123 : overbeek 1.74 $func2 = $func2 ? $func2 : "&nbsp;";
1124 :     $aliases = $aliases ? $aliases : "&nbsp;";
1125 : parrello 1.60 push( @$html, "\t<TR>\n",
1126 :     #
1127 :     # Colorize check box by Domain
1128 :     #
1129 :     "\t\t<TD Align=center Bgcolor=$oc>$cbox</TD>\n",
1130 :     $expand_groups ? "\t\t<TD>$fam_link</TD>/n" : (),
1131 :     $expand_groups ? "\t\t<TD>$sz</TD>\n" : (),
1132 :     "\t\t<TD Nowrap>$id2_link</TD>\n",
1133 :     "\t\t<TD Nowrap>$psc<br>$iden\%</TD>\n",
1134 :     "\t\t<TD Nowrap Bgcolor=$color2>$reg2</TD>\n",
1135 :     "\t\t<TD Nowrap Bgcolor=$color1>$reg1</TD>\n",
1136 :     $user ? "\t\t<TD Align=center>$radio</TD>\n" : (),
1137 :     "\t\t<TD>$in_sub</TD>",
1138 :     "\t\t<TD Bgcolor=$color3>$func2</TD>\n",
1139 :     #
1140 :     # Colorize organism by Domain
1141 :     #
1142 :     # "\t\t<TD>$org</TD>\n",
1143 :     "\t\t<TD Bgcolor=$oc>$org</TD>\n",
1144 :     $alia ? "\t\t<TD>$aliases</TD>\n" : (),
1145 :     "\t</TR>\n"
1146 :     );
1147 :     }
1148 : overbeek 1.11
1149 : parrello 1.60 push( @$html, "</TABLE>\n" );
1150 :     push( @$html, $cgi->end_form );
1151 : efrank 1.1 }
1152 :     }
1153 :    
1154 : golsen 1.18 #
1155 :     # Support functions for writing the similarities
1156 :     #
1157 :     # This is a sufficient set of escaping for text in HTML:
1158 :     #
1159 :    
1160 :     sub html_enc { $_ = $_[0]; s/\&/&amp;/g; s/\>/&gt;/g; s/\</&lt;/g; $_ }
1161 :    
1162 :     #
1163 :     # Make a background color that reflects the position and extent of a
1164 :     # matching region.
1165 :     #
1166 :     # Left side is red; right side is blue.
1167 :     # Long match is white or pastel; short match is saturated color.
1168 :     #
1169 :    
1170 :     sub match_color {
1171 :     my ( $b, $e, $n ) = @_;
1172 :     my ( $l, $r ) = ( $e > $b ) ? ( $b, $e ) : ( $e, $b );
1173 :     # my $hue = 3/4 * 0.5*($l+$r)/$n - 1/24;
1174 :     my $hue = 5/6 * 0.5*($l+$r)/$n - 1/12;
1175 :     my $cov = ( $r - $l + 1 ) / $n;
1176 :     my $sat = 1 - 10 * $cov / 9;
1177 :     # my $br = 0.8 + 0.2 * $cov;
1178 :     my $br = 1;
1179 :     rgb2html( hsb2rgb( $hue, $sat, $br ) );
1180 :     }
1181 :    
1182 :     #
1183 :     # Convert HSB to RGB. Hue is taken to be in range 0 - 1 (red to red);
1184 :     #
1185 :    
1186 :     sub hsb2rgb {
1187 :     my ( $h, $s, $br ) = @_;
1188 :     $h = 6 * ($h - floor($h)); # Hue is made cyclic modulo 1
1189 :     if ( $s > 1 ) { $s = 1 } elsif ( $s < 0 ) { $s = 0 }
1190 :     if ( $br > 1 ) { $br = 1 } elsif ( $br < 0 ) { $br = 0 }
1191 :     my ( $r, $g, $b ) = ( $h <= 3 ) ? ( ( $h <= 1 ) ? ( 1, $h, 0 )
1192 :     : ( $h <= 2 ) ? ( 2 - $h, 1, 0 )
1193 :     : ( 0, 1, $h - 2 )
1194 :     )
1195 :     : ( ( $h <= 4 ) ? ( 0, 4 - $h, 1 )
1196 :     : ( $h <= 5 ) ? ( $h - 4, 0, 1 )
1197 :     : ( 1, 0, 6 - $h )
1198 :     );
1199 :     ( ( $r * $s + 1 - $s ) * $br,
1200 :     ( $g * $s + 1 - $s ) * $br,
1201 :     ( $b * $s + 1 - $s ) * $br
1202 :     )
1203 :     }
1204 :    
1205 :     #
1206 :     # Convert an RGB value to an HTML color string:
1207 :     #
1208 :    
1209 :     sub rgb2html {
1210 :     my ( $r, $g, $b ) = @_;
1211 :     if ( $r > 1 ) { $r = 1 } elsif ( $r < 0 ) { $r = 0 }
1212 :     if ( $g > 1 ) { $g = 1 } elsif ( $g < 0 ) { $g = 0 }
1213 :     if ( $b > 1 ) { $b = 1 } elsif ( $b < 0 ) { $b = 0 }
1214 :     sprintf("\"#%02x%02x%02x\"", int(255.999*$r), int(255.999*$g), int(255.999*$b) )
1215 :     }
1216 :    
1217 :     #
1218 :     # floor could be gotten from POSIX::, but why bother?
1219 :     #
1220 :    
1221 :     sub floor {
1222 :     my $x = $_[0];
1223 :     defined( $x ) || return undef;
1224 :     ( $x >= 0 ) || ( int($x) == $x ) ? int( $x ) : -1 - int( - $x )
1225 :     }
1226 :    
1227 :    
1228 : golsen 1.76 #------------------------------------------------------------------------
1229 :     # Generate similarity query forms for the SEED. Consolidates things like
1230 :     # style and defaults in one place.
1231 :     #
1232 :     # my $user = $cgi->param('user') || "";
1233 :     # my $short_form = 0;
1234 :     # my $SimParam = sims_request_form( $fig, $cgi, $html, $peg, $user, $short_form );
1235 :     #------------------------------------------------------------------------
1236 :    
1237 :     sub sims_request_form {
1238 :     my ( $fig, $cgi, $html, $peg, $user, $short_form ) = @_;
1239 :    
1240 :     # Read available parameters, and fill in defaults:
1241 :    
1242 :     my $maxN = defined( $cgi->param('maxN') ) ? $cgi->param('maxN') : 50;
1243 :     my $max_expand = defined( $cgi->param('max_expand') ) ? $cgi->param('max_expand') : 5;
1244 :     my $maxP = defined( $cgi->param('maxP') ) ? $cgi->param('maxP') : 1.0e-5;
1245 :     my $just_fig = $cgi->param('just_fig') || 0;
1246 :     my $show_env = $cgi->param('show_env') || 0;
1247 :     my $hide_alias = $cgi->param('hide_alias') || 0;
1248 : overbeek 1.90 my $group_by_genome = $cgi->param('group_by_genome') || 0;
1249 : golsen 1.76 my $trans_role = $cgi->param('translate') || 0;
1250 :     my $expand_groups = $cgi->param('expand_groups') || 0;
1251 :    
1252 : golsen 1.77 # New similarity options
1253 :    
1254 :     # Act on request for more or fewer sim options
1255 : golsen 1.76
1256 :     my $extra_opt = defined( $cgi->param('extra_opt') ) ? $cgi->param('extra_opt') : 0;
1257 : golsen 1.77 if ( $cgi->param('more sim options') ) {
1258 :     $extra_opt = 1;
1259 :     $cgi->delete('more sim options');
1260 :     }
1261 :     if ( $cgi->param('fewer sim options') ) {
1262 :     $extra_opt = 0;
1263 :     $cgi->delete('fewer sim options');
1264 :     }
1265 :    
1266 :     # Make defaults completely open (match original behavior)
1267 :    
1268 :     my $min_sim = $extra_opt && defined( $cgi->param('min_sim') ) ? $cgi->param('min_sim') : 0;
1269 :     my $min_q_cov = $extra_opt && defined( $cgi->param('min_q_cov') ) ? $cgi->param('min_q_cov') : 0;
1270 :     my $min_s_cov = $extra_opt && defined( $cgi->param('min_s_cov') ) ? $cgi->param('min_s_cov') : 0;
1271 :     my $sim_meas = $extra_opt && defined( $cgi->param('sim_meas') ) ? $cgi->param('sim_meas') : 'id';
1272 : golsen 1.76
1273 : golsen 1.77 # New parameters. Not yet implimented.
1274 : golsen 1.76 # The defaults for representative sequences might be tuned:
1275 :    
1276 : golsen 1.77 my $show_rep = $extra_opt && defined( $cgi->param('show_rep') ) ? $cgi->param('show_rep') : 0;
1277 :     my $max_sim = $extra_opt && defined( $cgi->param('max_sim') ) ? $cgi->param('max_sim') : 0.70;
1278 :     my $dyn_thrsh = $extra_opt && defined( $cgi->param('dyn_thrsh') ) ? $cgi->param('dyn_thrsh') : 0;
1279 :     my $save_dist = $extra_opt && defined( $cgi->param('save_dist') ) ? $cgi->param('save_dist') : 0.80;
1280 : golsen 1.76
1281 :     # Mark some of the sequences automatically?
1282 :    
1283 : golsen 1.77 my $chk_which = $extra_opt && defined( $cgi->param('chk_which') ) ? $cgi->param('chk_which') : 'none';
1284 :    
1285 : golsen 1.76
1286 :     # Use $cgi->param('more similarities') to drive increase in maxN and max_expand
1287 :    
1288 :     if ( $cgi->param('more similarities') ) {
1289 :     $maxN *= 2;
1290 :     $max_expand *= 2;
1291 :     $cgi->delete('more similarities');
1292 :     }
1293 :    
1294 :     # We have processed all options. Use them to build forms.
1295 :    
1296 :     # Sanity checks on fixed vocabulary parameter values:
1297 :    
1298 :     $sim_meas = 'id' unless $sim_meas eq 'pos' || $sim_meas eq 'bpp';
1299 :     $chk_which = 'none' unless $chk_which eq 'all' || $chk_which eq 'rep';
1300 :    
1301 :     # Checkmarks for input tags
1302 :    
1303 :     my $chk_just_fig = chked_if( $just_fig );
1304 :     my $chk_show_env = chked_if( $show_env );
1305 :     my $chk_hide_alias = chked_if( $hide_alias );
1306 : overbeek 1.90 my $chk_group_by_genome = chked_if( $group_by_genome );
1307 : golsen 1.76
1308 :     # Features unique to the long form:
1309 :    
1310 :     if ( $short_form )
1311 :     {
1312 :     # Use a here document to push the short version of the similarities form
1313 :     # on @$html (many values are passed as hidden inputs).
1314 :    
1315 :     push @$html, <<"End_Short_Form";
1316 :    
1317 :     <FORM Action=\"protein.cgi#Similarities\">
1318 :     <input type=hidden name=prot value=\"$peg\">
1319 :     <input type=hidden name=sims value=1>
1320 :     <input type=hidden name=fid value=\"$peg\">
1321 :     <input type=hidden name=user value=\"$user\">
1322 :     <input type=hidden name=translate value=$trans_role>
1323 :    
1324 :     <input type=submit name=Similarities value=Similarities>
1325 :     Max sims:<input type=text name=maxN size=5 value=$maxN>
1326 :     Max expand:<input type=text name=max_expand size=5 value=$max_expand>
1327 :     Max E-val:<input type=text name=maxP size=8 value=$maxP>
1328 :     Just FIG IDs:<input type=checkbox name=just_fig value=1 $chk_just_fig>
1329 :     Show Env. samples:<input type=checkbox name=show_env value=1 $chk_show_env>
1330 : overbeek 1.90 Hide aliases:<input type=checkbox name=hide_alias value=1 $chk_hide_alias>
1331 :     Group by Genome:<input type=checkbox name=group_by_genome value=1 $chk_group_by_genome><br />
1332 : golsen 1.76 </FORM>
1333 :     End_Short_Form
1334 :    
1335 :     }
1336 :     else
1337 :     {
1338 :     # Navigation buttons
1339 :    
1340 :     my ( $prev_peg_btn, $next_peg_btn ) = ( "", "" );
1341 :     my ( $prefix, $protnum ) = $peg =~ /^(.*\.)(\d+)$/;
1342 :     if ( $prefix && $protnum ) {
1343 :     if ( ( $protnum > 1 ) && &translatable( $fig_or_sprout, $prefix . ($protnum-1) ) )
1344 :     {
1345 :     $prev_peg_btn = $cgi->submit('previous PEG');
1346 :     }
1347 :     if ( &translatable( $fig_or_sprout, $prefix . ($protnum+1) ) )
1348 :     {
1349 :     $next_peg_btn = $cgi->submit('next PEG');
1350 :     }
1351 :     }
1352 :    
1353 :     # Add/remove extra options button
1354 :    
1355 :     my $extra_opt_btn = $extra_opt ? $cgi->submit('fewer sim options')
1356 :     : $cgi->submit('more sim options');
1357 :    
1358 :     # Checkmarks for input tags
1359 :    
1360 :     my $chk_sim_meas_id = select_if( $sim_meas eq 'id' );
1361 :     my $chk_sim_meas_pos = select_if( $sim_meas eq 'pos' );
1362 :     my $chk_sim_meas_bpp = select_if( $sim_meas eq 'bpp' );
1363 :     my $chk_show_rep = chked_if( $show_rep );
1364 :     my $chk_dyn_thrsh = chked_if( $dyn_thrsh );
1365 :     my $chk_chk_none = select_if( $chk_which eq 'none' );
1366 :     my $chk_chk_all = select_if( $chk_which eq 'all' );
1367 :     my $chk_chk_rep = select_if( $chk_which eq 'rep' );
1368 :    
1369 : golsen 1.77 # Finally time to write some HTML
1370 :     #
1371 : golsen 1.76 # Default options
1372 :    
1373 :     push @$html, <<"End_Default_Options";
1374 :     <FORM Action=\"protein.cgi#Similarities\">
1375 :     <input type=hidden name=prot value=\"$peg\">
1376 :     <input type=hidden name=sims value=1>
1377 :     <input type=hidden name=fid value=\"$peg\">
1378 :     <input type=hidden name=user value=\"$user\">
1379 :     <input type=hidden name=translate value=$trans_role>
1380 :    
1381 :     Max sims:<input type=text name=maxN size=5 value=$maxN>
1382 :     Max expand:<input type=text name=max_expand size=5 value=$max_expand>
1383 :     Max E-val:<input type=text name=maxP size=8 value=$maxP>
1384 :     Just FIG IDs:<input type=checkbox name=just_fig value=1 $chk_just_fig>
1385 :     Show Env. samples:<input type=checkbox name=show_env value=1 $chk_show_env>
1386 : overbeek 1.90 Hide aliases:<input type=checkbox name=hide_alias value=1 $chk_hide_alias>
1387 :     Group by Genome:<input type=checkbox name=group_by_genome value=1 $chk_group_by_genome><br />
1388 : golsen 1.76 End_Default_Options
1389 :    
1390 :     # Extra options
1391 :    
1392 :     push @$html, <<"End_Extra_Options" if $extra_opt;
1393 : golsen 1.77 <input type=hidden name=extra_opt value=\"$extra_opt\">
1394 :    
1395 : golsen 1.76 Min similarity:<input type=text name=min_sim size=5 value=$min_sim>
1396 :     As defined by
1397 :     <select name=sim_meas>
1398 :     <option value=id $chk_sim_meas_id>identities</option>
1399 : golsen 1.77 <!-- Hide unimplimented options
1400 : golsen 1.76 <option value=pos $chk_sim_meas_pos>\"positives\"</option>
1401 :     <option value=bpp $chk_sim_meas_bpp>bit score per position</option>
1402 : golsen 1.77 -->
1403 : golsen 1.76 </select>
1404 :     Min query coverage:<input type=text name=min_q_cov size=5 value=$min_q_cov>
1405 : golsen 1.77 Min subject coverage:<input type=text name=min_s_cov size=5 value=$min_s_cov><br />
1406 : golsen 1.76
1407 : golsen 1.77 <!-- Hide unimplimented options
1408 : golsen 1.76 <TABLE Cols=2>
1409 :     <TR>
1410 :     <TD Valign=top><input type=checkbox name=show_rep $chk_show_rep></TD>
1411 :     <TD> Show only representative sequences whose similarities to one another
1412 :     are less than <input type=text size=5 name=max_sim value=$max_sim>
1413 :     <br />
1414 :     <input type=checkbox name=dyn_thrsh value=1 $chk_dyn_thrsh> But keep sequences
1415 :     that are at least <input type=text size=5 name=save_dist value=$save_dist>
1416 :     times as distant from one another as from the query</TD>
1417 :     </TR>
1418 :     </TABLE>
1419 :    
1420 : golsen 1.77 <input type=hidden name=chk_which value=\"$chk_which\">
1421 :    
1422 : golsen 1.76 Automatically Select (check) which sequences:<select name=chk_which>
1423 :     <option value=none $chk_chk_none>none</option>
1424 :     <option value=all $chk_chk_all>all shown</option>
1425 :     <option value=rep $chk_chk_rep>representative set</option>
1426 :     </select><br />
1427 : golsen 1.77 -->
1428 : golsen 1.76 End_Extra_Options
1429 :    
1430 :     # Submit buttons
1431 :    
1432 :     push @$html, <<"End_of_Buttons";
1433 :     <input type=submit name='resubmit' value='resubmit'>
1434 :     <input type=submit name='more similarities' value='more similarities'>
1435 :     $prev_peg_btn
1436 :     $next_peg_btn
1437 : golsen 1.77 $extra_opt_btn
1438 : golsen 1.76 </FORM>
1439 :     End_of_Buttons
1440 :    
1441 :     }
1442 :    
1443 :     # Return the current parameter values in a hash
1444 :    
1445 :     { maxN => $maxN,
1446 :     maxP => $maxP,
1447 :     max_expand => $max_expand,
1448 :     just_fig => $just_fig,
1449 :     show_env => $show_env,
1450 :     hide_alias => $hide_alias,
1451 : overbeek 1.90 group_by_genome => $group_by_genome,
1452 : golsen 1.76 trans_role => $trans_role,
1453 :     extra_opt => $extra_opt,
1454 :     min_sim => $min_sim,
1455 :     min_q_cov => $min_q_cov,
1456 :     min_s_cov => $min_s_cov,
1457 :     sim_meas => $sim_meas,
1458 :     show_rep => $show_rep,
1459 :     max_sim => $max_sim,
1460 :     dyn_thrsh => $dyn_thrsh,
1461 :     save_dist => $save_dist,
1462 :     chk_which => $chk_which,
1463 :     expand_groups => $expand_groups
1464 :     }
1465 :     }
1466 :    
1467 :    
1468 :     #------------------------------------------------------------------------
1469 :     # Auxilliary function to acivate checkmark for input fields
1470 :     #------------------------------------------------------------------------
1471 :     sub chked_if { $_[0] ? 'checked ' : '' }
1472 :    
1473 :     sub select_if { $_[0] ? 'selected ' : '' }
1474 :    
1475 :    
1476 :    
1477 : efrank 1.1 ################# Context on the Chromosome ############################
1478 :    
1479 :     sub print_context {
1480 : overbeek 1.53 my($fig_or_sprout,$cgi,$html,$peg,$feat,$beg,$end) = @_;
1481 : olson 1.56
1482 : olson 1.57 if ($beg eq $end) { cluck "Have zero len"; }
1483 : efrank 1.1 my($contig1,$beg1,$end1,$strand,$max_so_far,$gap,$comment,$fc,$aliases);
1484 : overbeek 1.81 my($fid1,$sz,$color,$map,$gg,$n,$link,$in_neighborhood);
1485 : efrank 1.1
1486 : overbeek 1.41
1487 :     my $user = $cgi->param('user');
1488 : overbeek 1.53 my $sprout = $cgi->param('SPROUT') ? 1 : "";
1489 :     push(@$html,$cgi->start_form(-action => &cgi_url . "/chromosomal_clusters.cgi"),
1490 :     $cgi->hidden(-name => 'SPROUT', -value => $sprout),
1491 : overbeek 1.41 $cgi->hidden(-name => "prot", -value => $peg),
1492 : overbeek 1.44 $cgi->hidden(-name => "uni", -value => 1),
1493 : overbeek 1.41 $cgi->hidden(-name => "user", -value => $user));
1494 :    
1495 : overbeek 1.53 my %in_cluster = map { $_ => 1 } &in_cluster_with($fig_or_sprout,$peg);
1496 : efrank 1.1
1497 : overbeek 1.73 my $col_hdrs;
1498 :     if ($cgi->param('SPROUT'))
1499 :     {
1500 : overbeek 1.81 $col_hdrs = ["fid","starts","ends","size","","gap","req.<br>in<br>pin","fc","neigh","comment","","","aliases"];
1501 : overbeek 1.73 }
1502 :     else
1503 :     {
1504 : overbeek 1.81 $col_hdrs = ["fid","starts","ends","size","","gap","req.<br>in<br>pin","fc","neigh","comment","aliases"];
1505 : overbeek 1.73 }
1506 :    
1507 : efrank 1.1 my($tab) = [];
1508 :     my $genes = [];
1509 : parrello 1.60
1510 : overbeek 1.53 my $peg_function = &trans_function_of($cgi,$fig_or_sprout,$peg,$user);
1511 : efrank 1.1
1512 :     my($role,$role1,%related_roles);
1513 : parrello 1.60 foreach $role (&roles_of_function($peg_function)) {
1514 :     foreach $role1 (&neighborhood_of_role($fig_or_sprout,$role)) {
1515 :     $related_roles{$role1} = 1;
1516 :     }
1517 : efrank 1.1 }
1518 : parrello 1.60 foreach $fid1 (@$feat) {
1519 :     $fc = $in_cluster{$fid1} ? &pin_link($cgi,$fid1) : "";
1520 : efrank 1.1
1521 : parrello 1.60 my $aliases = join( ', ', &feature_aliasesL($fig_or_sprout,$fid1) );
1522 : olson 1.48 my $uniprot;
1523 :     if ($aliases =~ /(uni[^,]+)/) {
1524 :     # print STDERR "$1\n";
1525 :     $uniprot = $1;
1526 :     }
1527 : overbeek 1.68 $aliases = &HTML::set_prot_links($cgi,$aliases),
1528 :     $aliases =~ s/SPROUT=1/SPROUT=0/g;
1529 :     $aliases =~ s/[&;]user=[^&;]+[;&]/;/g;
1530 : overbeek 1.74 $aliases = $aliases ? $aliases : "&nbsp;";
1531 : overbeek 1.68
1532 : overbeek 1.73 my($to_seed,$to_gbrowse);
1533 :     $to_seed = $to_gbrowse = "";
1534 :     if ($cgi->param('SPROUT') && ($fid1 =~ /peg/))
1535 :     {
1536 :     $to_seed = &cgi_url . "/protein.cgi?prot=$fid1";
1537 :     $to_gbrowse = &cgi_url . $fig_or_sprout->get_gbrowse_feature_link($fid1);
1538 :     }
1539 :    
1540 :    
1541 : overbeek 1.68 ($contig1,$beg1,$end1) = &boundaries_of($fig_or_sprout,&feature_locationS($fig_or_sprout,$fid1));;
1542 :     $strand = ($beg1 < $end1) ? "+" : "-";
1543 :    
1544 :     my $function = &function_ofS($fig_or_sprout,$fid1);
1545 : 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 : '');
1546 :    
1547 : parrello 1.60 if ($fid1 eq $peg) { $color = "green" }
1548 :     elsif ($fc) { $color = "blue" }
1549 :     else { $color = "red" }
1550 :    
1551 :     if ($fid1 =~ /peg\.(\d+)$/) {
1552 :     $n = $1;
1553 : overbeek 1.63 my $sprout = $cgi->param('SPROUT');
1554 :     $sprout = $sprout ? $sprout : "";
1555 :     $link = $cgi->url() . "?prot=$fid1&user=$user&SPROUT=$sprout";
1556 : parrello 1.60 } elsif ($fid1 =~ /\.([a-z]+)\.\d+$/) {
1557 :     $n = uc $1;
1558 :     $link = "";
1559 :     } else {
1560 :     $n ="";
1561 :     $link = "";
1562 :     }
1563 :    
1564 :     push(@$genes,[&min($beg1,$end1),&max($beg1,$end1),($strand eq "+") ? "rightArrow" : "leftArrow", $color,$n,$link,$info]);
1565 :     if ($max_so_far) {
1566 :     $gap = (&min($beg1,$end1) - $max_so_far) - 1;
1567 :     } else {
1568 :     $gap = "";
1569 :     }
1570 :     $max_so_far = &max($beg1,$end1);
1571 : olson 1.48
1572 : efrank 1.1
1573 : overbeek 1.74 $in_neighborhood = "&nbsp;";
1574 : parrello 1.60 if (&ftype($fid1) eq "peg") {
1575 :     $comment = &trans_function_of($cgi,$fig_or_sprout,$fid1,$user);
1576 :     foreach $role (&roles_of_function($comment)) {
1577 :     if ($related_roles{$role}) {
1578 :     $in_neighborhood = "*";
1579 :     }
1580 :     }
1581 :     } else {
1582 :     $comment = "";
1583 :     }
1584 : overbeek 1.84 $comment = &set_ec_and_tc_links($fig_or_sprout,&genome_of($fid1),$comment);
1585 : parrello 1.60 if ($fid1 eq $peg) {
1586 :     $comment = "\@bgcolor=\"#00FF00\":$comment";
1587 :     }
1588 :     $sz = abs($end1-$beg1)+1;
1589 :    
1590 : overbeek 1.74 my $must_have = (($fid1 eq $peg) || (! $fc)) ? "&nbsp;" : $cgi->checkbox(-name => 'must_have',
1591 : parrello 1.60 -value => $fid1,
1592 :     -checked => 0,
1593 :     -override => 1,
1594 :     -label => "");
1595 : overbeek 1.74
1596 :     $comment = $comment ? $comment : "&nbsp;";
1597 : overbeek 1.73 if ($cgi->param('SPROUT'))
1598 :     {
1599 : olson 1.83 my($s_link, $g_link);
1600 :     if (0)
1601 :     {
1602 :     $s_link = "<a href=$to_seed>S</a>";
1603 :     $g_link = "<a href=$to_gbrowse>G</a>";
1604 :     }
1605 :     else
1606 :     {
1607 :     $s_link = "<a href=$to_seed><img src=\"Html/button-s.png\" border=\"0\"></a>";
1608 :     $g_link = "<a href=$to_gbrowse><img src=\"Html/button-g.png\" border=\"0\"></a>";
1609 :     }
1610 : overbeek 1.73 push(@$tab,[&HTML::fid_link($cgi,$fid1,"local"),$beg1,$end1,$sz,$strand,$gap,
1611 :     $must_have,
1612 :     $fc,$in_neighborhood,
1613 :     $comment,
1614 : olson 1.83 $s_link,
1615 :     $g_link,
1616 : overbeek 1.81 $aliases]);
1617 : overbeek 1.73 }
1618 :     else
1619 :     {
1620 :     push(@$tab,[&HTML::fid_link($cgi,$fid1,"local"),$beg1,$end1,$sz,$strand,$gap,
1621 :     $must_have,
1622 :     $fc,$in_neighborhood,
1623 :     $comment,
1624 : overbeek 1.81 $aliases]);
1625 : overbeek 1.73 }
1626 : efrank 1.1 }
1627 : overbeek 1.27 push(@$html,&HTML::make_table($col_hdrs,$tab,"Context on contig $contig1"));
1628 : overbeek 1.41 push(@$html,$cgi->br,$cgi->submit('pin with checked genes'),$cgi->end_form,$cgi->br);
1629 : overbeek 1.53 return ($beg,$end,$genes);
1630 :     }
1631 :    
1632 :     sub print_graphics_context {
1633 :     my($beg,$end,$genes,$html) = @_;
1634 :    
1635 :     my $map = ["",$beg,$end,$genes];
1636 :     my $gg = [$map];
1637 : overbeek 1.2 push(@$html,@{ &GenoGraphics::render($gg,700,4,0,1) });
1638 : efrank 1.1 return;
1639 :     }
1640 :    
1641 :     sub assign_link {
1642 :     my($cgi,$func,$existing_func) = @_;
1643 :     my($assign_url,$assign_link);
1644 :    
1645 : parrello 1.60 if ($func && ((! $existing_func) || ($existing_func ne $func))) {
1646 :     $cgi->delete('request');
1647 :     $assign_url = $cgi->self_url() . "&request=fast_assign&func=$func"; ## must encode
1648 :     $assign_link = "<a href=\"$assign_url\">&nbsp;<=&nbsp;</a>";
1649 :     } else {
1650 :     $assign_link = "";
1651 : efrank 1.1 }
1652 :     return $assign_link;
1653 :     }
1654 :    
1655 :     sub pin_link {
1656 :     my($cgi,$peg) = @_;
1657 :     my $user = $cgi->param('user');
1658 :     $user = defined($user) ? $user : "";
1659 :    
1660 : overbeek 1.63 # RAO disconnect SPROUT from pinning requests until chromosomal_clusters.cgi is rewritten
1661 : overbeek 1.53 my $sprout = $cgi->param('SPROUT') ? 1 : "";
1662 : overbeek 1.63 my $cluster_url = "chromosomal_clusters.cgi?prot=$peg&user=$user&uni=1"; # &SPROUT=$sprout";
1663 : olson 1.83
1664 :     my $cluster_img = 0 ? "*" : '<img src="Html/button-fc.png" border="0">';
1665 :     my $cluster_link = "<a href=\"$cluster_url\">$cluster_img</a>";
1666 : efrank 1.1 return $cluster_link;
1667 :     }
1668 :    
1669 : overbeek 1.84 sub set_ec_and_tc_links {
1670 : overbeek 1.53 my($fig_or_sprout,$org,$func) = @_;
1671 : efrank 1.1
1672 : parrello 1.60 if ($func =~ /^(.*)(\d+\.\d+\.\d+\.\d+)(.*)$/) {
1673 :     my $before = $1;
1674 :     my $ec = $2;
1675 :     my $after = $3;
1676 : overbeek 1.84 return &set_ec_and_tc_links($fig_or_sprout,$org,$before) . &set_ec_to_maps($fig_or_sprout,$org,$ec) . &set_ec_and_tc_links($fig_or_sprout,$org,$after);
1677 :     }
1678 :     elsif ($func =~ /^(.*)(TC \d+(\.[0-9A-Z]+){3,6})(.*)$/) {
1679 :     my $before = $1;
1680 :     my $tc = $2;
1681 :     my $after = $4;
1682 :     return &set_ec_and_tc_links($fig_or_sprout,$org,$before) . &set_tc_link($fig_or_sprout,$org,$tc) . &set_ec_and_tc_links($fig_or_sprout,$org,$after);
1683 : efrank 1.1 }
1684 :     return $func;
1685 :     }
1686 :    
1687 : overbeek 1.84 sub set_tc_link {
1688 :     my($fig_or_sprout,$org,$tc) = @_;
1689 :    
1690 :     if ($tc =~ /^TC\s+(\S+)$/)
1691 :     {
1692 :     return "<a href=http://tcdb.ucsd.edu/tcdb/index.php?tc=$1&Submit=Lookup>$tc</a>";
1693 :     }
1694 :     return $tc;
1695 :     }
1696 :    
1697 :    
1698 : efrank 1.1 sub set_ec_to_maps {
1699 : overbeek 1.53 my($fig_or_sprout,$org,$ec) = @_;
1700 : efrank 1.1
1701 : overbeek 1.53 my @maps = &ec_to_maps($fig_or_sprout,$ec);
1702 : parrello 1.60 if (@maps > 0) {
1703 :     $cgi->delete('request');
1704 :     my $url = $cgi->self_url() . "&request=ec_to_maps&ec=$ec&org=$org";
1705 :     my $link = "<a href=\"$url\">$ec</a>";
1706 :     return $link;
1707 : efrank 1.1 }
1708 :     return $ec;
1709 :     }
1710 :    
1711 :     sub show_ec_to_maps {
1712 : overbeek 1.53 my($fig_or_sprout,$cgi,$html,$ec) = @_;
1713 : efrank 1.1
1714 :     my $ec = $cgi->param('ec');
1715 : parrello 1.60 if (! $ec) {
1716 :     push(@$html,$cgi->h1("Missing EC number"));
1717 :     return;
1718 : efrank 1.1 }
1719 :    
1720 : overbeek 1.53 my @maps = &ec_to_maps($fig_or_sprout,$ec);
1721 : parrello 1.60 if (@maps > 0) {
1722 :     my $col_hdrs = ["map","metabolic topic"];
1723 :     my $map;
1724 :     my $tab = [map { $map = $_; [&map_link($cgi,$map),&map_name($fig_or_sprout,$map)] } @maps];
1725 :     push(@$html,&HTML::make_table($col_hdrs,$tab,"$ec: " . &ec_name($fig_or_sprout,$ec)));
1726 : efrank 1.1 }
1727 :     }
1728 :    
1729 :     sub map_link {
1730 :     my($cgi,$map) = @_;
1731 :    
1732 :     $cgi->delete('request');
1733 :     my $url = $cgi->self_url() . "&request=link_to_map&map=$map";
1734 :     my $link = "<a href=\"$url\">$map</a>";
1735 :     return $link;
1736 :     }
1737 :    
1738 :     sub link_to_map {
1739 : overbeek 1.53 my($fig_or_sprout,$cgi,$html) = @_;
1740 : efrank 1.1
1741 :     my $map = $cgi->param('map');
1742 : parrello 1.60 if (! $map) {
1743 :     push(@$html,$cgi->h1("Missing Map"));
1744 :     return;
1745 : efrank 1.1 }
1746 :    
1747 :     my $org = $cgi->param('org');
1748 : parrello 1.60 if (! $org) {
1749 :     push(@$html,$cgi->h1("Missing Org Parameter"));
1750 :     return;
1751 : efrank 1.1 }
1752 :     my$user = $cgi->param('user');
1753 :     $user = $user ? $user : "";
1754 :    
1755 :     $ENV{"REQUEST_METHOD"} = "GET";
1756 :     $ENV{"QUERY_STRING"} = "user=$user&map=$map&org=$org";
1757 :     my @out = `./show_kegg_map.cgi`;
1758 :     &HTML::trim_output(\@out);
1759 :     push(@$html,@out);
1760 :     }
1761 : parrello 1.60
1762 : efrank 1.1 sub aa_sequence {
1763 : overbeek 1.53 my($fig_or_sprout,$cgi,$html,$prot) = @_;
1764 : efrank 1.1 my($seq,$func,$i);
1765 :    
1766 : golsen 1.19 unshift @$html, "<TITLE>The SEED: Protein Sequence</TITLE>\n";
1767 : parrello 1.60 if ($seq = &get_translation($fig_or_sprout,$prot)) {
1768 :     $func = &function_ofS($fig_or_sprout,$prot,$cgi->param('user'));
1769 :     push(@$html,$cgi->pre,">$prot $func\n");
1770 :     for ($i=0; ($i < length($seq)); $i += 60) {
1771 :     if ($i > (length($seq) - 60)) {
1772 :     push(@$html,substr($seq,$i) . "\n");
1773 :     } else {
1774 :     push(@$html,substr($seq,$i,60) . "\n");
1775 :     }
1776 :     }
1777 :     push(@$html,$cgi->end_pre);
1778 :     } else {
1779 :     push(@$html,$cgi->h1("No translation available for $prot"));
1780 : efrank 1.1 }
1781 :     }
1782 :    
1783 :     sub dna_sequence {
1784 : overbeek 1.53 my($fig_or_sprout,$cgi,$html,$fid) = @_;
1785 : efrank 1.1 my($seq,$func,$i);
1786 :    
1787 : golsen 1.19 unshift @$html, "<TITLE>The SEED: Nucleotide Sequence</TITLE>\n";
1788 : parrello 1.60 if ($seq = &dna_seq($fig_or_sprout,&genome_of($fid),&feature_locationS($fig_or_sprout,$fid))) {
1789 :     $func = &function_ofS($fig_or_sprout,$prot,$cgi->param('user'));
1790 :     push(@$html,$cgi->pre,">$fid $func\n");
1791 :     for ($i=0; ($i < length($seq)); $i += 60) {
1792 :     if ($i > (length($seq) - 60)) {
1793 :     push(@$html,substr($seq,$i) . "\n");
1794 :     } else {
1795 :     push(@$html,substr($seq,$i,60) . "\n");
1796 :     }
1797 :     }
1798 :     push(@$html,$cgi->end_pre);
1799 :     } else {
1800 :     push(@$html,$cgi->h1("No DNA sequence available for $fid"));
1801 : efrank 1.1 }
1802 :     }
1803 : parrello 1.60
1804 : efrank 1.1 sub show_fusions {
1805 : overbeek 1.53 my($fig_or_sprout,$cgi,$html,$prot) = @_;
1806 : efrank 1.1
1807 : overbeek 1.22 my $user = $cgi->param('user');
1808 :     $user = $user ? $user : "";
1809 : overbeek 1.53 my $sprout = $cgi->param('SPROUT') ? 1 : "";
1810 :    
1811 : efrank 1.1 $ENV{"REQUEST_METHOD"} = "GET";
1812 : overbeek 1.53 $ENV{"QUERY_STRING"} = "peg=$prot&user=$user&SPROUT=$sprout";
1813 : efrank 1.1 my @out = `./fusions.cgi`;
1814 :     print join("",@out);
1815 :     exit;
1816 : overbeek 1.2 }
1817 :    
1818 : overbeek 1.53 ###########################################################################
1819 : overbeek 1.2 sub print_compared_regions {
1820 : overbeek 1.53 my($fig_or_sprout,$cgi,$html,$peg) = @_;
1821 :    
1822 :     my $sz_region = $cgi->param('sz_region');
1823 :     $sz_region = $sz_region ? $sz_region : 16000;
1824 :    
1825 :     my $num_close = $cgi->param('num_close');
1826 :     $num_close = $num_close ? $num_close : 5;
1827 : overbeek 1.2
1828 : overbeek 1.65 my @closest_pegs = &closest_pegs($fig_or_sprout,$cgi,$peg,$num_close);
1829 : overbeek 1.40
1830 : parrello 1.60 if (@closest_pegs > 0) {
1831 :     if (&possibly_truncated($fig_or_sprout,$peg)) {
1832 :     push(@closest_pegs,&possible_extensions($peg,\@closest_pegs));
1833 :     }
1834 :     @closest_pegs = &sort_fids_by_taxonomy($fig_or_sprout,@closest_pegs);
1835 :     unshift(@closest_pegs,$peg);
1836 :     my @all_pegs = ();
1837 :     my $gg = &build_maps($fig_or_sprout,\@closest_pegs,\@all_pegs,$sz_region);
1838 :     #warn Dumper($gg);
1839 : overbeek 1.68 my $color_sets = &cluster_genes($fig_or_sprout,$cgi,\@all_pegs,$peg);
1840 : parrello 1.60 &set_colors_text_and_links($gg,\@all_pegs,$color_sets);
1841 :     ################################### add commentary capability
1842 : overbeek 1.35
1843 : parrello 1.60 my @parm_reset_form = ($cgi->hr);
1844 :     push(@parm_reset_form,$cgi->start_form(-action => &cgi_url . "/protein.cgi" ));
1845 : overbeek 1.53 my $param;
1846 : parrello 1.60 foreach $param ($cgi->param()) {
1847 :     next if (($param eq "sz_region") || ($param eq "num_close"));
1848 :     push(@parm_reset_form,$cgi->hidden(-name => $param, -value => $cgi->param($param)));
1849 :     }
1850 :     push(@parm_reset_form,
1851 :     "size region: ",
1852 :     $cgi->textfield(-name => 'sz_region', -size => 10, -value => $sz_region, -override => 1),
1853 :     "&nbsp; &nbsp; &nbsp; &nbsp; &nbsp; ",
1854 :     "Number close genomes: ",
1855 :     $cgi->textfield(-name => 'num_close', -size => 4, -value => $num_close, -override => 1),
1856 :     $cgi->br,
1857 :     $cgi->submit('Reset Parameters')
1858 :     );
1859 :     push(@parm_reset_form,$cgi->end_form);
1860 :     push(@$html,@parm_reset_form);
1861 :     ####
1862 :     my @commentary_form = ();
1863 :     my $ctarget = "window$$";
1864 :     my $user = $cgi->param('user');
1865 :     my $sprout = $cgi->param('SPROUT') ? 1 : "";
1866 :    
1867 :     push(@commentary_form,$cgi->start_form(-target => $ctarget,
1868 :     -action => &cgi_url . "/chromosomal_clusters.cgi"
1869 :     ));
1870 :    
1871 :     push(@commentary_form,$cgi->hidden(-name => 'SPROUT', -value => $sprout),
1872 :     $cgi->hidden(-name => "request", -value => "show_commentary"));
1873 :     push(@commentary_form,$cgi->hidden(-name => "prot", -value => $peg));
1874 :     push(@commentary_form,$cgi->hidden(-name => "uni", -value => 1));
1875 :     push(@commentary_form,$cgi->hidden(-name => "user", -value => $user));
1876 :    
1877 :     my($gene,$n,%how_many,$val,@vals,$x);
1878 :     my($i,$map);
1879 :     @vals = ();
1880 :     for ($i=(@$gg - 1); ($i >= 0); $i--) {
1881 :     my @vals1 = ();
1882 :     $map = $gg->[$i];
1883 :     my $found = 0;
1884 :     my $got_red = 0;
1885 :     undef %how_many;
1886 :     foreach $gene (@{$map->[3]}) {
1887 :     if (($x = $gene->[3]) ne "grey") {
1888 :     $n = $gene->[4];
1889 :     if ($n == 1) { $got_red = 1 }
1890 :     $how_many{$n}++;
1891 :     $gene->[5] =~ /(fig\|\d+\.\d+\.peg\.\d+)/;
1892 :     $val = join("@",($n,$i,$1,$map->[0],$how_many{$n}));
1893 :     push(@vals1,$val);
1894 :     $found++;
1895 :     }
1896 :     }
1897 :    
1898 :     if (! $got_red) {
1899 :     splice(@$gg,$i,1);
1900 :     } else {
1901 :     push(@vals,@vals1);
1902 :     }
1903 :     }
1904 : overbeek 1.35
1905 : parrello 1.60 if (@$gg == 0) {
1906 :     push(@$html,$cgi->h1("Sorry, no pins worked out"));
1907 :     } else {
1908 :     push(@commentary_form,$cgi->hidden(-name => "show", -value => [@vals]));
1909 :     push(@commentary_form,$cgi->submit('commentary'));
1910 :     push(@commentary_form,$cgi->end_form());
1911 :     push(@$html,@commentary_form);
1912 :     }
1913 : overbeek 1.35 ################################################################end commentary
1914 : parrello 1.60 push(@$html,@{ &GenoGraphics::render($gg,700,4,0,2) });
1915 : overbeek 1.85 if (! $cgi->param('SPROUT'))
1916 :     {
1917 :     push @$html, &FIGGenDB::linkClusterGenDB($peg);
1918 :     }
1919 : overbeek 1.2 }
1920 :     }
1921 :    
1922 :     sub closest_pegs {
1923 : overbeek 1.65 my($fig_or_sprout,$cgi,$peg,$n) = @_;
1924 : overbeek 1.2 my($id2,$d,$peg2,$i);
1925 :    
1926 : overbeek 1.65 my @closest;
1927 :     if ($cgi->param('SPROUT'))
1928 :     {
1929 :     @closest = map { $_->[0] } sort { $a->[1] <=> $b->[1] } $fig_or_sprout->bbhs($peg, 1.0e-10, 0);
1930 :     }
1931 :     else
1932 :     {
1933 : overbeek 1.88 @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),1.0e-20);
1934 : overbeek 1.65 }
1935 : overbeek 1.2
1936 :     if (@closest > $n) { $#closest = $n-1 }
1937 :     my %closest = map { $_ => 1 } @closest;
1938 : overbeek 1.53 my @pinned_to = grep { $_ ne $peg} &in_pch_pin_with($fig_or_sprout,$peg);
1939 :     my $g1 = &genome_of($peg);
1940 : parrello 1.60 @pinned_to =
1941 : overbeek 1.2 map {$_->[1] }
1942 :     sort { $a->[0] <=> $b->[0] }
1943 : overbeek 1.53 map { $peg2 = $_; $d = &crude_estimate_of_distance($fig_or_sprout,$g1,&genome_of($peg2)); [$d,$peg2] }
1944 : overbeek 1.2 @pinned_to;
1945 :    
1946 : parrello 1.60 for ($i=0; ($i < @pinned_to) && ($i < $n); $i++) {
1947 :     $closest{$pinned_to[$i]} = 1;
1948 : overbeek 1.2 }
1949 : parrello 1.60 return keys(%closest);
1950 : overbeek 1.2 }
1951 :    
1952 :     sub build_maps {
1953 : overbeek 1.53 my($fig_or_sprout,$pinned_pegs,$all_pegs,$sz_region) = @_;
1954 : overbeek 1.2 my($gg,$loc,$contig,$beg,$end,$mid,$min,$max,$genes,$feat,$fid);
1955 :     my($contig1,$beg1,$end1,$map,$peg);
1956 :    
1957 :     $gg = [];
1958 : parrello 1.60 foreach $peg (@$pinned_pegs) {
1959 :     $loc = &feature_locationS($fig_or_sprout,$peg);
1960 :     ($contig,$beg,$end) = &boundaries_of($fig_or_sprout,$loc);
1961 :     if ($contig && $beg && $end) {
1962 :     $mid = int(($beg + $end) / 2);
1963 :     $min = int($mid - ($sz_region / 2));
1964 :     $max = int($mid + ($sz_region / 2));
1965 :     $genes = [];
1966 : overbeek 1.81 ($feat,undef,undef) = &genes_in_region($fig_or_sprout,$cgi,&genome_of($peg),$contig,$min,$max);
1967 : parrello 1.60 foreach $fid (@$feat) {
1968 :     ($contig1,$beg1,$end1) = &boundaries_of($fig_or_sprout,&feature_locationS($fig_or_sprout,$fid));
1969 :     $beg1 = &in_bounds($min,$max,$beg1);
1970 :     $end1 = &in_bounds($min,$max,$end1);
1971 :     my $aliases = join( ', ', &feature_aliasesL($fig_or_sprout,$fid) );
1972 :     my $function = &function_ofS($fig_or_sprout,$fid);
1973 :     my $uniprot;
1974 :     if ($aliases =~ /(uni[^,]+)/) {
1975 :     $uniprot = $1;
1976 :     }
1977 :     my $info = join ('<br/>', "<b>PEG:</b> ".$fid, "<b>Contig:</b> ".$contig1, "<b>Begin:</b> ".$beg1, "<b>End:</b> ".$end1,$function ? "<b>Function:</b> ".$function : '', $uniprot ? "<b>Uniprot ID:</b> ".$uniprot : '');
1978 :    
1979 :     my $sprout = $cgi->param('SPROUT') ? 1 : "";
1980 : overbeek 1.68 my $fmg;
1981 :     if ($sprout)
1982 :     {
1983 :     $fmg = "<a href=\&quot;protein.cgi?SPROUT=$sprout&compare_region=1\&prot=$fid\&user=\&quot>show</a>";
1984 :     }
1985 :     else
1986 :     {
1987 :     $fmg = join ('<br/>', "<a href=\&quot;protein.cgi?SPROUT=$sprout&compare_region=1\&prot=$fid\&user=\&quot>show</a>",
1988 : parrello 1.60 "<a onClick=\&quot;setValue('bound1', '$fid'); return false;\&quot;>set bound 1</a>",
1989 :     "<a onClick=\&quot;setValue('bound2', '$fid'); return false;\&quot;>set bound 2</a>",
1990 :     "<a onClick=\&quot;setValue('candidates', '$fid'); return false;\&quot;>set candidate</a>");
1991 : overbeek 1.68 }
1992 : parrello 1.60 push(@$genes,[&min($beg1,$end1),
1993 :     &max($beg1,$end1),
1994 :     ($beg1 < $end1) ? "rightArrow" : "leftArrow",
1995 :     "grey",
1996 :     "",
1997 :     $fid,
1998 :     $info, $fmg]);
1999 :    
2000 :     if ($fid =~ /peg/) {
2001 :     push(@$all_pegs,$fid);
2002 :     }
2003 :     }
2004 :     $map = [&abbrev(&org_of($fig_or_sprout,$peg)),0,$max+1-$min,
2005 :     ($beg < $end) ? &decr_coords($genes,$min) : &flip_map($genes,$min,$max)];
2006 :     push(@$gg,$map);
2007 :     }
2008 : overbeek 1.2 }
2009 : overbeek 1.55 &GenoGraphics::disambiguate_maps($gg);
2010 : overbeek 1.2 return $gg;
2011 :     }
2012 :    
2013 :     sub in {
2014 :     my($x,$xL) = @_;
2015 :     my($i);
2016 :    
2017 :     for ($i=0; ($i < @$xL) && ($x != $xL->[$i]); $i++) {}
2018 :     return ($i < @$xL);
2019 :     }
2020 :    
2021 :     sub in_bounds {
2022 :     my($min,$max,$x) = @_;
2023 :    
2024 :     if ($x < $min) { return $min }
2025 :     elsif ($x > $max) { return $max }
2026 :     else { return $x }
2027 :     }
2028 :    
2029 :     sub decr_coords {
2030 :     my($genes,$min) = @_;
2031 :     my($gene);
2032 :    
2033 : parrello 1.60 foreach $gene (@$genes) {
2034 :     $gene->[0] -= $min;
2035 :     $gene->[1] -= $min;
2036 : overbeek 1.2 }
2037 :     return $genes;
2038 :     }
2039 :    
2040 :     sub flip_map {
2041 :     my($genes,$min,$max) = @_;
2042 :     my($gene);
2043 : parrello 1.60
2044 :     foreach $gene (@$genes) {
2045 :     ($gene->[0],$gene->[1]) = ($max - $gene->[1],$max - $gene->[0]);
2046 :     $gene->[2] = ($gene->[2] eq "rightArrow") ? "leftArrow" : "rightArrow";
2047 : overbeek 1.2 }
2048 :     return $genes;
2049 :     }
2050 :    
2051 :     sub cluster_genes {
2052 : overbeek 1.68 my($fig_or_sprout,$cgi,$all_pegs,$peg) = @_;
2053 : overbeek 1.2 my(%seen,$i,$j,$k,$x,$cluster,$conn,$pegI,$red_set);
2054 :    
2055 :     my @color_sets = ();
2056 :    
2057 : overbeek 1.68 $conn = &get_connections_by_similarity($fig_or_sprout,$cgi,$all_pegs);
2058 :    
2059 : parrello 1.60 for ($i=0; ($i < @$all_pegs); $i++) {
2060 :     if ($all_pegs->[$i] eq $peg) { $pegI = $i }
2061 :     if (! $seen{$i}) {
2062 :     $cluster = [$i];
2063 :     $seen{$i} = 1;
2064 :     for ($j=0; ($j < @$cluster); $j++) {
2065 :     $x = $conn->{$cluster->[$j]};
2066 :     foreach $k (@$x) {
2067 :     if (! $seen{$k}) {
2068 :     push(@$cluster,$k);
2069 :     $seen{$k} = 1;
2070 :     }
2071 :     }
2072 :     }
2073 :    
2074 :     if ((@$cluster > 1) || ($cluster->[0] eq $pegI)) {
2075 :     push(@color_sets,$cluster);
2076 :     }
2077 :     }
2078 : overbeek 1.2 }
2079 :     for ($i=0; ($i < @color_sets) && (! &in($pegI,$color_sets[$i])); $i++) {}
2080 :     $red_set = $color_sets[$i];
2081 :     splice(@color_sets,$i,1);
2082 :     @color_sets = sort { @$b <=> @$a } @color_sets;
2083 :     unshift(@color_sets,$red_set);
2084 :    
2085 :     my $color_sets = {};
2086 : parrello 1.60 for ($i=0; ($i < @color_sets); $i++) {
2087 :     foreach $x (@{$color_sets[$i]}) {
2088 :     $color_sets->{$all_pegs->[$x]} = $i;
2089 :     }
2090 : overbeek 1.2 }
2091 :     return $color_sets;
2092 :     }
2093 :    
2094 :     sub get_connections_by_similarity {
2095 : overbeek 1.68 my($fig_or_sprout,$cgi,$all_pegs) = @_;
2096 :    
2097 :     if ($cgi->param('SPROUT'))
2098 :     {
2099 :     return &get_connections_by_similarity_SPROUT($fig_or_sprout,$all_pegs);
2100 :     }
2101 :     else
2102 :     {
2103 :     return &get_connections_by_similarity_SEED($fig_or_sprout,$all_pegs);
2104 :     }
2105 :     }
2106 :    
2107 :     sub get_connections_by_similarity_SPROUT {
2108 :     my($fig_or_sprout,$all_pegs) = @_;
2109 :     my(%in,$i,$j,$peg1,$peg2);
2110 :    
2111 :     my $conn = {};
2112 :    
2113 :     for ($i=0; $i < @$all_pegs; $i++)
2114 :     {
2115 :     $in{$all_pegs->[$i]} = $i;
2116 :     }
2117 :    
2118 :     foreach $peg1 (@$all_pegs)
2119 :     {
2120 :     $i = $in{$peg1};
2121 :     foreach $peg2 (map { $_->[0] } $fig_or_sprout->bbhs($peg1, 1.0e-10, 0))
2122 :     {
2123 :     $j = $in{$peg2};
2124 :     if (defined($i) && defined($j))
2125 :     {
2126 :     push(@{$conn->{$i}},$j);
2127 :     }
2128 :     }
2129 :     }
2130 :     return $conn;
2131 :     }
2132 :    
2133 :     sub get_connections_by_similarity_SEED {
2134 :     my($fig_or_sprout,$all_pegs) = @_;
2135 : overbeek 1.40 my($i,$j,$tmp,$peg,%pos_of);
2136 :     my($sim,%conn,$x,$y);
2137 : overbeek 1.2
2138 : parrello 1.60 for ($i=0; ($i < @$all_pegs); $i++) {
2139 :     $tmp = &maps_to_id($fig_or_sprout,$all_pegs->[$i]);
2140 :     push(@{$pos_of{$tmp}},$i); # map the representative in nr to subscript in all_pegs
2141 :     if ($tmp ne $all_pegs->[$i]) {
2142 :     push(@{$pos_of{$all_pegs->[$i]}},$i);
2143 :     }
2144 : overbeek 1.2 }
2145 :    
2146 : parrello 1.60 foreach $y (keys(%pos_of)) {
2147 :     $x = $pos_of{$y};
2148 :     for ($i=0; ($i < @$x); $i++) {
2149 :     for ($j=$i+1; ($j < @$x); $j++) {
2150 :     push(@{$conn{$x->[$i]}},$x->[$j]);
2151 :     push(@{$conn{$x->[$j]}},$x->[$i]);
2152 :     }
2153 :     }
2154 : overbeek 1.40 }
2155 :    
2156 : parrello 1.60 for ($i=0; ($i < @$all_pegs); $i++) {
2157 :     foreach $sim (&sims($fig_or_sprout,$all_pegs->[$i],500,1.0e-5,"raw")) {
2158 :     if (defined($x = $pos_of{$sim->id2})) {
2159 :     foreach $y (@$x) {
2160 :     push(@{$conn{$i}},$y);
2161 :     }
2162 :     }
2163 :     }
2164 : overbeek 1.2 }
2165 :     return \%conn;
2166 :     }
2167 :    
2168 :     sub set_colors_text_and_links {
2169 :     my($gg,$all_pegs,$color_sets) = @_;
2170 :     my($map,$gene,$peg,$color);
2171 :    
2172 : parrello 1.60 foreach $map (@$gg) {
2173 :     foreach $gene (@{$map->[3]}) {
2174 :     $peg = $gene->[5];
2175 :     if (defined($color = $color_sets->{$peg})) {
2176 :     $gene->[3] = ($color == 0) ? "red" : "color$color";
2177 :     $gene->[4] = $color + 1;
2178 :     }
2179 :     $gene->[5] = &peg_url($cgi,$peg);
2180 :     }
2181 : overbeek 1.2 }
2182 :     }
2183 :    
2184 :     sub peg_url {
2185 :     my($cgi,$peg) = @_;
2186 :    
2187 :     my $prot = $cgi->param('prot');
2188 :     $cgi->delete('prot');
2189 :     my $url = $cgi->self_url() . "&prot=$peg&compare_region=1";
2190 :     $cgi->delete('prot');
2191 :     $cgi->param(-name => 'prot', -value => $prot);
2192 :    
2193 :     return $url;
2194 : parrello 1.60 }
2195 : overbeek 1.2
2196 :     sub possible_extensions {
2197 :     my($peg,$closest_pegs) = @_;
2198 :     my($g,$sim,$id2,$peg1,%poss);
2199 :    
2200 : overbeek 1.53 $g = &genome_of($peg);
2201 : overbeek 1.2
2202 : parrello 1.60 foreach $peg1 (@$closest_pegs) {
2203 :     if ($g ne &genome_of($peg1)) {
2204 :     foreach $sim (&sims($fig_or_sprout,$peg1,500,1.0e-5,"all")) {
2205 :     $id2 = $sim->id2;
2206 :     if (($id2 ne $peg) && ($id2 =~ /^fig\|$g\./) && &possibly_truncated($fig_or_sprout,$id2)) {
2207 :     $poss{$id2} = 1;
2208 :     }
2209 :     }
2210 :     }
2211 : overbeek 1.2 }
2212 :     return keys(%poss);
2213 : efrank 1.1 }
2214 : overbeek 1.53
2215 :     sub display_page {
2216 :     my($fig_or_sprout,$cgi,$html) = @_;
2217 :    
2218 : parrello 1.60 if (ref($html) eq "ARRAY") {
2219 :     if ($traceData) {
2220 :     push @$html, QTrace('html');
2221 :     }
2222 :     &HTML::show_page($cgi,$html);
2223 :     } else {
2224 :     Trace(Dumper($html)) if T(2);
2225 :     if ($cgi->param('SPROUT')) {
2226 :     if ($traceData) {
2227 :     $html->{tracings} = "<h3>Trace Messages</h3>\n" . QTrace('html');
2228 :     } else {
2229 :     $html->{tracings} = "\n";
2230 :     }
2231 :     print "Content-Type: text/html\n";
2232 :     print "\n";
2233 :     my $templ = "$FIG_Config::fig/CGI/Html/Protein_tmpl.html";
2234 : overbeek 1.63 print PageBuilder::Build(">$templ", $html,"Html");
2235 : parrello 1.60 } else {
2236 :     my $gathered = [];
2237 :    
2238 :     my $section;
2239 :     foreach $section (qw( javascript
2240 :     general
2241 :     translate_status
2242 :     contig_context
2243 :     context_graphic
2244 :     subsys_connections
2245 : overbeek 1.68 assign_for_equiv_prots
2246 : parrello 1.60 links
2247 :     services
2248 :     kv_pairs
2249 :     compare_region
2250 :     similarities
2251 :     tools
2252 :     ) ) {
2253 :     if (@{$html->{$section}} > 0) {
2254 :     push(@$gathered,@{$html->{$section}});
2255 :     push(@$gathered,$cgi->hr);
2256 :     }
2257 :     }
2258 :     pop @$gathered;
2259 :     &HTML::show_page($cgi,$gathered);
2260 :     }
2261 : overbeek 1.53 }
2262 :     }
2263 :    
2264 :     sub show_html_followed_by_initial {
2265 :     my($fig_or_sprout,$cgi,$html,$prot) = @_;
2266 :    
2267 :     my %html = ( general => [],
2268 :     contig_context => [],
2269 :     context_graphic => [],
2270 :     subsys_connections => [],
2271 :     links => [],
2272 :     services => [],
2273 :     translate_status => [],
2274 :     tools => [],
2275 :     kv_pairs => [],
2276 :     similarities => [],
2277 : overbeek 1.68 assign_for_equiv_prots => [],
2278 : overbeek 1.53 javascript => [],
2279 :     compare_region => []
2280 :     );
2281 :    
2282 :     push(@{$html{general}},@$html);
2283 :     $html = \%html;
2284 : parrello 1.60 &show_initial($fig_or_sprout,$cgi,$html,$prot);
2285 : overbeek 1.53 return $html;
2286 :     }
2287 :    
2288 :     sub translation_piece {
2289 :     my($fig_or_sprout,$cgi,$html) = @_;
2290 :    
2291 :     my $msg;
2292 :     my $url = $cgi->self_url();
2293 :     if ($cgi->param('translate')) {
2294 : parrello 1.60 $url =~ s/[;&]translate(=[^;&])?//i or $url =~ s/translate(=[^;&])?[;&]//i;
2295 :     $msg = "Turn Off Function Translation";
2296 :     } else {
2297 :     $url .= ";translate=1";
2298 :     $msg = "Translate Function Assignments";
2299 : overbeek 1.53 }
2300 :     push(@$html, "<a href=\"$url\">$msg</a><br>\n");
2301 :     }
2302 :    
2303 :    
2304 :     #######################################################################################
2305 :    
2306 :     sub by_alias {
2307 :     my($fig_or_sprout,$prot) = @_;
2308 :     return $fig_or_sprout->by_alias($prot);
2309 :     }
2310 :    
2311 :     sub org_of {
2312 :     my($fig_or_sprout,$prot) = @_;
2313 :    
2314 :     return $fig_or_sprout->org_of($prot);
2315 :     }
2316 :    
2317 :     sub is_real_feature {
2318 :     my($fig_or_sprout,$prot) = @_;
2319 :    
2320 :     return $fig_or_sprout->is_real_feature($prot);
2321 :     }
2322 :    
2323 :     sub coupling_and_evidence {
2324 :     my($fig_or_sprout,$peg,$bound,$sim_cutoff,$coupling_cutoff) = @_;
2325 :    
2326 :     return $fig_or_sprout->coupling_and_evidence($peg,$bound,$sim_cutoff,$coupling_cutoff,"keep");
2327 :     }
2328 :    
2329 :     sub feature_locationS {
2330 :     my($fig_or_sprout,$peg) = @_;
2331 :    
2332 :     return scalar $fig_or_sprout->feature_location($peg);
2333 :     }
2334 :    
2335 :     sub boundaries_of {
2336 :     my($fig_or_sprout,$loc) = @_;
2337 :    
2338 :     return $fig_or_sprout->boundaries_of($loc);
2339 :     }
2340 :    
2341 :    
2342 :     sub in_cluster_with {
2343 :     my($fig_or_sprout,$peg) = @_;
2344 :    
2345 :     return $fig_or_sprout->in_cluster_with($peg);
2346 :     }
2347 :    
2348 :     sub neighborhood_of_role {
2349 :     my($fig_or_sprout,$role) = @_;
2350 :    
2351 :     return $fig_or_sprout->neighborhood_of_role($role);
2352 :     }
2353 :    
2354 :     sub feature_aliasesL {
2355 :     my($fig_or_sprout,$fid) = @_;
2356 :    
2357 :     my @tmp = $fig_or_sprout->feature_aliases($fid);
2358 :     return @tmp;
2359 :     }
2360 :    
2361 :     sub feature_aliasesS {
2362 :     my($fig_or_sprout,$fid) = @_;
2363 :    
2364 :     return scalar $fig_or_sprout->feature_aliases($fid);
2365 :     }
2366 :    
2367 :     sub function_ofL {
2368 :     my($fig_or_sprout,$peg) = @_;
2369 :    
2370 :     my @tmp = $fig_or_sprout->function_of($peg);
2371 :     return @tmp;
2372 :     }
2373 :    
2374 :     sub function_ofS {
2375 : overbeek 1.68 my($fig_or_sprout,$peg,$user) = @_;
2376 : overbeek 1.53
2377 : overbeek 1.68 return scalar $fig_or_sprout->function_of($peg,$user);
2378 : overbeek 1.53 }
2379 :    
2380 :     sub mapped_prot_ids {
2381 : overbeek 1.68 my($fig_or_sprout,$cgi,$peg) = @_;
2382 : overbeek 1.53
2383 : overbeek 1.68 if ($cgi->param('SPROUT'))
2384 :     {
2385 :     return map { [$_,0] } grep { $_ =~ /^(([NXYZA]P_[0-9\.]+)|(gi\|\d+)|(kegg\|\S+)|(uni\|[A-Z0-9]{6})|(sp\|[A-Z0-9]{6}))$/ } &feature_aliasesL($fig_or_sprout,$peg);
2386 :     }
2387 :     else
2388 :     {
2389 :     return $fig_or_sprout->mapped_prot_ids($peg);
2390 :     }
2391 : overbeek 1.53 }
2392 :    
2393 :     sub peg_links {
2394 :     my($fig_or_sprout,$peg) = @_;
2395 :    
2396 :     return $fig_or_sprout->peg_links($peg);
2397 :     }
2398 :    
2399 :     sub get_translation {
2400 :     my($fig_or_sprout,$prot) = @_;
2401 :    
2402 :     return $fig_or_sprout->get_translation($prot);
2403 :     }
2404 :    
2405 :     sub assign_function {
2406 :     my($fig_or_sprout,$prot,$who,$function) = @_;
2407 :    
2408 :     $fig_or_sprout->assign_function($prot,$who,$function,"");
2409 :     }
2410 :    
2411 :     sub add_annotation {
2412 : overbeek 1.68 my($fig_or_sprout,$cgi,$prot,$user,$annotation) = @_;
2413 : overbeek 1.53
2414 : overbeek 1.68 if ((! $cgi->param('SPROUT')) || ($annotation !~ /Set function/))
2415 :     {
2416 :     $fig_or_sprout->add_annotation($prot,$user,$annotation);
2417 :     }
2418 : overbeek 1.53 }
2419 :    
2420 :     sub feature_annotations {
2421 : overbeek 1.68 my($fig_or_sprout,$cgi,$prot) = @_;
2422 :     if ($cgi->param('SPROUT'))
2423 :     {
2424 : overbeek 1.69 return $fig_or_sprout->feature_annotations($prot);
2425 : overbeek 1.68 }
2426 : overbeek 1.53 return $fig_or_sprout->feature_annotations($prot);
2427 :     }
2428 :    
2429 :     sub related_by_func_sim {
2430 : overbeek 1.68 my($fig_or_sprout,$cgi,$peg,$user) = @_;
2431 : overbeek 1.53
2432 : overbeek 1.68 if ($cgi->param('SPROUT'))
2433 :     {
2434 :     return map { $_->[0] } sort { $a->[1] <=> $b->[1] } $fig_or_sprout->bbhs($peg, 1.0e-10, 0);
2435 :     }
2436 : overbeek 1.53 return $fig_or_sprout->related_by_func_sim($peg,$user);
2437 :     }
2438 :    
2439 :     sub merged_related_annotations {
2440 :     my($fig_or_sprout,$related) = @_;
2441 :    
2442 :     return $fig_or_sprout->merged_related_annotations($related);
2443 :     }
2444 :    
2445 :     sub genus_species {
2446 :     my($fig_or_sprout,$genome) = @_;
2447 :    
2448 :     return $fig_or_sprout->genus_species($genome);
2449 :     }
2450 :    
2451 :     sub genes_in_region {
2452 : overbeek 1.81 my($fig_or_sprout,$cgi,$genome,$contig,$min,$max) = @_;
2453 : overbeek 1.53
2454 : overbeek 1.81 if ($cgi->param('SPROUT'))
2455 :     {
2456 :     my($x,$feature_id);
2457 :     my($feat,$min,$max) = $fig_or_sprout->genes_in_region($genome,$contig,$min,$max);
2458 :     my @tmp = sort { ($a->[1] cmp $b->[1]) or
2459 :     (($a->[2]+$a->[3]) <=> ($b->[2]+$b->[3]))
2460 :     }
2461 :     map { $feature_id = $_;
2462 :     $x = &feature_locationS($fig_or_sprout,$feature_id);
2463 :     $x ? [$feature_id,&boundaries_of($fig_or_sprout,$x)] : ()
2464 :     }
2465 :     @$feat;
2466 :     return ([map { $_->[0] } @tmp],$min,$max);
2467 :     }
2468 :     else
2469 :     {
2470 :     return $fig_or_sprout->genes_in_region($genome,$contig,$min,$max);
2471 :     }
2472 : overbeek 1.53 }
2473 :    
2474 :     sub translate_function {
2475 :     my($fig_or_sprout,$func) = @_;
2476 :    
2477 :     return $fig_or_sprout->translate_function($func);
2478 :     }
2479 :    
2480 :     sub feature_attributes {
2481 :     my($fig_or_sprout,$peg) = @_;
2482 :    
2483 :     return $fig_or_sprout->feature_attributes($peg);
2484 :     }
2485 :    
2486 :     sub subsystems_for_peg {
2487 :     my($fig_or_sprout,$peg) = @_;
2488 :    
2489 :     return $fig_or_sprout->subsystems_for_peg($peg);
2490 :     }
2491 :    
2492 :     sub sims {
2493 : overbeek 1.90 my($fig_or_sprout,$peg,$max,$cutoff,$select,$expand,$group_by_genome) = @_;
2494 :     my(@tmp,$id,$genome,@genomes,%sims,$sim);
2495 :    
2496 :     @tmp = $fig_or_sprout->sims($peg,$max,$cutoff,$select,$expand);
2497 :     if (! $group_by_genome) { return @tmp };
2498 : overbeek 1.53
2499 : overbeek 1.90 foreach $sim (@tmp)
2500 :     {
2501 :     $id = $sim->id2;
2502 :     if ($id =~ /^fig\|(\d+\.\d+)\.peg\.\d+/)
2503 :     {
2504 :     $genome = $1;
2505 :     }
2506 :     else
2507 :     {
2508 :     $genome = $id;
2509 :     }
2510 :     if (! defined($sims{$genome}))
2511 :     {
2512 :     push(@genomes,$genome);
2513 :     }
2514 :     push(@{$sims{$genome}},$sim);
2515 :     }
2516 :     return map { @{$sims{$_}} } @genomes;
2517 : overbeek 1.53 }
2518 :    
2519 :     sub in_family {
2520 :     my($fig_or_sprout,$id) = @_;
2521 :    
2522 :     return $fig_or_sprout->in_family($id);
2523 :     }
2524 :    
2525 :     sub sz_family {
2526 :     my($fig_or_sprout,$family) = @_;
2527 :    
2528 :     return $fig_or_sprout->sz_family($family);
2529 :     }
2530 :    
2531 :     sub peg_to_subsystems {
2532 :     my($fig_or_sprout,$id) = @_;
2533 :    
2534 :     return $fig_or_sprout->peg_to_subsystems($id);
2535 :     }
2536 :    
2537 :     sub org_and_color_of {
2538 :     my($fig_or_sprout,$id) = @_;
2539 :    
2540 :     return $fig_or_sprout->org_and_color_of($id);
2541 :     }
2542 :    
2543 :     sub ec_to_maps {
2544 :     my($fig_or_sprout,$ec) = @_;
2545 :    
2546 :     return $fig_or_sprout->ec_to_maps($ec);
2547 :     }
2548 :    
2549 :     sub map_name {
2550 :     my($fig_or_sprout,$map) = @_;
2551 :    
2552 :     return $fig_or_sprout->map_name($map);
2553 :     }
2554 :    
2555 :     sub ec_name {
2556 :     my($fig_or_sprout,$ec) = @_;
2557 : parrello 1.60
2558 : overbeek 1.53 return $fig_or_sprout->ec_name($ec);
2559 :     }
2560 :    
2561 :     sub dna_seq {
2562 :     my($fig_or_sprout,$genome,$loc) = @_;
2563 :    
2564 :     return $fig_or_sprout->dna_seq($genome,$loc);
2565 :     }
2566 :    
2567 :     sub possibly_truncated {
2568 :     my($fig_or_sprout,$id) = @_;
2569 :    
2570 :     return $fig_or_sprout->possibly_truncated($id);
2571 :     }
2572 :    
2573 :     sub sort_fids_by_taxonomy {
2574 :     my($fig_or_sprout,@fids) = @_;
2575 :    
2576 :     return $fig_or_sprout->sort_fids_by_taxonomy(@fids);
2577 :     }
2578 :    
2579 :     sub in_pch_pin_with {
2580 :     my($fig_or_sprout,$peg) = @_;
2581 :    
2582 :     return $fig_or_sprout->in_pch_pin_with($peg);
2583 :     }
2584 :    
2585 :     sub crude_estimate_of_distance {
2586 :     my($fig_or_sprout,$genome1,$genome2) = @_;
2587 :    
2588 :     return $fig_or_sprout->crude_estimate_of_distance($genome1,$genome2);
2589 :     }
2590 :    
2591 :     sub maps_to_id {
2592 :     my($fig_or_sprout,$peg) = @_;
2593 :    
2594 :     return $fig_or_sprout->maps_to_id($peg);
2595 :     }
2596 :    
2597 :     sub translatable {
2598 :     my($fig_or_sprout,$peg) = @_;
2599 :    
2600 :     return $fig_or_sprout->translatable($peg);
2601 :     }
2602 :    
2603 :     sub cgi_url {
2604 :     return &FIG::plug_url($FIG_Config::cgi_url);
2605 :     }
2606 :    
2607 :    
2608 :    
2609 :     ###########################################################
2610 :    
2611 :     sub genome_of {
2612 : parrello 1.60 my $prot_id = (@_ == 1) ? $_[0] : $_[1];
2613 : overbeek 1.53
2614 :     if ($prot_id =~ /^fig\|(\d+\.\d+)/) { return $1; }
2615 :     return undef;
2616 :     }
2617 :    
2618 :     sub min {
2619 :     my(@x) = @_;
2620 :     my($min,$i);
2621 :    
2622 :     (@x > 0) || return undef;
2623 :     $min = $x[0];
2624 : parrello 1.60 for ($i=1; ($i < @x); $i++) {
2625 :     $min = ($min > $x[$i]) ? $x[$i] : $min;
2626 : overbeek 1.53 }
2627 :     return $min;
2628 :     }
2629 :    
2630 :     sub max {
2631 :     my(@x) = @_;
2632 :     my($max,$i);
2633 :    
2634 :     (@x > 0) || return undef;
2635 :     $max = $x[0];
2636 : parrello 1.60 for ($i=1; ($i < @x); $i++) {
2637 :     $max = ($max < $x[$i]) ? $x[$i] : $max;
2638 : overbeek 1.53 }
2639 :     return $max;
2640 :     }
2641 :    
2642 :    
2643 :     sub roles_of_function {
2644 : parrello 1.60 my $func = (@_ == 1) ? $_[0] : $_[1];
2645 : overbeek 1.53
2646 :     return (split(/\s*[\/;]\s+/,$func),($func =~ /\d+\.\d+\.\d+\.\d+/g));
2647 :     }
2648 :    
2649 :     sub ftype {
2650 :     my($feature_id) = @_;
2651 :    
2652 : parrello 1.60 if ($feature_id =~ /^fig\|\d+\.\d+\.([^\.]+)/) {
2653 :     return $1;
2654 : overbeek 1.53 }
2655 :     return undef;
2656 :     }
2657 :    
2658 :     sub abbrev {
2659 :     my($genome_name) = @_;
2660 :    
2661 : overbeek 1.55 return &FIG::abbrev($genome_name);
2662 : overbeek 1.63 }

MCS Webmaster
ViewVC Help
Powered by ViewVC 1.0.3