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

Diff of /FigWebServices/protein.cgi

Parent Directory Parent Directory | Revision Log Revision Log | View Patch Patch

revision 1.217, Tue Jul 25 19:22:57 2006 UTC revision 1.218, Tue Jul 25 19:58:08 2006 UTC
# Line 16  Line 16 
16  # http://www.theseed.org/LICENSE.TXT.  # http://www.theseed.org/LICENSE.TXT.
17  #  #
18    
 use InterfaceRoutines;  
   
 use FIG;  
   
19  my $sproutAvail = eval {  my $sproutAvail = eval {
20      require SproutFIG;      require SproutFIG;
21      require PageBuilder;      require PageBuilder;
22  };  };
23    
24  #if (!$sproutAvail) {  use warnings;
 #    warn "Sprout library not available: $@\n";  
 #}  
   
 use FIGGenDB;  
 use FIGjs;  
   
 use URI::Escape;  # uri_escape  
 use HTML;  
 use Data::Dumper;  
   
25  use strict;  use strict;
 use GenoGraphics;  
 use CGI;  
 use Tracer;  
 use BasicLocation;  
   
 my $cgi = new CGI;  
   
 use Carp 'cluck';  
 my $traceData = $cgi->param('trace');  
 if ($traceData) {  
     warn "Trace parameter is $traceData.";  
     TSetup($traceData, "WARN");  
     $traceData = 1;  
 } else {  
     TSetup(0, "NONE");  
     $traceData = 0;  
 }  
   
 if (0) {  
     my $VAR1;  
     eval(join("",`cat /tmp/protein_parms`));  
     $cgi = $VAR1;  
 #   print STDERR &Dumper($cgi);  
 }  
   
 if (0) {  
     print $cgi->header;  
     my @params = $cgi->param;  
     print "<pre>\n";  
     foreach $_ (@params) {  
         print "$_\t:",join(",",$cgi->param($_)),":\n";  
     }  
   
     if (0) {  
         if (open(TMP,">/tmp/protein_parms")) {  
             print TMP &Dumper($cgi);  
             close(TMP);  
         }  
     }  
     exit;  
 }  
   
 if ($cgi->param('new_framework'))  
 {  
     $ENV{'METHOD'} = 'GET';  
 #    $ENV{'QUERY_STRING'} = join("&","new_framework=1",  
 #                   map { my $k = $_; my $v = $cgi->param($k); "$k=$v" } $cgi->@param);  
     $ENV{'QUERY_STRING'} .= "&new_framwork=1";  
     my @out = `./frame.cgi`;  
     print @out;  
     exit;  
 }  
   
   
 my($fig_or_sprout);  
   
 my $is_sprout;  
   
 my $html = [];  
   
 if ($cgi->param('SPROUT')) {  
     $is_sprout = 1;  
     $fig_or_sprout = new SproutFIG($FIG_Config::sproutDB, $FIG_Config::sproutData);  
     unshift @$html, "<TITLE>The NMPDR Protein Page</TITLE>\n";  
 } else {  
     $is_sprout = 0;  
     $fig_or_sprout = new FIG;  
     unshift @$html, "<TITLE>The SEED Protein Page</TITLE>\n";  
 }  
   
 # The request param tells us which template to use, but some subroutines modify  
 # its value. As a result, we need to save it in a global for later use.  
 my $Global_request_type = $cgi->param('request');  
 if (! defined($Global_request_type)) { $Global_request_type = ""; }  
   
 my $prot = $cgi->param('prot');  
 if (! $prot) {  
     unshift @$html, "<TITLE>The SEED: Protein Page</TITLE>\n";  
     push(@$html,"<h1>Sorry, you need to specify a protein</h1>\n");  
     &display_page($fig_or_sprout,$cgi,$html);  
     exit;  
 }  
   
 if ($prot !~ /^fig\|/) {  
     my @poss = &by_alias($fig_or_sprout,$prot);  
   
     if (@poss > 0) {  
         $prot = $poss[0];  
     } else {  
         unshift @$html, "<TITLE>The SEED: Protein Page</TITLE>\n";  
         push(@$html,"<h1>Sorry, $prot appears not to have a FIG id at this point</h1>\n");  
         &display_page($fig_or_sprout,$cgi,$html);  
         exit;  
     }  
 }  
   
   
 #  
 #  Allow previous and next actions in calls to the script -- GJO  
 #  
   
 my $adjust = $cgi->param('previous PEG') ? -1 : $cgi->param('next PEG') ? 1 : 0;  
 if ( $adjust ) {  
     my ( $prefix, $protnum ) = $prot =~ /^(.*\.)(\d+)$/;  
     if ( $prefix && $protnum ) {  
         my $prot2 = $prefix . ($protnum + $adjust);  
         if ( &translatable($fig_or_sprout, $prot2 ) ) {  
             $prot = $prot2;  
             $cgi->delete('prot');  
             $cgi->param(-name => 'prot', -value => $prot);  
         }  
     }  
     ( $adjust < 0 ) && $cgi->delete('previous PEG');  
     ( $adjust > 0 ) && $cgi->delete('next PEG');  
 }  
   
 my $request = $cgi->param("request") || "";  
 #my $compute_ok = eval {  
   
   
         if    ($request eq "use_protein_tool")       { &use_protein_tool($fig_or_sprout,$cgi,$html,$prot); }  
     elsif ($request eq "view_annotations")       { &view_annotations($fig_or_sprout,$cgi,$html,$prot); }  
     elsif ($request eq "view_all_annotations")   { &view_all_annotations($fig_or_sprout,$cgi,$html,$prot); }  
     elsif ($request eq "aa_sequence")            { &aa_sequence($fig_or_sprout,$cgi,$html,$prot);  }  
     elsif ($request eq "dna_sequence")           { &dna_sequence($fig_or_sprout,$cgi,$html,$prot); }  
     elsif ($request eq "dna_sequence_adjacent")  { &dna_sequence_adjacent($fig_or_sprout,$cgi,$html,$prot); }  
     elsif ($request eq "fast_assign")            { $html = &make_assignment($fig_or_sprout,$cgi,$html,$prot); }  
     elsif ($request eq "show_coupling_evidence") { &show_coupling_evidence($fig_or_sprout,$cgi,$html,$prot); }  
     elsif ($request eq "abstract_coupling")      { &show_abstract_coupling_evidence($fig_or_sprout,$cgi,$html,$prot); }  
     elsif ($request eq "ec_to_maps")             { &show_ec_to_maps($fig_or_sprout,$cgi,$html); }  
     elsif ($request eq "link_to_map")            { &link_to_map($fig_or_sprout,$cgi,$html); }  
     elsif ($request eq "fusions")                { &show_fusions($fig_or_sprout,$cgi,$html,$prot); }  
     else {  
         $html = &show_html_followed_by_initial($fig_or_sprout,$cgi,$html,$prot);  
     }  
   
         if ($cgi->param('SPROUT') && (ref($html) eq "ARRAY"))  
         {  
             $_ = {};  
         $_->{kv_pairs} = $html;  
         $html = $_;  
     }  
 #};  
   
 #if (!$compute_ok) {  
 #    Trace($@);  
 #}  
   
 &display_page($fig_or_sprout,$cgi,$html);  
 exit;  
   
 #==============================================================================  
 #  flat_array  
 #==============================================================================  
 sub flat_array {  
   
     my @kv_pairs = @_;  
     my @return_args=();  
     my @args;  
   
     foreach my $x (@kv_pairs)  
     {  
         #cannot be a nested array to be passed in to gather  
   
         my @args = ($x->[0], $x->[1]);  
         push(@return_args, "$x->[0]\t$x->[1]");  
     }  
   
     return @return_args;  
 }  
   
   
 #==============================================================================  
 #  use_protein_tool  
 #==============================================================================  
   
 sub use_protein_tool {  
     my($fig_or_sprout,$cgi,$html,$prot) = @_;  
     my($url,$method,@args,$line,$name,$val);  
   
     my $seq = &get_translation($fig_or_sprout,$prot);  
     if (! $seq) {  
         unshift @$html, "<TITLE>The SEED: Protein Page</TITLE>\n";  
         push(@$html,$cgi->h1("Sorry, $prot does not have a translation"));  
         return;  
     }  
     my $protQ = quotemeta $prot;  
   
     my $tool = $cgi->param('tool');  
     $/ = "\n//\n";  
     my @tools = grep { $_ =~ /^$tool\n/ } `cat $FIG_Config::global/LinksToTools`;  
     if (@tools == 1) {  
         chomp $tools[0];  
         (undef,undef,$url,$method,@args) = split(/\n/,$tools[0]);  
         my $args = [];  
                 foreach $line (@args)  
                 {  
                     print "the line is $line<p>";  
                     next if ($line =~ /^\#/); # ignore comments  
                     ($name,$val) = split(/\t/,$line);  
                     $val =~ s/FIGID/$prot/;  
                     $val =~ s/FIGSEQ/$seq/;  
                     $val =~ s/\\n/\n/g;  
                     push(@$args,[$name,$val]);  
                 }  
   
         my @result;  
   
         if ($method =~/internal/i)  
                 {  
                     my $pegid;  
                     #If method is internal, then the url is actually a  perl script  
                     my $script = $url;  
                     $script=~ s/\.pl//g;  
   
                     my @script_array = &flat_array(@$args);  
                     my $out = &FIG::run_gathering_output("$FIG_Config::bin/$script", @script_array);  
             @result = split(/[\012\015]+/,$out);  
   
                 }  
                 else  
                 {  
                     @result = &HTML::get_html($url,$method,$args);  
                 }  
   
                 # some pages are setting the base  
                 #@result = grep {$_ !~ /base href/} @result;  
   
                 # and some pages have the audactiy to add <head> and <body tags>  
                 # first remove them by regexp:  
                 map {$_ =~ s/^.*<\/head>//i; $_ =~ s/^.*<body>//i} @result;  
                 map {$_ =~ s/<\/body>.*$//i; $_ =~ s/<\/html>.*$//i} @result;  
   
                 # now try looping through  
                 my $splice=0; my $splast=0;  
                 foreach my $i (0..$#result)  
                 {  
                     if ($result[$i] =~ /<body>/i || $result[$i] =~ /<\/head>/i) {$splice=$i}  
                     if ($result[$i] =~ /<\/body>/i) {$splast=$i}  
                 }  
                 if ($splast) {splice(@result, -$splast)}  
                 if ($splice) {splice(@result, 0, $splice)}  
   
   
   
   
                 #  
                 # The extra form in the Sprout header causes some problems with javascript-containing  
                 # pages. So if we're in sprout, and there's javascript in the page, just show the  
         # output and exit.  
         #  
   
         if ($is_sprout)  
         {  
             for my $rl (@result)  
             {  
             if ($rl =~ /javascript/i)  
             {  
                 print $cgi->header;  
                 print join("", @result);  
                 exit 0;  
             }  
             }  
         }  
   
                 push(@$html, @result);  
         }  
 }  
   
 #==============================================================================  
 #  make_assignment  
 #==============================================================================  
   
 sub make_assignment {  
     my($fig_or_sprout,$cgi,$html,$prot) = @_;  
     my($userR);  
   
     my $function = $cgi->param('func');  
     my $user     = $cgi->param('user');  
   
     if ($function && $user && $prot) {  
         if ($user =~ /master:(.*)/) {  
             $userR = $1;  
             &assign_function($fig_or_sprout,$prot,"master",$function,"");  
             &add_annotation($fig_or_sprout,$cgi,$prot,$userR,"Set master function to\n$function\n");  
         } else {  
         &assign_function($fig_or_sprout,$prot,$user,$function,"");  
         &add_annotation($fig_or_sprout,$cgi,$prot,$user,"Set function to\n$function\n");  
     }  
     }  
     $cgi->delete("request");  
     $cgi->delete("func");  
     $html = &show_html_followed_by_initial($fig_or_sprout,$cgi,$html,$prot);  
     return $html;  
 }  
   
 #==============================================================================  
 #  view_annotations  
 #==============================================================================  
   
 sub view_annotations {  
     my($fig_or_sprout,$cgi,$html,$prot) = @_;  
   
     unshift @$html, "<TITLE>The SEED: Protein Annotations</TITLE>\n";  
     my $col_hdrs = ["who","when","annotation"];  
   
     my $tab = [ map { [$_->[2],$_->[1],"<pre>" . $_->[3] . "<\/pre>"] } &feature_annotations($fig_or_sprout,$cgi,$prot) ];  
     if (@$tab > 0) {  
         push(@$html,&HTML::make_table($col_hdrs,$tab,"Annotations for $prot"));  
     } else {  
         push(@$html,"<h1>No Annotations for $prot</h1>\n");  
     }  
 }  
   
 sub view_all_annotations {  
     my($fig_or_sprout,$cgi,$html,$peg) = @_;  
     my($ann);  
   
     unshift @$html, "<TITLE>The SEED: Protein Annotations</TITLE>\n";  
     if (&is_real_feature($fig_or_sprout,$peg)) {  
         my $col_hdrs = ["who","when","PEG","genome","annotation"];  
         my @related  = &related_by_func_sim($fig_or_sprout,$cgi,$peg,$cgi->param('user'));  
         push(@related,$peg);  
   
         my @annotations = &merged_related_annotations($fig_or_sprout,\@related);  
   
         my $tab = [ map { $ann = $_;  
                   [$ann->[2],$ann->[1],&HTML::fid_link($cgi,$ann->[0]),  
                    &genus_species($fig_or_sprout,&genome_of($ann->[0])),  
                    "<pre>" . $ann->[3] . "</pre>"  
                    ] } @annotations];  
         if (@$tab > 0) {  
             push(@$html,&HTML::make_table($col_hdrs,$tab,"All Related Annotations for $peg"));  
         } else {  
             push(@$html,"<h1>No Annotations for $peg</h1>\n");  
         }  
     }  
 }  
   
 #==============================================================================  
 #  show_coupling_evidence  
 #==============================================================================  
   
 sub show_abstract_coupling_evidence {  
     my($fig_or_sprout,$cgi,$html,$prot) = @_;  
   
     my @coupling = $fig_or_sprout->abstract_coupled_to($prot);  
     if (@coupling > 0)  
     {  
     push(@$html,&HTML::abstract_coupling_table($cgi,$prot,\@coupling));  
     }  
     else  
     {  
     push(@$html,$cgi->h1("sorry, no abstract coupling data for $prot"));  
     }  
 }  
   
 sub show_coupling_evidence {  
     my($fig_or_sprout,$cgi,$html,$peg) = @_;  
     my($pair,$peg1,$peg2,$link1,$link2);  
   
     unshift @$html, "<TITLE>The SEED: Functional Coupling</TITLE>\n";  
     my $user = $cgi->param('user');  
     my $to   = $cgi->param('to');  
     my @coup = grep { $_->[1] eq $to } &coupling_and_evidence($fig_or_sprout,$peg,5000,1.0e-10,4,1);  
   
     if (@coup != 1) {  
         push(@$html,"<h1>Sorry, no evidence that $peg is coupled to $to</h1>\n");  
     } else {  
         my $col_hdrs = ["Peg1","Function1","Peg2","Function2","Organism"];  
         my $tab = [];  
         foreach $pair (@{$coup[0]->[2]}) {  
             ($peg1,$peg2) = @$pair;  
             $link1 = &HTML::fid_link($cgi,$peg1);  
             $link2 = &HTML::fid_link($cgi,$peg2);  
             push( @$tab, [ $link1,  
                        scalar &function_ofS($fig_or_sprout,$peg1,$user),  
                    $link2,  
                    scalar &function_ofS($fig_or_sprout,$peg2,$user),  
                    &org_of($fig_or_sprout,$peg1)  
                          ]  
             );  
         }  
         push(@$html,&HTML::make_table($col_hdrs,$tab,"Evidence that $peg Is Coupled To $to"));  
     }  
 }  
   
 #==============================================================================  
 #  psi_blast_prot_sequence  
 #==============================================================================  
   
 sub psi_blast_prot_sequence {  
     my($fig_or_sprout,$cgi,$prot_id) = @_;  
 }  
   
 #==============================================================================  
 #  show_initial  
 #==============================================================================  
   
 sub show_initial {  
     my($fig_or_sprout,$cgi,$html,$prot) = @_;  
   
     unshift @{$html->{general}}, "<TITLE>The SEED: Protein Page</TITLE>\n";  
   
     my $gs = &org_of($fig_or_sprout,$prot);  
     Trace("got gs=$gs prot=$prot $fig_or_sprout\n") if T(2);  
     if ($prot =~ /^fig\|\d+\.\d+\.peg/) {  
         if (! &is_real_feature($fig_or_sprout,$prot)) {  
             push(@{$html->{general}},"<h1>Sorry, $prot is an unknown identifier</h1>\n");  
         } else {  
             push(@{$html->{general}},"<h1>Protein $prot: $gs</h1>\n");  
   
         # caBIG insists on explicitly displaying the taxon ID rather  
         # than learning how to read the figID, so display it.  
         # ...please don't delete this without consulting with Ed  
   
         my $taxon;  
         if ($prot =~ /^fig\|(\d+)\.(\d+)/) {  
         push(@{$html->{general}},"<h2>Taxon=$1 (NCBI TaxonId, if one exists)</h2>\n");  
         }  
   
             &translation_piece($fig_or_sprout,$cgi,$html->{translate_status});  
             &display_peg($fig_or_sprout,$cgi,$html,$prot);  
         }  
     } else {  
         #   &display_external($fig_or_sprout,$cgi,$html,$prot);  
     }  
 }  
   
 #==============================================================================  
 #  display_peg  
 #==============================================================================  
   
 sub display_peg {  
     my($fig_or_sprout,$cgi,$html,$peg) = @_;  
     my $loc;  
   
     my $user = $cgi->param('user');  
     my $org     = &genome_of($peg);  
     my $domain  = &genome_domain($fig_or_sprout,$org);  
   
     #...set default minimum size for euk or non-euk display region...  
     my $half_sz = ($domain =~ m/^euk/i) ? 50000 : 5000;  
   
     my $fc = $cgi->param('fc');  
     my @fc_data;  
     if ($fc) {  
         # RAE Added the following lines so that you can define this in the URL  
         # but the default behavior remains unchanged. I doubt anyone will ever  
         # see this, but I use it sometimes to see what happens  
         my ($bound,$sim_cutoff,$coupling_cutoff)=(5000, 1.0e-10, 4);  
         if ($cgi->param('fcbound')) {$bound=$cgi->param('fcbound')}  
         if ($cgi->param('fcsim')) {$sim_cutoff=$cgi->param('fcsim')}  
         if ($cgi->param('fccoup')) {$coupling_cutoff=$cgi->param('fccoup')}  
   
         @fc_data = &coupling_and_evidence($fig_or_sprout,$peg,$bound,$sim_cutoff,$coupling_cutoff,1);  
     } else {  
         @fc_data = ();  
     }  
   
     if ($loc = &feature_locationS($fig_or_sprout,$peg)) {  
     if ($loc =~ /^(\d+\.\d+:(\S+)) \2$/)  
     {  
         #  
         # REMOVE ME.  
         #  
         #  Patch a sprout bug that returns spurious gunk in feature locations.  
         #  
   
         $loc = $1;  
     }  
   
         my($contig,$beg,$end) = &boundaries_of($fig_or_sprout,$loc);  
   
     my $len  = abs($end-$beg) + 1;  
     if ($len > $half_sz)  
     {  
         $half_sz = $len;  
     }  
     else  
     {  
         $half_sz = $half_sz * (1 + 3*int($len/$half_sz));   #...set scale of region...  
     }  
 #   print STDERR "half_sz = $half_sz\n";  
   
         my $min  = &max(0,&min($beg,$end) - $half_sz);  
         my $max  = &max($beg,$end) + $half_sz;  
         Trace("display_peg: min=$min max=$max beg=$beg end=$end") if T(2);  
   
     my $feat;  
     ($feat,$min,$max) = &genes_in_region($fig_or_sprout,$cgi,&genome_of($peg),$contig,$min,$max);  
   
         Trace("beg=$beg end=$end New min = $min, max = $max, features = " . join(", ", @{$feat})) if T(3);  
   
         my ($beg,$end,$genes) = &print_context($fig_or_sprout,$cgi,$html->{contig_context},$peg,$feat,$min,$max);  
         Trace("Print context returned: beg=$beg, end=$end, genes = " . join(", ", @{$genes})) if T(3);  
         &print_graphics_context($beg,$end,$genes,$html->{context_graphic});  
   
         &print_assignments($fig_or_sprout,$cgi,$html->{assign_for_equiv_prots},$peg);  
         &print_kv_pairs($is_sprout, $fig_or_sprout,$cgi,$html->{kv_pairs},$peg);  
     &print_protein_fams($is_sprout, $fig_or_sprout,$cgi,$html->{kv_pairs},$peg,$user);  
         &print_subsys_connections($fig_or_sprout,$cgi,$html->{subsys_connections},$peg,$user);  
         &print_links($fig_or_sprout,$cgi,$html->{links},$peg);  
   
   
         my $has_translation = &translatable($fig_or_sprout,$peg);  
         &print_services($fig_or_sprout,$cgi,$html->{services},$peg,$has_translation,\@fc_data);  
   
         &print_sims_block($fig_or_sprout,$cgi,$html->{similarities},$peg,$user,$has_translation);  
   
         if ($has_translation) {  
             &show_tools($fig_or_sprout,$cgi,$html->{tools},$peg);  
         }  
     }  
 }  
26    
27  ################# Table-Driven Show Tools  ############################  use CGI qw(:standard);
28    use HTML::Template;
29    use Data::Dumper;
30    
31  sub show_tools {  use FIG;
32      my($fig_or_sprout,$cgi,$html,$peg) = @_;  use FIG_Config;
33    use FIG_CGI;
34    use UserData;
35    use FigWebServices::SeedComponents;
36    
37      # generate the link to turn tools on or off  eval {
38      my $toollink = $cgi->url(-relative => 1, -query => 1, -path_info => 1);      &main();
39    };
40    
41      $toollink =~ s/[\&\;]fulltools.*[^\;\&]/\&/;  if($@) {
42      my $fulltoolbutton  = $cgi->a({href=> $toollink . "&fulltools='1'"}, "> Show tool descriptions"); # define this here before we mess with ourself!      print header(),start_html();
43        print STDERR "EXCEPTION: $@\n";
44      my $brieftoolbutton = $cgi->a({href=> $toollink}, "< Hide tool descriptions");      print "EXCEPTION: $@\n",end_html();
   
     $cgi->param(-name => "request",  
         -value => "use_protein_tool");  
     my $url = $cgi->url(-relative => 1, -query => 1, -path_info => 1);  
   
     if (open(TMP,"<$FIG_Config::global/LinksToTools")) {  
         my $col_hdrs = ["Tool","Description"];  
         my $tab = [];  
   
         $/ = "\n//\n";  
     my $brieftools; # in case we don't want descriptions and whatnot  
         while (defined($_ = <TMP>)) {  
         # allow comment lines in the file  
         next if (/^#/);  
             my($tool,$desc, undef, $internal_or_not) = split(/\n/,$_);  
   
         #KSH modified - only show general tools and tools that are specific to the organism  
             my $tool_org = $peg;  
             $tool_org=~ s/fig\|//;  
             $tool_org=~ s/\.peg.*//;  
   
             next if (($tool ne 'ProDom')  
                      && ($internal_or_not eq "INTERNAL") && ($desc !=$tool_org));  
   
             # RAE modified this so we can include column headers.  
         undef($desc) if ($desc eq "//"); # it is a separator  
         # RAE modified again so that we only get a short tool list instead of the big table if that is what we want.  
         if ($cgi->param('fulltools')) {  
          if ($desc) {push(@$tab,["<a href=\"$url\&tool=$tool\">$tool</a>",$desc])}  
          else {push(@$tab, [["<strong>$tool</strong>", "td colspan=2 align=center"]])}  
         }  
         else {  
          # Why doesn't this work $brieftools .= "<span class=\"tool\" style=\"border: 0 1px solid gray\"><a href=\"$url\&tool=$tool\">$tool</a></span>";  
          if ($desc) {$brieftools .= " &nbsp; <a href=\"$url\&tool=$tool\">$tool</a> &nbsp;|"}  
         }  
         }  
         close(TMP);  
         $/ = "\n";  
     if ($brieftools) {push(@$html, $cgi->p("|" . $brieftools), $fulltoolbutton)}  
     else {push(@$html,&HTML::make_table($col_hdrs,$tab,"Tools to Analyze Protein Sequences"), $brieftoolbutton)}  
     }  
     $cgi->delete('request');  
45  }  }
46    
47  ################# Functional Coupling  ############################  1;
48    
49  sub print_fc {  sub main {
50      my($fig_or_sprout,$cgi,$html,$peg,$fc_data) = @_;      # initialize fig object
51      my($sc,$neigh);      my ($fig, $cgi, $user) = FIG_CGI::init(debug_save   => 0,
52                                               debug_load   => 0,
53                                               print_params => 0);
54    
     my $user  = $cgi->param('user');  
     my @tab   = map { ($sc,$neigh) = @$_;  
                         [&ev_link($cgi,$neigh,$sc),$neigh,scalar &function_ofS($fig_or_sprout,$neigh,$user)]  
                     } @$fc_data;  
     if (@tab > 0) {  
         push(@$html,"<hr>\n");  
         my $col_hdrs = ["Score","Peg","Function"];  
         push(@$html,&HTML::make_table($col_hdrs,\@tab,"Functional Coupling"));  
     }  
 }  
55    
56  sub ev_link {      # check if an external page is to be displayed, called with data from seed
57      my($cgi,$neigh,$sc) = @_;      if ($cgi->param('tool')) {
58    
     my $prot = $cgi->param('prot');  
     my $sprout = $cgi->param('SPROUT');  
59      my $user = $cgi->param('user');      my $user = $cgi->param('user');
     if (! defined($user)) { $user = "" }  
     my $link = $cgi->url(-relative => 1) . "?user=$user&request=show_coupling_evidence&prot=$prot&to=$neigh&SPROUT=$sprout";  
     return "<a href=$link>$sc</a>";  
 }  
   
 ################# Assignments  ############################  
   
 sub trans_function_of {  
     my($cgi,$fig_or_sprout,$peg,$user) = @_;  
   
     if (wantarray()) {  
         my $x;  
         my @funcs = &function_ofL($fig_or_sprout,$peg,$user);  
   
         if ($cgi->param('translate')) {  
             @funcs = map { $x = $_; $x->[1] = &translate_function($fig_or_sprout,$x->[1]); $x } @funcs;  
         }  
         return @funcs;  
     } else {  
         my $func = &function_ofS($fig_or_sprout,$peg,$user);  
         if ($cgi->param('translate')) {  
             $func = &translate_function($fig_or_sprout,$func);  
         }  
         return $func;  
     }  
 }  
   
 ##########################  Routines that build pieces of HTML ######################  
   
   
 sub print_sims_block {  
     my($fig_or_sprout,$cgi,$html,$peg,$user,$has_translation) = @_;  
   
     my $sims = $cgi->param('sims');  
     if ( (! $sims ) && $has_translation)  
     {  
     my $short_form = 1;  
     sims_request_form( $fig_or_sprout, $cgi, $html, $peg, $user, $short_form );  
     }  
   
     #  Added test $has_translation && (...) -- GJO  
     elsif ( $has_translation && $sims)  
     {  
         print_similarities( $fig_or_sprout, $cgi, $html, $peg );  
     }  
 }  
   
   
 sub print_services {  
     my($fig_or_sprout,$cgi,$html,$peg,$has_translation,$fc_data) = @_;  
   
 #    my $baseurl=$FIG_Config::cgi_base;  
 # Old base    my $base = $cgi->self_url();  
60    
61      my $baseurl = ".";          my $html = "";
62            $html .= $cgi->header();
     my $base = $cgi->url(-relative => 1, -query => 1, -path_info => 1);  
     my $link1 = "$base&request=view_annotations";  
     my $link2 = "$base&request=view_all_annotations";  
   
     #  
     # Since one cannot annotate in SPROUT, don't show this help.  
     #  
   
     if (not $is_sprout)  
     {  
     push(@$html, "<a href='$baseurl/Html/seedtips.html#gene_names' class='help' target='help'>Help on Annotations</a><br>\n");  
     }  
63    
64            my $parameters = { fig_object  => $fig,
65                               peg_id      => $cgi->param('prot'),
66                               table_style => 'plain',
67                               fig_disk    => $FIG_Config::fig_disk . "/",
68                               form_target => 'protein.cgi'
69            };
70    
71      push(@$html,"<a href=$link1>To View Annotations</a> / <a href=$link2>To View All Related Annotations</a>\n");          # write the seed header
72      my $user = $cgi->param('user');          $html .= FigWebServices::SeedComponents::Framework::get_plain_header($parameters);
73            $html .= "<br/>" . FigWebServices::SeedComponents::Protein::get_index_link() . "<br/><hr/>";
74    
75      #KSH get journal articles for this peg          # call the tool page
76      #push(@$html, "peg here is $peg");          $html .= & FigWebServices::SeedComponents::Basic::call_tool($fig, $cgi->param('prot'));
     my $pubmed_url = &get_pubmed_journals($peg);  
77    
78      #push(@$html, $pubmed_url);          $html .= "<hr/>" . FigWebServices::SeedComponents::Protein::get_index_link();
     push(@$html,"<p><a href=$pubmed_url target=_new> See PubMed  Journal Articles </a>\n");  
79    
80            $html .= $cgi->end_html();
81    
82      #          print $html;
     # Controlled vocabulary is SEED-only  
     #  
     if (not $is_sprout)  
     {  
     my $cv_link = "cv.cgi?prot=$peg&user=$user";  
     push(@$html,"<br><a href=$cv_link>Edit Controlled Vocabulary</a>\n");  
     }  
83    
84      if ((! $cgi->param('SPROUT')) && &peg_in_gendb($fig_or_sprout,$cgi,$peg))      # check for the new framework
85      {      } elsif ($cgi->param('new_framework')) {
     push(@$html, "<br/>".&FIGGenDB::linkPEGGenDB($peg));  
     push(@$html, "<br/>".&FIGGenDB::importOrganismGenDB($peg));  
     }  
86    
87      my $link = $cgi->url(-relative => 1, -query => 1, -path_info => 1) . "&request=aa_sequence";          # display the new version
88      push(@$html,"<br><a href=$link>Protein Sequence</a>\n");          my @out = `./frame.cgi`;
89            print @out;
90            exit;
91    
     $link = $cgi->url(-relative => 1, -query => 1, -path_info => 1) . "&request=dna_sequence";  
     push(@$html,"<br><a href=$link>DNA Sequence</a>\n");  
     $link = $cgi->url(-relative => 1, -query => 1, -path_info => 1) . "&request=dna_sequence_adjacent";  
     push(@$html," [<a href=$link>with flanking sequence</a>]<br>\n");  
   
     $link = $cgi->url(-relative => 1);  
     $link =~ s/protein.cgi/fid_checked.cgi/;  
     my $sprout = $cgi->param('SPROUT') ? 1 : "";  
     my $user = $cgi->param('user');  
     if (! $user) {  
         $user = "";  
92      } else {      } else {
         if (not $is_sprout)  
         {  
             push(@$html, "<a href='$baseurl/Html/seedtips.html#gene_names' class='help' target='help'>Help on Annotations</a><br>\n");  
         }  
         my $nlink = $link . "?SPROUT=$sprout&fid=$prot&user=$user&checked=$prot&assign/annotate=assign/annotate";  
         my $notlink = $link . "?SPROUT=$sprout&fid=$prot&user=$user&checked=$prot&assign/annotate=assign/annotate&negate=1";  
         push(@$html,"<a href='$nlink' target='checked_window'>To Make an Annotation</a> [<a href='$notlink' target='checked_window'>Negate annotation</a>]\n");  
     }  
   
     if (! $sprout)  
     {  
     my($cid,@fams);  
   
     my $fc = $cgi->param('fc');  
     if ((! $fc) && (&feature_locationS($fig_or_sprout,$peg))) {  
         my $link = $cgi->url(-relative => 1, -query => 1, -path_info => 1) . "&fc=1";  
         push(@$html,"<br><a href=$link>To Get Detailed Functional Coupling Data</a>\n");  
     } elsif ($fc) {  
         &print_fc($fig_or_sprout,$cgi,$html,$peg,$fc_data);  
     }  
   
     my $link = $cgi->url(-relative => 1, -query => 1, -path_info => 1) . "&request=fusions";  
     push(@$html,"<br><a href=$link>To Get Fusion Data</a>\n");  
   
     my $link = &cgi_url . "/homologs_in_clusters.cgi?prot=$peg&user=$user\n";  
     push(@$html,"<br><a href=$link>To Find Homologs in Clusters</a>\n");  
   
     my @coup = $fig_or_sprout->abstract_coupled_to($peg);  
     if (@coup > 0)  
     {  
         my $new_framework = $cgi->param('new_framework') ? 1 : 0;  
         my $link = &cgi_url . "/protein.cgi?prot=$peg&user=$user&request=abstract_coupling&new_framework=$new_framework\n";  
         push(@$html,"<br><a href=$link>Show Abstract Coupling Data</a>\n");  
     }  
     }  
   
     if ((! $cgi->param('compare_region')) && $has_translation) {  
         my $link = $cgi->url(-relative => 1, -query => 1, -path_info => 1) . "&compare_region=1";  
     push(@$html,"<A href=\"Html/compare_regions.html\" class='help' target=\"SEED_or_SPROUT_help\">Help on compare regions</A>\n");  
         push(@$html,"<a href=$link>To Compare Region</a> &nbsp;\n<br>");  
         push(@$html, "<a href='proteinfamilies.cgi?user=$user&prot=$peg&equivalence=1'>Explore Protein Families for $peg</a></br>\n");  
     } elsif ($cgi->param('compare_region')) {  
         &print_compared_regions($fig_or_sprout,$cgi,$html,$peg);  
     }  
 }  
93    
94  sub print_assignments {          # display the old version
     my($fig_or_sprout,$cgi,$html,$peg) = @_;  
     my($who,$func,$ec,@ecs,@tmp,$id,$i,$master_func,$user_func,$x);  
95    
96      my $user = $cgi->param('user');      my $user = $cgi->param('user');
     $user = defined($user) ? $user : "";  
   
     my @funcs    = map { [$peg,@$_] } &trans_function_of($cgi,$fig_or_sprout,$peg);  
     $user_func   = &trans_function_of($cgi,$fig_or_sprout,$peg);  
   
     push(@$html,$cgi->h2("Current Assignment: $peg: $user_func"));  
   
     my @maps_to  = grep { $_ ne $peg and $_ !~ /^xxx/ } map { $_->[0] } &mapped_prot_ids($fig_or_sprout,$cgi,$peg);  
   
     foreach $id (@maps_to) {  
     my $tmp;  
         if (($id ne $peg) && ($tmp = &trans_function_of($cgi,$fig_or_sprout,$id)))  
     {  
             push(@funcs, [$id,&who($id),$tmp]);  
         }  
     }  
     @funcs = map { ($_->[1] eq "master") ? [$_->[0],"",$_->[2]] : $_ } @funcs;  
   
   
     push(@$html,"<hr>\n");  
   
     if ((@funcs == 0) && (! $user_func)) {  
         push(@$html,$cgi->h1("No function has been assigned"));  
     }  
   
     my $tab = [ map { ($id,$who,$func) = @$_;  
               [ &HTML::set_prot_links($cgi,$id),  
             &org_of($fig_or_sprout,$id),  
             $who ? $who : "&nbsp;",  
             ($user ? &assign_link($cgi,$func,$user_func) : "&nbsp;"),  
             &set_ec_and_tc_links($fig_or_sprout,$cgi,&genome_of($peg),$func)] } @funcs ];  
     if (@$tab > 0) {  
         my $col_hdrs = ["Id","Organism","Who","ASSIGN","Assignment"];  
         my $title    = "Assignments for Essentially Identical Proteins";  
     push @$html, "<a href=\"javascript:toggleOffLayer('identicalproteins');\" title=\"Show Identicals\">Show/Hide Assignments for Essentially Identical Proteins</a>";  
         push(@$html,$cgi->div({id=>"identicalproteins"}, &HTML::make_table($col_hdrs,$tab,$title)));  
     }  
 }  
97    
98  sub get_pubmed_journals {          my $html = "";
99            $html .= $cgi->header();
100    
101      my $fig= new FIG;          my $parameters = { fig_object  => $fig,
102      my $protein_peg = @_[0];                             peg_id      => $cgi->param('prot'),
103      my @gid_aliases = $fig->feature_aliases($protein_peg);                             table_style => 'plain',
104      my @gid = grep {/.*gi.*/} @gid_aliases;                             fig_disk    => $FIG_Config::fig_disk . "/",
105      my $pubmed_base_url =   "http://www.ncbi.nlm.nih.gov/entrez/query.fcgi?cmd=Link&db=PubMed&dbFrom=Protein";                             form_target => 'protein.cgi'
106      #return "Peg is $protein_peg";          };
     my $append_to_base;  
     foreach (@gid) {  
         $_=~ s/gi\|//;  
         $append_to_base = "$append_to_base&from_uid=$_";  
     }  
107    
108      my $pubmed_url = "$pubmed_base_url$append_to_base";          my ($min, $max, $features) = FigWebServices::SeedComponents::Protein::get_region_data($parameters);
109      return $pubmed_url;          $parameters->{min} = $min;
110  }          $parameters->{max} = $max;
111            $parameters->{features} = $features;
112    
113            $html .= FigWebServices::SeedComponents::Framework::get_plain_header($parameters);
114            $html .= "<br/>" . FigWebServices::SeedComponents::Protein::get_index_link() . "<br/>";
115            $html .= FigWebServices::SeedComponents::Framework::get_js_css_links();
116    
117            # check for request parameter
118            my $request = $cgi->param("request") || "";
119    
120  sub print_kv_pairs {          # check for quick assign
121      my($is_sprout, $fig_or_sprout,$cgi,$html,$peg) = @_;          if ($request eq "fast_assign")            {
122      my $baseurl=$FIG_Config::cgi_base;              &FigWebServices::SeedComponents::Protein::make_assignment($fig,$cgi,$cgi->param('prot'));
123      $baseurl = "./";        # Relative url fix              $request = "";
124            }
125      # we don't want to do this for SPROUT  
126      if ($is_sprout)          if    ($request eq "view_annotations") {
127      {              $html .= &FigWebServices::SeedComponents::Protein::view_annotations($fig,$cgi,$cgi->param('prot'));
128      return print_kv_pairs_sprout($fig_or_sprout,$cgi,$html,$peg);          } elsif ($request eq "view_all_annotations") {
129                $html .= &FigWebServices::SeedComponents::Protein::view_all_annotations($fig,$cgi,$cgi->param('prot'));
130            } elsif ($request eq "show_coupling_evidence") {
131                $html .= &FigWebServices::SeedComponents::Protein::show_coupling_evidence($fig,$cgi,$cgi->param('prot'));
132            } elsif ($request eq "abstract_coupling") {
133                $html .= &FigWebServices::SeedComponents::Protein::show_abstract_coupling_evidence($fig,$cgi,$cgi->param('prot'));
134            } elsif ($request eq "ec_to_maps") {
135                $html .= &FigWebServices::SeedComponents::Protein::show_ec_to_maps($fig,$cgi);
136            } elsif ($request eq "link_to_map") {
137                $html .= &FigWebServices::SeedComponents::Protein::link_to_map($fig,$cgi);
138            } elsif ($request eq "fusions") {
139                $html = &FigWebServices::SeedComponents::Protein::show_fusions($fig,$cgi,$cgi->param('prot'));
140      }      }
141    
142      # RAE: modified this to allow the users to edit the key/value pairs.          # otherwise show normal page
     # there will be two choices: when the "Edit Attributes" button is pressed  
     # we will redraw the table with input fields and what not.  
   
     # If the Add Changes button is pressed we will save the changes  
     # we will do this first before displaying the results  
   
     my @attr = sort { ($a->[1] cmp $b->[1]) or ($a->[2] cmp $b->[2]) } $fig_or_sprout->get_attributes($peg);  
     if ($cgi->param('Add Changes')) {  
       my ($deleted, $added, $changed)=(undef, undef, undef);  
   
       foreach my $key (@attr) {  
          unless ($cgi->param("key.".$key->[1])) {  
         if (&delete_attribute($fig_or_sprout, $peg, $key->[1], $cgi->param("value.".$key->[1]), $cgi->param("url.".$key->[1]))) {  
           push @$deleted, [@$key, ["deleted", "td colspan=2 style=\"text-align: center\""]];  
         }  
      }  
      if (($cgi->param("value.".$key->[1]) ne $key->[2]) || ($cgi->param("url.".$key->[1]) ne $key->[3])) {  
         if (&change_attribute($fig_or_sprout,$peg, $key->[1], $key->[2], $key->[3], $cgi->param("value.".$key->[1]), $cgi->param("url.".$key->[1]))) {  
           push @$changed, [@$key, $cgi->param("value.".$key->[1]), $cgi->param("url.".$key->[1])];  
         }  
      }  
       }  
       for (my $i=0; $i<=5; $i++) {  
          if ($cgi->param("key.$i")) {  
         if (&add_attribute($fig_or_sprout,$peg, $cgi->param("key.$i"), $cgi->param("value.$i"), $cgi->param("url.$i"))) {  
          push @$added, [$cgi->param("key.$i"), ["added", "td colspan=3 style=\"text-align: center\""], $cgi->param("value.$i"), $cgi->param("url.$i")];  
         }  
143          else {          else {
          print STDERR $peg, " and ", $cgi->param("key.$i"), " not added\n";  
         }  
          }  
       }  
144    
145        if ($changed || $deleted || $added) {              $html .= FigWebServices::SeedComponents::Protein::get_title($parameters);
146          my $tab = [];              $html .= FigWebServices::SeedComponents::Protein::get_current_assignment($parameters);
147          my $col_hdrs=["Peg", "Attribute", "Original Value", "Original URL", "New Value", "New URL"];              $html .= "<hr/>";
148          if ($changed) {push @$tab, [["<strong>Changed Attributes", "td colspan=6 bgcolor=gray style=\"text-align: center\""]], @$changed}              $html .= FigWebServices::SeedComponents::Protein::get_translation_link();
149          if ($deleted) {push @$tab, [["<strong>Deleted Attributes", "td colspan=6 bgcolor=gray style=\"text-align: center\""]], @$deleted}              $html .= "<hr/>";
150          if ($added)   {push @$tab, [["<strong>Added Attributes",   "td colspan=6 bgcolor=gray style=\"text-align: center\""]], @$added}              $html .= FigWebServices::SeedComponents::Protein::get_peg_view($parameters);
151                $html .= FigWebServices::SeedComponents::Protein::get_chromosome_context($parameters);
152                $parameters->{initial_value} = 'expanded';
153                $html .= FigWebServices::SeedComponents::Protein::get_subsystem_connections($parameters);
154                $parameters->{initial_value} = 'collapsed';
155                $html .= FigWebServices::SeedComponents::Protein::get_aa_sequence($parameters);
156                $parameters->{initial_value} = 'collapsed';
157                $html .= FigWebServices::SeedComponents::Protein::get_dna_sequence($parameters);
158                $parameters->{initial_value} = 'collapsed';
159                $html .= FigWebServices::SeedComponents::Protein::get_dna_sequence_adjacent($parameters);
160                $parameters->{initial_value} = 'expanded';
161                $html .= FigWebServices::SeedComponents::Protein::get_assignments_for_identical_proteins($parameters);
162                $parameters->{initial_value} = 'collapsed';
163                $html .= FigWebServices::SeedComponents::Protein::get_links($parameters);
164                $parameters->{initial_value} = 'collapsed';
165                $html .= FigWebServices::SeedComponents::Protein::get_functional_coupling($parameters);
166                $parameters->{initial_value} = 'collapsed';
167                $html .= FigWebServices::SeedComponents::Protein::get_attributes($parameters);
168                $parameters->{initial_value} = 'collapsed';
169                $html .= FigWebServices::SeedComponents::Protein::get_protein_families($parameters);
170                $html .= "<br/><hr/>";
171                $html .= FigWebServices::SeedComponents::Protein::get_compared_regions($parameters);
172                $html .= "<br/><hr/>";
173                $html .= FigWebServices::SeedComponents::Protein::get_similarities($parameters);
174                $html .= "<br/><hr/>";
175                $parameters->{noheadline} = 1;
176                $html .= FigWebServices::SeedComponents::Protein::get_tools($parameters);
177                $parameters->{noheadline} = undef;
178            }
179    
180            $html .= "<br/><hr/>";
181            $html .= FigWebServices::SeedComponents::Protein::get_index_link();
182    
183          push(@$html,&HTML::make_table($col_hdrs,$tab,"Changed Data"));          print $html;
184          @attr = sort { ($a->[1] cmp $b->[1]) or ($a->[2] cmp $b->[2]) } $fig_or_sprout->get_attributes($peg);          print end_html();
       }  
       # now get the explanations and save those  
       my $explanations;  
       foreach my $key (@attr) {  
         if ($cgi->param("explanation.".$key->[1])) {  
       if (&key_info($fig_or_sprout, $key->[1], {"description"=>$cgi->param("explanation.".$key->[1])})) {  
        push @$explanations, [@$key, $cgi->param("explanation.".$key->[1])];  
       }  
185       }       }
186        }        }
       for (my $i=0; $i<=5; $i++) {  
         if ($cgi->param("key.$i") && $cgi->param("value.$i") &&  $cgi->param("explanation.".$i)) {  
            if (&key_info($fig_or_sprout, $cgi->param("key.$i"), {"description"=>$cgi->param("explanation.".$i)})) {  
             push @$explanations, [$cgi->param("key.$i"), $cgi->param("value.$i"), $cgi->param("url.$i"), $cgi->param("explanation.".$i)];  
            }  
         }  
       }  
       if ($explanations) {  
         my $col_hdrs=["Peg", "Attribute", "Value", "URL", "Explanation"];  
         push(@$html,&HTML::make_table($col_hdrs,$explanations,"Explanations"));  
       }  
     }  
   
     my $col_hdrs=["Key<br><span style='font-size: smaller'>Link Explains Key</span>","Value"];  
   
     my $tab = [];  
     if ($cgi->param('Edit Attributes') && $cgi->param('user')) {  
        push @$col_hdrs, "URL", "Explanation";  
        foreach my $key (sort {$a->[1] cmp $b->[1]} @attr) {  
       my $data=$fig_or_sprout->key_info($key->[1]);  
       if ($data->{"is_cv"} == 1){next}  
           push @$tab,  
           [  
               $cgi->textfield(-name=>"key.".$key->[1], -default=>$key->[1], -size=>30),  
               $cgi->textfield(-name=>"value.".$key->[1], -default=>$key->[2], -size=>30),  
               $cgi->textfield(-name=>"url.".$key->[1], -default=>$key->[3], -size=>30),  
           $cgi->textfield(-name=>"explanation.".$key->[1], -default=>$data->{"description"}, -size=>30),  
           ];  
        }  
        for (my $i=0; $i<=5; $i++) {  
      push @$tab,  
         [  
              $cgi->textfield(-name=>"key.$i", -size=>30),  
          $cgi->textfield(-name=>"value.$i", -size=>30),  
          $cgi->textfield(-name=>"url.$i", -size=>30),  
          $cgi->textfield(-name=>"explanation.$i", -default=>'', -size=>30),  
             ];  
        }  
     }  
     #RAE we need to check that this is a scalar  
     elsif (ref($attr[0]) eq "ARRAY") {  
        my $link=$cgi->url(-relative => 1, -query => 1, -path_info => 1);  
        foreach $_ (sort {$a->[0] cmp $b->[0]} @attr) {  
            my($peg,$tag,$val,$url) = @$_;  
        push(@$tab,["<a href='$link&showtag=$tag'>$tag</a>",$url ? "<a href=\"$url\">$val</a>" : $val]);  
        if ($cgi->param("showtag") && $cgi->param("showtag") eq $tag) {  
         my $data=&key_info($fig_or_sprout, $tag);  
         my $info="No Information Known about $tag";  
         if ($data->{"description"}) {$info=$data->{"description"}}  
         push(@$tab, [["Key", "th"], ["Explanation", "th"]], [$tag, $info]);  
           }  
        }  
     }  
   
     # Add the appropriate submit button to the table  
     if ($cgi->param('user') && $cgi->param('Edit Attributes')) {  
     # we want a Add button  
     push @$tab, [[$cgi->submit('Add Changes'), "td colspan=3 style=\"text-align: center\""]];  
     }  
     elsif ($cgi->param('user')) {  
     # RAE:  
     # I have turned off editing attributes at the moment. I think it is debateable that it has any value  
     # I am not aware of anyone editing attributes on a per-protein basis, although I know that people have  
     # edited them in bulk. The code is not working properly, and should be rewritten, so for now  
     # I have disabled them.  
   
     #push @$tab, [[$cgi->submit('Edit Attributes'), "td colspan=2 style=\"text-align: center\""]];  
     }  
     push(@$html,$cgi->start_form(-action=>"protein.cgi"),  
                 $cgi->hidden("prot"),  
                 $cgi->hidden("user"),  
                 $cgi->hidden('new_framework'));  
     if (($cgi->param('user') && $cgi->param('Edit Attributes')) || $cgi->param("showtag")) {  
         # these are the cases where we automatically want this shown  
         push(@$html,$cgi->br,$cgi->hr,&HTML::make_table($col_hdrs, $tab,"Attributes"),$cgi->hr);  
     }  
     else {  
         # otherwise we set the javascript section to hide this.  
     push @$html, "<a href=\"javascript:toggleLayer('attributes');\" title=\"Show Attributes\">Show/Hide Attributes</a>",  
                  "\n<div id='attributes'>\n<a href='$baseurl/Html/Attributes.html' class='help' target='help'>Help on Attributes</a>\n",  
                      &HTML::make_table($col_hdrs, $tab,"Attributes"), "</div>";  
     }  
     #  Add end of form -- GJO  
     #  RAE: sorry about that Gary.  
     push( @$html, $cgi->end_form );  
 }  
   
 sub print_kv_pairs_sprout  
 {  
     my($fig_or_sprout, $cgi, $html, $peg) = @_;  
   
     my @props = sort { ($a->[1] cmp $b->[1]) or ($a->[2] cmp $b->[2]) } $fig_or_sprout->get_attributes($peg);  
   
     my @col_hdrs = ("Key", "Value");  
   
     my @tab;  
   
     for my $prop (@props)  
     {  
     my($fid, $name, $value, $evidence) = @$prop;  
     my $txt;  
     if ($evidence =~ /^http/)  
     {  
         $txt = qq(<a href="$evidence">$value</a>);  
     }  
     else  
     {  
         $txt = $value;  
     }  
     push(@tab, [$name, $txt]);  
     }  
   
     push(@$html, &HTML::make_table(\@col_hdrs, \@tab, "Attributes"), $cgi->hr);  
   
     print STDERR Dumper($html);  
 }  
   
   
 sub print_protein_fams {  
   
     ############## RAE  
     # This code adds the protein family table to the page. This can be shown/hidden at the discretion of the viewer. Hopefully.  
   
     my($is_sprout, $fig_or_sprout,$cgi,$html,$peg,$user) = @_;  
     # we don't want to do this for SPROUT  
     return if ($is_sprout);  
   
     # get the families and other information  
     my $tab=[];  
     my @families=&families_for_protein($fig_or_sprout,$peg);  
     unless (scalar @families) {  
      push @$html, "No protein families found\n";  
      return;  
     }  
   
     my $baseurl=$FIG_Config::cgi_base;  
   
     push @$html, "<a href=\"javascript:toggleLayer('proteinfamilies');\" title=\"Show Protein Families\">Show/Hide Protein Families</a>";  
     foreach my $fam (@families)  
     {  
      my $link="<a href='proteinfamilies.cgi?user=$user&family=$fam'>$fam</a>";  
      push @$tab, [$link, &family_function($fig_or_sprout, $fam), &sz_family($fig_or_sprout, $fam)];  
     }  
     my $col_hdrs=["Family ID<br><small>Link Investigates Family</small>", "Family Function", "Family Size"];  
     push @$html, $cgi->br, $cgi->div({id=>"proteinfamilies"},  
         "\n<a href='Html/ProteinFamilies.html' class='help' target='help'>Help on Protein Families</a>\n",  
         &HTML::make_table($col_hdrs, $tab, "Protein Families")  
     );  
 }  
   
   
 sub old_print_protein_fams {  
   
     ############## RAE  
     # This is functional code that displays the protein families, but I want to try it using  
     # the CSS method. Therefore, I am keeping this code just for now, rather than munging it and being  
     # stuck with nothing working. Just rename this method and it will be fine!  
   
     my($is_sprout, $fig_or_sprout,$cgi,$html,$peg,$user) = @_;  
   
     # we don't want to do this for SPROUT  
     return if ($is_sprout);  
   
     # generate the link to turn protein fams on or off  
     my $link=$cgi->url(-relative => 1, -query => 1, -path_info => 1);  
     if ($link =~ /showproteinfams/) {  
      $link =~ s/[\&\;]showproteinfams.*[^\;\&]/\&/;  
      push @$html, "< &nbsp; " . $cgi->a({href=> $link}, "Hide Protein Families");  
   
      # get the families and other information  
      my $tab=[];  
      my @families=&families_for_protein($fig_or_sprout,$peg);  
      return unless (scalar @families);  
      foreach my $fam (@families)  
      {  
       my $baseurl=$FIG_Config::cgi_base;  
       $baseurl = './';      # Relative url fix  
       my $link="<a href='$baseurl/proteinfamilies.cgi?user=$user&family=$fam'>$fam</a>";  
       push @$tab, [$link, &family_function($fig_or_sprout, $fam), &sz_family($fig_or_sprout, $fam)];  
      }  
      my $col_hdrs=["Family ID<br><small>Link Investigates Family</small>", "Family Function", "Family Size"];  
      push @$html, $cgi->br, &HTML::make_table($col_hdrs, $tab, "Protein Families"), $cgi->hr;  
     }  
     else  
     {  
      push @$html, "> &nbsp; " . $cgi->a({href=> $link . "&showproteinfams='1'"}, "Show Protein Families"); # define this here before we mess with ourself!  
     }  
 }  
   
 sub who {  
     my($id) = @_;  
   
     if ($id =~ /^fig\|/)           { return "FIG" }  
     if ($id =~ /^gi\|/)            { return "" }  
     if ($id =~ /^^[NXYZA]P_/)      { return "RefSeq" }  
     if ($id =~ /^sp\|/)            { return "SwissProt" }  
     if ($id =~ /^uni\|/)           { return "UniProt" }  
     if ($id =~ /^tigr\|/)          { return "TIGR" }  
     if ($id =~ /^pir\|/)           { return "PIR" }  
     if ($id =~ /^kegg\|/)          { return "KEGG" }  
 }  
   
 sub print_subsys_connections {  
     my($fig_or_sprout,$cgi,$html,$peg,$user) = @_;  
   
     #  
     # Show the subsystems in which this protein participates.  
     #  
   
     if (my @subsystems = &subsystems_for_peg($fig_or_sprout,$peg)) {  
         push(@$html,  
              $cgi->h2("Subsystems in which this peg is present"));  
   
         my(@hdrs);  
         my(@table);  
   
         @hdrs = ("Subsystem", "Curator", "Role");  
   
         my $sprout = $cgi->param('SPROUT') ? 1 : "";  
   
         for my $ent (@subsystems) {  
             my($sub, $role) = @$ent;  
         my $curator = &subsystem_curator($fig_or_sprout,$sub);  
             my $can_alter;  
   
             my $esc_sub = uri_escape($sub);  # in URI::Escape  
         my $genome = &FIG::genome_of($peg);  
         my %opts = (SPROUT => $sprout,  
             user => $user,  
             ssa_name => $esc_sub,  
             focus => $genome,  
             request => 'show_ssa',  
             show_clusters => 1,  
             sort => 'by_phylo'  
             );  
   
         my $opts = join("&", map { "$_=$opts{$_}" } keys(%opts));  
             my $url = $cgi->a({href => "display_subsys.cgi?$opts"}, $sub);  
   
             push(@table, [$url, $curator, $role]);  
         }  
         push(@$html, &HTML::make_table(\@hdrs, \@table));  
     }  
 }  
   
 sub print_links {  
     my($fig_or_sprout,$cgi,$html,$peg) = @_;  
   
     my @links = &peg_links($fig_or_sprout,$peg);  
     if (@links > 0) {  
         my $col_hdrs = [1,2,3,4,5];  
         my $title    = "Links to Related Entries in Other Sites";  
         my $tab = [];  
         my ($n,$i);  
         for ($i=0; ($i < @links); $i += 5) {  
             $n = (($i + (5-1)) < @links) ? $i+(5-1) : $i+(@links - $i);  
             push(@$tab,[@links[$i..$n]]);  
         }  
         push @$html, "<a href=\"javascript:toggleLayer('linkselsewhere');\" title=\"Show Links\">Show/Hide Links to Related Entries in Other Sites</a>";  
     push(@$html,$cgi->div({id=>"linkselsewhere"}, &HTML::make_table($col_hdrs,$tab,$title)));  
     }  
     if (! $cgi->param('SPROUT'))  
     {  
         my $url = &cgi_url . "/add_links.cgi?peg=$peg";  
         push @$html, $cgi->br("<a href=$url>To Add New Links to this Gene</a>\n");  
     }  
 }  
   
   
   
 ################# Similarities  ############################  
   
   
 sub print_similarities {  
     my( $fig_or_sprout, $cgi, $html, $peg ) = @_;  
   
     if ($cgi->param('SPROUT'))  
     {  
     &print_similarities_SPROUT($fig_or_sprout, $cgi, $html, $peg );  
     }  
     else  
     {  
     &print_similarities_SEED($fig_or_sprout, $cgi, $html, $peg );  
     }  
 }  
   
   
 sub print_similarities_SPROUT {  
     my($fig_or_sprout, $cgi, $html, $peg ) = @_;  
   
     $cgi->delete('sims');  
   
     my $user = $cgi->param('user') || "";  
   
     my $current_func = &trans_function_of($cgi,$fig_or_sprout,$peg,$user);  
   
     push( @$html, $cgi->hr,  
                   "<a name=Similarities>",  
                   $cgi->h1(''),  
                   "</a>\n"  
         );  
   
     my @sims = sort { $a->[1] <=> $b->[1] } &bbhs($fig_or_sprout,$peg,1.0e-10);  
   
     my @from = $cgi->radio_group(-name => 'from',  
                                  -nolabels => 1,  
                  -override => 1,  
                                  -values => ["",$peg,map { $_->[0] } @sims]);  
   
     my $target = "window$$";  
         # RAE: added a name to the form so tha the javascript works  
     push( @$html, $cgi->start_form( -method => 'post',  
                     -target => $target,  
                     -action => 'fid_checked.cgi',  
                     -name   => 'fid_checked'  
                     ),  
               $cgi->hidden(-name => 'SPROUT', -value => 1),  
               $cgi->hidden(-name => 'fid', -value => $peg),  
               $cgi->hidden(-name => 'user', -value => $user),  
               $cgi->br,  
                   "For Selected (checked) sequences: ",  
               $cgi->submit('align'),  
             );  
   
     if ($user) {  
     my $help_url = "Html/help_for_assignments_and_rules.html";  
     push ( @$html, $cgi->br, $cgi->br,  
                        "<a href=$help_url target=\"SEED_or_SPROUT_help\">Help on Assignments, Rules, and Checkboxes</a>",  
                        $cgi->br, $cgi->br,  
                        $cgi->submit('assign/annotate')  
            );  
   
     if ($cgi->param('translate')) {  
         push( @$html, $cgi->submit('add rules'),  
           $cgi->submit('check rules'),  
           $cgi->br  
           );  
     }  
     }  
   
     push( @$html, $cgi->br,  
               $cgi->checkbox( -name    => 'checked',  
                   -value   => $peg,  
                   -override => 1,  
                   -checked => 1,  
                   -label   => ""  
                   )  
       );  
   
     my $col_hdrs;  
     if ($user && $cgi->param('translate')) {  
     push( @$html, " ASSIGN to/Translate from/SELECT current PEG", $cgi->br,  
                   "ASSIGN/annotate with form: ", shift @from, $cgi->br,  
                       "ASSIGN from/Translate to current PEG: ", shift @from  
           );  
     $col_hdrs = [ "ASSIGN to<hr>Translate from",  
                       "Similar sequence",  
                       "E-val",  
               "In Sub",  
                       "ASSIGN from<hr>Translate to",  
               "Function",  
               "Organism",  
                       "Aliases"  
               ];  
     } elsif ($user) {  
     push( @$html, " ASSIGN to/SELECT current PEG", $cgi->br,  
                       "ASSIGN/annotate with form: ", shift @from, $cgi->br,  
                       "ASSIGN from current PEG: ", shift @from  
           );  
     $col_hdrs = [ "ASSIGN to<hr>SELECT",  
                           "Similar sequence",  
                           "E-val",  
                           "In Sub",  
                           "ASSIGN from",  
                           "Function",  
                           "Organism",  
                           "Aliases"  
               ];  
     } else {  
     push(@$html, " SELECT current PEG", $cgi->br );  
     $col_hdrs = [ "SELECT",  
               "Similar sequence",  
               "E-val",  
               "In Sub",  
               "Function",  
               "Organism",  
               "Aliases"  
               ];  
     }  
   
     my $ncol = @$col_hdrs;  
     push( @$html, "<TABLE border cols=$ncol>\n",  
               "\t<Caption><h2>Bidirectional Best Hits</h2></Caption>\n",  
                   "\t<TR>\n\t\t<TH>",  
                   join( "</TH>\n\t\t<TH>", @$col_hdrs ),  
                   "</TH>\n\t</TR>\n"  
       );  
   
     #  Add the table data, row-by-row  
   
     my $sim;  
     foreach $sim ( @sims ) {  
     my($id2,$psc) = @$sim;  
     my $cbox = &translatable($fig_or_sprout,$id2) ?  
         qq(<input type=checkbox name=checked value="$id2">) : "";  
     my $id2_link = &HTML::set_prot_links($cgi,$id2);  
     chomp $id2_link;  
   
     my @in_sub  = &peg_to_subsystems($fig_or_sprout,$id2);  
     my $in_sub;  
     if (@in_sub > 0) {  
         $in_sub = @in_sub;  
     } else {  
         $in_sub = "&nbsp;";  
     }  
   
     my $radio   = $user ? shift @from : undef;  
     my $func2   = html_enc( scalar &trans_function_of( $cgi, $fig_or_sprout, $id2, $user ) );  
     ## RAE Added color3. This will color function tables that do not match the original  
     ## annotation. This makes is a lot easier to see what is different (e.g. caps/spaces, etc)  
     my $color3="#FFFFFF";  
     unless ($func2 eq $current_func) {$color3="#FFDEAD"}  
   
     #  
     # Colorize organisms:  
     #  
     # my $org     = html_enc( &org_of($fig_or_sprout, $id2 ) );  
     my ($org,$oc) = &org_and_color_of($fig_or_sprout, $id2 );  
     $org        = html_enc( $org );  
   
     my $aliases = html_enc( join( ", ", &feature_aliasesL($fig_or_sprout,$id2) ) );  
   
     $aliases = &HTML::set_prot_links($cgi,$aliases);  
   
     #  Okay, everything is calculated, let's "print" the row datum-by-datum:  
   
     $func2 = $func2 ? $func2 : "&nbsp;";  
     $aliases = $aliases ? $aliases : "&nbsp;";  
     push( @$html, "\t<TR>\n",  
           #  
           #  Colorize check box by Domain  
           #  
           "\t\t<TD Align=center Bgcolor=$oc>$cbox</TD>\n",  
           "\t\t<TD Nowrap>$id2_link</TD>\n",  
           "\t\t<TD Nowrap>$psc</TD>\n",  
           "\t\t<TD>$in_sub</TD>",  
           $user ? "\t\t<TD Align=center>$radio</TD>\n" : (),  
           "\t\t<TD Bgcolor=$color3>$func2</TD>\n",  
           #  
           #  Colorize organism by Domain  
           #  
           # "\t\t<TD>$org</TD>\n",  
           "\t\t<TD Bgcolor=$oc>$org</TD>\n",  
           "\t\t<TD>$aliases</TD>\n",  
           "\t</TR>\n"  
           );  
     }  
     push( @$html, "</TABLE>\n" );  
     push( @$html, $cgi->end_form );  
 }  
   
   
 sub print_similarities_SEED {  
     my( $fig_or_sprout, $cgi, $html, $peg ) = @_;  
   
     my $user = $cgi->param('user') || "";  
     my $current_func = &trans_function_of( $cgi, $fig_or_sprout, $peg, $user );  
   
     push @$html, $cgi->hr,  
                  "<a name=Similarities>",   #  Put an anchor on the heading  
                  $cgi->h2('Similarities'),  
                  "</a>\n";  
   
     #  Generate the request form, and return current option values in hash  
   
     my $short_form = 0;  
     my $SimParams  = sims_request_form( $fig_or_sprout, $cgi, $html, $peg, $user, $short_form );  
   
     my $maxN       = $SimParams->{ maxN };  
     my $maxP       = $SimParams->{ maxP };  
     my $max_expand = $SimParams->{ max_expand };  
     my $select     = $SimParams->{ select };  
     my $show_env   = $SimParams->{ show_env };  
     my $hide_alias = $SimParams->{ hide_alias };  
     my $group_by_genome = $SimParams->{ group_by_genome };  
   
     #  These are active, but the values are only used in sims()  
     # my $extra_opt = $SimParams->{ extra_opt };  
     # my $min_q_cov = $SimParams->{ min_q_cov };  
     # my $min_s_cov = $SimParams->{ min_s_cov };  
     # my $min_sim   = $SimParams->{ min_sim };  
     # my $sim_meas  = $SimParams->{ sim_meas };  
     # my $sort_by   = $SimParams->{ sort_by };  
   
     #  None of these are currently active: -- GJO  
     # my $show_rep   = $SimParams->{ show_rep };  
     # my $max_sim    = $SimParams->{ max_sim };  
     # my $dyn_thrsh  = $SimParams->{ dyn_thrsh };  
     # my $save_dist  = $SimParams->{ save_dist };  
     # my $chk_which  = $SimParams->{ chk_which };  
   
     #  There is currently no control to turn this on! -- GJO  
     my $expand_groups = $SimParams->{ expand_groups };  
   
     #  Move filtering of sims list out of display loop.  Avoids many problems,  
     #  including display of table with no entries.  Anticipate more filters.  
     #  -- GJO  
     #  
     #  All the filtering is now done in get_raw_sims and expand_raw_sims. -- GJO  
   
     my @sims = sims( $fig_or_sprout,  
                      $peg,  
                      $maxN,  
                      $maxP,  
                      $select,  
                      $max_expand,  
                      $group_by_genome,  
                      $SimParams  
                    );  
   
     if ( @sims ) {  
     push( @$html, $cgi->hr );  
     my @from = $cgi->radio_group( -name => 'from',  
                                   -nolabels => 1,  
                                   -override => 1,  
                                   -values => [ "", $peg, map { $_->id2 } @sims ]  
                                 );  
   
         my $target = "window$$";  
         # RAE: added a name to the form so tha the javascript works  
         push( @$html, $cgi->start_form( -method => 'post',  
                                     -target => $target,  
                                     -action => 'fid_checked.cgi',  
                                     -name   => 'fid_checked'  
                                       ),  
                       $cgi->hidden(-name => 'fid', -value => $peg),  
                       $cgi->hidden(-name => 'user', -value => $user),  
                       $cgi->br,  
                       "For Selected (checked) sequences: ",  
                            $cgi->submit('align'),  
                            $cgi->submit('view annotations'),  
                            $cgi->submit('get sequences'),  
                            $cgi->submit('show regions')  
             );  
   
         if ($user) {  
             my $help_url = "Html/help_for_assignments_and_rules.html";  
             push ( @$html, $cgi->br, $cgi->br,  
                        "<a href=$help_url target=\"SEED_or_SPROUT_help\">Help on Assignments, Rules, and Checkboxes</a>",  
                        $cgi->br, $cgi->br,  
                        $cgi->submit('assign/annotate')  
              );  
   
             if ($cgi->param('translate')) {  
                 push( @$html, $cgi->submit('add rules'),  
                               $cgi->submit('check rules'),  
                               $cgi->br  
                     );  
             }  
         }  
   
         push( @$html, $cgi->br,  
                       $cgi->checkbox( -name    => 'checked',  
                                       -value   => $peg,  
                           -override => 1,  
                                       -checked => 1,  
                                       -label   => ""  
                                     )  
             );  
   
         my $col_hdrs;  
         my $color_help = "(<A href=\"Html/similarity_region_colors.html\" target=\"SEED_or_SPROUT_help\">colors</A>)";  
         my $func_clr_help = "(<A href=\"Html/function_colors.html\" target=\"SEED_or_SPROUT_help\">function colors</A>)";  
   
         if ($user && $cgi->param('translate')) {  
             push( @$html, " ASSIGN to/Translate from/SELECT current PEG", $cgi->br,  
                           "ASSIGN/annotate with form: ", shift @from, $cgi->br,  
                           "ASSIGN from/Translate to current PEG: ", shift @from  
             );  
             $col_hdrs = [ "ASSIGN to<hr>Translate from",  
                           $expand_groups ? "family" : (),  
                           $expand_groups ? "size" : (),  
                           "Similar sequence",  
                           "E-val<br>% iden",  
                           "region in<br>sim seq<br>$color_help",  
                           "region in<br>peg<br>$color_help",  
                           "ASSIGN from<hr>Translate to",  
                           "In Sub",  
               &evidence_codes_link($cgi),  
                           "Function<br>$func_clr_help",  
                           "Organism",  
                           (! $hide_alias) ? "Aliases" : ()  
                         ];  
         } elsif ($user) {  
             push( @$html, " ASSIGN to/SELECT current PEG", $cgi->br,  
                           "ASSIGN/annotate with form: ", shift @from, $cgi->br,  
                           "ASSIGN from current PEG: ", shift @from  
             );  
             $col_hdrs = [ "ASSIGN to<hr>SELECT",  
                           $expand_groups ? "family" : (),  
                           $expand_groups ? "size" : (),  
                           "Similar sequence",  
                           "E-val<br>% iden",  
                           "region in<br>sim seq<br>$color_help",  
                           "region in<br>peg<br>$color_help",  
                           "Assign from",  
                           "In Sub",  
               &evidence_codes_link($cgi),  
                           "Function<br>$func_clr_help",  
                           "Organism",  
                           (! $hide_alias) ? "Aliases" : ()  
                         ];  
         } else {  
             push(@$html, " SELECT current PEG", $cgi->br );  
             $col_hdrs = [ "SELECT",  
                           $expand_groups ? "family" : (),  
                           $expand_groups ? "size" : (),  
                           "Similar sequence",  
                           "E-val<br>% iden",  
                           "region in<br>similar sequence<br>$color_help",  
                           "region in<br>$peg<br>$color_help",  
                           "In Sub",  
               &evidence_codes_link($cgi),  
                           "Function<br>$func_clr_help",  
                           "Organism",  
                           (! $hide_alias) ? "Aliases" : ()  
                         ];  
         }  
   
         # RAE Add the check all/uncheck all boxes.  
         push (@$html, $cgi->br, &HTML::java_buttons("fid_checked", "checked"), $cgi->br);  
   
         #  
         # Total rewrite of sim table code: cleaner program flow; omitting  
         # empty columns; colorizing region-of-similarity cells -- GJO  
         #  
         # Start the similarity table with "Caption" and header row  
   
         my $ncol = @$col_hdrs;  
         push( @$html, "<TABLE border cols=$ncol>\n",  
                       "\t<Caption><h2>Similarities</h2></Caption>\n",  
                       "\t<TR>\n\t\t<TH>",  
                       join( "</TH>\n\t\t<TH>", @$col_hdrs ),  
                       "</TH>\n\t</TR>\n"  
             );  
   
         #  
         #  Grouping by genome is hard to see.  This is an attempt to make it more obvious  
         #  by consolidating the "Organism" for all rows in which it is repeated.  -- GJO  
         #  
         #  Let's figure out the function here too.  This will allow color to be  
         #  specific for more than one function.  For example, we can color:  
         #  
         #     Identical function white  
         #     Most common alternative brown  
         #     Next most common alternatives red, orange, yellow, green, blue, and violet  
         #     Any additional alternatives gray  
         #  
   
         my $sim;  
         my ( $id2, $func, $genome, $org, $color, $info, $prev_genome, $prev_sim );  
         my %func_cnt = ();  
   
         foreach $sim ( @sims ) {  
             $id2  = $sim->id2;  
   
             $func = html_enc( scalar trans_function_of( $cgi, $fig_or_sprout, $id2, $user ) );  
             $func && $func_cnt{ $func }++;  
   
             if ( $group_by_genome && ( ( $genome ) = $id2 =~ /fig\|(\d+\.\d+)\./ )  
                                   && ( $genome eq $prev_genome ) )  
             {  
                 $prev_sim->[-1]->[3]++;         # Increase row span of org  
                 push @$sim, [ $func, "", $color, 0 ];  # No org name, prev_color, no row span  
             }  
             else  
             {  
                 ( $org, $color ) = org_and_color_of( $fig_or_sprout, $id2 );  
                 push @$sim, [ $func, html_enc( $org ), $color, 1 ];  
                 $prev_genome = $genome || "";  
                 $prev_sim = $sim;  
             }  
         }  
   
         #  Build a function to color translation table based on frequence of function.  
         #  Reserve white for the current function.  
   
         my %func_color;  
         $func_cnt{ $current_func } && delete $func_cnt{ $current_func };  
         $func_color{ $current_func } = "#FFFFFF";  
   
         #  Assign other colors until we run out:  
   
         my @colors = qw( #EECCAA #FFAAAA #FFCC66 #FFFF00 #AAFFAA #BBBBFF #FFAAFF );  
         for ( sort { $func_cnt{ $b } <=> $func_cnt{ $a } } keys %func_cnt )  
         {  
             $func_color{ $_ } = ( shift @colors ) || "#DDDDDD";  
         }  
   
         #  Add the table data, row-by-row  
   
         my $alia = (! $hide_alias);  
         foreach $sim ( @sims ) {  
             my $id2  = $sim->id2;  
   
             my $cbox = &translatable($fig_or_sprout,$id2) ?  
                    qq(<input type=checkbox name=checked value="$id2">) : "";  
   
             my( $family, $sz, $funcF, $fam_link );  
         $family = $sz = $funcF = $fam_link = "";  
   
             my $id2_link = &HTML::set_prot_links($cgi,$id2);  
             chomp $id2_link;  
   
             my @in_sub  = &peg_to_subsystems($fig_or_sprout,$id2);  
             my $in_sub;  
   
             if (@in_sub > 0) {  
                 $in_sub = @in_sub;  
             # RAE: add a javascript popup with all the subsystems  
                 my $ss_list=join "<br>", map { my $g = $_; $g =~ s/\_/ /g; $_ = $g } sort {$a cmp $b} @in_sub;  
                 $in_sub = $cgi->a(  
           {id=>"subsystems", onMouseover=>"javascript:if(!this.tooltip) this.tooltip=new Popup_Tooltip(this, 'Subsystems', '$ss_list', ''); this.tooltip.addHandler(); return false;"}, $in_sub);  
             } else {  
                 $in_sub = "&nbsp;";  
             }  
   
         # evidence codes moved here so I can add a tool tip for them  
         my $ev_codes=" &nbsp; ";  
         my @ev_codes=&evidence_codes($fig_or_sprout,$id2);  
         if (scalar(@ev_codes) && $ev_codes[0])  
         {  
          my $ev_code_help=join("<br />", map {&evidence_codes_explain($_)} @ev_codes);  
          $ev_codes = $cgi->a(  
            {id=>"evidence_codes", onMouseover=>"javascript:if(!this.tooltip) this.tooltip=new Popup_Tooltip(this, 'Evidence Codes', '$ev_code_help', ''); this.tooltip.addHandler(); return false;"}, join("<br />", @ev_codes));  
         }  
   
             my $psc     = $sim->psc;  
             my $iden    = $sim->iden;  
             my $ln1     = $sim->ln1;  
             my $ln2     = $sim->ln2;  
             my $b1      = $sim->b1;  
             my $e1      = $sim->e1;  
             my $b2      = $sim->b2;  
             my $e2      = $sim->e2;  
             my $d1      = abs($e1 - $b1) + 1;  
             my $d2      = abs($e2 - $b2) + 1;  
             my $reg1    = "$b1-$e1 (<b>$d1/$ln1</b>)";  
             my $color1  = match_color( $b1, $e1, $ln1 );  
             my $reg2    = "$b2-$e2 (<b>$d2/$ln2</b>)";  
             my $color2  = match_color( $b2, $e2, $ln2 );  
             my $radio   = $user ? shift @from : undef;  
   
             # Retrieve the Function and Organism data that was pushed on the end of the sim:  
   
             my ( $func2, $org, $oc, $rowspan ) = @{$sim->[-1]};  
   
             ## RAE Added color3. This will color function cells that do not match the original  
             ## annotation. This makes is a lot easier to see what is different (e.g. caps/spaces, etc)  
   
             my $color3 = $func2 && $func_color{ $func2 } || "#DDDDDD";  
   
             if ( $funcF && ( $funcF ne $func2 ) ) { $func2 = "$funcF<br>$func2" }  
             $func2 ||= "&nbsp;";  
   
             my $aliases = undef;  
             if ( $alia )  
             {  
                 $aliases = html_enc( join( ", ", &feature_aliasesL($fig_or_sprout,$id2) ) );  
                 $aliases = &HTML::set_prot_links( $cgi, $aliases );  
                 $aliases ||= "&nbsp;";  
             }  
   
             #  Okay, everything is calculated, let's "print" the row datum-by-datum:  
   
             push( @$html, "\t<TR>\n",  
                           #  
                           #  Colorize check box by Domain  
                           #  
                           "\t\t<TD Align=center Bgcolor=$oc>$cbox</TD>\n",  
                           $expand_groups ? "\t\t<TD>$fam_link</TD>/n" : (),  
                           $expand_groups ? "\t\t<TD>$sz</TD>\n" : (),  
                           "\t\t<TD Nowrap>$id2_link</TD>\n",  
                           "\t\t<TD Nowrap>$psc<br>$iden\%</TD>\n",  
                           "\t\t<TD Nowrap Bgcolor=$color2>$reg2</TD>\n",  
                           "\t\t<TD Nowrap Bgcolor=$color1>$reg1</TD>\n",  
                           $user ? "\t\t<TD Align=center>$radio</TD>\n" : (),  
                           "\t\t<TD Align=center>$in_sub</TD>",  
               "\t\t<TD Align=center>$ev_codes</TD>",  
                           "\t\t<TD Bgcolor=$color3>$func2</TD>\n",  
                           #  
                           #  Colorize organism by Domain  
                           #  
                           $rowspan ? "\t\t<TD Rowspan=$rowspan Bgcolor=$oc>$org</TD>\n" : (),  
                           $alia ? "\t\t<TD>$aliases</TD>\n" : (),  
                           "\t</TR>\n"  
                 );  
         }  
   
         push( @$html, "</TABLE>\n" );  
         push( @$html, $cgi->end_form );  
     }  
 }  
   
 #  
 #  Support functions for writing the similarities  
 #  
 #  This is a sufficient set of escaping for text in HTML:  
 #  
   
 sub html_enc { $_ = $_[0]; s/\&/&amp;/g; s/\>/&gt;/g; s/\</&lt;/g; $_ }  
   
 #  
 #  Make a background color that reflects the position and extent of a  
 #  matching region.  
 #  
 #      Left side is red; right side is blue.  
 #      Long match is white or pastel; short match is saturated color.  
 #  
   
 sub match_color {  
     my ( $b, $e, $n ) = @_;  
     my ( $l, $r ) = ( $e > $b ) ? ( $b, $e ) : ( $e, $b );  
     # my $hue = 3/4 * 0.5*($l+$r)/$n - 1/24;  
     my $hue = 5/6 * 0.5*($l+$r)/$n - 1/12;  
     my $cov = ( $r - $l + 1 ) / $n;  
     my $sat = 1 - 10 * $cov / 9;  
     my $br  = 1;  
     rgb2html( hsb2rgb( $hue, $sat, $br ) );  
 }  
   
 #  
 #  Convert HSB to RGB.  Hue is taken to be in range 0 - 1 (red to red);  
 #  
   
 sub hsb2rgb {  
     my ( $h, $s, $br ) = @_;  
     $h = 6 * ($h - floor($h));      # Hue is made cyclic modulo 1  
     if ( $s  > 1 ) { $s  = 1 } elsif ( $s  < 0 ) { $s  = 0 }  
     if ( $br > 1 ) { $br = 1 } elsif ( $br < 0 ) { $br = 0 }  
     my ( $r, $g, $b ) = ( $h <= 3 ) ? ( ( $h <= 1 ) ? ( 1,      $h,     0      )  
                                       : ( $h <= 2 ) ? ( 2 - $h, 1,      0      )  
                                       :               ( 0,      1,      $h - 2 )  
                                       )  
                                     : ( ( $h <= 4 ) ? ( 0,      4 - $h, 1      )  
                                       : ( $h <= 5 ) ? ( $h - 4, 0,      1      )  
                                       :               ( 1,      0,      6 - $h )  
                                       );  
     ( ( $r * $s + 1 - $s ) * $br,  
       ( $g * $s + 1 - $s ) * $br,  
       ( $b * $s + 1 - $s ) * $br  
     )  
 }  
   
 #  
 #  Convert an RGB value to an HTML color string:  
 #  
   
 sub rgb2html {  
     my ( $r, $g, $b ) = @_;  
     if ( $r > 1 ) { $r = 1 } elsif ( $r < 0 ) { $r = 0 }  
     if ( $g > 1 ) { $g = 1 } elsif ( $g < 0 ) { $g = 0 }  
     if ( $b > 1 ) { $b = 1 } elsif ( $b < 0 ) { $b = 0 }  
     sprintf("\"#%02x%02x%02x\"", int(255.999*$r), int(255.999*$g), int(255.999*$b) )  
 }  
   
 #  
 #  floor could be gotten from POSIX::, but why bother?  
 #  
   
 sub floor {  
     my $x = $_[0];  
     defined( $x ) || return undef;  
     ( $x >= 0 ) || ( int($x) == $x ) ? int( $x ) : -1 - int( - $x )  
 }  
   
   
 #------------------------------------------------------------------------  
 #  Generate similarity query forms for the SEED.  Consolidates things like  
 #  style and defaults in one place.  
 #  
 #   my $user = $cgi->param('user') || "";  
 #   my $short_form = 0;  
 #   my $SimParam = sims_request_form( $fig, $cgi, $html, $peg, $user, $short_form );  
 #------------------------------------------------------------------------  
   
 sub sims_request_form {  
     my ( $fig, $cgi, $html, $peg, $user, $short_form ) = @_;  
   
     my $trans_role = $cgi->param('translate')            ||  0;  
   
     if ($cgi->param('SPROUT'))  
     {  
     &sprout_sims_request_form($cgi,$html,$peg,$trans_role,$user);  
     return;  
     }  
   
     #  Read available parameters, and fill in defaults:  
   
     my $maxN       = defined( $cgi->param('maxN') )       ? $cgi->param('maxN')       : 50;  
     my $max_expand = defined( $cgi->param('max_expand') ) ? $cgi->param('max_expand') :  5;  
     my $maxP       = defined( $cgi->param('maxP') )       ? $cgi->param('maxP')       :  1.0e-5;  
     my $select     = $cgi->param('select')               || 'all';  
     my $show_env   = $cgi->param('show_env')             ||  0;  
     my $hide_alias = $cgi->param('hide_alias')           ||  0;  
     my $sort_by    = $cgi->param('sort_by')              || 'bits';  
     my $group_by_genome = $cgi->param('group_by_genome') ||  0;  
     my $expand_groups = $cgi->param('expand_groups')     ||  0;  
   
     #  New similarity options  
   
     #  Act on request for more or fewer sim options  
   
     my $extra_opt = defined( $cgi->param('extra_opt') ) ? $cgi->param('extra_opt') : 0;  
     if ( $cgi->param('more sim options') ) {  
         $extra_opt = 1;  
         $cgi->delete('more sim options');  
     }  
     if ( $cgi->param('fewer sim options') ) {  
         $extra_opt = 0;  
         $cgi->delete('fewer sim options');  
     }  
   
     #  Make defaults completely open (match original behavior)  
   
     my $min_sim   = $extra_opt && defined( $cgi->param('min_sim') )   ? $cgi->param('min_sim')   : 0;  
     my $sim_meas  = $extra_opt && defined( $cgi->param('sim_meas') )  ? $cgi->param('sim_meas')  : 'id';  
     my $min_q_cov = $extra_opt && defined( $cgi->param('min_q_cov') ) ? $cgi->param('min_q_cov') : 0;  
     my $min_s_cov = $extra_opt && defined( $cgi->param('min_s_cov') ) ? $cgi->param('min_s_cov') : 0;  
   
     #  New parameters.  Not yet implimented.  
     #  The defaults for representative sequences might be tuned:  
   
     my $show_rep  = $extra_opt && defined( $cgi->param('show_rep') )  ? $cgi->param('show_rep')  : 0;  
     my $max_sim   = $extra_opt && defined( $cgi->param('max_sim') )   ? $cgi->param('max_sim')   : 0.70;  
     my $dyn_thrsh = $extra_opt && defined( $cgi->param('dyn_thrsh') ) ? $cgi->param('dyn_thrsh') : 0;  
     my $save_dist = $extra_opt && defined( $cgi->param('save_dist') ) ? $cgi->param('save_dist') : 0.80;  
   
     #  Mark some of the sequences automatically?  
   
     my $chk_which = $extra_opt && defined( $cgi->param('chk_which') ) ? $cgi->param('chk_which')  : 'none';  
   
     #  Use $cgi->param('more similarities') to drive increase in maxN and max_expand  
   
     if ( $cgi->param('more similarities') ) {  
         $maxN       *= 2;  
         $max_expand *= 2;  
         $cgi->delete('more similarities');  
     }  
   
     #  Sanity checks on fixed vocabulary parameter values:  
   
     my %select_opts    = map { ( $_, 1 ) } qw( all  fig  figx  fig_pref  figx_pref );  
     my %sort_opts      = map { ( $_, 1 ) } qw( bits  id  id2  bpp  bpp2 );  
     my %sim_meas_opts  = map { ( $_, 1 ) } qw( id  bpp );  
     my %chk_which_opts = map { ( $_, 1 ) } qw( none  all  rep );  
   
     $select    = 'all'  unless $select_opts{ $select };  
     $sort_by   = 'bits' unless $sort_opts{ $sort_by };  
     $sim_meas  = 'id'   unless $sim_meas_opts{ $sim_meas };  
     $chk_which = 'none' unless $chk_which_opts{ $chk_which };  
   
     #  We have processed all options.  Use them to build forms.  
   
     #  Checkmarks for input tags  
   
     my $chk_select_all   = select_if( $select eq 'all' );  
     my $chk_select_figp  = select_if( $select eq 'fig_pref' );  
     my $chk_select_figxp = select_if( $select eq 'figx_pref' );  
     my $chk_select_fig   = select_if( $select eq 'fig' );  
     my $chk_select_figx  = select_if( $select eq 'figx' );  
     my $chk_show_env     = chked_if( $show_env );  
     my $chk_hide_alias   = chked_if( $hide_alias );  
     my $chk_group_by_genome = chked_if( $group_by_genome );  
     my $chk_sort_by_id    = select_if( $sort_by eq 'id' );  
     my $chk_sort_by_id2   = select_if( $sort_by eq 'id2' );  
     my $chk_sort_by_bits  = select_if( $sort_by eq 'bits' );  
     my $chk_sort_by_bpp   = select_if( $sort_by eq 'bpp' );  
     my $chk_sort_by_bpp2  = select_if( $sort_by eq 'bpp2' );  
     my $new_framework = $cgi->param('new_framework') ? 1 : 0;  
   
     #  Features unique to the long form:  
   
     if ( $short_form )  
     {  
     #  Use a here document to push the short version of the similarities form  
     #  on @$html (many values are passed as hidden inputs).  
   
     push @$html, <<"End_Short_Form";  
   
 <FORM Action=\"protein.cgi#Similarities\">  
     <input type=hidden name=prot      value=\"$peg\">  
     <input type=hidden name=sims      value=1>  
     <input type=hidden name=fid       value=\"$peg\">  
     <input type=hidden name=user      value=\"$user\">  
     <input type=hidden name=translate value=$trans_role>  
     <input type=hidden name=new_framework value=\"$new_framework\">  
   
     &nbsp;&nbsp;&nbsp; Max sims:<input type=text name=maxN size=5 value=$maxN> &nbsp;&nbsp;  
     Max expand:<input type=text name=max_expand size=5 value=$max_expand> &nbsp;&nbsp;  
     Max E-val:<input type=text name=maxP size=8 value=$maxP> &nbsp;&nbsp;  
     <select name=select>  
     <option value=all       $chk_select_all>Show all databases</option>  
     <option value=fig_pref  $chk_select_figp>Prefer FIG IDs (to max exp)</option>  
     <option value=figx_pref $chk_select_figxp>Prefer FIG IDs (all)</option>  
     <option value=fig       $chk_select_fig>Just FIG IDs (to max exp)</option>  
     <option value=figx      $chk_select_figx>Just FIG IDs (all)</option>  
     </select> &nbsp;&nbsp;  
     Show Env. samples:<input type=checkbox name=show_env value=1 $chk_show_env> &nbsp;&nbsp;  
     Hide aliases:<input type=checkbox name=hide_alias value=1 $chk_hide_alias><br />  
   
     <input type=submit name=Similarities value=Similarities> &nbsp;&nbsp;  
     Sort by  
     <select name=sort_by>  
     <option value=bits $chk_sort_by_bits>score</option>  
     <option value=id2  $chk_sort_by_id2>percent identity*</option>  
     <option value=bpp2 $chk_sort_by_bpp2>score per position*</option>  
     <option value=id   $chk_sort_by_id>percent identity</option>  
     <option value=bpp  $chk_sort_by_bpp>score per position</option>  
     </select> &nbsp;&nbsp;  
     Group by genome:<input type=checkbox name=group_by_genome value=1 $chk_group_by_genome>  
     &nbsp;&nbsp;&nbsp;  
     <A href=\"Html/similarities_options.html\" target=\"SEED_or_SPROUT_help\" class=\"help\">Help with SEED similarities options</A><BR />  
 </FORM>  
   
 End_Short_Form  
   
     }  
     else  
     {  
     #  Navigation buttons  
   
     my ( $prev_peg_btn, $next_peg_btn ) = ( "", "" );  
     my ( $prefix, $protnum ) = $peg =~ /^(.*\.)(\d+)$/;  
     if ( $prefix && $protnum ) {  
         if ( ( $protnum > 1 ) && &translatable( $fig_or_sprout, $prefix . ($protnum-1) ) )  
         {  
         $prev_peg_btn = $cgi->submit('previous PEG');  
         }  
         if ( &translatable( $fig_or_sprout, $prefix . ($protnum+1) ) )  
         {  
         $next_peg_btn = $cgi->submit('next PEG');  
         }  
     }  
   
     #  Add/remove extra options button  
   
     my $extra_opt_btn = $extra_opt ? $cgi->submit('fewer sim options')  
                                    : $cgi->submit('more sim options');  
   
     #  Checkmarks for input tags  
   
     my $chk_sim_meas_id  = select_if( $sim_meas eq 'id' );  
     my $chk_sim_meas_bpp = select_if( $sim_meas eq 'bpp' );  
     my $chk_show_rep     = chked_if( $show_rep );  
     my $chk_dyn_thrsh    = chked_if( $dyn_thrsh );  
     my $chk_chk_none     = select_if( $chk_which eq 'none' );  
     my $chk_chk_all      = select_if( $chk_which eq 'all' );  
     my $chk_chk_rep      = select_if( $chk_which eq 'rep' );  
   
     #  Finally time to write some HTML  
     #  
     #  Default options  
   
     push @$html, <<"End_Default_Options";  
   
 <FORM Action=\"protein.cgi#Similarities\">  
     <input type=hidden name=prot      value=\"$peg\">  
     <input type=hidden name=sims      value=1>  
     <input type=hidden name=fid       value=\"$peg\">  
     <input type=hidden name=user      value=\"$user\">  
     <input type=hidden name=translate value=$trans_role>  
     <input type=hidden name=new_framework value=\"$new_framework\">  
   
     Max sims:<input type=text name=maxN size=5 value=$maxN> &nbsp;&nbsp;  
     Max expand:<input type=text name=max_expand size=5 value=$max_expand> &nbsp;&nbsp;  
     Max E-val:<input type=text name=maxP size=8 value=$maxP> &nbsp;&nbsp;  
     <select name=select>  
     <option value=all       $chk_select_all>Show all databases</option>  
     <option value=fig_pref  $chk_select_figp>Prefer FIG IDs (to max exp)</option>  
     <option value=figx_pref $chk_select_figxp>Prefer FIG IDs (all)</option>  
     <option value=fig       $chk_select_fig>Just FIG IDs (to max exp)</option>  
     <option value=figx      $chk_select_figx>Just FIG IDs (all)</option>  
     </select> &nbsp;&nbsp;  
     Show Env. samples:<input type=checkbox name=show_env value=1 $chk_show_env> &nbsp;&nbsp;  
     Hide aliases:<input type=checkbox name=hide_alias value=1 $chk_hide_alias><br />  
   
     Sort by  
     <select name=sort_by>  
     <option value=bits $chk_sort_by_bits>score</option>  
     <option value=id2  $chk_sort_by_id2>percent identity*</option>  
     <option value=bpp2 $chk_sort_by_bpp2>score per position*</option>  
     <option value=id   $chk_sort_by_id>percent identity</option>  
     <option value=bpp  $chk_sort_by_bpp>score per position</option>  
     </select> &nbsp;&nbsp;  
     Group by genome:<input type=checkbox name=group_by_genome value=1 $chk_group_by_genome> &nbsp;&nbsp;&nbsp;  
     <A href=\"Html/similarities_options.html\" target=\"SEED_or_SPROUT_help\" class=\"help\">Help with SEED similarities options</A><br />  
 End_Default_Options  
   
     #  Extra options  
   
     push @$html, <<"End_Extra_Options" if $extra_opt;  
     <input type=hidden name=extra_opt value=\"$extra_opt\">  
   
     Min similarity:<input type=text name=min_sim size=5 value=$min_sim>  
     defined by  
     <select name=sim_meas>  
     <option value=id  $chk_sim_meas_id>identities (0-100%)</option>  
     <option value=bpp $chk_sim_meas_bpp>score per position (0-2 bits)</option>  
     </select> &nbsp;&nbsp;  
     Min query cover (%):<input type=text name=min_q_cov size=5 value=$min_q_cov> &nbsp;&nbsp;  
     Min subject cover (%):<input type=text name=min_s_cov size=5 value=$min_s_cov><br />  
   
     <!--  Hide unimplimented options  
     <TABLE Cols=2>  
         <TR>  
             <TD Valign=top><input type=checkbox name=show_rep $chk_show_rep></TD>  
             <TD> Show only representative sequences whose similarities to one another  
                 are less than <input type=text size=5 name=max_sim value=$max_sim>  
                 <br />  
                 <input type=checkbox name=dyn_thrsh value=1 $chk_dyn_thrsh> But keep sequences  
                 that are at least <input type=text size=5 name=save_dist value=$save_dist>  
                 times as distant from one another as from the query</TD>  
         </TR>  
     </TABLE>  
   
     <input type=hidden name=chk_which value=\"$chk_which\">  
   
     Automatically Select (check) which sequences:<select name=chk_which>  
     <option value=none $chk_chk_none>none</option>  
     <option value=all  $chk_chk_all>all shown</option>  
     <option value=rep  $chk_chk_rep>representative set</option>  
     </select><br />  
     -->  
 End_Extra_Options  
   
     #  Submit buttons  
   
     push @$html, <<"End_of_Buttons";  
     <input type=submit name='resubmit' value='resubmit'>  
     <input type=submit name='more similarities' value='more similarities'>  
     $prev_peg_btn  
     $next_peg_btn  
     $extra_opt_btn  
 </FORM>  
   
 End_of_Buttons  
   
     }  
   
     #  Return the current parameter values in a hash  
   
     { maxN          => $maxN,  
       maxP          => $maxP,  
       max_expand    => $max_expand,  
       select        => $select,  
       show_env      => $show_env,  
       hide_alias    => $hide_alias,  
       group_by_genome => $group_by_genome,  
       trans_role    => $trans_role,  
       extra_opt     => $extra_opt,  
       min_sim       => $min_sim,  
       min_q_cov     => $min_q_cov,  
       min_s_cov     => $min_s_cov,  
       sim_meas      => $sim_meas,  
       sort_by       => $sort_by,  
       show_rep      => $show_rep,  
       max_sim       => $max_sim,  
       dyn_thrsh     => $dyn_thrsh,  
       save_dist     => $save_dist,  
       chk_which     => $chk_which,  
       expand_groups => $expand_groups  
     }  
 }  
   
 sub sprout_sims_request_form {  
     my($cgi,$html,$peg,$trans_role,$user) = @_;  
   
     push @$html, <<"End_Short_Form";  
   
 <FORM Action=\"protein.cgi\">  
     <input type=hidden name=prot      value=\"$peg\">  
     <input type=hidden name=sims      value=1>  
     <input type=hidden name=SPROUT    value=1>  
     <input type=hidden name=user      value=\"$user\">  
     <input type=hidden name=translate value=$trans_role>  
     <input type=submit name='Bidirectional Best Hits' value='Bidirectional Best Hits'>  
   
 </FORM>  
   
 End_Short_Form  
 }  
   
   
 #------------------------------------------------------------------------  
 #  Auxilliary function to acivate checkmark for input fields  
 #------------------------------------------------------------------------  
 sub chked_if { $_[0] ? 'checked ' : '' }  
   
 sub select_if { $_[0] ? 'selected ' : '' }  
   
   
   
 ################# Context on the Chromosome ############################  
   
 sub print_context {  
     my($fig_or_sprout,$cgi,$html,$peg,$feat,$beg,$end) = @_;  
   
     if ($beg eq $end) { cluck "Have zero len"; }  
     my($contig1,$beg1,$end1,$strand,$max_so_far,$gap,$comment,$fc,$aliases);  
     my($fid1,$sz,$color,$map,$gg,$n,$link,$in_neighborhood);  
   
   
     my $user = $cgi->param('user');  
     my $sprout = $cgi->param('SPROUT') ? 1 : "";  
     push(@$html,$cgi->start_form(-action => &cgi_url . "/chromosomal_clusters.cgi"),  
             $cgi->hidden(-name => 'SPROUT', -value => $sprout),  
         $cgi->hidden(-name => "prot", -value => $peg),  
         $cgi->hidden(-name => "uni", -value => 1),  
             $cgi->hidden(-name => "user", -value => $user));  
   
     my $in_cluster = &in_cluster_with($fig_or_sprout,$cgi,$peg);  
     my $col_hdrs;  
   
     # RAE Added Subsys col headers  
     # BDP removed extra button columns per request by LKM  
 #    if ($cgi->param('SPROUT'))  
 #    {  
 #   $col_hdrs = ["fid","starts","ends","size","","gap","find<br>best<br>clusters","pins","fc-sc","SS",&evidence_codes_link($cgi),"comment","","","aliases"];  
 #    }  
 #    else  
 #    {  
     $col_hdrs = ["fid","starts","ends","size","","gap","find<br>best<br>clusters","pins","fc-sc","SS",&evidence_codes_link($cgi),"comment","aliases"];  
 #    }  
   
     my($tab) = [];  
     my $genes = [];  
   
     my %coupled;  
   
     #  
     # Make a pass over the features, determining what subsystems they appear in. Assign  
     # unique numbers (names?) for them.  
     #  
   
     my %fid_to_subs;  
     my %subs;  
     for my $fid (@$feat)  
     {  
     my $subs = [&peg_to_subsystems($fig_or_sprout, $fid)];  
     map { $subs{$_}++ } @$subs;  
     $fid_to_subs{$fid} = $subs;  
     }  
   
     my $sub_idx = 1;  
     my %sub_names;  
     for my $sub (sort { $subs{$b} <=> $subs{$a} } keys %subs)  
     {  
     $sub_names{$sub} = $sub_idx++;  
     }  
   
     my $fc_sc;  
     foreach $fid1 (@$feat) {  
     my $best_clusters_link = "<a href=" . &cgi_url . "/homologs_in_clusters.cgi?prot=$fid1&user=$user&SPROUT=$sprout><img src=\"Html/button-cl.png\" border=\"0\"></a>";  
     if (defined($fc_sc = $in_cluster->{$fid1}))  
     {  
         $fc = &pin_link($cgi,$fid1);  
     }  
     else  
     {  
         $fc    = "";  
         $fc_sc = "";  
     }  
   
         my $aliases = join( ', ', &feature_aliasesL($fig_or_sprout,$fid1) );  
         my $uniprot;  
         if ($aliases =~ /(uni[^,]+)/) {  
              # print STDERR "$1\n";  
              $uniprot = $1;  
         }  
     $aliases = &HTML::set_prot_links($cgi,$aliases),  
     $aliases =~ s/SPROUT=1/SPROUT=0/g;  
     $aliases =~ s/[&;]user=[^&;]+[;&]/;/g;  
     $aliases = $aliases ? $aliases : "&nbsp;";  
   
     my($to_seed,$to_gbrowse);  
     $to_seed = $to_gbrowse = "";  
     # BDP: removed extra columns per request by LKM  
 #   if ($cgi->param('SPROUT') && ($fid1 =~ /peg/))  
 #   {  
 #       $to_seed     = &cgi_url . "/protein.cgi?prot=$fid1";  
 #       $to_gbrowse  = &cgi_url . $fig_or_sprout->get_gbrowse_feature_link($fid1);  
 #   }  
   
   
         ($contig1,$beg1,$end1) = &boundaries_of($fig_or_sprout,&feature_locationS($fig_or_sprout,$fid1));;  
         $strand = ($beg1 < $end1) ? "+" : "-";  
   
         my $function = &function_ofS($fig_or_sprout,$fid1);  
         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 : '');  
   
         if     ($fid1 eq $peg)    { $color = "green" }  
         elsif  ($fc)              { $color = "blue" }  
         else                      { $color = "red" }  
   
         if ($fid1 =~ /peg\.(\d+)$/) {  
             $n = $1;  
         my $sprout = $cgi->param('SPROUT');  
         $sprout = $sprout ? $sprout : "";  
             $link = $cgi->url(-relative => 1) . "?prot=$fid1&user=$user&SPROUT=$sprout";  
         } elsif ($fid1 =~ /\.([a-z]+)\.\d+$/) {  
             $n = uc $1;  
             $link = "";  
         } else {  
             $n ="";  
             $link = "";  
         }  
   
         push(@$genes,[&min($beg1,$end1),&max($beg1,$end1),($strand eq "+") ? "rightArrow" : "leftArrow", $color,$n,$link,$info]);  
         if ($max_so_far) {  
             $gap = (&min($beg1,$end1) - $max_so_far) - 1;  
         } else {  
             $gap = "";  
         }  
         $max_so_far = &max($beg1,$end1);  
   
   
         if (&ftype($fid1) eq "peg") {  
             $comment = &trans_function_of($cgi,$fig_or_sprout,$fid1,$user);  
         } else {  
             $comment = "";  
         }  
         $comment = &set_ec_and_tc_links($fig_or_sprout,$cgi,&genome_of($fid1),$comment);  
         if ($fid1 eq $peg) {  
             $comment = "\@bgcolor=\"#00FF00\":$comment";  
         }  
         $sz = abs($end1-$beg1)+1;  
   
     $comment = $comment ? $comment : "&nbsp;";  
     # RAE Count the number of subsystems. This is just copied from elsewhere  
     #my @in_sub  = &peg_to_subsystems($fig_or_sprout,$fid1);  
     my @in_sub = @{$fid_to_subs{$fid1}};  
   
         my $in_sub;  
         if (@in_sub > 0) {  
         if ($is_sprout)  
         {  
         $in_sub = @in_sub;  
         }  
         else  
         {  
         $in_sub = @in_sub;  
         $in_sub .= ": " . join(" ", map { $sub_names{$_} } sort {$b cmp $a} @in_sub);  
         # RAE: add a javascript popup with all the subsystems  
         # RAE: unless you assign $_ to $g,the map operates on the result of s///, i.e. the number of substitutions made. I think there is a cleaner  
         # way to do this, eh Gary?  
         my $ss_list=join "<br>", map { my $g = "$sub_names{$_} : $_"; $g =~ s/_/ /g; $_=$g } sort {$b cmp $a} @in_sub;  
         $in_sub = $cgi->a(  
           {id=>"subsystems", onMouseover=>"javascript:if(!this.tooltip) this.tooltip=new Popup_Tooltip(this, 'Subsystems', '$ss_list', ''); this.tooltip.addHandler(); return false;"}, $in_sub),  
         }  
         } else {  
             $in_sub = "&nbsp;";  
         }  
   
     # Generate the text for the evidence codes so we can have the popup tool tips  
     my $ev_codes=" &nbsp; ";  
     my @ev_codes=&evidence_codes($fig_or_sprout,$fid1);  
     if (scalar(@ev_codes) && $ev_codes[0])  
     {  
      my $ev_code_help=join("<br />", map {&evidence_codes_explain($_)} @ev_codes);  
      $ev_codes = $cgi->a(  
        {id=>"evidence_codes", onMouseover=>"javascript:if(!this.tooltip) this.tooltip=new Popup_Tooltip(this, 'Evidence Codes', '$ev_code_help', ''); this.tooltip.addHandler(); return false;"}, join("<br />", @ev_codes));  
     }  
   
   
   
     if ($cgi->param('SPROUT'))  
     {  
         # BDP: removed Sprout and GBrowse columns  
 #       my($s_link, $g_link);  
 #       if (0)  
 #       {  
 #       $s_link = "<a href=$to_seed>S</a>";  
 #       $g_link = "<a href=$to_gbrowse>G</a>";  
 #       }  
 #       else  
 #       {  
 #       $s_link = "<a href=$to_seed><img src=\"Html/button-s.png\" border=\"0\"></a>";  
 #       $g_link = "<a href=$to_gbrowse><img src=\"Html/button-g.png\" border=\"0\"></a>";  
 #       }  
         push(@$tab,[&HTML::fid_link($cgi,$fid1,"local"),$beg1,$end1,$sz,$strand,$gap,  
             $best_clusters_link,  
             $fc ? $fc : "&nbsp;",  
             $fc_sc ? $fc_sc : "&nbsp;",  
             $in_sub,  
             join("<br>",&evidence_codes($fig_or_sprout,$fid1)),  
             $comment,  
 #           $s_link,  
 #           $g_link,  
             $aliases]);  
     }  
     else  
     {  
         push(@$tab,[&HTML::fid_link($cgi,$fid1,"local"),$beg1,$end1,$sz,$strand,$gap,  
             $best_clusters_link,  
             $fc,$fc_sc,  
             $in_sub,  
             $ev_codes,  
             $comment,  
             $aliases]);  
     }  
     }  
     push(@$html,&HTML::make_table($col_hdrs,$tab,"Context on contig $contig1 from base $beg to $end (".(abs($end-$beg)+1)." bp)"));  
     push(@$html,$cgi->end_form);  
     return ($beg,$end,$genes);  
 }  
   
 sub print_graphics_context {  
     my($beg,$end,$genes,$html) = @_;  
   
     my $map = ["",$beg,$end,$genes];  
     my $gg = [$map];  
     push(@$html,@{ &GenoGraphics::render($gg,700,4,0,1) });  
     return;  
 }  
   
 sub assign_link {  
     my($cgi,$func,$existing_func) = @_;  
     my($assign_url,$assign_link);  
   
     if ($func && ((! $existing_func) || ($existing_func ne $func))) {  
         $cgi->delete('request');  
         $assign_url  = $cgi->url(-relative => 1, -query => 1, -path_info => 1) . "&request=fast_assign&func=$func";  ## must encode  
         $assign_link = "<a href=\"$assign_url\">&nbsp;<=&nbsp;</a>";  
     } else {  
         $assign_link = "";  
     }  
     return $assign_link;  
 }  
   
 sub pin_link {  
     my($cgi,$peg) = @_;  
     my $user = $cgi->param('user');  
     $user = defined($user) ? $user : "";  
   
     my $new_framework = $cgi->param('new_framework') ? 1 : 0;  
     my $sprout = $cgi->param('SPROUT') ? 1 : "";  
     my $cluster_url  = "chromosomal_clusters.cgi?new_framework=$new_framework&prot=$peg&user=$user&uni=1&SPROUT=$sprout";  
   
     my $cluster_img = 0 ? "*" : '<img src="Html/button-pins-1.png" border="0">';  
     my $cluster_link = "<a href=\"$cluster_url\" target=pinned_region.$$>$cluster_img</a>";  
     return $cluster_link;  
 }  
   
 sub set_ec_and_tc_links {  
     my($fig_or_sprout,$cgi,$org,$func) = @_;  
     Trace("Incoming functional assignment is \"$func\".") if T(EClink => 4);  
     if ($func =~ /^(.*)(\d+\.\d+\.\d+\.\d+)(.*)$/) {  
         my $before = $1;  
         my $ec     = $2;  
         my $after  = $3;  
         Trace("Matched EC case: ID = $ec.") if T(EClink => 4);  
         return &set_ec_and_tc_links($fig_or_sprout,$cgi,$org,$before) . &set_ec_to_maps($fig_or_sprout,$cgi,$org,$ec) . &set_ec_and_tc_links($fig_or_sprout,$cgi,$org,$after);  
     }  
     elsif ($func =~ /^(.*)(TC \d+(\.[0-9A-Z]+){3,6})(.*)$/) {  
         my $before = $1;  
         my $tc     = $2;  
         my $after  = $4;  
         Trace("Matched TC case: ID = $tc.") if T(EClink => 4);  
         return &set_ec_and_tc_links($fig_or_sprout,$cgi,$org,$before) . &set_tc_link($fig_or_sprout,$org,$tc) . &set_ec_and_tc_links($fig_or_sprout,$cgi,$org,$after);  
     }  
     return $func;  
 }  
   
 sub set_tc_link {  
     my($fig_or_sprout,$org,$tc) = @_;  
   
     if ($tc =~ /^TC\s+(\S+)$/)  
     {  
         return "<a href=http://www.tcdb.org/tcdb/index.php?tc=$1&Submit=Lookup>$tc</a>";  
     }  
     return $tc;  
 }  
   
   
 sub set_ec_to_maps {  
     my($fig_or_sprout,$cgi,$org,$ec) = @_;  
   
     my @maps = &ec_to_maps($fig_or_sprout,$ec);  
     if (@maps > 0) {  
         $cgi->delete('request');  
         my $url  = $cgi->url(-relative => 1, -query => 1, -path_info => 1) . "&request=ec_to_maps&ec=$ec&org=$org";  
         my $link = "<a href=\"$url\">$ec</a>";  
         return $link;  
     }  
     return $ec;  
 }  
   
 sub show_ec_to_maps {  
     my($fig_or_sprout,$cgi,$html,$ec) = @_;  
   
     my $ec = $cgi->param('ec');  
     if (! $ec) {  
         push(@$html,$cgi->h1("Missing EC number"));  
         return;  
     }  
   
     my @maps = &ec_to_maps($fig_or_sprout,$ec);  
     if (@maps > 0) {  
         my $col_hdrs = ["map","metabolic topic"];  
         my $map;  
         my $tab      = [map { $map = $_; [&map_link($cgi,$map),&map_name($fig_or_sprout,$map)] } @maps];  
         push(@$html,&HTML::make_table($col_hdrs,$tab,"$ec: " . &ec_name($fig_or_sprout,$ec)));  
     }  
 }  
   
 sub map_link {  
     my($cgi,$map) = @_;  
   
     $cgi->delete('request');  
     my $url  = $cgi->url(-relative => 1, -query => 1, -path_info => 1) . "&request=link_to_map&map=$map";  
     my $link = "<a href=\"$url\">$map</a>";  
     return $link;  
 }  
   
 sub link_to_map {  
     my($fig_or_sprout,$cgi,$html) = @_;  
   
     my $map = $cgi->param('map');  
     if (! $map) {  
         push(@$html,$cgi->h1("Missing Map"));  
         return;  
     }  
   
     my $org = $cgi->param('org');  
     if (! $org) {  
         push(@$html,$cgi->h1("Missing Org Parameter"));  
         return;  
     }  
     my$user = $cgi->param('user');  
     $user = $user ? $user : "";  
   
     $ENV{"REQUEST_METHOD"} = "GET";  
     $ENV{"QUERY_STRING"} = "user=$user&map=$map&org=$org";  
     my @out = `./show_kegg_map.cgi`;  
     &HTML::trim_output(\@out);  
     push(@$html,@out);  
 }  
   
 sub aa_sequence {  
     my($fig_or_sprout,$cgi,$html,$prot) = @_;  
     my($seq,$func,$i);  
   
     unshift @$html, "<TITLE>The SEED: Protein Sequence</TITLE>\n";  
     if ($seq = &get_translation($fig_or_sprout,$prot)) {  
         $func = &function_ofS($fig_or_sprout,$prot,$cgi->param('user'));  
         push(@$html,$cgi->pre,">$prot $func\n");  
         for ($i=0; ($i < length($seq)); $i += 60) {  
             if ($i > (length($seq) - 60)) {  
                 push(@$html,substr($seq,$i) . "\n");  
             } else {  
                 push(@$html,substr($seq,$i,60) . "\n");  
             }  
         }  
         push(@$html,$cgi->end_pre);  
     } else {  
         push(@$html,$cgi->h1("No translation available for $prot"));  
     }  
 }  
   
 sub dna_sequence {  
     my($fig_or_sprout,$cgi,$html,$fid) = @_;  
     my($seq,$func,$i);  
   
     unshift @$html, "<TITLE>The SEED: Nucleotide Sequence</TITLE>\n";  
     if ($seq = &dna_seq($fig_or_sprout,&genome_of($fid),&feature_locationS($fig_or_sprout,$fid))) {  
         $func = &function_ofS($fig_or_sprout,$prot,$cgi->param('user'));  
         push(@$html,$cgi->pre,">$fid $func\n");  
         for ($i=0; ($i < length($seq)); $i += 60) {  
             if ($i > (length($seq) - 60)) {  
                 push(@$html,substr($seq,$i) . "\n");  
             } else {  
                 push(@$html,substr($seq,$i,60) . "\n");  
             }  
         }  
         push(@$html,$cgi->end_pre);  
     } else {  
         push(@$html,$cgi->h1("No DNA sequence available for $fid"));  
     }  
 }  
   
 # RAE: Added this routine to get the adjacent sequence. The default is to get 500 bp on either side of the  
 # gene, but you can (secretly) change this to get more or less sequence by setting additional_sequence  
 # in the URL. Also, I changed the way that the display is generated above so that I can used the s///  
 # to add the color and new lines.  
 #  
 # Fixed off-by-one errors in the end of coloring (which started this all).  
 # Modified to detect end of contig (otherwise it fails when it runs off an end).  
 # Modified to handle multisegment locations.  -- GJO  
   
 sub dna_sequence_adjacent {  
     my( $fig_or_sprout,$cgi, $html, $fid ) = @_;  
     my( $contig, $beg, $end, $seq, $func, $i );  
   
     unshift @$html, "<TITLE>The SEED: Nucleotide Sequence</TITLE>\n";  
     my $additional = $cgi->param("additional_sequence");  
     defined( $additional ) or ( $additional = 500 );  
   
     # Now handles segmented location and running off an end. -- GJO  
   
     my $genome = &genome_of( $fid );  
     my $loc = &feature_locationS($fig_or_sprout,$fid);  
     # my $loc = $fig_or_sprout->feature_location( $fid );  
     my @loc = split /,/, $loc;  
   
   
     # Add to beginning of the first segment:  
   
     # NOTE the difference  
     # Sprout returns locations in the form contig_start-stop  
   
     # ( $contig, $beg, $end ) = $loc[0] =~ /^(.*)_(\d+)\D(\d+)$/;  
   
     ($contig, $beg, $end) = BasicLocation::Parse($loc[0]);  
   
     if ( ! ( $contig && $beg && $end ) )  
     {  
         push @$html, $cgi->h2( "Bad location information for $fid" );  
         print STDERR "SEED Error: Bad location information ($loc) for $fid in dna_sequence_adjacent\n";  
         return;  
     }  
     my ( $n1, $npre );  
     if ( $beg < $end )  
     {  
         $n1 = $beg - $additional;  
         $n1 = 1 if $n1 < 1;  
         $npre = $beg - $n1;  
     }  
     else  
     {  
         $n1 = $beg + $additional;  
         my $clen = $fig_or_sprout->contig_ln( $genome, $contig );  
         $n1 = $clen if $n1 > $clen;  
         $npre = $n1 - $beg;  
     }  
     $loc[0] = join( '_', $contig, $n1, $end );  
   
     # Add to the end of the last segment:  
   
     ( $contig, $beg, $end ) = BasicLocation::Parse($loc[-1]);  
   
     if ( ! ( $contig && $beg && $end ) )  
     {  
         push @$html, $cgi->h2( "Bad location information for $fid" );  
         print STDERR "SEED Error: Bad location information ($loc) for $fid in dna_sequence_adjacent\n";  
         return;  
     }  
     my ( $n2, $npost );  
     if ( $beg < $end )  
     {  
         $n2 = $end + $additional;  
         my $clen = $fig_or_sprout->contig_ln( $genome, $contig );  
         $n2 = $clen if $n2 > $clen;  
         $npost = $n2 - $end;  
     }  
     else  
     {  
         $n2 = $end - $additional;  
         $n2 = 1 if $n2 < 1;  
         $npost = $end - $n2;  
     }  
     $loc[-1] = join( '_', $contig, $beg, $n2 );  
   
     $seq = $fig_or_sprout->dna_seq( $genome, join( ',', @loc ) );  
     if ( ! $seq )  
     {  
         push @$html, $cgi->h2( "No DNA sequence available for $fid" );  
         return;  
     }  
   
     my $len = length( $seq );         # Get length before adding newlines  
     $seq =~ s/(.{60})/$1\n/g;         # Cleaver way to wrap the sequence  
     my $p1 = $npre + int( $npre/60 ); # End of prefix, adjusted for newlines  
     my $p2 = $len - $npost;           # End of data,  
     $p2 += int( $p2/60 );             #     adjusted for newlines  
     my $diff = $p2 - $p1;             # Characters of data  
     # Integrate the HTML codes  
     $seq =~ s/^(.{$p1})(.{$diff})(.*)$/$1<SPAN Style="color:red">$2<\/SPAN>$3/s;  
   
     $func = $fig_or_sprout->function_of( $fid, $cgi->param('user') );  
   
     push @$html, $cgi->pre, ">$fid $func\n$seq\n", $cgi->end_pre;  
 }  
   
   
 sub show_fusions {  
     my($fig_or_sprout,$cgi,$html,$prot) = @_;  
   
     my $user = $cgi->param('user');  
     $user = $user ? $user : "";  
     my $sprout = $cgi->param('SPROUT') ? 1 : "";  
   
     $ENV{"REQUEST_METHOD"} = "GET";  
     $ENV{"QUERY_STRING"} = "peg=$prot&user=$user&SPROUT=$sprout";  
     my @out = `./fusions.cgi`;  
     print join("",@out);  
     exit;  
 }  
   
 ###########################################################################  
 sub print_compared_regions {  
     my($fig_or_sprout,$cgi,$html,$peg) = @_;  
   
     my $new_framework = $cgi->param('new_framework') ? 1 : 0;  
   
     my $sz_region = $cgi->param('sz_region');  
     $sz_region = $sz_region ? $sz_region : 16000;  
   
     my $num_close = $cgi->param('num_close');  
     $num_close = $num_close ? $num_close : 5;  
   
     my $user = $cgi->param('user');  
     my @closest_pegs = &closest_pegs($fig_or_sprout,$cgi,$peg,$num_close);  
   
     if (@closest_pegs > 0) {  
         if (&possibly_truncated($fig_or_sprout,$peg)) {  
             push(@closest_pegs,&possible_extensions($peg,\@closest_pegs));  
         }  
         @closest_pegs = &sort_fids_by_taxonomy($fig_or_sprout,@closest_pegs);  
         unshift(@closest_pegs,$peg);  
         my @all_pegs = ();  
   
         my $gg = &build_maps($fig_or_sprout,\@closest_pegs,\@all_pegs,$sz_region);  
         #warn Dumper($gg);  
         my $color_sets = &cluster_genes($fig_or_sprout,$cgi,\@all_pegs,$peg);  
         &set_colors_text_and_links($gg,\@all_pegs,$color_sets);  
         ################################### add commentary capability  
         my $sprout = $cgi->param('SPROUT') ? 1 : "";  
   
         my($gene,$n,%how_many,$val,@vals,$x);  
         my($i,$map);  
         @vals = ();  
         for ($i=(@$gg - 1); ($i >= 0); $i--) {  
             my @vals1 = ();  
             $map = $gg->[$i];  
             my $found = 0;  
             my $got_red = 0;  
             undef %how_many;  
             foreach $gene (@{$map->[3]}) {  
                 if (($x = $gene->[3]) ne "grey") {  
                     $n = $gene->[4];  
                     if ($n == 1) { $got_red = 1 }  
                     $how_many{$n}++;  
                     $gene->[5] =~ /(fig\|\d+\.\d+\.peg\.\d+)/;  
                     $val = join("@",($n,$i,$1,$map->[0]->[0],$how_many{$n}));  
                     push(@vals1,$val);  
                     $found++;  
                 }  
             }  
   
             if (! $got_red) {  
                 splice(@$gg,$i,1);  
             } else {  
                 push(@vals,@vals1);  
             }  
         }  
   
         if (@$gg < 2) {  
             push(@$html,$cgi->h3("No alignable regions in close genomes"));  
             &add_previous_next($html,undef,undef,$fig_or_sprout,$peg,$user,$sz_region,$num_close);  
         } else {  
   
             my @parm_reset_form = ($cgi->hr);  
             push(@parm_reset_form,$cgi->start_form(-action => &cgi_url . "/protein.cgi" ),  
                               $cgi->hidden(-name => 'new_framework', -value => $new_framework));  
             my $param;  
             foreach $param ($cgi->param()) {  
                 next if (($param eq "sz_region") || ($param eq "num_close"));  
                 push(@parm_reset_form,$cgi->hidden(-name => $param, -value => $cgi->param($param)));  
             }  
             push(@parm_reset_form,  
                               "size region: ",  
                               $cgi->textfield(-name => 'sz_region', -size =>  10, -value => $sz_region, -override => 1),  
                               "&nbsp; &nbsp; &nbsp; &nbsp; &nbsp; ",  
                                       "Number genomes: ",  
                                       $cgi->textfield(-name => 'num_close', -size => 4, -value => $num_close, -override => 1),  
                                       $cgi->br,  
                                       $cgi->submit('Resubmit')  
                     );  
             push(@parm_reset_form,$cgi->end_form);  
             push(@$html,@parm_reset_form);  
   
             my @commentary_form = ();  
             my $ctarget = "window$$";  
             push(@commentary_form,$cgi->start_form(-target => $ctarget,  
                                -action => &cgi_url . "/chromosomal_clusters.cgi"  
                                ));  
   
             push(@commentary_form,$cgi->hidden(-name => 'SPROUT', -value => $sprout),  
                               $cgi->hidden(-name => "request", -value => "show_commentary"),  
                               $cgi->hidden(-name => "new_framework", -value => $new_framework));  
             push(@commentary_form,$cgi->hidden(-name => "prot", -value => $peg));  
             push(@commentary_form,$cgi->hidden(-name => "uni", -value => 1));  
             push(@commentary_form,$cgi->hidden(-name => "user", -value => $user));  
             push(@commentary_form,$cgi->hidden(-name => "show", -value => [@vals]));  
             push(@commentary_form,$cgi->submit('commentary'));  
             push(@commentary_form,$cgi->end_form());  
             push(@$html,@commentary_form);  
             push(@$html,@{ &GenoGraphics::render($gg,700,4,0,2) });  
   
             my($prev,$next);  
             my $map1 = $gg->[0]->[3];  
             if (($map1->[0]->[5] =~ /(fig\|\d+\.\d+\.peg\.\d+)/) && ($1 ne $peg))  
             {  
                 $prev = $1;  
             }  
             if (($map1->[$#{$map1}]->[5] =~ /(fig\|\d+\.\d+\.peg\.\d+)/) && ($1 ne $peg))  
             {  
                 $next = $1;  
             }  
             &add_previous_next($html,$prev,$next,$fig_or_sprout,$peg,$user,$sz_region,$num_close);  
         }  
   
         if (! $cgi->param('SPROUT'))  
         {  
             push @$html, &FIGGenDB::linkClusterGenDB($peg);  
         }  
     }  
     else  
     {  
         push(@$html,$cgi->h3("No alignable regions in close genomes"));  
         &add_previous_next($html,undef,undef,$fig_or_sprout,$peg,$user,$sz_region,$num_close);  
     }  
 }  
   
 sub add_previous_next {  
     my($html,$prev,$next,$fig_or_sprout,$peg,$user,$sz_region,$num_close) = @_;  
   
     my $new_framework = $cgi->param('new_framework') ? 1 : 0;  
   
     push(@$html,$cgi->br);  
     if ($prev)  
     {  
         push(@$html,"<a href=protein.cgi?prot=$prev&compare_region=1&user=$user&sz_region=$sz_region&num_close=$num_close&new_framework=$new_framework>previous</a>");  
     }  
     else  
     {  
         my $genome = &FIG::genome_of($peg);  
         my @contigs = $fig_or_sprout->contigs_of($genome);  
         my @loc = $fig_or_sprout->feature_location($peg);  
         my $contig;  
         if ((@loc > 0) && ($loc[0] =~ /^(\S+)_\d+_\d+$/))  
         {  
             $contig = $1;  
         }  
         my $i;  
         for ($i=0; ($i < @contigs) && ($contig ne $contigs[$i]); $i++) {}  
         if (($i > 0) && ($i < @contigs))  
         {  
             $contig = $contigs[$i-1];  
             my($genes,undef,undef) = $fig_or_sprout->genes_in_region($genome,$contig,1,10000);  
             my @genes = grep { $fig_or_sprout->ftype($_) eq "peg" } @$genes;  
   
             if (@genes > 0)  
             {  
                 my $gene = $genes[0];  
                 push(@$html,"<a href=protein.cgi?prot=$gene&compare_region=1&user=$user&sz_region=$sz_region&num_close=$num_close&new_framework=$new_framework>previous</a>");  
             }  
         }  
     }  
   
     if ($next)  
     {  
         push(@$html,"&nbsp;&nbsp;&nbsp;&nbsp;&nbsp; <a href=protein.cgi?prot=$next&compare_region=1&user=$user&sz_region=$sz_region&num_close=$num_close&new_framework=$new_framework>next</a>");  
     }  
     else  
     {  
         my $genome = &FIG::genome_of($peg);  
         my @contigs = $fig_or_sprout->contigs_of($genome);  
         my @loc = $fig_or_sprout->feature_location($peg);  
         my $contig;  
         if ((@loc > 0) && ($loc[0] =~ /^(\S+)_\d+_\d+$/))  
         {  
             $contig = $1;  
         }  
         my $i;  
         for ($i=0; ($i < @contigs) && ($contig ne $contigs[$i]); $i++) {}  
         if (($i >= 0) && ($i < $#contigs))  
         {  
             $contig = $contigs[$i+1];  
             my($genes,undef,undef) = $fig_or_sprout->genes_in_region($genome,$contig,1,10000);  
             my @genes = grep { $fig_or_sprout->ftype($_) eq "peg" } @$genes;  
   
             if (@genes > 0)  
             {  
                 my $gene = $genes[0];  
                 push(@$html,"&nbsp;&nbsp;&nbsp;&nbsp;&nbsp; <a href=protein.cgi?prot=$gene&compare_region=1&user=$user&sz_region=$sz_region&num_close=$num_close&new_framework=$new_framework>next</a>");  
             }  
         }  
     }  
 }  
   
   
 sub closest_pegs {  
     my($fig_or_sprout,$cgi,$peg,$n) = @_;  
     my($id2,$d,$peg2,$i);  
   
     my @closest;  
     if ($cgi->param('SPROUT'))  
     {  
         @closest = map { $_->[0] } sort { $a->[1] <=> $b->[1] } &bbhs($fig_or_sprout,$peg, 1.0e-10);  
     }  
     else  
     {  
         @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));  
     }  
   
     if (@closest >= ($n-1))  
     {  
         $#closest = $n-2 ;  
     }  
     my %closest = map { $_ => 1 } @closest;  
   
     my @pinned_to = grep { ($_ ne $peg) && (! $closest{$_}) } &in_pch_pin_with($fig_or_sprout,$peg);  
     my $g1 = &genome_of($peg);  
     @pinned_to = map {$_->[1] }  
                  sort { $a->[0] <=> $b->[0] }  
                  map { $peg2 = $_; $d = &crude_estimate_of_distance($fig_or_sprout,$g1,&genome_of($peg2)); [$d,$peg2] }  
                  @pinned_to;  
   
     if (@closest == ($n-1))  
     {  
         $#closest = ($n - 2) - &FIG::min(scalar @pinned_to,int($n/2));  
         for ($i=0; ($i < @pinned_to) && (@closest < ($n-1)); $i++)  
         {  
             if (! $closest{$pinned_to[$i]})  
             {  
             $closest{$pinned_to[$i]} = 1;  
             push(@closest,$pinned_to[$i]);  
             }  
         }  
     }  
     return @closest;  
 }  
   
 sub build_maps {  
     my($fig_or_sprout,$pinned_pegs,$all_pegs,$sz_region) = @_;  
     my($gg,$loc,$contig,$beg,$end,$mid,$min,$max,$genes,$feat,$fid);  
     my($contig1,$beg1,$end1,$map,$peg);  
   
     $gg = [];  
     foreach $peg (@$pinned_pegs) {  
         $loc = &feature_locationS($fig_or_sprout,$peg);  
         ($contig,$beg,$end) = &boundaries_of($fig_or_sprout,$loc);  
         if ($contig && $beg && $end) {  
             $mid = int(($beg + $end) / 2);  
             $min = int($mid - ($sz_region / 2));  
             $max = int($mid + ($sz_region / 2));  
             $genes = [];  
             ($feat,undef,undef) = &genes_in_region($fig_or_sprout,$cgi,&genome_of($peg),$contig,$min,$max);  
             foreach $fid (@$feat) {  
                 ($contig1,$beg1,$end1) = &boundaries_of($fig_or_sprout,&feature_locationS($fig_or_sprout,$fid));  
                 $beg1 = &in_bounds($min,$max,$beg1);  
                 $end1 = &in_bounds($min,$max,$end1);  
                 my $aliases = join( ', ', &feature_aliasesL($fig_or_sprout,$fid) );  
                 my $function = &function_ofS($fig_or_sprout,$fid);  
                 my ( $uniprot ) = $aliases =~ /(uni\|[^,]+)/;  
         my $user = $cgi->param('user');  
                 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" : ()  
                                );  
   
                 my $sprout = $cgi->param('SPROUT') ? 1 : "";  
         my $new_framework = $cgi->param('new_framework') ? 1 : 0;  
   
                 my $fmg;  
                 if ($sprout)  
                 {  
                     $fmg = "<a href=\&quot;protein.cgi?SPROUT=$sprout&compare_region=1\&num_close=".$cgi->param('num_close'). "\&prot=$fid\&user=$user&new_framework=$new_framework\&quot>show</a>";  
                 }  
                 else  
                 {  
                     $fmg = join ('<br/>', "<a href=\&quot;protein.cgi?SPROUT=$sprout&compare_region=1\&num_close=".$cgi->param('num_close'). "\&prot=$fid\&user=$user&new_framework=$new_framework\&quot>show</a>",  
                             "<a onClick=\&quot;setValue('bound1', '$fid'); return false;\&quot;>set bound 1</a>",  
                             "<a onClick=\&quot;setValue('bound2', '$fid'); return false;\&quot;>set bound 2</a>",  
                             "<a onClick=\&quot;setValue('candidates', '$fid'); return false;\&quot;>set candidate</a>");  
                 }  
                 push(@$genes,[&min($beg1,$end1),  
                           &max($beg1,$end1),  
                           ($beg1 < $end1) ? "rightArrow" : "leftArrow",  
                           "grey",  
                           "",  
                           $fid,  
                           $info, $fmg]);  
   
                 if ($fid =~ /peg/) {  
                     push(@$all_pegs,$fid);  
                 }  
             }  
   
             #  Sequence title can be replaced by [ title, url, popup_text, menu, popup_title ]  
   
             my $org = org_of( $fig_or_sprout, $peg );  
             my $desc = "Genome: $org<br />Contig: $contig";  
             $map = [ [ FIG::abbrev( $org ), undef, $desc, undef, 'Contig' ],  
                      0,  
                      $max+1 - $min,  
                      ($beg < $end) ? &decr_coords($genes,$min) : &flip_map($genes,$min,$max)  
                    ];  
             push(@$gg,$map);  
         }  
     }  
     &GenoGraphics::disambiguate_maps($gg);  
     return $gg;  
 }  
   
 sub in {  
     my($x,$xL) = @_;  
     my($i);  
   
     for ($i=0; ($i < @$xL) && ($x != $xL->[$i]); $i++) {}  
     return ($i < @$xL);  
 }  
   
 sub in_bounds {  
     my($min,$max,$x) = @_;  
   
     if     ($x < $min)     { return $min }  
     elsif  ($x > $max)     { return $max }  
     else                   { return $x   }  
 }  
   
 sub decr_coords {  
     my($genes,$min) = @_;  
     my($gene);  
   
     foreach $gene (@$genes) {  
         $gene->[0] -= $min;  
         $gene->[1] -= $min;  
     }  
     return $genes;  
 }  
   
 sub flip_map {  
     my($genes,$min,$max) = @_;  
     my($gene);  
   
     foreach $gene (@$genes) {  
         ($gene->[0],$gene->[1]) = ($max - $gene->[1],$max - $gene->[0]);  
         $gene->[2] = ($gene->[2] eq "rightArrow") ? "leftArrow" : "rightArrow";  
     }  
     return $genes;  
 }  
   
 sub cluster_genes {  
     my($fig_or_sprout,$cgi,$all_pegs,$peg) = @_;  
     my(%seen,$i,$j,$k,$x,$cluster,$conn,$pegI,$red_set);  
   
     my @color_sets = ();  
   
     $conn = &get_connections_by_similarity($fig_or_sprout,$cgi,$all_pegs);  
   
     for ($i=0; ($i < @$all_pegs); $i++) {  
         if ($all_pegs->[$i] eq $peg) { $pegI = $i }  
         if (! $seen{$i}) {  
             $cluster = [$i];  
             $seen{$i} = 1;  
             for ($j=0; ($j < @$cluster); $j++) {  
                 $x = $conn->{$cluster->[$j]};  
                 foreach $k (@$x) {  
                     if (! $seen{$k}) {  
                         push(@$cluster,$k);  
                         $seen{$k} = 1;  
                     }  
                 }  
             }  
   
             if ((@$cluster > 1) || ($cluster->[0] eq $pegI)) {  
                 push(@color_sets,$cluster);  
             }  
         }  
     }  
     for ($i=0; ($i < @color_sets) && (! &in($pegI,$color_sets[$i])); $i++) {}  
     $red_set = $color_sets[$i];  
     splice(@color_sets,$i,1);  
     @color_sets = sort { @$b <=> @$a } @color_sets;  
     unshift(@color_sets,$red_set);  
   
     my $color_sets = {};  
     for ($i=0; ($i < @color_sets); $i++) {  
         foreach $x (@{$color_sets[$i]}) {  
             $color_sets->{$all_pegs->[$x]} = $i;  
         }  
     }  
     return $color_sets;  
 }  
   
 sub get_connections_by_similarity {  
     my($fig_or_sprout,$cgi,$all_pegs) = @_;  
   
     if ($cgi->param('SPROUT'))  
     {  
         return &get_connections_by_similarity_SPROUT($fig_or_sprout,$all_pegs);  
     }  
     else  
     {  
         return &get_connections_by_similarity_SEED($fig_or_sprout,$all_pegs);  
     }  
 }  
   
 sub get_connections_by_similarity_SPROUT {  
     my($fig_or_sprout,$all_pegs) = @_;  
     my(%in,$i,$j,$peg1,$peg2);  
   
     my $conn = {};  
   
     for ($i=0; $i < @$all_pegs; $i++)  
     {  
     $in{$all_pegs->[$i]} = $i;  
     }  
   
     foreach $peg1 (@$all_pegs)  
     {  
     $i = $in{$peg1};  
     foreach $peg2 (map { $_->[0] } bbhs($fig_or_sprout,$peg1,1.0e-10))  
     {  
         $j = $in{$peg2};  
         if (defined($i) && defined($j))  
         {  
         push(@{$conn->{$i}},$j);  
         }  
     }  
     }  
     return $conn;  
 }  
   
 sub get_connections_by_similarity_SEED {  
     my($fig_or_sprout,$all_pegs) = @_;  
     my($i,$j,$tmp,$peg,%pos_of);  
     my($sim,%conn,$x,$y);  
   
     for ($i=0; ($i < @$all_pegs); $i++) {  
         $tmp = &maps_to_id($fig_or_sprout,$all_pegs->[$i]);  
         push(@{$pos_of{$tmp}},$i);             # map the representative in nr to subscript in all_pegs  
         if ($tmp ne $all_pegs->[$i]) {  
             push(@{$pos_of{$all_pegs->[$i]}},$i);  
         }  
     }  
   
     foreach $y (keys(%pos_of)) {  
         $x = $pos_of{$y};  
         for ($i=0; ($i < @$x); $i++) {  
             for ($j=$i+1; ($j < @$x); $j++) {  
                 push(@{$conn{$x->[$i]}},$x->[$j]);  
                 push(@{$conn{$x->[$j]}},$x->[$i]);  
             }  
         }  
     }  
   
     for ($i=0; ($i < @$all_pegs); $i++) {  
         foreach $sim (&sims($fig_or_sprout,$all_pegs->[$i],500,1.0e-5,"raw")) {  
             if (defined($x = $pos_of{$sim->id2})) {  
                 foreach $y (@$x) {  
                     push(@{$conn{$i}},$y);  
                 }  
             }  
         }  
     }  
     return \%conn;  
 }  
   
 sub set_colors_text_and_links {  
     my($gg,$all_pegs,$color_sets) = @_;  
     my($map,$gene,$peg,$color);  
   
     foreach $map (@$gg) {  
         foreach $gene (@{$map->[3]}) {  
             $peg = $gene->[5];  
             if (defined($color = $color_sets->{$peg})) {  
                 $gene->[3] = ($color == 0) ? "red" : "color$color";  
                 $gene->[4] = $color + 1;  
             }  
             $gene->[5] = &peg_url($cgi,$peg);  
         }  
     }  
 }  
   
 sub peg_url {  
     my($cgi,$peg) = @_;  
   
     my $prot = $cgi->param('prot');  
     $cgi->delete('prot');  
     my $url  = $cgi->url(-relative => 1, -query => 1, -path_info => 1) . "&prot=$peg&compare_region=1";  
     $cgi->delete('prot');  
     $cgi->param(-name => 'prot', -value => $prot);  
   
     return $url;  
 }  
   
 sub possible_extensions {  
     my($peg,$closest_pegs) = @_;  
     my($g,$sim,$id2,$peg1,%poss);  
   
     $g = &genome_of($peg);  
   
     foreach $peg1 (@$closest_pegs) {  
         if ($g ne &genome_of($peg1)) {  
             foreach $sim (&sims($fig_or_sprout,$peg1,500,1.0e-5,"all")) {  
                 $id2 = $sim->id2;  
                 if (($id2 ne $peg) && ($id2 =~ /^fig\|$g\./) && &possibly_truncated($fig_or_sprout,$id2)) {  
                     $poss{$id2} = 1;  
                 }  
             }  
         }  
     }  
     return keys(%poss);  
 }  
   
 sub display_page {  
     my($fig_or_sprout,$cgi,$html) = @_;  
   
     if (ref($html) eq "ARRAY") {  
         if ($traceData) {  
             push @$html, QTrace('html');  
         }  
         &HTML::show_page($cgi,$html);  
     } else {  
         Trace(Dumper($html)) if T(2);  
         if ($cgi->param('SPROUT')) {  
             if ($traceData) {  
                 $html->{tracings} = "<h3>Trace Messages</h3>\n" . QTrace('html');  
             } else {  
                 $html->{tracings} = "\n";  
             }  
             print "Content-Type: text/html\n";  
             print "\n";  
             my $templ;  
             if ($FIG_Config::template_url) {  
                 # Here we have an external template. As long as we're being  
                 # fancy, we will tailor the template to the request type.  
                 my $type = $Global_request_type;  
                 if (! $type) {  
                     # No request, so use the default template.  
                     $type = "";  
                 } else {  
                     # Request provided, so fix up the request type to provide  
                     # a good name.  
                     $type =~ s/\s/_/g;  
                     # Add an underscore at the front to separate it from the  
                     # "tmpl" part of the name.  
                     $type = "_$type";  
                 }  
                 $templ = "$FIG_Config::template_url/Protein_tmpl$type.php";  
                 Trace("Template will be $templ.") if T(3);  
             } else {  
                 $templ = "<$FIG_Config::fig/CGI/Html/Protein_tmpl.html";  
             }  
             print PageBuilder::Build($templ, $html,"Html");  
         } else {  
             my $gathered = [];  
   
             my $section;  
             foreach $section (qw( javascript  
                                     general  
                                     translate_status  
                                     contig_context  
                                     context_graphic  
                                     subsys_connections  
                                     assign_for_equiv_prots  
                                     links  
                                     services  
                                     kv_pairs  
                                     compare_region  
                                     similarities  
                                     tools  
                                 ) ) {  
                 if (@{$html->{$section}} > 0) {  
                     push(@$gathered,@{$html->{$section}});  
                     push(@$gathered,$cgi->hr);  
                 }  
             }  
             pop @$gathered;  
             &HTML::show_page($cgi,$gathered);  
         }  
     }  
 }  
   
 sub show_html_followed_by_initial {  
     my($fig_or_sprout,$cgi,$html,$prot) = @_;  
   
     my $loc_url = $cgi->url(-absolute => 1, -full => 1, -query => 1, -path_info => 1);  
   
     #  
     # Truncate it in case the url is humongous (like it will be for the pins commentary page).  
     #  
   
     $loc_url = substr($loc_url, 0, 100);  
   
     my %html = ( general               => [],  
                 contig_context        => [],  
                 context_graphic       => [],  
                 subsys_connections    => [],  
                 links                 => [],  
                 services              => [],  
                 translate_status      => [],  
                 tools                 => [],  
                 kv_pairs              => [],  
                 similarities          => [],  
                 assign_for_equiv_prots => [],  
                 javascript            => [],  
                 compare_region        => [],  
                 location_tag => [uri_escape($loc_url)],  
            );  
   
     push(@{$html{general}},@$html);  
     $html = \%html;  
     &show_initial($fig_or_sprout,$cgi,$html,$prot);  
     return $html;  
 }  
   
 sub translation_piece {  
     my($fig_or_sprout,$cgi,$html) = @_;  
   
     my $msg;  
     my $url = $cgi->url(-relative => 1, -query => 1, -path_info => 1);  
     if ($cgi->param('translate')) {  
         $url =~ s/[;&]translate(=[^;&])?//i or $url =~ s/translate(=[^;&])?[;&]//i;  
         $msg = "Turn Off Function Translation";  
     } else {  
         $url .= "&translate=1";  
         $msg = "Translate Function Assignments";  
     }  
     push(@$html, "<a href=\"$url\">$msg</a><br>\n");  
 }  
   
   
 #######################################################################################  
 sub sims {  
     my( $fig_or_sprout, $peg, $max, $cutoff, $select, $expand, $group_by_genome, $filters ) = @_;  
     my( @tmp, $id, $genome, @genomes, %sims, $sim );  
   
     @tmp = $fig_or_sprout->sims( $peg, $max, $cutoff, $select, $expand, $filters );  
     if (! $group_by_genome)  { return @tmp };  
   
     #  Collect all sims from genome with the first occurance of the genome:  
   
     foreach $sim ( @tmp )  
     {  
         $id = $sim->id2;  
         $genome = ($id =~ /^fig\|(\d+\.\d+)\.peg\.\d+/) ? $1 : $id;  
         if (! defined( $sims{ $genome } ) ) { push @genomes, $genome }  
         push @{ $sims{ $genome } }, $sim;  
     }  
     return map { @{ $sims{$_} } } @genomes;  
 }  
   
 sub in_cluster_with {  
     my($fig_or_sprout,$cgi,$peg) = @_;  
     my %in_cluster;  
   
     if ($fig_or_sprout->table_exists('fc_pegs') && $fig_or_sprout->is_complete(&FIG::genome_of($peg)))  
     {  
         %in_cluster = map { $_->[0] => &ev_link($cgi,$_->[0],$_->[1]) } $fig_or_sprout->coupled_to($peg);  
         if (keys(%in_cluster) > 0)  
         {  
             $in_cluster{$peg} = "";  
         }  
         elsif ($cgi->param('fc'))  
         {  
             %in_cluster = map { $_ => "" } $fig_or_sprout->in_cluster_with($peg);  
             if (keys(%in_cluster) == 1)  
             {  
             my @tmp = keys(%in_cluster);  
             delete $in_cluster{$tmp[0]};  
             }  
         }  
     }  
     return \%in_cluster;  
 }  
   
 sub evidence_codes {  
     my($fig_or_sprout,$peg) = @_;  
   
     if ($peg !~ /^fig\|\d+\.\d+\.peg\.\d+$/) { return "" }  
   
     my @codes = grep { $_->[1] =~ /^evidence_code/i } $fig_or_sprout->get_attributes($peg);  
     return (@codes > 0) ? map { $_->[2] } @codes : ();  
 }  
   
 sub evidence_codes_link {  
     my($cgi) = @_;  
     return "<A href=\"Html/evidence_codes.html\" target=\"SEED_or_SPROUT_help\">Ev</A>";  
 }  
187    
188    sub show_standard {
189    
 sub evidence_codes_explain {  
  my($ec)=@_;  
  return unless ($ec);  
   
  $ec=uc($ec);  
  return "IDA: Inferred from Direct Assay" if ($ec eq "IDA");  
  return "IGI: Inferred from Genetic Interaction" if ($ec eq "IGI");  
  return "TAS: Traceable Author Statement" if ($ec eq "TAS");  
  return "ISU: in subsystem unique" if ($ec eq "ISU");  
  return "$ec: in subsystem duplicates" if ($ec =~ /IDU/);  
  return "$ec: in cluster with" if ($ec =~ /ICW/);  
  return "$ec: unknown!";  
190  }  }

Legend:
Removed from v.1.217  
changed lines
  Added in v.1.218

MCS Webmaster
ViewVC Help
Powered by ViewVC 1.0.3