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

Annotation of /FigWebServices/protein.cgi

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.113 - (view) (download)

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

MCS Webmaster
ViewVC Help
Powered by ViewVC 1.0.3