[Bio] / Sprout / SearchHelper.pm Repository:
ViewVC logotype

Diff of /Sprout/SearchHelper.pm

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

revision 1.19, Mon Nov 20 05:54:09 2006 UTC revision 1.33, Tue Jun 19 21:28:21 2007 UTC
# Line 19  Line 19 
19      use FeatureQuery;      use FeatureQuery;
20      use URI::Escape;      use URI::Escape;
21      use PageBuilder;      use PageBuilder;
22        use POSIX;
23    
24  =head1 Search Helper Base Class  =head1 Search Helper Base Class
25    
# Line 88  Line 89 
89  TRUE if this is a feature-filtered search, else FALSE. B<NOTE> that this  TRUE if this is a feature-filtered search, else FALSE. B<NOTE> that this
90  field is updated by the B<FeatureQuery> object.  field is updated by the B<FeatureQuery> object.
91    
92    =item extraPos
93    
94    Hash indicating which extra columns should be put at the end. Extra columns
95    not mentioned in this hash are put at the beginning. Use the L</SetExtraPos>
96    method to change this option.
97    
98  =back  =back
99    
100  =head2 Adding a new Search Tool  =head2 Adding a new Search Tool
# Line 230  Line 237 
237  in the output, or you could search for something that's not a feature at all. The  in the output, or you could search for something that's not a feature at all. The
238  above code is just a loose framework.  above code is just a loose framework.
239    
240    In addition to the finding and filtering, it is necessary to send status messages
241    to the output so that the user does not get bored waiting for results. The L</PrintLine>
242    method performs this function. The single parameter should be text to be
243    output to the browser. In general, you'll invoke it as follows.
244    
245        $self->PrintLine("...my message text...<br />");
246    
247    The break tag is optional. When the Find method gets control, a paragraph will
248    have been started so that everything is XHTML-compliant.
249    
250  If you wish to add your own extra columns to the output, use the B<AddExtraColumns>  If you wish to add your own extra columns to the output, use the B<AddExtraColumns>
251  method of the feature query object.  method of the feature query object.
252    
# Line 251  Line 268 
268    
269  =head3 new  =head3 new
270    
271  C<< my $shelp = SearchHelper->new($query); >>  C<< my $shelp = SearchHelper->new($cgi); >>
272    
273  Construct a new SearchHelper object.  Construct a new SearchHelper object.
274    
# Line 272  Line 289 
289      my $session_id = $cgi->param("SessionID");      my $session_id = $cgi->param("SessionID");
290      my $type = "old";      my $type = "old";
291      if (! $session_id) {      if (! $session_id) {
292            Trace("No session ID found.") if T(3);
293          # Here we're starting a new session. We create the session ID and          # Here we're starting a new session. We create the session ID and
294          # store it in the query object.          # store it in the query object.
295          $session_id = NewSessionID();          $session_id = NewSessionID();
296          $type = "new";          $type = "new";
297          $cgi->param(-name => 'SessionID', -value => $session_id);          $cgi->param(-name => 'SessionID', -value => $session_id);
298        } else {
299            Trace("Session ID is $session_id.") if T(3);
300      }      }
301      # Compute the subclass name.      # Compute the subclass name.
302      my $subClass;      my $subClass;
# Line 307  Line 327 
327                    genomeList => undef,                    genomeList => undef,
328                    genomeParms => [],                    genomeParms => [],
329                    filtered => 0,                    filtered => 0,
330                      extraPos => {},
331                   };                   };
332      # Bless and return it.      # Bless and return it.
333      bless $retVal, $class;      bless $retVal, $class;
# Line 367  Line 388 
388      return ($self->{type} eq 'new');      return ($self->{type} eq 'new');
389  }  }
390    
391    =head3 SetExtraPos
392    
393    C<< $shelp->SetExtraPos(@columnMap); >>
394    
395    Indicate whether the extra columns should be in the front (C<0>) or end (C<1>) columns of the results.
396    
397    =over 4
398    
399    =item columnMap
400    
401    A list of extra columns to display at the end.
402    
403    =back
404    
405    =cut
406    
407    sub SetExtraPos {
408        # Get the parameters.
409        my ($self, @columnMap) = @_;
410        # Convert the column map to a hash.
411        my %map = map { $_ => 1 } @columnMap;
412        # Save a reference to it.
413        $self->{extraPos} = \%map;
414    }
415    
416  =head3 ID  =head3 ID
417    
418  C<< my $sessionID = $shelp->ID(); >>  C<< my $sessionID = $shelp->ID(); >>
# Line 669  Line 715 
715      # Check for a first-call situation.      # Check for a first-call situation.
716      if (! defined $self->{cols}) {      if (! defined $self->{cols}) {
717          Trace("Setting up the columns.") if T(3);          Trace("Setting up the columns.") if T(3);
718          # Here we need to set up the column information. Start with the extras,          # Tell the user what's happening.
719          # sorted by column name.          $self->PrintLine("Creating output columns.<br />");
720          my @colNames = ();          # Here we need to set up the column information. First we accumulate the extras,
721            # sorted by column name and separate by whether they go in the beginning or the
722            # end.
723            my @xtraNamesFront = ();
724            my @xtraNamesEnd = ();
725            my $xtraPosMap = $self->{extraPos};
726          for my $col (sort keys %{$extraCols}) {          for my $col (sort keys %{$extraCols}) {
727              push @colNames, "X=$col";              if ($xtraPosMap->{$col}) {
728                    push @xtraNamesEnd, "X=$col";
729                } else {
730                    push @xtraNamesFront, "X=$col";
731                }
732          }          }
733            # Set up the column name array.
734            my @colNames = ();
735            # Put in the extra columns that go in the beginning.
736            push @colNames, @xtraNamesFront;
737          # Add the default columns.          # Add the default columns.
738          push @colNames, $self->DefaultFeatureColumns();          push @colNames, $self->DefaultFeatureColumns();
739          # Add any additional columns requested by the feature filter.          # Add any additional columns requested by the feature filter.
740          push @colNames, FeatureQuery::AdditionalColumns($self);          push @colNames, FeatureQuery::AdditionalColumns($self);
741            # If extras go at the end, put them in here.
742            push @colNames, @xtraNamesEnd;
743            Trace("Full column list determined.") if T(3);
744          # Save the full list.          # Save the full list.
745          $self->{cols} = \@colNames;          $self->{cols} = \@colNames;
746          # Write out the column headers. This also prepares the cache file to receive          # Write out the column names. This also prepares the cache file to receive
747          # output.          # output.
748          $self->WriteColumnHeaders(map { $self->FeatureColumnTitle($_) } @{$self->{cols}});          Trace("Writing column headers.") if T(3);
749            $self->WriteColumnHeaders(@{$self->{cols}});
750            Trace("Column headers written.") if T(3);
751      }      }
752      # Get the feature ID.      # Get the feature ID.
753      my $fid = $fd->FID();      my $fid = $fd->FID();
754      # Loop through the column headers, producing the desired data.      # Loop through the column headers, producing the desired data. The first column
755      my @output = ();      # is the feature ID. The feature ID does not show up in the output: its purpose
756        # is to help the various output formatters.
757        my @output = ($fid);
758      for my $colName (@{$self->{cols}}) {      for my $colName (@{$self->{cols}}) {
759          push @output, $self->FeatureColumnValue($colName, $record, $extraCols);          push @output, $self->FeatureColumnValue($colName, $record, $extraCols);
760      }      }
# Line 726  Line 792 
792      # Write the column headers and close the file.      # Write the column headers and close the file.
793      Tracer::PutLine($handle1, \@colNames);      Tracer::PutLine($handle1, \@colNames);
794      close $handle1;      close $handle1;
795        Trace("Column headers are: " . join("; ", @colNames) . ".") if T(3);
796      # Now open the sort pipe and save the file handle. Note how we append the      # Now open the sort pipe and save the file handle. Note how we append the
797      # sorted data to the column header row already in place. The output will      # sorted data to the column header row already in place. The output will
798      # contain a sort key followed by the real columns. The sort key is      # contain a sort key followed by the real columns. The sort key is
# Line 759  Line 826 
826      my ($self, $key, @colValues) = @_;      my ($self, $key, @colValues) = @_;
827      # Write them to the cache file.      # Write them to the cache file.
828      Tracer::PutLine($self->{fileHandle}, [$key, @colValues]);      Tracer::PutLine($self->{fileHandle}, [$key, @colValues]);
829        Trace("Column data is " . join("; ", $key, @colValues) . ".") if T(4);
830  }  }
831    
832  =head3 CloseSession  =head3 CloseSession
# Line 777  Line 845 
845          # We found one, so close it.          # We found one, so close it.
846          Trace("Closing session file.") if T(2);          Trace("Closing session file.") if T(2);
847          close $self->{fileHandle};          close $self->{fileHandle};
848            # Tell the user.
849            my $cgi = $self->Q();
850            $self->PrintLine("Output formatting complete.<br />");
851      }      }
852  }  }
853    
# Line 805  Line 876 
876    
877  =head3 OrganismData  =head3 OrganismData
878    
879  C<< my ($orgName, $group) = $shelp->Organism($genomeID); >>  C<< my ($orgName, $group, $domain) = $shelp->Organism($genomeID); >>
880    
881  Return the name and status of the organism corresponding to the specified genome ID.  Return the name and status of the organism corresponding to the specified genome ID.
882  For performance reasons, this information is cached in a special hash table, so we  For performance reasons, this information is cached in a special hash table, so we
# Line 819  Line 890 
890    
891  =item RETURN  =item RETURN
892    
893  Returns a list of two items. The first item in the list is the organism name,  Returns a list of three items. The first item in the list is the organism name,
894  and the second is the name of the NMPDR group, or an empty string if the  and the second is the name of the NMPDR group, or an empty string if the
895  organism is not in an NMPDR group.  organism is not in an NMPDR group. The third item is the organism's domain.
896    
897  =back  =back
898    
# Line 831  Line 902 
902      # Get the parameters.      # Get the parameters.
903      my ($self, $genomeID) = @_;      my ($self, $genomeID) = @_;
904      # Declare the return variables.      # Declare the return variables.
905      my ($orgName, $group);      my ($orgName, $group, $domain);
906      # Check the cache.      # Check the cache.
907      my $cache = $self->{orgs};      my $cache = $self->{orgs};
908      if (exists $cache->{$genomeID}) {      if (exists $cache->{$genomeID}) {
909          ($orgName, $group) = @{$cache->{$genomeID}};          ($orgName, $group, $domain) = @{$cache->{$genomeID}};
910      } else {      } else {
911          # Here we have to use the database.          # Here we have to use the database.
912          my $sprout = $self->DB();          my $sprout = $self->DB();
913          my ($genus, $species, $strain, $group) = $sprout->GetEntityValues('Genome', $genomeID,          my ($genus, $species, $strain, $group, $taxonomy) = $sprout->GetEntityValues('Genome', $genomeID,
914                                                      ['Genome(genus)', 'Genome(species)',                                                      ['Genome(genus)', 'Genome(species)',
915                                                       'Genome(unique-characterization)',                                                       'Genome(unique-characterization)',
916                                                       'Genome(primary-group)']);                                                                   'Genome(primary-group)',
917                                                                     'Genome(taxonomy)']);
918          # Format and cache the name and display group.          # Format and cache the name and display group.
919          ($orgName, $group) = $self->SaveOrganismData($group, $genomeID, $genus, $species,          ($orgName, $group, $domain) = $self->SaveOrganismData($group, $genomeID, $genus, $species,
920                                                              $strain);                                                                $strain, $taxonomy);
921      }      }
922      # Return the result.      # Return the result.
923      return ($orgName, $group);      return ($orgName, $group, $domain);
924  }  }
925    
926  =head3 Organism  =head3 Organism
# Line 876  Line 948 
948      # Get the parameters.      # Get the parameters.
949      my ($self, $genomeID) = @_;      my ($self, $genomeID) = @_;
950      # Get the organism data.      # Get the organism data.
951      my ($retVal, $group) = $self->OrganismData($genomeID);      my ($retVal) = $self->OrganismData($genomeID);
952      # Return the result.      # Return the result.
953      return $retVal;      return $retVal;
954  }  }
# Line 956  Line 1028 
1028    
1029  =head3 ComputeFASTA  =head3 ComputeFASTA
1030    
1031  C<< my $fasta = $shelp->ComputeFASTA($desiredType, $sequence); >>  C<< my $fasta = $shelp->ComputeFASTA($desiredType, $sequence, $flankingWidth); >>
1032    
1033  Parse a sequence input and convert it into a FASTA string of the desired type.  Parse a sequence input and convert it into a FASTA string of the desired type with
1034    the desired flanking width.
1035    
1036  =over 4  =over 4
1037    
# Line 974  Line 1047 
1047  if the input does not begin with a greater-than sign (FASTA label line), a default label  if the input does not begin with a greater-than sign (FASTA label line), a default label
1048  line will be provided.  line will be provided.
1049    
1050    =item flankingWidth
1051    
1052    If the DNA FASTA of a feature is desired, the number of base pairs to either side of the
1053    feature that should be included. Currently we can't do this for Proteins because the
1054    protein translation of a feature doesn't always match the DNA and is taken directly
1055    from the database.
1056    
1057  =item RETURN  =item RETURN
1058    
1059  Returns a string in FASTA format representing the content of the desired sequence with  Returns a string in FASTA format representing the content of the desired sequence with
# Line 986  Line 1066 
1066    
1067  sub ComputeFASTA {  sub ComputeFASTA {
1068      # Get the parameters.      # Get the parameters.
1069      my ($self, $incomingType, $desiredType, $sequence) = @_;      my ($self, $desiredType, $sequence, $flankingWidth) = @_;
1070      # Declare the return variable. If an error occurs, it will remain undefined.      # Declare the return variable. If an error occurs, it will remain undefined.
1071      my $retVal;      my $retVal;
1072      # This variable will be cleared if an error is detected.      # This variable will be cleared if an error is detected.
# Line 994  Line 1074 
1074      # Create variables to hold the FASTA label and data.      # Create variables to hold the FASTA label and data.
1075      my ($fastaLabel, $fastaData);      my ($fastaLabel, $fastaData);
1076      Trace("FASTA desired type is $desiredType.") if T(4);      Trace("FASTA desired type is $desiredType.") if T(4);
1077      # Check for a feature specification.      # Check for a feature specification. The smoking gun for that is a vertical bar.
1078      if ($sequence =~ /^\s*(\w+\|\S+)\s*$/) {      if ($sequence =~ /^\s*(\w+\|\S+)\s*$/) {
1079          # Here we have a feature ID in $1. We'll need the Sprout object to process          # Here we have a feature ID in $1. We'll need the Sprout object to process
1080          # it.          # it.
# Line 1009  Line 1089 
1089              $self->SetMessage("No gene found with the ID \"$fid\".");              $self->SetMessage("No gene found with the ID \"$fid\".");
1090              $okFlag = 0;              $okFlag = 0;
1091          } else {          } else {
1092              # Set the FASTA label.              # Set the FASTA label. The ID is the first favored alias.
1093              my $fastaLabel = $fid;              my $favored = $self->Q()->param('FavoredAlias') || 'fig';
1094                my $favorLen = length $favored;
1095                ($fastaLabel) = grep { substr($_, 0, $favorLen) eq $favored } $sprout->FeatureAliases($fid);
1096                if (! $fastaLabel) {
1097                    # In an emergency, fall back to the original ID.
1098                    $fastaLabel = $fid;
1099                }
1100              # Now proceed according to the sequence type.              # Now proceed according to the sequence type.
1101              if ($desiredType eq 'prot') {              if ($desiredType =~ /prot/) {
1102                  # We want protein, so get the translation.                  # We want protein, so get the translation.
1103                  $fastaData = $sprout->FeatureTranslation($figID);                  $fastaData = $sprout->FeatureTranslation($figID);
1104                  Trace(length $fastaData . " characters returned for translation of $fastaLabel.") if T(3);                  Trace(length $fastaData . " characters returned for translation of $fastaLabel.") if T(3);
1105              } else {              } else {
1106                  # We want DNA, so get the DNA sequence. This is a two-step process.                  # We want DNA, so get the DNA sequence. This is a two-step process. First, we get the
1107                    # locations.
1108                  my @locList = $sprout->FeatureLocation($figID);                  my @locList = $sprout->FeatureLocation($figID);
1109                    if ($flankingWidth > 0) {
1110                        # Here we need to add flanking data. Convert the locations to a list
1111                        # of location objects.
1112                        my @locObjects = map { BasicLocation->new($_) } @locList;
1113                        # Initialize the return variable. We will put the DNA in here segment by segment.
1114                        $fastaData = "";
1115                        # Now we widen each location by the flanking width and stash the results. This
1116                        # requires getting the contig length for each contig so we don't fall off the end.
1117                        for my $locObject (@locObjects) {
1118                            Trace("Current location is " . $locObject->String . ".") if T(4);
1119                            # Remember the current start and length.
1120                            my ($start, $len) = ($locObject->Left, $locObject->Length);
1121                            # Get the contig length.
1122                            my $contigLen = $sprout->ContigLength($locObject->Contig);
1123                            # Widen the location and get its DNA.
1124                            $locObject->Widen($flankingWidth, $contigLen);
1125                            my $fastaSegment = $sprout->DNASeq([$locObject->String()]);
1126                            # Now we need to do some case changing. The main DNA is upper case and
1127                            # the flanking DNA is lower case.
1128                            my $leftFlank = $start - $locObject->Left;
1129                            my $rightFlank = $leftFlank + $len;
1130                            Trace("Wide location is " . $locObject->String . ". Flanks are $leftFlank and $rightFlank. Contig len is $contigLen.") if T(4);
1131                            my $fancyFastaSegment = lc(substr($fastaSegment, 0, $leftFlank)) .
1132                                                    uc(substr($fastaSegment, $leftFlank, $rightFlank - $leftFlank)) .
1133                                                    lc(substr($fastaSegment, $rightFlank));
1134                            $fastaData .= $fancyFastaSegment;
1135                        }
1136                    } else {
1137                        # Here we have just the raw sequence.
1138                  $fastaData = $sprout->DNASeq(\@locList);                  $fastaData = $sprout->DNASeq(\@locList);
1139                  Trace(length $fastaData . " characters returned for DNA of $fastaLabel.") if T(3);                  }
1140                    Trace((length $fastaData) . " characters returned for DNA of $fastaLabel.") if T(3);
1141              }              }
1142          }          }
1143      } else {      } else {
# Line 1042  Line 1159 
1159          $fastaData =~ s/\n//g;          $fastaData =~ s/\n//g;
1160          $fastaData =~ s/\s+//g;          $fastaData =~ s/\s+//g;
1161          # Finally, verify that it's DNA if we're doing DNA stuff.          # Finally, verify that it's DNA if we're doing DNA stuff.
1162          if ($desiredType eq 'dna' && $fastaData =~ /[^agct]/i) {          if ($desiredType eq 'dna' && $fastaData =~ /[^agctxn]/i) {
1163              $self->SetMessage("Invaid characters detected. Is the input really a DNA sequence?");              $self->SetMessage("Invalid characters detected. Is the input really a DNA sequence?");
1164              $okFlag = 0;              $okFlag = 0;
1165          }          }
1166      }      }
1167      Trace("FASTA data sequence: $fastaData") if T(4);      Trace("FASTA data sequence: $fastaData") if T(4);
1168      # Only proceed if no error was detected.      # Only proceed if no error was detected.
1169      if ($okFlag) {      if ($okFlag) {
1170            if ($desiredType =~ /pattern/i) {
1171                # We're doing a scan, so only the data is passed in.
1172                $retVal = $fastaData;
1173            } else {
1174          # We need to format the sequence into 60-byte chunks. We use the infamous          # We need to format the sequence into 60-byte chunks. We use the infamous
1175          # grep-split trick. The split, because of the presence of the parentheses,          # grep-split trick. The split, because of the presence of the parentheses,
1176          # includes the matched delimiters in the output list. The grep strips out          # includes the matched delimiters in the output list. The grep strips out
# Line 1058  Line 1179 
1179          my @chunks = grep { $_ } split /(.{1,60})/, $fastaData;          my @chunks = grep { $_ } split /(.{1,60})/, $fastaData;
1180          $retVal = join("\n", ">$fastaLabel", @chunks, "");          $retVal = join("\n", ">$fastaLabel", @chunks, "");
1181      }      }
1182        }
1183      # Return the result.      # Return the result.
1184      return $retVal;      return $retVal;
1185  }  }
# Line 1114  Line 1236 
1236      # Read in the subsystems.      # Read in the subsystems.
1237      my @subs = $sprout->GetAll(['Subsystem'], "ORDER BY Subsystem(classification), Subsystem(id)", [],      my @subs = $sprout->GetAll(['Subsystem'], "ORDER BY Subsystem(classification), Subsystem(id)", [],
1238                                 ['Subsystem(classification)', 'Subsystem(id)']);                                 ['Subsystem(classification)', 'Subsystem(id)']);
1239        # Put any unclassified subsystems at the end. They will always be at the beginning, so if one
1240        # is at the end, ALL subsystems are unclassified and we don't bother.
1241        if ($#subs >= 0 && $subs[$#subs]->[0] ne '') {
1242            while ($subs[0]->[0] eq '') {
1243                my $classLess = shift @subs;
1244                push @subs, $classLess;
1245            }
1246        }
1247      # Declare the return variable.      # Declare the return variable.
1248      my @retVal = ();      my @retVal = ();
1249      # Each element in @subs represents a leaf node, so as we loop through it we will be      # Each element in @subs represents a leaf node, so as we loop through it we will be
# Line 1188  Line 1318 
1318              if ($optionThing->{links}) {              if ($optionThing->{links}) {
1319                  # Compute the link value.                  # Compute the link value.
1320                  my $linkable = uri_escape($id);                  my $linkable = uri_escape($id);
1321                  $nodeContent->{link} = "../FIG/display_subsys.cgi?ssa_name=$linkable;request=show_ssa;sort=by_phylo;SPROUT=1";                  $nodeContent->{link} = "../FIG/display_subsys.cgi?ssa_name=$linkable;request=show_ssa;sort=by_phylo;show_clusters=1;SPROUT=1";
1322              }              }
1323              if ($optionThing->{radio}) {              if ($optionThing->{radio}) {
1324                  # Compute the radio value.                  # Compute the radio value.
# Line 1263  Line 1393 
1393      # Get the form name.      # Get the form name.
1394      my $formName = $self->FormName();      my $formName = $self->FormName();
1395      # Check to see if we already have a genome list in memory.      # Check to see if we already have a genome list in memory.
     my $genomes = $self->{genomeList};  
1396      my $groupHash;      my $groupHash;
1397        my @groups;
1398        my $nmpdrGroupCount;
1399        my $genomes = $self->{genomeList};
1400      if (defined $genomes) {      if (defined $genomes) {
1401          # We have a list ready to use.          # We have a list ready to use.
1402          $groupHash = $genomes;          $groupHash = $genomes;
1403            @groups = @{$self->{groupList}};
1404            $nmpdrGroupCount = $self->{groupCount};
1405      } else {      } else {
1406          # Get a list of all the genomes in group order. In fact, we only need them ordered          # Get a list of all the genomes in group order. In fact, we only need them ordered
1407          # by name (genus,species,strain), but putting primary-group in front enables us to          # by name (genus,species,strain), but putting primary-group in front enables us to
# Line 1276  Line 1410 
1410                                           "ORDER BY Genome(primary-group), Genome(genus), Genome(species), Genome(unique-characterization)",                                           "ORDER BY Genome(primary-group), Genome(genus), Genome(species), Genome(unique-characterization)",
1411                                           [], ['Genome(primary-group)', 'Genome(id)',                                           [], ['Genome(primary-group)', 'Genome(id)',
1412                                                'Genome(genus)', 'Genome(species)',                                                'Genome(genus)', 'Genome(species)',
1413                                                'Genome(unique-characterization)']);                                                'Genome(unique-characterization)',
1414                                                  'Genome(taxonomy)']);
1415          # Create a hash to organize the genomes by group. Each group will contain a list of          # Create a hash to organize the genomes by group. Each group will contain a list of
1416          # 2-tuples, the first element being the genome ID and the second being the genome          # 2-tuples, the first element being the genome ID and the second being the genome
1417          # name.          # name.
1418          my %gHash = ();          my %gHash = ();
1419          for my $genome (@genomeList) {          for my $genome (@genomeList) {
1420              # Get the genome data.              # Get the genome data.
1421              my ($group, $genomeID, $genus, $species, $strain) = @{$genome};              my ($group, $genomeID, $genus, $species, $strain, $taxonomy) = @{$genome};
1422              # Compute and cache its name and display group.              # Compute and cache its name and display group.
1423              my ($name, $displayGroup) = $self->SaveOrganismData($group, $genomeID, $genus, $species,              my ($name, $displayGroup, $domain) = $self->SaveOrganismData($group, $genomeID, $genus, $species,
1424                                                                  $strain);                                                                           $strain, $taxonomy);
1425              # Push the genome into the group's list. Note that we use the real group              # Push the genome into the group's list. Note that we use the real group
1426              # name here, not the display group name.              # name here, not the display group name.
1427              push @{$gHash{$group}}, [$genomeID, $name];              push @{$gHash{$group}}, [$genomeID, $name, $domain];
1428            }
1429            # We are almost ready to unroll the menu out of the group hash. The final step is to separate
1430            # the supporting genomes by domain. First, we sort the NMPDR groups.
1431            @groups = sort grep { $_ ne $FIG_Config::otherGroup } keys %gHash;
1432            # Remember the number of NMPDR groups.
1433            $nmpdrGroupCount = scalar @groups;
1434            # Loop through the supporting genomes, classifying them by domain. We'll also keep a list
1435            # of the domains found.
1436            my @otherGenomes = @{$gHash{$FIG_Config::otherGroup}};
1437            my @domains = ();
1438            for my $genomeData (@otherGenomes) {
1439                my ($genomeID, $name, $domain) = @{$genomeData};
1440                if (exists $gHash{$domain}) {
1441                    push @{$gHash{$domain}}, $genomeData;
1442                } else {
1443                    $gHash{$domain} = [$genomeData];
1444                    push @domains, $domain;
1445                }
1446          }          }
1447            # Add the domain groups at the end of the main group list. The main group list will now
1448            # contain all the categories we need to display the genomes.
1449            push @groups, sort @domains;
1450            # Delete the supporting group.
1451            delete $gHash{$FIG_Config::otherGroup};
1452          # Save the genome list for future use.          # Save the genome list for future use.
1453          $self->{genomeList} = \%gHash;          $self->{genomeList} = \%gHash;
1454            $self->{groupList} = \@groups;
1455            $self->{groupCount} = $nmpdrGroupCount;
1456          $groupHash = \%gHash;          $groupHash = \%gHash;
1457      }      }
     # Now we are ready to unroll the menu out of the group hash. First, we sort the groups, putting  
     # the supporting-genome group last.  
     my @groups = sort grep { $_ ne $FIG_Config::otherGroup } keys %{$groupHash};  
     push @groups, $FIG_Config::otherGroup;  
1458      # Next, create a hash that specifies the pre-selected entries. Note that we need to deal      # Next, create a hash that specifies the pre-selected entries. Note that we need to deal
1459      # with the possibility of undefined values in the incoming list.      # with the possibility of undefined values in the incoming list.
1460      my %selectedHash = ();      my %selectedHash = ();
# Line 1335  Line 1491 
1491          # Get the genomes in the group.          # Get the genomes in the group.
1492          for my $genome (@{$groupHash->{$group}}) {          for my $genome (@{$groupHash->{$group}}) {
1493              # Count this organism if it's NMPDR.              # Count this organism if it's NMPDR.
1494              if ($group ne $FIG_Config::otherGroup) {              if ($nmpdrGroupCount > 0) {
1495                  $nmpdrCount++;                  $nmpdrCount++;
1496              }              }
1497              # Get the organism ID and name.              # Get the organism ID, name, and domain.
1498              my ($genomeID, $name) = @{$genome};              my ($genomeID, $name, $domain) = @{$genome};
1499              # See if it's selected.              # See if it's selected.
1500              my $select = ($selectedHash{$genomeID} ? " selected" : "");              my $select = ($selectedHash{$genomeID} ? " selected" : "");
1501              # Generate the option tag.              # Generate the option tag.
1502              my $optionTag = "<OPTION value=\"$genomeID\"$select>$name <em>($genomeID)</em></OPTION>";              my $optionTag = "<OPTION class=\"$domain\" value=\"$genomeID\"$select>$name <em>($genomeID)</em></OPTION>";
1503              push @lines, "    $optionTag";              push @lines, "    $optionTag";
1504          }          }
1505          # Close the option group.          # Close the option group.
1506          push @lines, "  </OPTGROUP>";          push @lines, "  </OPTGROUP>";
1507            # Record this group in the nmpdrGroup count. When that gets to 0, we've finished the NMPDR
1508            # groups.
1509            $nmpdrGroupCount--;
1510      }      }
1511      # Close the SELECT tag.      # Close the SELECT tag.
1512      push @lines, "</SELECT>";      push @lines, "</SELECT>";
# Line 1452  Line 1611 
1611  =item rows  =item rows
1612    
1613  Reference to a list of table rows. Each table row must be in HTML form with all  Reference to a list of table rows. Each table row must be in HTML form with all
1614  the TR and TD tags set up. The first TD or TH tag in each row will be modified to  the TR and TD tags set up. The first TD or TH tag in the first non-colspanned row
1615  set the width. Everything else will be left as is.  will be modified to set the width. Everything else will be left as is.
1616    
1617  =item RETURN  =item RETURN
1618    
# Line 1468  Line 1627 
1627      my ($self, $rows) = @_;      my ($self, $rows) = @_;
1628      # Get the CGI object.      # Get the CGI object.
1629      my $cgi = $self->Q();      my $cgi = $self->Q();
1630      # Fix the widths on the first column. Note that we eschew the use of the "g"      # The first column of the first row must have its width fixed.
1631        # This flag will be set to FALSE when that happens.
1632        my $needWidth = 1;
1633      # modifier becase we only want to change the first tag. Also, if a width      # modifier becase we only want to change the first tag. Also, if a width
1634      # is already specified on the first column bad things will happen.      # is already specified on the first column bad things will happen.
1635      for my $row (@{$rows}) {      for my $row (@{$rows}) {
1636          $row =~ s/(<td|th)/$1 width="150"/i;          # See if this row needs a width.
1637            if ($needWidth && $row =~ /<(td|th) ([^>]+)>/i) {
1638                # Here we have a first cell and its tag parameters are in $2.
1639                my $elements = $2;
1640                if ($elements !~ /colspan/i) {
1641                    Trace("No colspan tag found in element \'$elements\'.") if T(3);
1642                    # Here there's no colspan, so we plug in the width. We
1643                    # eschew the "g" modifier on the substitution because we
1644                    # only want to update the first cell.
1645                    $row =~ s/(<(td|th))/$1 width="150"/i;
1646                    # Denote we don't need this any more.
1647                    $needWidth = 0;
1648                }
1649            }
1650      }      }
1651      # Create the table.      # Create the table.
1652      my $retVal = $cgi->table({border => 2, cellspacing => 2,      my $retVal = $cgi->table({border => 2, cellspacing => 2,
# Line 1519  Line 1693 
1693      my $retVal = $cgi->Tr($cgi->td("Results/Page"),      my $retVal = $cgi->Tr($cgi->td("Results/Page"),
1694                            $cgi->td($cgi->popup_menu(-name => 'PageSize',                            $cgi->td($cgi->popup_menu(-name => 'PageSize',
1695                                                      -values => [10, 25, 50, 100, 1000],                                                      -values => [10, 25, 50, 100, 1000],
1696                                                      -default => $pageSize) . " " .                                                      -default => $pageSize)),
                                    $cgi->checkbox(-name => 'ShowURL',  
                                                   -value => 1,  
                                                   -label => 'Show URL')),  
1697                            $cgi->td($cgi->submit(-class => 'goButton',                            $cgi->td($cgi->submit(-class => 'goButton',
1698                                                  -name => 'Search',                                                  -name => 'Search',
1699                                                  -value => $realCaption)));                                                  -value => $realCaption)));
# Line 1532  Line 1703 
1703    
1704  =head3 FeatureFilterRows  =head3 FeatureFilterRows
1705    
1706  C<< my $htmlText = $shelp->FeatureFilterRows(); >>  C<< my $htmlText = $shelp->FeatureFilterRows(@subset); >>
1707    
1708  This method creates table rows that can be used to filter features. The form  This method creates table rows that can be used to filter features. The form
1709  values can be used to select features by genome using the B<FeatureQuery>  values can be used to select features by genome using the B<FeatureQuery>
1710  object.  object.
1711    
1712    =over 4
1713    
1714    =item subset
1715    
1716    List of rows to display. The default (C<all>) is to display all rows.
1717    C<words> displays the word search box, C<subsys> displays the subsystem
1718    selector, and C<options> displays the options row.
1719    
1720    =item RETURN
1721    
1722    Returns the html text for table rows containing the desired feature filtering controls.
1723    
1724    =back
1725    
1726  =cut  =cut
1727    
1728  sub FeatureFilterRows {  sub FeatureFilterRows {
1729      # Get the parameters.      # Get the parameters.
1730      my ($self) = @_;      my ($self, @subset) = @_;
1731        if (@subset == 0 || $subset[0] eq 'all') {
1732            @subset = qw(words subsys options);
1733        }
1734      # Return the result.      # Return the result.
1735      return FeatureQuery::FilterRows($self);      return FeatureQuery::FilterRows($self, @subset);
1736  }  }
1737    
1738  =head3 GBrowseFeatureURL  =head3 GBrowseFeatureURL
# Line 1767  Line 1955 
1955          # a singleton list, but that's okay.          # a singleton list, but that's okay.
1956          my @values = split (/\0/, $parms{$parmKey});          my @values = split (/\0/, $parms{$parmKey});
1957          # Check for special cases.          # Check for special cases.
1958          if (grep { $_ eq $parmKey } qw(SessionID ResultCount Page PageSize Trace TF ShowURL)) {          if (grep { $_ eq $parmKey } qw(SessionID ResultCount Page PageSize Trace TF)) {
1959              # These are bookkeeping parameters we don't need to start a search.              # These are bookkeeping parameters we don't need to start a search.
1960              @values = ();              @values = ();
1961          } elsif ($parmKey =~ /_SearchThing$/) {          } elsif ($parmKey =~ /_SearchThing$/) {
# Line 1852  Line 2040 
2040    
2041  sub AdvancedClassList {  sub AdvancedClassList {
2042      my @retVal = map { $_ =~ /^SH(\w+)\.pm/; $1 } grep { $_ =~ /^SH/ } keys %INC;      my @retVal = map { $_ =~ /^SH(\w+)\.pm/; $1 } grep { $_ =~ /^SH/ } keys %INC;
2043      return @retVal;      return sort @retVal;
2044  }  }
2045    
2046  =head3 SelectionTree  =head3 SelectionTree
# Line 2142  Line 2330 
2330                      if ($hasChildren) {                      if ($hasChildren) {
2331                          Trace("Processing children of $myLabel.") if T(4);                          Trace("Processing children of $myLabel.") if T(4);
2332                          push @childHtml, ShowBranch($cgi, $myLabel, $myID, $myContent, $options, 'none');                          push @childHtml, ShowBranch($cgi, $myLabel, $myID, $myContent, $options, 'none');
2333                            Trace("Children of $myLabel finished.") if T(4);
2334                      }                      }
2335                  }                  }
2336              }              }
# Line 2176  Line 2365 
2365              }              }
2366              # Next, we format the label.              # Next, we format the label.
2367              my $labelHtml = $myLabel;              my $labelHtml = $myLabel;
2368              Trace("Formatting tree node for $myLabel.") if T(4);              Trace("Formatting tree node for \"$myLabel\".") if T(4);
2369              # Apply a hyperlink if necessary.              # Apply a hyperlink if necessary.
2370              if (defined $attrHash->{link}) {              if (defined $attrHash->{link}) {
2371                  $labelHtml = $cgi->a({ href => $attrHash->{link}, target => $options->{target} },                  $labelHtml = $cgi->a({ href => $attrHash->{link}, target => $options->{target} },
# Line 2226  Line 2415 
2415      return $retVal;      return $retVal;
2416  }  }
2417    
2418    
2419    =head3 PrintLine
2420    
2421    C<< $shelp->PrintLine($message); >>
2422    
2423    Print a line of CGI output. This is used during the operation of the B<Find> method while
2424    searching, so the user sees progress in real-time.
2425    
2426    =over 4
2427    
2428    =item message
2429    
2430    HTML text to display.
2431    
2432    =back
2433    
2434    =cut
2435    
2436    sub PrintLine {
2437        # Get the parameters.
2438        my ($self, $message) = @_;
2439        # Send them to the output.
2440        print "$message\n";
2441    }
2442    
2443  =head2 Feature Column Methods  =head2 Feature Column Methods
2444    
2445  The methods in this section manage feature column data. If you want to provide the  The methods in this section manage feature column data. If you want to provide the
# Line 2236  Line 2450 
2450  the name for the protein page link column is C<protlink>. If the column is to appear  the name for the protein page link column is C<protlink>. If the column is to appear
2451  in the default list of feature columns, add it to the list returned by  in the default list of feature columns, add it to the list returned by
2452  L</DefaultFeatureColumns>. Then add code to produce the column title to  L</DefaultFeatureColumns>. Then add code to produce the column title to
2453  L</FeatureColumnTitle> and code to produce its value to L</FeatureColumnValue>, and  L</FeatureColumnTitle> and code to produce its value to L</FeatureColumnValue>. If the
2454  everything else will happen automatically.  feature column should be excluded from downloads, add it to the C<FeatureColumnSkip>
2455    hash. Everything else will happen automatically.
2456    
2457  There is one special column name syntax for extra columns (that is, nonstandard  There is a special column name syntax for extra columns (that is, nonstandard
2458  feature columns). If the column name begins with C<X=>, then it is presumed to be  feature columns). If the column name begins with C<X=>, then it is presumed to be
2459  an extra column. The column title is the text after the C<X=>, and its value is  an extra column. The column title is the text after the C<X=>, and its value is
2460  pulled from the extra column hash.  pulled from the extra column hash.
2461    
2462    =cut
2463    
2464    # This hash is used to determine which columns should not be included in downloads.
2465    my %FeatureColumnSkip = map { $_ => 1 } qw(gblink viewerlink protlink);
2466    
2467  =head3 DefaultFeatureColumns  =head3 DefaultFeatureColumns
2468    
2469  C<< my @colNames = $shelp->DefaultFeatureColumns(); >>  C<< my @colNames = $shelp->DefaultFeatureColumns(); >>
# Line 2303  Line 2523 
2523      } elsif ($colName =~ /^keyword:(.+)$/) {      } elsif ($colName =~ /^keyword:(.+)$/) {
2524          $retVal = ucfirst $1;          $retVal = ucfirst $1;
2525      } elsif ($colName eq 'orgName') {      } elsif ($colName eq 'orgName') {
2526          $retVal = "Gene Name";          $retVal = "Organism and Gene ID";
2527      } elsif ($colName eq 'protlink') {      } elsif ($colName eq 'protlink') {
2528          $retVal = "NMPDR Protein Page";          $retVal = "NMPDR Protein Page";
2529        } elsif ($colName eq 'viewerlink') {
2530            $retVal = "Annotation Page";
2531      } elsif ($colName eq 'subsystem') {      } elsif ($colName eq 'subsystem') {
2532          $retVal = "Subsystems";          $retVal = "Subsystems";
2533        } elsif ($colName eq 'pdb') {
2534            $retVal = "Best PDB Match";
2535      }      }
2536      # Return the result.      # Return the result.
2537      return $retVal;      return $retVal;
2538  }  }
2539    
2540    =head3 FeatureColumnDownload
2541    
2542    C<< my $keep = $shelp->FeatureColumnDownload($colName); >>
2543    
2544    Return TRUE if the named feature column is to be kept when downloading, else FALSE.
2545    
2546    =over 4
2547    
2548    =item colName
2549    
2550    Name of the relevant feature column.
2551    
2552    =item RETURN
2553    
2554    Return TRUE if the named column should be kept while downloading, else FALSE. In general,
2555    FALSE is returned if the column generates a button, image, or other purely-HTML value.
2556    
2557    =back
2558    
2559    =cut
2560    
2561    sub FeatureColumnDownload {
2562        # Get the parameters.
2563        my ($self, $colName) = @_;
2564        # Return the determination. We download the column if it's not in the skip-hash.
2565        # Note we return 0 and 1 instead of 1 and undef because it simplifies some tracing.
2566        return (exists $FeatureColumnSkip{$colName} ? 0 : 1);
2567    }
2568    
2569    
2570  =head3 FeatureColumnValue  =head3 FeatureColumnValue
2571    
# Line 2328  Line 2581 
2581    
2582  =item record  =item record
2583    
2584  DBObject record for the feature being displayed in the current row.  ERDBObject record for the feature being displayed in the current row.
2585    
2586  =item extraCols  =item extraCols
2587    
# Line 2367  Line 2620 
2620      } elsif ($colName eq 'alias') {      } elsif ($colName eq 'alias') {
2621          # In this case, the user wants a list of external aliases for the feature.          # In this case, the user wants a list of external aliases for the feature.
2622          # These are very expensive, so we compute them when the row is displayed.          # These are very expensive, so we compute them when the row is displayed.
2623          $retVal = "%%alias=$fid";          # To do the computation, we need to know the favored alias type and the
2624            # feature ID.
2625            my $favored = $cgi->param("FavoredAlias") || "fig";
2626            $retVal = "%%alias=$fid,$favored";
2627      } elsif ($colName eq 'fid') {      } elsif ($colName eq 'fid') {
2628          # Here we have the raw feature ID. We hyperlink it to the protein page.          # Here we have the raw feature ID. We hyperlink it to the protein page.
2629          $retVal = HTML::set_prot_links($fid);          $retVal = HTML::set_prot_links($fid);
# Line 2376  Line 2632 
2632          ($retVal) = $record->Value('Feature(assignment)');          ($retVal) = $record->Value('Feature(assignment)');
2633      } elsif ($colName eq 'gblink') {      } elsif ($colName eq 'gblink') {
2634          # Here we want a link to the GBrowse page using the official GBrowse button.          # Here we want a link to the GBrowse page using the official GBrowse button.
2635          $retVal = Formlet('GBrowse', "GetGBrowse.cgi", undef,          $retVal = FakeButton('GBrowse', "GetGBrowse.cgi", undef,
2636                            fid => $fid);                            fid => $fid);
2637      } elsif ($colName eq 'group') {      } elsif ($colName eq 'group') {
2638          # Get the NMPDR group name.          # Get the NMPDR group name.
# Line 2394  Line 2650 
2650          $retVal = $self->FeatureName($fid);          $retVal = $self->FeatureName($fid);
2651      } elsif ($colName eq 'protlink') {      } elsif ($colName eq 'protlink') {
2652          # Here we want a link to the protein page using the official NMPDR button.          # Here we want a link to the protein page using the official NMPDR button.
2653          $retVal = Formlet('NMPDR', "protein.cgi", undef,          $retVal = FakeButton('NMPDR', "protein.cgi", undef,
2654                            prot => $fid, SPROUT => 1, new_framework => 0,                            prot => $fid, SPROUT => 1, new_framework => 0,
2655                            user => '');                            user => '');
2656        } elsif ($colName eq 'viewerlink') {
2657            # Here we want a link to the SEED viewer page using the official viewer button.
2658            $retVal = FakeButton('Annotation', "index.cgi", undef,
2659                                 action => 'ShowAnnotation', prot => $fid);
2660      }elsif ($colName eq 'subsystem') {      }elsif ($colName eq 'subsystem') {
2661          # Another run-time column: subsystem list.          # Another run-time column: subsystem list.
2662          $retVal = "%%subsystem=$fid";          $retVal = "%%subsystem=$fid";
2663        } elsif ($colName eq 'pdb') {
2664            $retVal = "%%pdb=$fid";
2665      }      }
2666      # Return the result.      # Return the result.
2667      return $retVal;      return $retVal;
# Line 2442  Line 2704 
2704      # Separate the text into a type and data.      # Separate the text into a type and data.
2705      if ($type eq 'alias') {      if ($type eq 'alias') {
2706          # Here the caller wants external alias links for a feature. The text          # Here the caller wants external alias links for a feature. The text
2707          # is the feature ID.          # parameter for computing the alias is the feature ID followed by
2708          my $fid = $text;          # the favored alias type.
2709          # The complicated part is we have to hyperlink them. First, get the          my ($fid, $favored) = split /\s*,\s*/, $text;
2710          # aliases.          # The complicated part is we have to hyperlink them and handle the
2711            # favorites. First, get the aliases.
2712          Trace("Generating aliases for feature $fid.") if T(4);          Trace("Generating aliases for feature $fid.") if T(4);
2713          my @aliases = $sprout->FeatureAliases($fid);          my @aliases = sort $sprout->FeatureAliases($fid);
2714          # Only proceed if we found some.          # Only proceed if we found some.
2715          if (@aliases) {          if (@aliases) {
2716              # Join the aliases into a comma-delimited list.              # Split the aliases into favored and unfavored.
2717              my $aliasList = join(", ", @aliases);              my @favored = ();
2718                my @unfavored = ();
2719                for my $alias (@aliases) {
2720                    # Use substr instead of pattern match because $favored is specified by the user
2721                    # and we don't want him to put funny meta-characters in there.
2722                    if (substr($alias, 0, length($favored)) eq $favored) {
2723                        push @favored, $alias;
2724                    } else {
2725                        push @unfavored, $alias;
2726                    }
2727                }
2728                # Rejoin the aliases into a comma-delimited list, with the favored ones first.
2729                my $aliasList = join(", ", @favored, @unfavored);
2730              # Ask the HTML processor to hyperlink them.              # Ask the HTML processor to hyperlink them.
2731              $retVal = HTML::set_prot_links($cgi, $aliasList);              $retVal = HTML::set_prot_links($cgi, $aliasList);
2732          }          }
# Line 2478  Line 2753 
2753                                        "Feature($keywordName)");                                        "Feature($keywordName)");
2754          # String them into a list.          # String them into a list.
2755          $retVal = join(", ", @values);          $retVal = join(", ", @values);
2756        } elsif ($type eq 'pdb') {
2757            # Here the caller wants the best PDB match to this feature. The text
2758            # is the feature ID. We will display the PDB with a link to the
2759            # PDB page along with the match score. If there are docking results we
2760            # will display a link to the docking result search.
2761            my $fid = $text;
2762            # Ask for the best PDB.
2763            my ($bestPDB) = $sprout->GetAll(['IsProteinForFeature', 'PDB'],
2764                                            "IsProteinForFeature(from-link) = ? ORDER BY IsProteinForFeature(score) LIMIT 1",
2765                                            [$fid], ['PDB(id)', 'PDB(docking-count)', 'IsProteinForFeature(score)']);
2766            # Only proceed if there is a PDB.
2767            if ($bestPDB) {
2768                my ($pdbID, $dockingCount, $score) = @{$bestPDB};
2769                # Convert the PDB ID to a hyperlink.
2770                my $pdbLink = SHDrugSearch::PDBLink($cgi, $pdbID);
2771                # Append the score.
2772                $retVal = "$pdbLink ($score)";
2773                # If there are docking results, append a docking results link.
2774                if ($dockingCount > 0) {
2775                    my $dockString = "$dockingCount docking results";
2776                    my $dockLink = $cgi->a({ href =>  $cgi->url() . "?Class=DrugSearch;PDB=$pdbID;NoForm=1",
2777                                             alt =>   "View computed docking results for $pdbID",
2778                                             title => "View computed docking results for $pdbID",
2779                                             target => "_blank"},
2780                                           $dockString);
2781                }
2782            }
2783        } elsif ($type eq 'role') {
2784            # Here the caller wants a functional role assignment. The key is the feature ID.
2785            $retVal = $sprout->FunctionOf($text);
2786        } elsif ($type eq 'loc') {
2787            # This is a tough one. We need to find the nearest feature in the appropriate direction
2788            # on the contig, and then output its id, functional role, and link button.
2789            if ($text =~ /^(.)\/(.+)/) {
2790                my ($direction, $locString) = ($1, $2);
2791                Trace("Location request of type $direction for $locString.") if T(3);
2792                # Convert the location string into a location object.
2793                my $loc = BasicLocation->new($locString);
2794                # Get the contig ID.
2795                my $contigID = $loc->Contig;
2796                # Compute the contig length.
2797                my $contigLen = $sprout->ContigLength($contigID);
2798                # Widen by the area to search in both directions.
2799                $loc->Widen(5000);
2800                # Now, if we're doing a before (-) search, we set the end point to the area's mid point.
2801                # If we're doing an after (+) search, we set the begin point to the area's mid point.
2802                my $mid = ($loc->Left + $loc->Right) / 2;
2803                # Compute the search direction.
2804                my $searchDir = ($direction eq $loc->Dir ? 1 : -1);
2805                # Adjust the midpoint so that it is different in the before direction from what it would
2806                # be in the after direction.
2807                if ($mid != int($mid)) {
2808                    # Here we need to round. The thing here is we want to round in a way that separates
2809                    # the after-search choice from the before-search choice.
2810                    if ($direction eq $loc->Dir) {
2811                        $mid = ceil($mid);
2812                    } else {
2813                        $mid = floor($mid);
2814                    }
2815                } elsif ($direction eq '+') {
2816                    # Here the midpoint is on a nucleotide and we are doing the after search. We bump the
2817                    # midpoint toward the end point.
2818                    $mid += $loc->NumDirection;
2819                }
2820                # Now put the midpoint on the proper end of the region.
2821                if ($direction eq '+') {
2822                    $loc->SetBegin($mid);
2823                } else {
2824                    $loc->SetEnd($mid);
2825                }
2826                Trace("Search region is " . $loc->String . ".") if T(3);
2827                # Find all the genes in the region.
2828                my ($fidList, $beg, $end) = $sprout->GenesInRegion($loc->Contig, $loc->Left, $loc->Right);
2829                Trace(scalar(@{$fidList}) . " features found.") if T(3);
2830                # Look for the best match.
2831                my $distance = 5000;
2832                my $chosenFid = undef;
2833                for my $fid (@{$fidList}) {
2834                    # Get the feature's location.
2835                    my ($locString) = $sprout->FeatureLocation($fid);
2836                    my $locObject = BasicLocation->new($locString);
2837                    # Check its begin point to see if we should keep it.
2838                    my $newDistance = ($mid - $locObject->Begin) * $searchDir;
2839                    Trace("Distance from $mid to $locString is $newDistance.") if T(4);
2840                    if ($newDistance > 0 && $newDistance < $distance) {
2841                        $distance = $newDistance;
2842                        $chosenFid = $fid;
2843                    }
2844                }
2845                # Only proceed if we found something.
2846                if (defined $chosenFid) {
2847                    my $role = $sprout->FunctionOf($chosenFid);
2848                    my $linkButton = SearchHelper::FakeButton('NMPDR', "protein.cgi", undef,
2849                                                               prot => $chosenFid, SPROUT => 1,
2850                                                               new_framework => 0, user => '');
2851                    $retVal = "$chosenFid&nbsp;$linkButton&nbsp;$role";
2852                }
2853            } else {
2854                Confess("Invalid location request %%loc=$text.");
2855            }
2856      }      }
2857      # Return the result.      # Return the result.
2858      return $retVal;      return $retVal;
# Line 2485  Line 2860 
2860    
2861  =head3 SaveOrganismData  =head3 SaveOrganismData
2862    
2863  C<< my ($name, $displayGroup) = $shelp->SaveOrganismData($group, $genomeID, $genus, $species, $strain); >>  C<< my ($name, $displayGroup) = $shelp->SaveOrganismData($group, $genomeID, $genus, $species, $strain, $taxonomy); >>
2864    
2865  Format the name of an organism and the display version of its group name. The incoming  Format the name of an organism and the display version of its group name. The incoming
2866  data should be the relevant fields from the B<Genome> record in the database. The  data should be the relevant fields from the B<Genome> record in the database. The
# Line 2515  Line 2890 
2890    
2891  Strain of the species represented by the genome.  Strain of the species represented by the genome.
2892    
2893    =item taxonomy
2894    
2895    Taxonomy of the species represented by the genome.
2896    
2897  =item RETURN  =item RETURN
2898    
2899  Returns a two-element list. The first element is the formatted genome name. The second  Returns a three-element list. The first element is the formatted genome name. The second
2900  element is the display name of the genome's group.  element is the display name of the genome's group. The third is the genome's domain.
2901    
2902  =back  =back
2903    
# Line 2526  Line 2905 
2905    
2906  sub SaveOrganismData {  sub SaveOrganismData {
2907      # Get the parameters.      # Get the parameters.
2908      my ($self, $group, $genomeID, $genus, $species, $strain) = @_;      my ($self, $group, $genomeID, $genus, $species, $strain, $taxonomy) = @_;
2909      # Declare the return values.      # Declare the return values.
2910      my ($name, $displayGroup);      my ($name, $displayGroup);
2911      # If the organism does not exist, format an unknown name and a blank group.      # If the organism does not exist, format an unknown name and a blank group.
# Line 2543  Line 2922 
2922          # name unless it's the supporting group, which is nulled out.          # name unless it's the supporting group, which is nulled out.
2923          $displayGroup = ($group eq $FIG_Config::otherGroup ? "" : $group);          $displayGroup = ($group eq $FIG_Config::otherGroup ? "" : $group);
2924      }      }
2925        # Compute the domain from the taxonomy.
2926        my ($domain) = split /\s*;\s*/, $taxonomy, 2;
2927      # Cache the group and organism data.      # Cache the group and organism data.
2928      my $cache = $self->{orgs};      my $cache = $self->{orgs};
2929      $cache->{$genomeID} = [$name, $displayGroup];      $cache->{$genomeID} = [$name, $displayGroup, $domain];
2930      # Return the result.      # Return the result.
2931      return ($name, $displayGroup);      return ($name, $displayGroup, $domain);
2932  }  }
2933    
2934  =head3 ValidateKeywords  =head3 ValidateKeywords
# Line 2588  Line 2969 
2969      if (! @wordList) {      if (! @wordList) {
2970          if ($required) {          if ($required) {
2971              $self->SetMessage("No search words specified.");              $self->SetMessage("No search words specified.");
2972            } else {
2973                $retVal = 1;
2974          }          }
2975      } elsif (! @plusWords) {      } elsif (! @plusWords) {
2976          $self->SetMessage("At least one keyword must be positive. All the keywords entered are preceded by minus signs.");          $self->SetMessage("At least one keyword must be positive. All the keywords entered are preceded by minus signs.");
# Line 2598  Line 2981 
2981      return $retVal;      return $retVal;
2982  }  }
2983    
2984    =head3 FakeButton
2985    
2986    C<< my $html = SearchHelper::FakeButton($caption, $url, $target, %parms); >>
2987    
2988    Create a fake button that hyperlinks to the specified URL with the specified parameters.
2989    Unlike a real button, this one won't visibly click, but it will take the user to the
2990    correct place.
2991    
2992    The parameters of this method are deliberately identical to L</Formlet> so that we
2993    can switch easily from real buttons to fake ones in the code.
2994    
2995    =over 4
2996    
2997    =item caption
2998    
2999    Caption to be put on the button.
3000    
3001    =item url
3002    
3003    URL for the target page or script.
3004    
3005    =item target
3006    
3007    Frame or target in which the new page should appear. If C<undef> is specified,
3008    the default target will be used.
3009    
3010    =item parms
3011    
3012    Hash containing the parameter names as keys and the parameter values as values.
3013    These will be appended to the URL.
3014    
3015    =back
3016    
3017    =cut
3018    
3019    sub FakeButton {
3020        # Get the parameters.
3021        my ($caption, $url, $target, %parms) = @_;
3022        # Declare the return variable.
3023        my $retVal;
3024        # Compute the target URL.
3025        my $targetUrl = "$url?" . join(";", map { "$_=" . uri_escape($parms{$_}) } keys %parms);
3026        # Compute the target-frame HTML.
3027        my $targetHtml = ($target ? " target=\"$target\"" : "");
3028        # Assemble the result.
3029        return "<a href=\"$targetUrl\" $targetHtml><span class=\"button2 button\">$caption</span></a>";
3030    }
3031    
3032  =head3 Formlet  =head3 Formlet
3033    
3034  C<< my $html = SearchHelper::Formlet($caption, $url, $target, %parms); >>  C<< my $html = SearchHelper::Formlet($caption, $url, $target, %parms); >>
# Line 2651  Line 3082 
3082      return $retVal;      return $retVal;
3083  }  }
3084    
3085    =head3 TuningParameters
3086    
3087    C<< my $options = $shelp->TuningParameters(%parmHash); >>
3088    
3089    Retrieve tuning parameters from the CGI query object. The parameter is a hash that maps parameter names
3090    to their default values. The parameters and their values will be returned as a hash reference.
3091    
3092    =over 4
3093    
3094    =item parmHash
3095    
3096    Hash mapping parameter names to their default values.
3097    
3098    =item RETURN
3099    
3100    Returns a reference to a hash containing the parameter names mapped to their actual values.
3101    
3102    =back
3103    
3104    =cut
3105    
3106    sub TuningParameters {
3107        # Get the parameters.
3108        my ($self, %parmHash) = @_;
3109        # Declare the return variable.
3110        my $retVal = {};
3111        # Get the CGI Query Object.
3112        my $cgi = $self->Q();
3113        # Loop through the parameter names.
3114        for my $parm (keys %parmHash) {
3115            # Get the incoming value for this parameter.
3116            my $value = $cgi->param($parm);
3117            # Zero might be a valid value, so we do an is-defined check rather than an OR.
3118            if (defined($value)) {
3119                $retVal->{$parm} = $value;
3120            } else {
3121                $retVal->{$parm} = $parmHash{$parm};
3122            }
3123        }
3124        # Return the result.
3125        return $retVal;
3126    }
3127    
3128  =head2 Virtual Methods  =head2 Virtual Methods
3129    
3130  =head3 Form  =head3 Form
# Line 2714  Line 3188 
3188      return $retVal;      return $retVal;
3189  }  }
3190    
3191    =head3 SearchTitle
3192    
3193    C<< my $titleHtml = $shelp->SearchTitle(); >>
3194    
3195    Return the display title for this search. The display title appears above the search results.
3196    If no result is returned, no title will be displayed. The result should be an html string
3197    that can be legally put inside a block tag such as C<h3> or C<p>.
3198    
3199    =cut
3200    
3201    sub SearchTitle {
3202        # Get the parameters.
3203        my ($self) = @_;
3204        # Declare the return variable.
3205        my $retVal;
3206        # Return it.
3207        return $retVal;
3208    }
3209    
3210    =head3 DownloadFormatAvailable
3211    
3212    C<< my $okFlag = $shelp->DownloadFormatAvailable($format); >>
3213    
3214    This method returns TRUE if a specified download format is legal for this type of search
3215    and FALSE otherwise. For any feature-based search, there is no need to override this
3216    method.
3217    
3218    =over 4
3219    
3220    =item format
3221    
3222    Download format type code.
3223    
3224    =item RETURN
3225    
3226    Returns TRUE if the download format is legal for this search and FALSE otherwise.
3227    
3228    =back
3229    
3230    =cut
3231    
3232    sub DownloadFormatAvailable {
3233        # Get the parameters.
3234        my ($self, $format) = @_;
3235        # Declare the return variable.
3236        my $retVal = 1;
3237        # Return the result.
3238        return $retVal;
3239    }
3240    
3241    =head3 ColumnTitle
3242    
3243    C<< my $title = $shelp->ColumnTitle($colName); >>
3244    
3245    Return the column heading title to be used for the specified column name. The
3246    default implementation is to simply call L</FeatureColumnTitle>.
3247    
3248    =over 4
3249    
3250    =item colName
3251    
3252    Name of the desired column.
3253    
3254    =item RETURN
3255    
3256    Returns the title to be used as the column header for the named column.
3257    
3258    =back
3259    
3260    =cut
3261    
3262    sub ColumnTitle {
3263        my ($self, $colName) = @_;
3264        return $self->FeatureColumnTitle($colName);
3265    }
3266    
3267    
3268  1;  1;

Legend:
Removed from v.1.19  
changed lines
  Added in v.1.33

MCS Webmaster
ViewVC Help
Powered by ViewVC 1.0.3