[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.2, Wed Sep 27 16:55:38 2006 UTC revision 1.17, Wed Nov 15 22:34:50 2006 UTC
# Line 17  Line 17 
17      use HTML;      use HTML;
18      use BasicLocation;      use BasicLocation;
19      use FeatureQuery;      use FeatureQuery;
20        use URI::Escape;
21        use PageBuilder;
22    
23  =head1 Search Helper Base Class  =head1 Search Helper Base Class
24    
# Line 73  Line 75 
75    
76  List of JavaScript statements to be executed after the form is closed.  List of JavaScript statements to be executed after the form is closed.
77    
78    =item genomeHash
79    
80    Cache of the genome group hash used to build genome selection controls.
81    
82    =item genomeParms
83    
84    List of the parameters that are used to select multiple genomes.
85    
86    =item filtered
87    
88    TRUE if this is a feature-filtered search, else FALSE. B<NOTE> that this
89    field is updated by the B<FeatureQuery> object.
90    
91  =back  =back
92    
93  =head2 Adding a new Search Tool  =head2 Adding a new Search Tool
# Line 98  Line 113 
113    
114  =item 4  =item 4
115    
116  In the C<SearchSkeleton.cgi> script, add a C<use> statement for your search tool  In the C<SearchSkeleton.cgi> script and add a C<use> statement for your search tool.
 and then put the class name in the C<@advancedClasses> list.  
117    
118  =back  =back
119    
# Line 139  Line 153 
153    
154  =item 1  =item 1
155    
156  L</NmpdrGenomeMenu> generates a control for selecting one or more genomes.  L</NmpdrGenomeMenu> generates a control for selecting one or more genomes. Use
157    L</GetGenomes> to retrieve all the genomes passed in for a specified parameter
158    name. Note that as an assist to people working with GET-style links, if no
159    genomes are specified and the incoming request style is GET, all genomes will
160    be returned.
161    
162  =item 2  =item 2
163    
# Line 158  Line 176 
176    
177  =back  =back
178    
179    If you are doing a feature search, you can also change the list of feature
180    columns displayed and their display order by overriding
181    L</DefaultFeatureColumns>.
182    
183  Finally, when generating the code for your controls, be sure to use any incoming  Finally, when generating the code for your controls, be sure to use any incoming
184  query parameters as default values so that the search request is persistent.  query parameters as default values so that the search request is persistent.
185    
# Line 195  Line 217 
217                      }                      }
218                  }                  }
219              }              }
         }  
220          # Close the session file.          # Close the session file.
221          $self->CloseSession();          $self->CloseSession();
222            }
223          # Return the result count.          # Return the result count.
224          return $retVal;          return $retVal;
225      }      }
226    
227  A Find method is of course much more complicated than generating a form, and there  A Find method is of course much more complicated than generating a form, and there
228  are variations on the above them. For example, you could eschew feature filtering  are variations on the above theme. For example, you could eschew feature filtering
229  entirely in favor of your own custom filtering, you could include extra columns  entirely in favor of your own custom filtering, you could include extra columns
230  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
231  above code is just a loose framework.  above code is just a loose framework.
# Line 218  Line 240 
240  by calling L</SetMessage>. If the parameters are valid, then the method must return  by calling L</SetMessage>. If the parameters are valid, then the method must return
241  the number of items found.  the number of items found.
242    
 =head2 Virtual Methods  
   
 =head3 Form  
   
 C<< my $html = $shelp->Form(); >>  
   
 Generate the HTML for a form to request a new search.  
   
 =head3 Find  
   
 C<< my $resultCount = $shelp->Find(); >>  
   
 Conduct a search based on the current CGI query parameters. The search results will  
 be written to the session cache file and the number of results will be  
 returned. If the search parameters are invalid, a result count of C<undef> will be  
 returned and a result message will be stored in this object describing the problem.  
   
 =head3 Description  
   
 C<< my $htmlText = $shelp->Description(); >>  
   
 Return a description of this search. The description is used for the table of contents  
 on the main search tools page. It may contain HTML, but it should be character-level,  
 not block-level, since the description is going to appear in a list.  
   
243  =cut  =cut
244    
245  # This counter is used to insure every form on the page has a unique name.  # This counter is used to insure every form on the page has a unique name.
246  my $formCount = 0;  my $formCount = 0;
247    # This counter is used to generate unique DIV IDs.
248    my $divCount = 0;
249    
250  =head2 Public Methods  =head2 Public Methods
251    
# Line 298  Line 297 
297                    orgs => {},                    orgs => {},
298                    name => $formName,                    name => $formName,
299                    scriptQueue => [],                    scriptQueue => [],
300                      genomeList => undef,
301                      genomeParms => [],
302                      filtered => 0,
303                   };                   };
304      # Bless and return it.      # Bless and return it.
305      bless $retVal, $class;      bless $retVal, $class;
# Line 319  Line 321 
321      return $self->{query};      return $self->{query};
322  }  }
323    
324    
325    
326  =head3 DB  =head3 DB
327    
328  C<< my $sprout = $shelp->DB(); >>  C<< my $sprout = $shelp->DB(); >>
# Line 610  Line 614 
614    
615  =head3 PutFeature  =head3 PutFeature
616    
617  C<< $shelp->PutFeature($fquery); >>  C<< $shelp->PutFeature($fdata); >>
618    
619  Store a feature in the result cache. This is the workhorse method for most  Store a feature in the result cache. This is the workhorse method for most
620  searches, since the primary data item in the database is features.  searches, since the primary data item in the database is features.
# Line 621  Line 625 
625  the feature query object using the B<AddExtraColumns> method. For example, the following  the feature query object using the B<AddExtraColumns> method. For example, the following
626  code adds columns for essentiality and virulence.  code adds columns for essentiality and virulence.
627    
628      $fq->AddExtraColumns(essential => $essentialFlag, virulence => $vfactor);      $fd->AddExtraColumns(essential => $essentialFlag, virulence => $vfactor);
629      $shelp->PutFeature($fq);      $shelp->PutFeature($fd);
630    
631  For correct results, all values should be specified for all extra columns in all calls to  For correct results, all values should be specified for all extra columns in all calls to
632  B<PutFeature>. (In particular, the column header names are computed on the first  B<PutFeature>. (In particular, the column header names are computed on the first
# Line 632  Line 636 
636      if (! $essentialFlag) {      if (! $essentialFlag) {
637          $essentialFlag = undef;          $essentialFlag = undef;
638      }      }
639      $fq->AddExtraColumns(essential => $essentialFlag, virulence => $vfactor);      $fd->AddExtraColumns(essential => $essentialFlag, virulence => $vfactor);
640      $shelp->PutFeature($fq);      $shelp->PutFeature($fd);
641    
642  =over 4  =over 4
643    
644  =item fquery  =item fdata
645    
646  FeatureQuery object containing the current feature data.  B<FeatureData> object containing the current feature data.
647    
648  =back  =back
649    
# Line 647  Line 651 
651    
652  sub PutFeature {  sub PutFeature {
653      # Get the parameters.      # Get the parameters.
654      my ($self, $fq) = @_;      my ($self, $fd) = @_;
655        # Get the CGI query object.
656        my $cgi = $self->Q();
657      # Get the feature data.      # Get the feature data.
658      my $record = $fq->Feature();      my $record = $fd->Feature();
659      my $extraCols = $fq->ExtraCols();      my $extraCols = $fd->ExtraCols();
660      # Check for a first-call situation.      # Check for a first-call situation.
661      if (! defined $self->{cols}) {      if (! defined $self->{cols}) {
662          # Here we need to set up the column information. Start with the defaults.          Trace("Setting up the columns.") if T(3);
663          $self->{cols} = $self->DefaultFeatureColumns();          # Here we need to set up the column information. Start with the extras,
664          # Append the extras, sorted by column name.          # sorted by column name.
665            my @colNames = ();
666          for my $col (sort keys %{$extraCols}) {          for my $col (sort keys %{$extraCols}) {
667              push @{$self->{cols}}, "X=$col";              push @colNames, "X=$col";
668          }          }
669            # Add the default columns.
670            push @colNames, $self->DefaultFeatureColumns();
671            # Add any additional columns requested by the feature filter.
672            push @colNames, FeatureQuery::AdditionalColumns($self);
673            # Save the full list.
674            $self->{cols} = \@colNames;
675          # Write out the column headers. This also prepares the cache file to receive          # Write out the column headers. This also prepares the cache file to receive
676          # output.          # output.
677          $self->WriteColumnHeaders(map { $self->FeatureColumnTitle($_) } @{$self->{cols}});          $self->WriteColumnHeaders(map { $self->FeatureColumnTitle($_) } @{$self->{cols}});
678      }      }
679      # Get the feature ID.      # Get the feature ID.
680      my ($fid) = $record->Value('Feature(id)');      my $fid = $fd->FID();
681      # Loop through the column headers, producing the desired data.      # Loop through the column headers, producing the desired data.
682      my @output = ();      my @output = ();
683      for my $colName (@{$self->{cols}}) {      for my $colName (@{$self->{cols}}) {
684          push @output, $self->FeatureColumnValue($colName, $record, $extraCols);          push @output, $self->FeatureColumnValue($colName, $record, $extraCols);
685      }      }
686      # Compute the sort key. The sort key floats NMPDR organism features to the      # Compute the sort key. The sort key usually floats NMPDR organism features to the
687      # top of the return list.      # top of the return list.
688      my $group = $self->FeatureGroup($fid);      my $key = $self->SortKey($fd);
     my $key = ($group ? "A$group" : "ZZ");  
689      # Write the feature data.      # Write the feature data.
690      $self->WriteColumnData($key, @output);      $self->WriteColumnData($key, @output);
691  }  }
# Line 754  Line 766 
766      # Check for an open session file.      # Check for an open session file.
767      if (defined $self->{fileHandle}) {      if (defined $self->{fileHandle}) {
768          # We found one, so close it.          # We found one, so close it.
769            Trace("Closing session file.") if T(2);
770          close $self->{fileHandle};          close $self->{fileHandle};
771      }      }
772  }  }
# Line 771  Line 784 
784      my $retVal;      my $retVal;
785      # Get a digest encoder.      # Get a digest encoder.
786      my $md5 = Digest::MD5->new();      my $md5 = Digest::MD5->new();
787      # If we have a randomization file, use it to seed the digester.      # Add the PID, the IP, and the time stamp. Note that the time stamp is
788      if (open(R, "/dev/urandom")) {      # actually two numbers, and we get them both because we're in list
789          my $b;      # context.
790          read(R, $b, 1024);      $md5->add($$, $ENV{REMOTE_ADDR}, $ENV{REMOTE_PORT}, gettimeofday());
791          $md5->add($b);      # Hash up all this identifying data.
792      }      $retVal = $md5->hexdigest();
793      # Add the PID and the time stamp.      # Return the result.
     $md5->add($$, gettimeofday);  
     # Hash it up and clean the result so that it works as a file name.  
     $retVal = $md5->b64digest();  
     $retVal =~ s,/,\$,g;  
     $retVal =~ s,\+,@,g;  
     # Return it.  
794      return $retVal;      return $retVal;
795  }  }
796    
# Line 827  Line 834 
834                                                      ['Genome(genus)', 'Genome(species)',                                                      ['Genome(genus)', 'Genome(species)',
835                                                       'Genome(unique-characterization)',                                                       'Genome(unique-characterization)',
836                                                       'Genome(primary-group)']);                                                       'Genome(primary-group)']);
837          # Null out the supporting group.          # Format and cache the name and display group.
838          $group = "" if ($group eq $FIG_Config::otherGroup);          ($orgName, $group) = $self->SaveOrganismData($group, $genomeID, $genus, $species,
839          # If the organism does not exist, format an unknown name.                                                              $strain);
         if (! defined($genus)) {  
             $orgName = "Unknown Genome $genomeID";  
         } else {  
             # It does exist, so format the organism name.  
             $orgName = "$genus $species";  
             if ($strain) {  
                 $orgName .= " $strain";  
             }  
         }  
         # Save this organism in the cache.  
         $cache->{$genomeID} = [$orgName, $group];  
840      }      }
841      # Return the result.      # Return the result.
842      return ($orgName, $group);      return ($orgName, $group);
# Line 942  Line 938 
938      } else {      } else {
939          # Here we can get its genome data.          # Here we can get its genome data.
940          $retVal = $self->Organism($genomeID);          $retVal = $self->Organism($genomeID);
941          # Append the type and number.          # Append the FIG ID.
942          $retVal .= " [$type $num]";          $retVal .= " [$fid]";
943      }      }
944      # Return the result.      # Return the result.
945      return $retVal;      return $retVal;
# Line 991  Line 987 
987      my ($self, $incomingType, $desiredType, $sequence) = @_;      my ($self, $incomingType, $desiredType, $sequence) = @_;
988      # Declare the return variable. If an error occurs, it will remain undefined.      # Declare the return variable. If an error occurs, it will remain undefined.
989      my $retVal;      my $retVal;
990        # This variable will be cleared if an error is detected.
991        my $okFlag = 1;
992      # Create variables to hold the FASTA label and data.      # Create variables to hold the FASTA label and data.
993      my ($fastaLabel, $fastaData);      my ($fastaLabel, $fastaData);
994        Trace("FASTA incoming type is $incomingType, desired type is $desiredType.") if T(4);
995      # Check for a feature specification.      # Check for a feature specification.
996      if ($sequence =~ /^\s*(\w+\|\S+)\s*$/) {      if ($sequence =~ /^\s*(\w+\|\S+)\s*$/) {
997          # 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
998          # it.          # it.
999          my $fid = $1;          my $fid = $1;
1000            Trace("Feature ID for fasta is $fid.") if T(3);
1001          my $sprout = $self->DB();          my $sprout = $self->DB();
1002          # Get the FIG ID. Note that we only use the first feature found. We are not          # Get the FIG ID. Note that we only use the first feature found. We are not
1003          # supposed to have redundant aliases, though we may have an ID that doesn't          # supposed to have redundant aliases, though we may have an ID that doesn't
1004          # exist.          # exist.
1005          my ($figID) = $sprout->FeaturesByAlias($fid);          my ($figID) = $sprout->FeaturesByAlias($fid);
1006          if (! $figID) {          if (! $figID) {
1007              $self->SetMessage("No feature found with the ID \"$fid\".");              $self->SetMessage("No gene found with the ID \"$fid\".");
1008                $okFlag = 0;
1009          } else {          } else {
1010              # Set the FASTA label.              # Set the FASTA label.
1011              my $fastaLabel = $fid;              my $fastaLabel = $fid;
1012              # Now proceed according to the sequence type.              # Now proceed according to the sequence type.
1013              if ($desiredType =~ /prot/i) {              if ($desiredType eq 'prot') {
1014                  # We want protein, so get the translation.                  # We want protein, so get the translation.
1015                  $fastaData = $sprout->FeatureTranslation($figID);                  $fastaData = $sprout->FeatureTranslation($figID);
1016                    Trace(length $fastaData . " characters returned for translation of $fastaLabel.") if T(3);
1017              } else {              } else {
1018                  # 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.
1019                  my @locList = $sprout->FeatureLocation($figID);                  my @locList = $sprout->FeatureLocation($figID);
1020                  $fastaData = $sprout->DNASeq(\@locList);                  $fastaData = $sprout->DNASeq(\@locList);
1021                    Trace(length $fastaData . " characters returned for DNA of $fastaLabel.") if T(3);
1022              }              }
1023          }          }
1024      } elsif ($incomingType =~ /prot/ && $desiredType =~ /dna/) {      } elsif ($incomingType eq 'prot' && $desiredType eq 'dna') {
1025          # Here we're being asked to do an impossible conversion.          # Here we're being asked to do an impossible conversion.
1026          $self->SetMessage("Cannot convert a protein sequence to DNA.");          $self->SetMessage("Cannot convert a protein sequence to DNA.");
1027            $okFlag = 0;
1028      } else {      } else {
1029            Trace("Analyzing FASTA sequence.") if T(4);
1030          # Here we are expecting a FASTA. We need to see if there's a label.          # Here we are expecting a FASTA. We need to see if there's a label.
1031          if ($sequence =~ /^>\s*(\S.*)\s*\n(.+)$/) {          if ($sequence =~ /^>[\n\s]*(\S[^\n]*)\n(.+)$/s) {
1032                Trace("Label \"$1\" found in match to sequence:\n$sequence") if T(4);
1033              # Here we have a label, so we split it from the data.              # Here we have a label, so we split it from the data.
1034              $fastaLabel = $1;              $fastaLabel = $1;
1035              $fastaData = $2;              $fastaData = $2;
1036          } else {          } else {
1037                Trace("No label found in match to sequence:\n$sequence") if T(4);
1038              # Here we have no label, so we create one and use the entire sequence              # Here we have no label, so we create one and use the entire sequence
1039              # as data.              # as data.
1040              $fastaLabel = "User-specified $incomingType sequence";              $fastaLabel = "User-specified $incomingType sequence";
# Line 1040  Line 1047 
1047          # we've already prevented a conversion from protein to DNA.          # we've already prevented a conversion from protein to DNA.
1048          if ($incomingType ne $desiredType) {          if ($incomingType ne $desiredType) {
1049              $fastaData = Sprout::Protein($fastaData);              $fastaData = Sprout::Protein($fastaData);
1050                # Check for bad characters.
1051                if ($fastaData =~ /X/) {
1052                    $self->SetMessage("Invalid characters detected. Is the input really of type $incomingType?");
1053                    $okFlag = 0;
1054                }
1055            } elsif ($desiredType eq 'dna' && $fastaData =~ /[^agct]/i) {
1056                $self->SetMessage("Invaid characters detected. Is the input really a DNA sequence?");
1057                $okFlag = 0;
1058          }          }
1059      }      }
1060      # At this point, either "$fastaLabel" and "$fastaData" have values or an error is      Trace("FASTA data sequence: $fastaData") if T(4);
1061      # in progress.      # Only proceed if no error was detected.
1062      if (defined $fastaLabel) {      if ($okFlag) {
1063          # 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
1064          # grep-split trick. The split, because of the presence of the parentheses,          # grep-split trick. The split, because of the presence of the parentheses,
1065          # includes the matched delimiters in the output list. The grep strips out          # includes the matched delimiters in the output list. The grep strips out
1066          # the empty list items that appear between the so-called delimiters, since          # the empty list items that appear between the so-called delimiters, since
1067          # the delimiters are what we want.          # the delimiters are what we want.
1068          my @chunks = grep { $_ } split /(.{1,60})/, $fastaData;          my @chunks = grep { $_ } split /(.{1,60})/, $fastaData;
1069          my $retVal = join("\n", ">$fastaLabel", @chunks, "");          $retVal = join("\n", ">$fastaLabel", @chunks, "");
1070      }      }
1071      # Return the result.      # Return the result.
1072      return $retVal;      return $retVal;
1073  }  }
1074    
1075    =head3 SubsystemTree
1076    
1077    C<< my $tree = SearchHelper::SubsystemTree($sprout, %options); >>
1078    
1079    This method creates a subsystem selection tree suitable for passing to
1080    L</SelectionTree>. Each leaf node in the tree will have a link to the
1081    subsystem display page. In addition, each node can have a radio button. The
1082    radio button alue is either C<classification=>I<string>, where I<string> is
1083    a classification string, or C<id=>I<string>, where I<string> is a subsystem ID.
1084    Thus, it can either be used to filter by a group of related subsystems or a
1085    single subsystem.
1086    
1087    =over 4
1088    
1089    =item sprout
1090    
1091    Sprout database object used to get the list of subsystems.
1092    
1093    =item options
1094    
1095    Hash containing options for building the tree.
1096    
1097    =item RETURN
1098    
1099    Returns a reference to a tree list suitable for passing to L</SelectionTree>.
1100    
1101    =back
1102    
1103    The supported options are as follows.
1104    
1105    =over 4
1106    
1107    =item radio
1108    
1109    TRUE if the tree should be configured for radio buttons. The default is FALSE.
1110    
1111    =item links
1112    
1113    TRUE if the tree should be configured for links. The default is TRUE.
1114    
1115    =back
1116    
1117    =cut
1118    
1119    sub SubsystemTree {
1120        # Get the parameters.
1121        my ($sprout, %options) = @_;
1122        # Process the options.
1123        my $optionThing = Tracer::GetOptions({ radio => 0, links => 1 }, \%options);
1124        # Read in the subsystems.
1125        my @subs = $sprout->GetAll(['Subsystem'], "ORDER BY Subsystem(classification), Subsystem(id)", [],
1126                                   ['Subsystem(classification)', 'Subsystem(id)']);
1127        # Declare the return variable.
1128        my @retVal = ();
1129        # Each element in @subs represents a leaf node, so as we loop through it we will be
1130        # producing one leaf node at a time. The leaf node is represented as a 2-tuple. The
1131        # first element is a semi-colon-delimited list of the classifications for the
1132        # subsystem. There will be a stack of currently-active classifications, which we will
1133        # compare to the incoming classifications from the end backward. A new classification
1134        # requires starting a new branch. A different classification requires closing an old
1135        # branch and starting a new one. Each classification in the stack will also contain
1136        # that classification's current branch. We'll add a fake classification at the
1137        # beginning that we can use to represent the tree as a whole.
1138        my $rootName = '<root>';
1139        # Create the classification stack. Note the stack is a pair of parallel lists,
1140        # one containing names and the other containing content.
1141        my @stackNames = ($rootName);
1142        my @stackContents = (\@retVal);
1143        # Add a null entry at the end of the subsystem list to force an unrolling.
1144        push @subs, ['', undef];
1145        # Loop through the subsystems.
1146        for my $sub (@subs) {
1147            # Pull out the classification list and the subsystem ID.
1148            my ($classString, $id) = @{$sub};
1149            Trace("Processing class \"$classString\" and subsystem $id.") if T(4);
1150            # Convert the classification string to a list with the root classification in
1151            # the front.
1152            my @classList = ($rootName, split($FIG_Config::splitter, $classString));
1153            # Find the leftmost point at which the class list differs from the stack.
1154            my $matchPoint = 0;
1155            while ($matchPoint <= $#stackNames && $matchPoint <= $#classList &&
1156                   $stackNames[$matchPoint] eq $classList[$matchPoint]) {
1157                $matchPoint++;
1158            }
1159            Trace("Match point is $matchPoint. Stack length is " . scalar(@stackNames) .
1160                  ". Class List length is " . scalar(@classList) . ".") if T(4);
1161            # Unroll the stack to the matchpoint.
1162            while ($#stackNames >= $matchPoint) {
1163                my $popped = pop @stackNames;
1164                pop @stackContents;
1165                Trace("\"$popped\" popped from stack.") if T(4);
1166            }
1167            # Start branches for any new classifications.
1168            while ($#stackNames < $#classList) {
1169                # The branch for a new classification contains its radio button
1170                # data and then a list of children. So, at this point, if radio buttons
1171                # are desired, we put them into the content.
1172                my $newLevel = scalar(@stackNames);
1173                my @newClassContent = ();
1174                if ($optionThing->{radio}) {
1175                    my $newClassString = join($FIG_Config::splitter, @classList[1..$newLevel]);
1176                    push @newClassContent, { value => "classification=$newClassString%" };
1177                }
1178                # The new classification node is appended to its parent's content
1179                # and then pushed onto the stack. First, we need the node name.
1180                my $nodeName = $classList[$newLevel];
1181                # Add the classification to its parent. This makes it part of the
1182                # tree we'll be returning to the user.
1183                push @{$stackContents[$#stackNames]}, $nodeName, \@newClassContent;
1184                # Push the classification onto the stack.
1185                push @stackContents, \@newClassContent;
1186                push @stackNames, $nodeName;
1187                Trace("\"$nodeName\" pushed onto stack.") if T(4);
1188            }
1189            # Now the stack contains all our parent branches. We add the subsystem to
1190            # the branch at the top of the stack, but only if it's NOT the dummy node.
1191            if (defined $id) {
1192                # Compute the node name from the ID.
1193                my $nodeName = $id;
1194                $nodeName =~ s/_/ /g;
1195                # Create the node's leaf hash. This depends on the value of the radio
1196                # and link options.
1197                my $nodeContent = {};
1198                if ($optionThing->{links}) {
1199                    # Compute the link value.
1200                    my $linkable = uri_escape($id);
1201                    $nodeContent->{link} = "../FIG/display_subsys.cgi?ssa_name=$linkable;request=show_ssa;sort=by_phylo;SPROUT=1";
1202                }
1203                if ($optionThing->{radio}) {
1204                    # Compute the radio value.
1205                    $nodeContent->{value} = "id=$id";
1206                }
1207                # Push the node into its parent branch.
1208                Trace("\"$nodeName\" added to node list.") if T(4);
1209                push @{$stackContents[$#stackNames]}, $nodeName, $nodeContent;
1210            }
1211        }
1212        # Return the result.
1213        return \@retVal;
1214    }
1215    
1216    
1217  =head3 NmpdrGenomeMenu  =head3 NmpdrGenomeMenu
1218    
1219  C<< my $htmlText = $shelp->NmpdrGenomeMenu($menuName, \%options, \@selected); >>  C<< my $htmlText = $shelp->NmpdrGenomeMenu($menuName, $multiple, \@selected, $rows); >>
1220    
1221  This method creates a hierarchical HTML menu for NMPDR genomes organized by category. The  This method creates a hierarchical HTML menu for NMPDR genomes organized by category. The
1222  category indicates the low-level NMPDR group. Organizing the genomes in this way makes it  category indicates the low-level NMPDR group. Organizing the genomes in this way makes it
# Line 1071  Line 1228 
1228    
1229  Name to give to the menu.  Name to give to the menu.
1230    
1231  =item options  =item multiple
1232    
1233  Reference to a hash containing the options to be applied to the C<SELECT> tag form the menu.  TRUE if the user is allowed to select multiple genomes, else FALSE.
 Typical options would include C<multiple> to specify  
 that multiple selections are allowed and C<size> to set the number of rows to display  
 in the menu.  
1234    
1235  =item selected  =item selected
1236    
# Line 1084  Line 1238 
1238  is not intended to allow multiple selections, the list should be a singleton. If the  is not intended to allow multiple selections, the list should be a singleton. If the
1239  list is empty, nothing will be pre-selected.  list is empty, nothing will be pre-selected.
1240    
1241    =item rows (optional)
1242    
1243    Number of rows to display. If omitted, the default is 1 for a single-select list
1244    and 10 for a multi-select list.
1245    
1246    =item crossMenu (optional)
1247    
1248    If specified, is presumed to be the name of another genome menu whose contents
1249    are to be mutually exclusive with the contents of this menu. As a result, instead
1250    of the standard onChange event, the onChange event will deselect any entries in
1251    the other menu.
1252    
1253  =item RETURN  =item RETURN
1254    
1255  Returns the HTML text to generate a C<SELECT> menu inside a form.  Returns the HTML text to generate a C<SELECT> menu inside a form.
# Line 1094  Line 1260 
1260    
1261  sub NmpdrGenomeMenu {  sub NmpdrGenomeMenu {
1262      # Get the parameters.      # Get the parameters.
1263      my ($self, $menuName, $options, $selected) = @_;      my ($self, $menuName, $multiple, $selected, $rows, $cross) = @_;
1264      # Get the Sprout and CGI objects.      # Get the Sprout and CGI objects.
1265      my $sprout = $self->DB();      my $sprout = $self->DB();
1266      my $cgi = $self->Q();      my $cgi = $self->Q();
1267        # Compute the row count.
1268        if (! defined $rows) {
1269            $rows = ($multiple ? 10 : 1);
1270        }
1271        # Create the multiple tag.
1272        my $multipleTag = ($multiple ? " multiple" : "");
1273      # Get the form name.      # Get the form name.
1274      my $formName = $self->FormName();      my $formName = $self->FormName();
1275        # Check to see if we already have a genome list in memory.
1276        my $genomes = $self->{genomeList};
1277        my $groupHash;
1278        if (defined $genomes) {
1279            # We have a list ready to use.
1280            $groupHash = $genomes;
1281        } else {
1282      # 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
1283      # 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
1284      # take advantage of an existing index.      # take advantage of an existing index.
# Line 1111  Line 1290 
1290      # 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
1291      # 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
1292      # name.      # name.
1293      my %groupHash = ();          my %gHash = ();
1294      for my $genome (@genomeList) {      for my $genome (@genomeList) {
1295          # Get the genome data.          # Get the genome data.
1296          my ($group, $genomeID, $genus, $species, $strain) = @{$genome};          my ($group, $genomeID, $genus, $species, $strain) = @{$genome};
1297          # Form the genome name.              # Compute and cache its name and display group.
1298          my $name = "$genus $species";              my ($name, $displayGroup) = $self->SaveOrganismData($group, $genomeID, $genus, $species,
1299          if ($strain) {                                                                  $strain);
1300              $name .= " $strain";              # Push the genome into the group's list. Note that we use the real group
1301          }              # name here, not the display group name.
1302          # Push the genome into the group's list.              push @{$gHash{$group}}, [$genomeID, $name];
1303          push @{$groupHash{$group}}, [$genomeID, $name];          }
1304            # Save the genome list for future use.
1305            $self->{genomeList} = \%gHash;
1306            $groupHash = \%gHash;
1307      }      }
1308      # Now we are ready to unroll the menu out of the group hash. First, we sort the groups, putting      # Now we are ready to unroll the menu out of the group hash. First, we sort the groups, putting
1309      # the supporting-genome group last.      # the supporting-genome group last.
1310      my @groups = sort grep { $_ ne $FIG_Config::otherGroup } keys %groupHash;      my @groups = sort grep { $_ ne $FIG_Config::otherGroup } keys %{$groupHash};
1311      push @groups, $FIG_Config::otherGroup;      push @groups, $FIG_Config::otherGroup;
1312      # Next, create a hash that specifies the pre-selected entries.      # Next, create a hash that specifies the pre-selected entries. Note that we need to deal
1313      my %selectedHash = map { $_ => 1 } @{$selected};      # with the possibility of undefined values in the incoming list.
1314      # Now it gets complicated. We need a way to mark all the NMPDR genomes.      my %selectedHash = ();
1315        if (defined $selected) {
1316            %selectedHash = map { $_ => 1 } grep { defined($_) } @{$selected};
1317        }
1318        # Now it gets complicated. We need a way to mark all the NMPDR genomes. We take advantage
1319        # of the fact they come first in the list. We'll accumulate a count of the NMPDR genomes
1320        # and use that to make the selections.
1321        my $nmpdrCount = 0;
1322      # Create the type counters.      # Create the type counters.
1323      my $groupCount = 1;      my $groupCount = 1;
1324      # Compute the ID for the status display.      # Compute the ID for the status display.
# Line 1138  Line 1327 
1327      my $showSelect = "showSelected($menuName, '$divID', 1000);";      my $showSelect = "showSelected($menuName, '$divID', 1000);";
1328      # If multiple selection is supported, create an onChange event.      # If multiple selection is supported, create an onChange event.
1329      my $onChange = "";      my $onChange = "";
1330      if ($options->{multiple}) {      if ($cross) {
1331            # Here we have a paired menu. Selecting something in our menu unselects it in the
1332            # other and redisplays the status of both.
1333            $onChange = " onChange=\"crossUnSelect($menuName, '$divID', $cross, '${formName}_${cross}_status', 1000)\"";
1334        } elsif ($multiple) {
1335            # This is an unpaired menu, so all we do is redisplay our status.
1336          $onChange = " onChange=\"$showSelect\"";          $onChange = " onChange=\"$showSelect\"";
1337      }      }
1338      # Create the SELECT tag and stuff it into the output array.      # Create the SELECT tag and stuff it into the output array.
1339      my $select = "<" . join(" ", "SELECT name=\"$menuName\"$onChange", map { " $_=\"$options->{$_}\"" } keys %{$options}) . ">";      my @lines = ("<SELECT name=\"$menuName\"$onChange$multipleTag size=\"$rows\">");
     my @lines = ($select);  
1340      # Loop through the groups.      # Loop through the groups.
1341      for my $group (@groups) {      for my $group (@groups) {
1342          # Create the option group tag.          # Create the option group tag.
1343          my $tag = "<OPTGROUP label=\"$group\">";          my $tag = "<OPTGROUP label=\"$group\">";
1344          push @lines, "  $tag";          push @lines, "  $tag";
         # Compute the label for this group's options. This is seriously dirty stuff, as the  
         # label option may have functionality in future browsers. If that happens, we'll need  
         # to modify the genome text so that the "selectSome" method can tell which are NMPDR  
         # organisms and which aren't. Sadly, the OPTGROUP tag is invisible in the DOM Javascript  
         # hierarchy.  
         my $label = ($group eq $FIG_Config::otherGroup ? "other" : "nmpdr");  
1345          # Get the genomes in the group.          # Get the genomes in the group.
1346          for my $genome (@{$groupHash{$group}}) {          for my $genome (@{$groupHash->{$group}}) {
1347                # Count this organism if it's NMPDR.
1348                if ($group ne $FIG_Config::otherGroup) {
1349                    $nmpdrCount++;
1350                }
1351                # Get the organism ID and name.
1352              my ($genomeID, $name) = @{$genome};              my ($genomeID, $name) = @{$genome};
1353              # See if it's selected.              # See if it's selected.
1354              my $select = ($selectedHash{$genomeID} ? " selected" : "");              my $select = ($selectedHash{$genomeID} ? " selected" : "");
1355              # Generate the option tag.              # Generate the option tag.
1356              my $optionTag = "<OPTION value=\"$genomeID\" label=\"$label\"$select>$name <em>($genomeID)</em></OPTION>";              my $optionTag = "<OPTION value=\"$genomeID\"$select>$name <em>($genomeID)</em></OPTION>";
1357              push @lines, "    $optionTag";              push @lines, "    $optionTag";
1358          }          }
1359          # Close the option group.          # Close the option group.
# Line 1170  Line 1362 
1362      # Close the SELECT tag.      # Close the SELECT tag.
1363      push @lines, "</SELECT>";      push @lines, "</SELECT>";
1364      # Check for multiple selection.      # Check for multiple selection.
1365      if ($options->{multiple}) {      if ($multiple) {
1366          # Since multi-select is on, we can set up some buttons to set and clear selections.          # Multi-select is on, so we need to add some selection helpers. First is
1367            # the search box. This allows the user to type text and have all genomes containing
1368            # the text selected automatically.
1369            my $searchThingName = "${menuName}_SearchThing";
1370            push @lines, "<br>Select genomes containing <INPUT type=\"text\" name=\"$searchThingName\" " .
1371                         "size=\"30\" onBlur=\"selectViaSearch($menuName, $searchThingName); $showSelect\" />";
1372            # Next are the buttons to set and clear selections.
1373          push @lines, "<br />";          push @lines, "<br />";
         push @lines, "<INPUT type=\"button\" name=\"SelectAll\" class=\"bigButton\" value=\"Select All\" onClick=\"selectAll($menuName); $showSelect\" />";  
1374          push @lines, "<INPUT type=\"button\" name=\"ClearAll\" class=\"bigButton\"  value=\"Clear All\" onClick=\"clearAll($menuName); $showSelect\" />";          push @lines, "<INPUT type=\"button\" name=\"ClearAll\" class=\"bigButton\"  value=\"Clear All\" onClick=\"clearAll($menuName); $showSelect\" />";
1375          push @lines, "<INPUT type=\"button\" name=\"NMPDROnly\" class=\"bigButton\"  value=\"Select NMPDR\" onClick=\"selectSome($menuName, 'nmpdr'); $showSelect\" />";          push @lines, "<INPUT type=\"button\" name=\"SelectAll\" class=\"bigButton\" value=\"Select All\" onClick=\"selectAll($menuName); $showSelect\" />";
1376          push @lines, "<INPUT type=\"button\" name=\"OtherOnly\" class=\"bigButton\" value=\"Select Supporting\" onClick=\"selectSome($menuName, 'other'); $showSelect\" />";          push @lines, "<INPUT type=\"button\" name=\"NMPDROnly\" class=\"bigButton\"  value=\"Select NMPDR\" onClick=\"selectSome($menuName, $nmpdrCount, true); $showSelect\" />";
1377            push @lines, "<INPUT type=\"button\" name=\"OtherOnly\" class=\"bigButton\" value=\"Select Supporting\" onClick=\"selectSome($menuName, $nmpdrCount, false); $showSelect\" />";
1378          # Add the status display, too.          # Add the status display, too.
1379          push @lines, "<DIV id=\"$divID\" class=\"selectStatus\"></DIV>";          push @lines, "<DIV id=\"$divID\" class=\"selectStatus\"></DIV>";
1380          # Queue to update the status display when the form loads. We need to modify the show statement          # Queue to update the status display when the form loads. We need to modify the show statement
# Line 1185  Line 1383 
1383          # in case we decide to twiddle the parameters.          # in case we decide to twiddle the parameters.
1384          $showSelect =~ s/showSelected\(/showSelected\(thisForm\./;          $showSelect =~ s/showSelected\(/showSelected\(thisForm\./;
1385          $self->QueueFormScript($showSelect);          $self->QueueFormScript($showSelect);
1386            # Finally, add this parameter to the list of genome parameters. This enables us to
1387            # easily find all the parameters used to select one or more genomes.
1388            push @{$self->{genomeParms}}, $menuName;
1389      }      }
1390      # Assemble all the lines into a string.      # Assemble all the lines into a string.
1391      my $retVal = join("\n", @lines, "");      my $retVal = join("\n", @lines, "");
# Line 1192  Line 1393 
1393      return $retVal;      return $retVal;
1394  }  }
1395    
1396    =head3 PropertyMenu
1397    
1398    C<< my $htmlText = $shelp->PropertyMenu($menuName, $selected, $force); >>
1399    
1400    Generate a property name dropdown menu.
1401    
1402    =over 4
1403    
1404    =item menuName
1405    
1406    Name to give to the menu.
1407    
1408    =item selected
1409    
1410    Value of the property name to pre-select.
1411    
1412    =item force (optional)
1413    
1414    If TRUE, then the user will be forced to choose a property name. If FALSE,
1415    then an additional menu choice will be provided to select nothing.
1416    
1417    =item RETURN
1418    
1419    Returns a dropdown menu box that allows the user to select a property name. An additional
1420    selection entry will be provided for selecting no property name
1421    
1422    =back
1423    
1424    =cut
1425    
1426    sub PropertyMenu {
1427        # Get the parameters.
1428        my ($self, $menuName, $selected, $force) = @_;
1429        # Get the CGI and Sprout objects.
1430        my $sprout = $self->DB();
1431        my $cgi = $self->Q();
1432        # Create the property name list.
1433        my @propNames = ();
1434        if (! $force) {
1435            push @propNames, "";
1436        }
1437        # Get all the property names, putting them after the null choice if one exists.
1438        push @propNames, $sprout->GetChoices('Property', 'property-name');
1439        # Create a menu from them.
1440        my $retVal = $cgi->popup_menu(-name=> $menuName, -values => \@propNames,
1441                                      -default => $selected);
1442        # Return the result.
1443        return $retVal;
1444    }
1445    
1446  =head3 MakeTable  =head3 MakeTable
1447    
1448  C<< my $htmlText = $shelp->MakeTable(\@rows); >>  C<< my $htmlText = $shelp->MakeTable(\@rows); >>
# Line 1254  Line 1505 
1505      # Get the parameters.      # Get the parameters.
1506      my ($self) = @_;      my ($self) = @_;
1507      my $cgi = $self->Q();      my $cgi = $self->Q();
1508      # Declare the return variable.      # Get the current page size.
1509        my $pageSize = $cgi->param('PageSize');
1510        # Get the incoming external-link flag.
1511        my $aliases = ($cgi->param('ShowAliases') ? 1 : 0);
1512        # Create the row.
1513      my $retVal = $cgi->Tr($cgi->td("Results/Page"),      my $retVal = $cgi->Tr($cgi->td("Results/Page"),
1514                            $cgi->td($cgi->popup_menu(-name => 'PageSize',                            $cgi->td($cgi->popup_menu(-name => 'PageSize',
1515                                                      -values => [10, 25, 45, 100, 1000],                                                      -values => [10, 25, 50, 100, 1000],
1516                                                      -default => $cgi->param('PageSize'))),                                                      -default => $pageSize) . " " .
1517                                       $cgi->checkbox(-name => 'ShowURL',
1518                                                      -value => 1,
1519                                                      -label => 'Show URL')),
1520                            $cgi->td($cgi->submit(-class => 'goButton',                            $cgi->td($cgi->submit(-class => 'goButton',
1521                                                  -name => 'Search',                                                  -name => 'Search',
1522                                                  -value => 'Go')));                                                  -value => 'Go')));
# Line 1270  Line 1528 
1528    
1529  C<< my $htmlText = $shelp->FeatureFilterRows(); >>  C<< my $htmlText = $shelp->FeatureFilterRows(); >>
1530    
1531  This method creates table rows that can be used to filter features. There are  This method creates table rows that can be used to filter features. The form
1532  two rows returned, and the values can be used to select features by genome  values can be used to select features by genome using the B<FeatureQuery>
1533  using the B<FeatureQuery> object.  object.
1534    
1535  =cut  =cut
1536    
# Line 1322  Line 1580 
1580          # Get the feature location string.          # Get the feature location string.
1581          my $loc = $sprout->FeatureLocation($feat);          my $loc = $sprout->FeatureLocation($feat);
1582          # Compute the contig, start, and stop points.          # Compute the contig, start, and stop points.
1583          my($start, $stop, $contig) = BasicLocation::Parse($loc);          my($contig, $start, $stop) = BasicLocation::Parse($loc);
1584            Trace("Start and stop are ($start,$stop) on contig $contig.") if T(3);
1585          # Now we need to do some goofiness to insure that the location is not too          # Now we need to do some goofiness to insure that the location is not too
1586          # big and that we get some surrounding stuff.          # big and that we get some surrounding stuff.
1587          my $mid = int(($start + $stop) / 2);          my $mid = int(($start + $stop) / 2);
# Line 1352  Line 1611 
1611          }          }
1612          my $seg_id = $contig;          my $seg_id = $contig;
1613          $seg_id =~ s/:/--/g;          $seg_id =~ s/:/--/g;
1614            Trace("Show limits are ($show_start,$show_stop) in genome $genomeID with ref $seg_id.") if T(3);
1615          # Assemble all the pieces.          # Assemble all the pieces.
1616          $retVal = "gbrowse.cgi/GB_$genomeID?ref=$seg_id&start=$show_start&stop=$show_stop";          $retVal = "gbrowse.cgi/GB_$genomeID?ref=$seg_id&start=$show_start&stop=$show_stop";
1617      }      }
# Line 1359  Line 1619 
1619      return $retVal;      return $retVal;
1620  }  }
1621    
1622  =head2 Feature Column Methods  =head3 GetGenomes
1623    
1624  The methods in this column manage feature column data. If you want to provide the  C<< my @genomeList = $shelp->GetGenomes($parmName); >>
 capability to include new types of data in feature columns, then all the changes  
 are made to this section of the source file. Technically, this should be implemented  
 using object-oriented methods, but this is simpler for non-programmers to maintain.  
 To add a new column of feature data, you must first give it a name. For example,  
 the name for the protein page link column is C<protlink>. If the column is to appear  
 in the default list of feature columns, add it to the list returned by  
 L</DefaultFeatureColumns>. Then add code to produce the column title to  
 L</FeatureColumnTitle> and code to produce its value to L</FeatureColumnValue>, and  
 everything else will happen automatically.  
1625    
1626  There is one special column name syntax for extra columns (that is, nonstandard  Return the list of genomes specified by the specified CGI query parameter.
1627  feature columns). If the column name begins with C<X=>, then it is presumed to be  If the request method is POST, then the list of genome IDs is returned
1628  an extra column. The column title is the text after the C<X=>, and its value is  without preamble. If the request method is GET and the parameter is not
1629  pulled from the extra column hash.  specified, then it is treated as a request for all genomes. This makes it
1630    easier for web pages to link to a search that wants to specify all genomes.
1631    
1632  =head3 DefaultFeatureColumns  =over 4
1633    
1634    =item parmName
1635    
1636    Name of the parameter containing the list of genomes. This will be the
1637    first parameter passed to the L</NmpdrGenomeMenu> call that created the
1638    genome selection control on the form.
1639    
1640    =item RETURN
1641    
1642  C<< my $colNames = $shelp->DefaultFeatureColumns(); >>  Returns a list of the genomes to process.
1643    
1644  Return a reference to a list of the default feature column identifiers. These  =back
 identifiers can be passed to L</FeatureColumnTitle> and L</FeatureColumnValue> in  
 order to produce the column titles and row values.  
1645    
1646  =cut  =cut
1647    
1648  sub DefaultFeatureColumns {  sub GetGenomes {
1649        # Get the parameters.
1650        my ($self, $parmName) = @_;
1651        # Get the CGI query object.
1652        my $cgi = $self->Q();
1653        # Get the list of genome IDs in the request header.
1654        my @retVal = $cgi->param($parmName);
1655        Trace("Genome list for $parmName is (" . join(", ", @retVal) . ") with method " . $cgi->request_method() . ".") if T(3);
1656        # Check for the special GET case.
1657        if ($cgi->request_method() eq "GET" && ! @retVal) {
1658            # Here the caller wants all the genomes.
1659            my $sprout = $self->DB();
1660            @retVal = $sprout->Genomes();
1661        }
1662        # Return the result.
1663        return @retVal;
1664    }
1665    
1666    =head3 GetHelpText
1667    
1668    C<< my $htmlText = $shelp->GetHelpText(); >>
1669    
1670    Get the help text for this search. The help text is stored in files on the template
1671    server. The help text for a specific search is taken from a file named
1672    C<SearchHelp_>I<class>C<.inc> in the template directory C<$FIG_Config::template_url>.
1673    There are also three standard help files: C<SearchHelp1_Filtering.inc> describes the
1674    feature filtering performed by the B<FeatureQuery> object, C<SearchHelp1_GenomeControl.inc>
1675    describes how to use a multiple-selection genome control, and C<SearchHelp1_Standard.inc>
1676    describes the standard controls for a search, such as page size, URL display, and
1677    external alias display.
1678    
1679    =cut
1680    
1681    sub GetHelpText {
1682        # Get the parameters.
1683        my ($self) = @_;
1684        # Create a list to hold the pieces of the help.
1685        my @helps = ();
1686        # Get the template directory URL.
1687        my $urlBase = $FIG_Config::template_url;
1688        # Start with the specific help.
1689        my $class = $self->{class};
1690        push @helps, PageBuilder::GetPage("$urlBase/SearchHelp_$class.inc");
1691        # Add the genome control help if needed.
1692        if (scalar @{$self->{genomeParms}}) {
1693            push @helps, PageBuilder::GetPage("$urlBase/SearchHelp1_GenomeControl.inc");
1694        }
1695        # Next the filter help.
1696        if ($self->{filtered}) {
1697            push @helps, PageBuilder::GetPage("$urlBase/SearchHelp1_Filtering.inc");
1698        }
1699        # Finally, the standard help.
1700        push @helps, PageBuilder::GetPage("$urlBase/SearchHelp1_Standard.inc");
1701        # Assemble the pieces.
1702        my $retVal = join("\n<p>&nbsp;</p>\n", @helps);
1703        # Return the result.
1704        return $retVal;
1705    }
1706    
1707    =head3 ComputeSearchURL
1708    
1709    C<< my $url = $shelp->ComputeSearchURL(); >>
1710    
1711    Compute the GET-style URL for the current search. In order for this to work, there
1712    must be a copy of the search form on the current page. This will always be the
1713    case if the search is coming from C<SearchSkeleton.cgi>.
1714    
1715    A little expense is involved in order to make the URL as smart as possible. The
1716    main complication is that if the user specified all genomes, we'll want to
1717    remove the parameter entirely from a get-style URL.
1718    
1719    =cut
1720    
1721    sub ComputeSearchURL {
1722      # Get the parameters.      # Get the parameters.
1723      my ($self) = @_;      my ($self) = @_;
1724        # Get the database and CGI query object.
1725        my $cgi = $self->Q();
1726        my $sprout = $self->DB();
1727        # Start with the full URL.
1728        my $retVal = $cgi->url(-full => 1);
1729        # Get all the query parameters in a hash.
1730        my %parms = $cgi->Vars();
1731        # Now we need to do some fixing. Each multi-valued parameter is encoded as a string with null
1732        # characters separating the individual values. We have to convert those to lists. In addition,
1733        # the multiple-selection genome parameters and the feature type parameter must be checked to
1734        # determine whether or not they can be removed from the URL. First, we get a list of the
1735        # genome parameters and a list of all genomes. Note that we only need the list if a
1736        # multiple-selection genome parameter has been found on the form.
1737        my %genomeParms = map { $_ => 1 } @{$self->{genomeParms}};
1738        my @genomeList;
1739        if (keys %genomeParms) {
1740            @genomeList = $sprout->Genomes();
1741        }
1742        # Create a list to hold the URL parameters we find.
1743        my @urlList = ();
1744        # Now loop through the parameters in the hash, putting them into the output URL.
1745        for my $parmKey (keys %parms) {
1746            # Get a list of the parameter values. If there's only one, we'll end up with
1747            # a singleton list, but that's okay.
1748            my @values = split (/\0/, $parms{$parmKey});
1749            # Check for special cases.
1750            if (grep { $_ eq $parmKey } qw(SessionID ResultCount Page PageSize Trace TF ShowURL)) {
1751                # These are bookkeeping parameters we don't need to start a search.
1752                @values = ();
1753            } elsif ($parmKey =~ /_SearchThing$/) {
1754                # Here the value coming in is from a genome control's search thing. It does
1755                # not affect the results of the search, so we clear it.
1756                @values = ();
1757            } elsif ($genomeParms{$parmKey}) {
1758                # Here we need to see if the user wants all the genomes. If he does,
1759                # we erase all the values just like with features.
1760                my $allFlag = $sprout->IsAllGenomes(\@values, \@genomeList);
1761                if ($allFlag) {
1762                    @values = ();
1763                }
1764            }
1765            # If we still have values, create the URL parameters.
1766            if (@values) {
1767                push @urlList, map { "$parmKey=" . uri_escape($_) } @values;
1768            }
1769        }
1770        # Add the parameters to the URL.
1771        $retVal .= "?" . join(";", @urlList);
1772      # Return the result.      # Return the result.
1773      return ['orgName', 'function', 'gblink', 'protlink'];      return $retVal;
1774  }  }
1775    
1776  =head3 FeatureColumnTitle  =head3 GetRunTimeValue
1777    
1778  C<< my $title = $shelp->FeatureColumnTitle($colName); >>  C<< my $htmlText = $shelp->GetRunTimeValue($text); >>
1779    
1780  Return the column heading title to be used for the specified feature column.  Compute a run-time column value.
1781    
1782  =over 4  =over 4
1783    
1784  =item name  =item text
1785    
1786  Name of the desired feature column.  The run-time column text. It consists of 2 percent signs, a column type, an equal
1787    sign, and the data for the current row.
1788    
1789  =item RETURN  =item RETURN
1790    
1791  Returns the title to be used as the column header for the named feature column.  Returns the fully-formatted HTML text to go into the current column of the current row.
1792    
1793  =back  =back
1794    
1795  =cut  =cut
1796    
1797  sub FeatureColumnTitle {  sub GetRunTimeValue {
1798      # Get the parameters.      # Get the parameters.
1799      my ($self, $colName) = @_;      my ($self, $text) = @_;
1800      # Declare the return variable. We default to a blank column name.      # Declare the return variable.
1801      my $retVal = "&nbsp;";      my $retVal;
1802      # Process the column name.      # Parse the incoming text.
1803      if ($colName =~ /^X=(.+)$/) {      if ($text =~ /^%%([^=]+)=(.*)$/) {
1804          # Here we have an extra column.          $retVal = $self->RunTimeColumns($1, $2);
1805          $retVal = $1;      } else {
1806      } elsif ($colName eq 'orgName') {          Confess("Invalid run-time column string \"$text\" encountered in session file.");
         $retVal = "Name";  
     } elsif ($colName eq 'fid') {  
         $retVal = "FIG ID";  
     } elsif ($colName eq 'alias') {  
         $retVal = "External Aliases";  
     } elsif ($colName eq 'function') {  
         $retVal = "Functional Assignment";  
     } elsif ($colName eq 'gblink') {  
         $retVal = "GBrowse";  
     } elsif ($colName eq 'protlink') {  
         $retVal = "NMPDR Protein Page";  
     } elsif ($colName eq 'group') {  
         $retVal = "NMDPR Group";  
1807      }      }
1808      # Return the result.      # Return the result.
1809      return $retVal;      return $retVal;
1810  }  }
1811    
1812  =head3 FeatureColumnValue  =head3 AdvancedClassList
1813    
1814  C<< my $value = $shelp->FeatureColumnValue($colName, $fid, \%extraCols); >>  C<< my @classes = SearchHelper::AdvancedClassList(); >>
1815    
1816  Return the value to be displayed in the specified feature column.  Return a list of advanced class names. This list is used to generate the directory
1817    of available searches on the search page.
1818    
1819    We use the %INC variable to accomplish this.
1820    
1821    =cut
1822    
1823    sub AdvancedClassList {
1824        my @retVal = map { $_ =~ /^SH(\w+)\.pm/; $1 } grep { $_ =~ /^SH/ } keys %INC;
1825        return @retVal;
1826    }
1827    
1828    =head3 SelectionTree
1829    
1830    C<< my $htmlText = SearchHelper::SelectionTree($cgi, \%tree, %options); >>
1831    
1832    Display a selection tree.
1833    
1834    This method creates the HTML for a tree selection control. The tree is implemented as a set of
1835    nested HTML unordered lists. Each selectable element of the tree will contain a radio button. In
1836    addition, some of the tree nodes can contain hyperlinks.
1837    
1838    The tree itself is passed in as a multi-level list containing node names followed by
1839    contents. Each content element is a reference to a similar list. The first element of
1840    each list may be a hash reference. If so, it should contain one or both of the following
1841    keys.
1842    
1843  =over 4  =over 4
1844    
1845  =item colName  =item link
1846    
1847  Name of the column to be displayed.  The navigation URL to be popped up if the user clicks on the node name.
1848    
1849  =item record  =item value
1850    
1851  DBObject record for the feature being displayed in the current row.  The form value to be returned if the user selects the tree node.
1852    
1853  =item extraCols  =back
1854    
1855  Reference to a hash of extra column names to values. If the incoming column name  The presence of a C<link> key indicates the node name will be hyperlinked. The presence of
1856  begins with C<X=>, its value will be taken from this hash.  a C<value> key indicates the node name will have a radio button. If a node has no children,
1857    you may pass it a hash reference instead of a list reference.
1858    
1859  =item RETURN  The following example shows the hash for a three-level tree with links on the second level and
1860    radio buttons on the third.
1861    
1862  Returns the HTML to be displayed in the named column for the specified feature.      [   Objects => [
1863                Entities => [
1864                    {link => "../docs/WhatIsAnEntity.html"},
1865                    Genome => {value => 'GenomeData'},
1866                    Feature => {value => 'FeatureData'},
1867                    Contig => {value => 'ContigData'},
1868                ],
1869                Relationships => [
1870                    {link => "../docs/WhatIsARelationShip.html"},
1871                    HasFeature => {value => 'GenomeToFeature'},
1872                    IsOnContig => {value => 'FeatureToContig'},
1873                ]
1874            ]
1875        ]
1876    
1877    Note how each leaf of the tree has a hash reference for its value, while the branch nodes
1878    all have list references.
1879    
1880    This next example shows how to set up a taxonomy selection field. The value returned
1881    by the tree control will be the taxonomy string for the selected node ready for use
1882    in a LIKE-style SQL filter. Only the single branch ending in campylobacter is shown for
1883    reasons of space.
1884    
1885        [   All => [
1886                {value => "%"},
1887                Bacteria => [
1888                    {value => "Bacteria%"},
1889                    Proteobacteria => [
1890                        {value => "Bacteria; Proteobacteria%"},
1891                        Epsilonproteobacteria => [
1892                            {value => "Bacteria; Proteobacteria;Epsilonproteobacteria%"},
1893                            Campylobacterales => [
1894                                {value => "Bacteria; Proteobacteria; Epsilonproteobacteria; Campylobacterales%"},
1895                                Campylobacteraceae =>
1896                                    {value => "Bacteria; Proteobacteria; Epsilonproteobacteria; Campylobacterales; Campylobacteraceae%"},
1897                                ...
1898                            ]
1899                            ...
1900                        ]
1901                        ...
1902                    ]
1903                    ...
1904                ]
1905                ...
1906            ]
1907        ]
1908    
1909    
1910    This method of tree storage allows the caller to control the order in which the tree nodes
1911    are displayed and to completely control value selection and use of hyperlinks. It is, however
1912    a bit complicated. Eventually, tree-building classes will be provided to simplify things.
1913    
1914    The parameters to this method are as follows.
1915    
1916    =over 4
1917    
1918    =item cgi
1919    
1920    CGI object used to generate the HTML.
1921    
1922    =item tree
1923    
1924    Reference to a hash describing a tree. See the description above.
1925    
1926    =item options
1927    
1928    Hash containing options for the tree display.
1929    
1930  =back  =back
1931    
1932  =cut  The allowable options are as follows
1933    
1934  sub FeatureColumnValue {  =over 4
1935      # Get the parameters.  
1936      my ($self, $colName, $record, $extraCols) = @_;  =item nodeImageClosed
1937      # Get the sprout and CGI objects.  
1938      my $cgi = $self->Q();  URL of the image to display next to the tree nodes when they are collapsed. Clicking
1939      my $sprout = $self->DB();  on the image will expand a section of the tree. The default is C<../FIG/Html/plus.gif>.
1940      # Get the feature ID.  
1941      my ($fid) = $record->Value('Feature(id)');  =item nodeImageOpen
1942      # Declare the return variable. Denote that we default to a non-breaking space,  
1943      # which will translate to an empty table cell (rather than a table cell with no  URL of the image to display next to the tree nodes when they are expanded. Clicking
1944      # interior, which is what you get for a null string).  on the image will collapse a section of the tree. The default is C<../FIG/Html/minus.gif>.
1945    
1946    =item style
1947    
1948    Style to use for the tree. The default is C<tree>. Because the tree style is implemented
1949    as nested lists, the key components of this style are the definitions for the C<ul> and
1950    C<li> tags. The default style file contains the following definitions.
1951    
1952        .tree ul {
1953           margin-left: 0; padding-left: 22px
1954        }
1955        .tree li {
1956            list-style-type: none;
1957        }
1958    
1959    The default image is 22 pixels wide, so in the above scheme each tree level is indented from its
1960    parent by the width of the node image. This use of styles limits the things we can do in formatting
1961    the tree, but it has the advantage of vastly simplifying the tree creation.
1962    
1963    =item name
1964    
1965    Field name to give to the radio buttons in the tree. The default is C<selection>.
1966    
1967    =item target
1968    
1969    Frame target for links. The default is C<_self>.
1970    
1971    =item selected
1972    
1973    If specified, the value of the radio button to be pre-selected.
1974    
1975    =back
1976    
1977    =cut
1978    
1979    sub SelectionTree {
1980        # Get the parameters.
1981        my ($cgi, $tree, %options) = @_;
1982        # Get the options.
1983        my $optionThing = Tracer::GetOptions({ name => 'selection',
1984                                               nodeImageClosed => '../FIG/Html/plus.gif',
1985                                               nodeImageOpen => '../FIG/Html/minus.gif',
1986                                               style => 'tree',
1987                                               target => '_self',
1988                                               selected => undef},
1989                                             \%options);
1990        # Declare the return variable. We'll do the standard thing with creating a list
1991        # of HTML lines and rolling them together at the end.
1992        my @retVal = ();
1993        # Only proceed if the tree is present.
1994        if (defined($tree)) {
1995            # Validate the tree.
1996            if (ref $tree ne 'ARRAY') {
1997                Confess("Selection tree is not a list reference.");
1998            } elsif (scalar @{$tree} == 0) {
1999                # The tree is empty, so we do nothing.
2000            } elsif ($tree->[0] eq 'HASH') {
2001                Confess("Hash reference found at start of selection tree. The tree as a whole cannot have attributes, only tree nodes.");
2002            } else {
2003                # Here we have a real tree. Apply the tree style.
2004                push @retVal, $cgi->start_div({ class => $optionThing->{style} });
2005                # Give us a DIV ID.
2006                my $divID = GetDivID($optionThing->{name});
2007                # Show the tree.
2008                push @retVal, ShowBranch($cgi, "(root)", $divID, $tree, $optionThing, 'block');
2009                # Close the DIV block.
2010                push @retVal, $cgi->end_div();
2011            }
2012        }
2013        # Return the result.
2014        return join("\n", @retVal, "");
2015    }
2016    
2017    =head3 ShowBranch
2018    
2019    C<< my @htmlLines = SearchHelper::ShowBranch($cgi, $label, $id, $branch, $options, $displayType); >>
2020    
2021    This is a recursive method that displays a branch of the tree.
2022    
2023    =over 4
2024    
2025    =item cgi
2026    
2027    CGI object used to format HTML.
2028    
2029    =item label
2030    
2031    Label of this tree branch. It is only used in error messages.
2032    
2033    =item id
2034    
2035    ID to be given to this tree branch. The ID is used in the code that expands and collapses
2036    tree nodes.
2037    
2038    =item branch
2039    
2040    Reference to a list containing the content of the tree branch. The list contains an optional
2041    hash reference that is ignored and the list of children, each child represented by a name
2042    and then its contents. The contents could by a hash reference (indicating the attributes
2043    of a leaf node), or another tree branch.
2044    
2045    =item options
2046    
2047    Options from the original call to L</SelectionTree>.
2048    
2049    =item displayType
2050    
2051    C<block> if the contents of this list are to be displayed, C<none> if they are to be
2052    hidden.
2053    
2054    =item RETURN
2055    
2056    Returns one or more HTML lines that can be used to display the tree branch.
2057    
2058    =back
2059    
2060    =cut
2061    
2062    sub ShowBranch {
2063        # Get the parameters.
2064        my ($cgi, $label, $id, $branch, $options, $displayType) = @_;
2065        # Declare the return variable.
2066        my @retVal = ();
2067        # Start the branch.
2068        push @retVal, $cgi->start_ul({ id => $id, style => "display:$displayType" });
2069        # Check for the hash and choose the start location accordingly.
2070        my $i0 = (ref $branch->[0] eq 'HASH' ? 1 : 0);
2071        # Get the list length.
2072        my $i1 = scalar(@{$branch});
2073        # Verify we have an even number of elements.
2074        if (($i1 - $i0) % 2 != 0) {
2075            Trace("Branch elements are from $i0 to $i1.") if T(3);
2076            Confess("Odd number of elements in tree branch $label.");
2077        } else {
2078            # Loop through the elements.
2079            for (my $i = $i0; $i < $i1; $i += 2) {
2080                # Get this node's label and contents.
2081                my ($myLabel, $myContent) = ($branch->[$i], $branch->[$i+1]);
2082                # Get an ID for this node's children (if any).
2083                my $myID = GetDivID($options->{name});
2084                # Now we need to find the list of children and the options hash.
2085                # This is a bit ugly because we allow the shortcut of a hash without an
2086                # enclosing list. First, we need some variables.
2087                my $attrHash = {};
2088                my @childHtml = ();
2089                my $hasChildren = 0;
2090                if (! ref $myContent) {
2091                    Confess("Invalid tree definition. Scalar found as content of node \"$myLabel\".");
2092                } elsif (ref $myContent eq 'HASH') {
2093                    # Here the node is a leaf and its content contains the link/value hash.
2094                    $attrHash = $myContent;
2095                } elsif (ref $myContent eq 'ARRAY') {
2096                    # Here the node may be a branch. Its content is a list.
2097                    my $len = scalar @{$myContent};
2098                    if ($len >= 1) {
2099                        # Here the first element of the list could by the link/value hash.
2100                        if (ref $myContent->[0] eq 'HASH') {
2101                            $attrHash = $myContent->[0];
2102                            # If there's data in the list besides the hash, it's our child list.
2103                            # We can pass the entire thing as the child list, because the hash
2104                            # is ignored.
2105                            if ($len > 1) {
2106                                $hasChildren = 1;
2107                            }
2108                        } else {
2109                            $hasChildren = 1;
2110                        }
2111                        # If we have children, create the child list with a recursive call.
2112                        if ($hasChildren) {
2113                            Trace("Processing children of $myLabel.") if T(4);
2114                            push @childHtml, ShowBranch($cgi, $myLabel, $myID, $myContent, $options, 'none');
2115                        }
2116                    }
2117                }
2118                # Okay, it's time to pause and take stock. We have the label of the current node
2119                # in $myLabel, its attributes in $attrHash, and if it is NOT a leaf node, we
2120                # have a child list in @childHtml. If it IS a leaf node, $hasChildren is 0.
2121                # Compute the image HTML. It's tricky, because we have to deal with the open and
2122                # closed images.
2123                my @images = ($options->{nodeImageOpen}, $options->{nodeImageClosed});
2124                my $image = $images[$hasChildren];
2125                my $prefixHtml = $cgi->img({src => $image, id => "${myID}img"});
2126                if ($hasChildren) {
2127                    # If there are children, we wrap the image in a toggle hyperlink.
2128                    $prefixHtml = $cgi->a({ onClick => "javascript:treeToggle('$myID','$images[0]', '$images[1]')" },
2129                                          $prefixHtml);
2130                }
2131                # Now the radio button, if any. Note we use "defined" in case the user wants the
2132                # value to be 0.
2133                if (defined $attrHash->{value}) {
2134                    # Due to a glitchiness in the CGI stuff, we have to build the attribute
2135                    # hash for the "input" method. If the item is pre-selected, we add
2136                    # "checked => undef" to the hash. Otherwise, we can't have "checked"
2137                    # at all.
2138                    my $radioParms = { type => 'radio',
2139                                       name => $options->{name},
2140                                       value => $attrHash->{value},
2141                                     };
2142                    if (defined $options->{selected} && $options->{selected} eq $attrHash->{value}) {
2143                        $radioParms->{checked} = undef;
2144                    }
2145                    $prefixHtml .= $cgi->input($radioParms);
2146                }
2147                # Next, we format the label.
2148                my $labelHtml = $myLabel;
2149                Trace("Formatting tree node for $myLabel.") if T(4);
2150                # Apply a hyperlink if necessary.
2151                if (defined $attrHash->{link}) {
2152                    $labelHtml = $cgi->a({ href => $attrHash->{link}, target => $options->{target} },
2153                                         $labelHtml);
2154                }
2155                # Finally, roll up the child HTML. If there are no children, we'll get a null string
2156                # here.
2157                my $childHtml = join("\n", @childHtml);
2158                # Now we have all the pieces, so we can put them together.
2159                push @retVal, $cgi->li("$prefixHtml$labelHtml$childHtml");
2160            }
2161        }
2162        # Close the tree branch.
2163        push @retVal, $cgi->end_ul();
2164        # Return the result.
2165        return @retVal;
2166    }
2167    
2168    =head3 GetDivID
2169    
2170    C<< my $idString = SearchHelper::GetDivID($name); >>
2171    
2172    Return a new HTML ID string.
2173    
2174    =over 4
2175    
2176    =item name
2177    
2178    Name to be prefixed to the ID string.
2179    
2180    =item RETURN
2181    
2182    Returns a hopefully-unique ID string.
2183    
2184    =back
2185    
2186    =cut
2187    
2188    sub GetDivID {
2189        # Get the parameters.
2190        my ($name) = @_;
2191        # Compute the ID.
2192        my $retVal = "elt_$name$divCount";
2193        # Increment the counter to make sure this ID is not re-used.
2194        $divCount++;
2195        # Return the result.
2196        return $retVal;
2197    }
2198    
2199    =head2 Feature Column Methods
2200    
2201    The methods in this column manage feature column data. If you want to provide the
2202    capability to include new types of data in feature columns, then all the changes
2203    are made to this section of the source file. Technically, this should be implemented
2204    using object-oriented methods, but this is simpler for non-programmers to maintain.
2205    To add a new column of feature data, you must first give it a name. For example,
2206    the name for the protein page link column is C<protlink>. If the column is to appear
2207    in the default list of feature columns, add it to the list returned by
2208    L</DefaultFeatureColumns>. Then add code to produce the column title to
2209    L</FeatureColumnTitle> and code to produce its value to L</FeatureColumnValue>, and
2210    everything else will happen automatically.
2211    
2212    There is one special column name syntax for extra columns (that is, nonstandard
2213    feature columns). If the column name begins with C<X=>, then it is presumed to be
2214    an extra column. The column title is the text after the C<X=>, and its value is
2215    pulled from the extra column hash.
2216    
2217    =head3 DefaultFeatureColumns
2218    
2219    C<< my @colNames = $shelp->DefaultFeatureColumns(); >>
2220    
2221    Return a list of the default feature column identifiers. These identifiers can
2222    be passed to L</FeatureColumnTitle> and L</FeatureColumnValue> in order to
2223    produce the column titles and row values.
2224    
2225    =cut
2226    
2227    sub DefaultFeatureColumns {
2228        # Get the parameters.
2229        my ($self) = @_;
2230        # Return the result.
2231        return qw(orgName function gblink protlink);
2232    }
2233    
2234    =head3 FeatureColumnTitle
2235    
2236    C<< my $title = $shelp->FeatureColumnTitle($colName); >>
2237    
2238    Return the column heading title to be used for the specified feature column.
2239    
2240    =over 4
2241    
2242    =item name
2243    
2244    Name of the desired feature column.
2245    
2246    =item RETURN
2247    
2248    Returns the title to be used as the column header for the named feature column.
2249    
2250    =back
2251    
2252    =cut
2253    
2254    sub FeatureColumnTitle {
2255        # Get the parameters.
2256        my ($self, $colName) = @_;
2257        # Declare the return variable. We default to a blank column name.
2258        my $retVal = "&nbsp;";
2259        # Process the column name.
2260        if ($colName =~ /^X=(.+)$/) {
2261            # Here we have an extra column.
2262            $retVal = $1;
2263        } elsif ($colName eq 'alias') {
2264            $retVal = "External Aliases";
2265        } elsif ($colName eq 'fid') {
2266            $retVal = "FIG ID";
2267        } elsif ($colName eq 'function') {
2268            $retVal = "Functional Assignment";
2269        } elsif ($colName eq 'gblink') {
2270            $retVal = "GBrowse";
2271        } elsif ($colName eq 'group') {
2272            $retVal = "NMDPR Group";
2273        } elsif ($colName =~ /^keyword:(.+)$/) {
2274            $retVal = ucfirst $1;
2275        } elsif ($colName eq 'orgName') {
2276            $retVal = "Gene Name";
2277        } elsif ($colName eq 'protlink') {
2278            $retVal = "NMPDR Protein Page";
2279        } elsif ($colName eq 'subsystem') {
2280            $retVal = "Subsystems";
2281        }
2282        # Return the result.
2283        return $retVal;
2284    }
2285    
2286    
2287    =head3 FeatureColumnValue
2288    
2289    C<< my $value = $shelp->FeatureColumnValue($colName, $fid, \%extraCols); >>
2290    
2291    Return the value to be displayed in the specified feature column.
2292    
2293    =over 4
2294    
2295    =item colName
2296    
2297    Name of the column to be displayed.
2298    
2299    =item record
2300    
2301    DBObject record for the feature being displayed in the current row.
2302    
2303    =item extraCols
2304    
2305    Reference to a hash of extra column names to values. If the incoming column name
2306    begins with C<X=>, its value will be taken from this hash.
2307    
2308    =item RETURN
2309    
2310    Returns the HTML to be displayed in the named column for the specified feature.
2311    
2312    =back
2313    
2314    =cut
2315    
2316    sub FeatureColumnValue {
2317        # Get the parameters.
2318        my ($self, $colName, $record, $extraCols) = @_;
2319        # Get the sprout and CGI objects.
2320        my $cgi = $self->Q();
2321        my $sprout = $self->DB();
2322        # Get the feature ID.
2323        my ($fid) = $record->Value('Feature(id)');
2324        # Declare the return variable. Denote that we default to a non-breaking space,
2325        # which will translate to an empty table cell (rather than a table cell with no
2326        # interior, which is what you get for a null string).
2327      my $retVal = "&nbsp;";      my $retVal = "&nbsp;";
2328      # Process according to the column name.      # Process according to the column name.
2329      if ($colName =~ /^X=(.+)$/) {      if ($colName =~ /^X=(.+)$/) {
# Line 1492  Line 2334 
2334          if (defined $extraCols->{$1}) {          if (defined $extraCols->{$1}) {
2335              $retVal = $extraCols->{$1};              $retVal = $extraCols->{$1};
2336          }          }
2337      } elsif ($colName eq 'orgName') {      } elsif ($colName eq 'alias') {
2338          # Here we want the formatted organism name and feature number.          # In this case, the user wants a list of external aliases for the feature.
2339          $retVal = $self->FeatureName($fid);          # These are very expensive, so we compute them when the row is displayed.
2340            $retVal = "%%alias=$fid";
2341      } elsif ($colName eq 'fid') {      } elsif ($colName eq 'fid') {
2342          # 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.
2343          $retVal = HTML::set_prot_links($fid);          $retVal = HTML::set_prot_links($fid);
     } elsif ($colName eq 'alias') {  
         # In this case, the user wants a list of external aliases for the feature.  
         # The complicated part is we have to hyperlink them. First, get the  
         # aliases.  
         my @aliases = $sprout->FeatureAliases($fid);  
         # Only proceed if we found some.  
         if (@aliases) {  
             # Join the aliases into a comma-delimited list.  
             my $aliasList = join(", ", @aliases);  
             # Ask the HTML processor to hyperlink them.  
             $retVal = HTML::set_prot_links($aliasList);  
         }  
2344      } elsif ($colName eq 'function') {      } elsif ($colName eq 'function') {
2345          # The functional assignment is just a matter of getting some text.          # The functional assignment is just a matter of getting some text.
2346          ($retVal) = $record->Value('Feature(assignment)');          ($retVal) = $record->Value('Feature(assignment)');
# Line 1520  Line 2351 
2351                            $cgi->img({ src => "../images/button-gbrowse.png",                            $cgi->img({ src => "../images/button-gbrowse.png",
2352                                        border => 0 })                                        border => 0 })
2353                           );                           );
     } elsif ($colName eq 'protlink') {  
         # Here we want a link to the protein page using the official NMPDR button.  
         my $hurl = HTML::fid_link($cgi, $fid, 0, 1);  
         $retVal = $cgi->a({ href => $hurl, title => "Protein page for $fid" },  
                           $cgi->img({ src => "../images/button-nmpdr.png",  
                                      border => 0 })  
                          );  
2354      } elsif ($colName eq 'group') {      } elsif ($colName eq 'group') {
2355          # Get the NMPDR group name.          # Get the NMPDR group name.
2356          my (undef, $group) = $self->OrganismData($fid);          my (undef, $group) = $self->OrganismData($fid);
# Line 1534  Line 2358 
2358          my $nurl = $sprout->GroupPageName($group);          my $nurl = $sprout->GroupPageName($group);
2359          $retVal = $cgi->a({ href => $nurl, title => "$group summary" },          $retVal = $cgi->a({ href => $nurl, title => "$group summary" },
2360                            $group);                            $group);
2361        } elsif ($colName =~ /^keyword:(.+)$/) {
2362            # Here we want keyword-related values. This is also expensive, so
2363            # we compute them when the row is displayed.
2364            $retVal = "%%$colName=$fid";
2365        } elsif ($colName eq 'orgName') {
2366            # Here we want the formatted organism name and feature number.
2367            $retVal = $self->FeatureName($fid);
2368        } elsif ($colName eq 'protlink') {
2369            # Here we want a link to the protein page using the official NMPDR button.
2370            my $hurl = HTML::fid_link($cgi, $fid, 0, 1);
2371            $retVal = $cgi->a({ href => $hurl, title => "Protein page for $fid" },
2372                              $cgi->img({ src => "../images/button-nmpdr.png",
2373                                         border => 0 })
2374                             );
2375        }elsif ($colName eq 'subsystem') {
2376            # Another run-time column: subsystem list.
2377            $retVal = "%%subsystem=$fid";
2378        }
2379        # Return the result.
2380        return $retVal;
2381    }
2382    
2383    =head3 RunTimeColumns
2384    
2385    C<< my $htmlText = $shelp->RunTimeColumns($type, $text); >>
2386    
2387    Return the HTML text for a run-time column. Run-time columns are evaluated when the
2388    list is displayed, rather than when it is generated.
2389    
2390    =over 4
2391    
2392    =item type
2393    
2394    Type of column.
2395    
2396    =item text
2397    
2398    Data relevant to this row of the column.
2399    
2400    =item RETURN
2401    
2402    Returns the fully-formatted HTML text to go in the specified column.
2403    
2404    =back
2405    
2406    =cut
2407    
2408    sub RunTimeColumns {
2409        # Get the parameters.
2410        my ($self, $type, $text) = @_;
2411        # Declare the return variable.
2412        my $retVal = "";
2413        # Get the Sprout and CGI objects.
2414        my $sprout = $self->DB();
2415        my $cgi = $self->Q();
2416        Trace("Runtime column $type with text \"$text\" found.") if T(4);
2417        # Separate the text into a type and data.
2418        if ($type eq 'alias') {
2419            # Here the caller wants external alias links for a feature. The text
2420            # is the feature ID.
2421            my $fid = $text;
2422            # The complicated part is we have to hyperlink them. First, get the
2423            # aliases.
2424            Trace("Generating aliases for feature $fid.") if T(4);
2425            my @aliases = $sprout->FeatureAliases($fid);
2426            # Only proceed if we found some.
2427            if (@aliases) {
2428                # Join the aliases into a comma-delimited list.
2429                my $aliasList = join(", ", @aliases);
2430                # Ask the HTML processor to hyperlink them.
2431                $retVal = HTML::set_prot_links($cgi, $aliasList);
2432            }
2433        } elsif ($type eq 'subsystem') {
2434            # Here the caller wants the subsystems in which this feature participates.
2435            # The text is the feature ID. We will list the subsystem names with links
2436            # to the subsystem's summary page.
2437            my $fid = $text;
2438            # Get the subsystems.
2439            Trace("Generating subsystems for feature $fid.") if T(4);
2440            my %subs = $sprout->SubsystemsOf($fid);
2441            # Convert them to links.
2442            my @links = map { HTML::sub_link($cgi, $_) } sort keys %subs;
2443            # String them into a list.
2444            $retVal = join(", ", @links);
2445        } elsif ($type =~ /^keyword:(.+)$/) {
2446            # Here the caller wants the value of the named keyword. The text is the
2447            # feature ID.
2448            my $keywordName = $1;
2449            my $fid = $text;
2450            # Get the attribute values.
2451            Trace("Getting $keywordName values for feature $fid.") if T(4);
2452            my @values = $sprout->GetFlat(['Feature'], "Feature(id) = ?", [$fid],
2453                                          "Feature($keywordName)");
2454            # String them into a list.
2455            $retVal = join(", ", @values);
2456        }
2457        # Return the result.
2458        return $retVal;
2459      }      }
2460    
2461    =head3 SaveOrganismData
2462    
2463    C<< my ($name, $displayGroup) = $shelp->SaveOrganismData($group, $genomeID, $genus, $species, $strain); >>
2464    
2465    Format the name of an organism and the display version of its group name. The incoming
2466    data should be the relevant fields from the B<Genome> record in the database. The
2467    data will also be stored in the genome cache for later use in posting search results.
2468    
2469    =over 4
2470    
2471    =item group
2472    
2473    Name of the genome's group as it appears in the database.
2474    
2475    =item genomeID
2476    
2477    ID of the relevant genome.
2478    
2479    =item genus
2480    
2481    Genus of the genome's organism. If undefined or null, it will be assumed the genome is not
2482    in the database. In this case, the organism name is derived from the genomeID and the group
2483    is automatically the supporting-genomes group.
2484    
2485    =item species
2486    
2487    Species of the genome's organism.
2488    
2489    =item strain
2490    
2491    Strain of the species represented by the genome.
2492    
2493    =item RETURN
2494    
2495    Returns a two-element list. The first element is the formatted genome name. The second
2496    element is the display name of the genome's group.
2497    
2498    =back
2499    
2500    =cut
2501    
2502    sub SaveOrganismData {
2503        # Get the parameters.
2504        my ($self, $group, $genomeID, $genus, $species, $strain) = @_;
2505        # Declare the return values.
2506        my ($name, $displayGroup);
2507        # If the organism does not exist, format an unknown name and a blank group.
2508        if (! defined($genus)) {
2509            $name = "Unknown Genome $genomeID";
2510            $displayGroup = "";
2511        } else {
2512            # It does exist, so format the organism name.
2513            $name = "$genus $species";
2514            if ($strain) {
2515                $name .= " $strain";
2516            }
2517            # Compute the display group. This is currently the same as the incoming group
2518            # name unless it's the supporting group, which is nulled out.
2519            $displayGroup = ($group eq $FIG_Config::otherGroup ? "" : $group);
2520        }
2521        # Cache the group and organism data.
2522        my $cache = $self->{orgs};
2523        $cache->{$genomeID} = [$name, $displayGroup];
2524        # Return the result.
2525        return ($name, $displayGroup);
2526    }
2527    
2528    =head3 ValidateKeywords
2529    
2530    C<< my $okFlag = $shelp->ValidateKeywords($keywordString, $required); >>
2531    
2532    Insure that a keyword string is reasonably valid. If it is invalid, a message will be
2533    set.
2534    
2535    =over 4
2536    
2537    =item keywordString
2538    
2539    Keyword string specified as a parameter to the current search.
2540    
2541    =item required
2542    
2543    TRUE if there must be at least one keyword specified, else FALSE.
2544    
2545    =item RETURN
2546    
2547    Returns TRUE if the keyword string is valid, else FALSE. Note that a null keyword string
2548    is acceptable if the I<$required> parameter is not specified.
2549    
2550    =back
2551    
2552    =cut
2553    
2554    sub ValidateKeywords {
2555        # Get the parameters.
2556        my ($self, $keywordString, $required) = @_;
2557        # Declare the return variable.
2558        my $retVal = 0;
2559        my @wordList = split /\s+/, $keywordString;
2560        # Right now our only real worry is a list of all minus words. The problem with it is that
2561        # it will return an incorrect result.
2562        my @plusWords = grep { $_ =~ /^[^\-]/ } @wordList;
2563        if (! @wordList) {
2564            if ($required) {
2565                $self->SetMessage("No search words specified.");
2566            }
2567        } elsif (! @plusWords) {
2568            $self->SetMessage("At least one keyword must be positive. All the keywords entered are preceded by minus signs.");
2569        } else {
2570            $retVal = 1;
2571        }
2572        # Return the result.
2573        return $retVal;
2574    }
2575    
2576    =head2 Virtual Methods
2577    
2578    =head3 Form
2579    
2580    C<< my $html = $shelp->Form(); >>
2581    
2582    Generate the HTML for a form to request a new search.
2583    
2584    =head3 Find
2585    
2586    C<< my $resultCount = $shelp->Find(); >>
2587    
2588    Conduct a search based on the current CGI query parameters. The search results will
2589    be written to the session cache file and the number of results will be
2590    returned. If the search parameters are invalid, a result count of C<undef> will be
2591    returned and a result message will be stored in this object describing the problem.
2592    
2593    =head3 Description
2594    
2595    C<< my $htmlText = $shelp->Description(); >>
2596    
2597    Return a description of this search. The description is used for the table of contents
2598    on the main search tools page. It may contain HTML, but it should be character-level,
2599    not block-level, since the description is going to appear in a list.
2600    
2601    =head3 SortKey
2602    
2603    C<< my $key = $shelp->SortKey($fdata); >>
2604    
2605    Return the sort key for the specified feature data. The default is to sort by feature name,
2606    floating NMPDR organisms to the top. If a full-text search is used, then the default
2607    sort is by relevance followed by feature name. This sort may be overridden by the
2608    search class to provide fancier functionality. This method is called by
2609    B<PutFeature>, so it is only used for feature searches. A non-feature search
2610    would presumably have its own sort logic.
2611    
2612    =over 4
2613    
2614    =item record
2615    
2616    The C<FeatureData> containing the current feature.
2617    
2618    =item RETURN
2619    
2620    Returns a key field that can be used to sort this row in among the results.
2621    
2622    =back
2623    
2624    =cut
2625    
2626    sub SortKey {
2627        # Get the parameters.
2628        my ($self, $fdata) = @_;
2629        # Get the feature ID from the record.
2630        my $fid = $fdata->FID();
2631        # Get the group from the feature ID.
2632        my $group = $self->FeatureGroup($fid);
2633        # Ask the feature query object to form the sort key.
2634        my $retVal = $fdata->SortKey($self, $group);
2635      # Return the result.      # Return the result.
2636      return $retVal;      return $retVal;
2637  }  }

Legend:
Removed from v.1.2  
changed lines
  Added in v.1.17

MCS Webmaster
ViewVC Help
Powered by ViewVC 1.0.3