--- SearchHelper.pm 2006/10/07 13:18:11 1.9 +++ SearchHelper.pm 2007/05/11 06:28:21 1.31 @@ -88,6 +88,12 @@ TRUE if this is a feature-filtered search, else FALSE. B that this field is updated by the B object. +=item extraPos + +Hash indicating which extra columns should be put at the end. Extra columns +not mentioned in this hash are put at the beginning. Use the L +method to change this option. + =back =head2 Adding a new Search Tool @@ -113,8 +119,7 @@ =item 4 -In the C script, add a C statement for your search tool -and then put the class name in the C<@advancedClasses> list. +In the C script and add a C statement for your search tool. =back @@ -177,6 +182,10 @@ =back +If you are doing a feature search, you can also change the list of feature +columns displayed and their display order by overriding +L. + Finally, when generating the code for your controls, be sure to use any incoming query parameters as default values so that the search request is persistent. @@ -222,11 +231,21 @@ } A Find method is of course much more complicated than generating a form, and there -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 entirely in favor of your own custom filtering, you could include extra columns in the output, or you could search for something that's not a feature at all. The above code is just a loose framework. +In addition to the finding and filtering, it is necessary to send status messages +to the output so that the user does not get bored waiting for results. The L +method performs this function. The single parameter should be text to be +output to the browser. In general, you'll invoke it as follows. + + $self->PrintLine("...my message text...
"); + +The break tag is optional. When the Find method gets control, a paragraph will +have been started so that everything is XHTML-compliant. + If you wish to add your own extra columns to the output, use the B method of the feature query object. @@ -241,18 +260,20 @@ # This counter is used to insure every form on the page has a unique name. my $formCount = 0; +# This counter is used to generate unique DIV IDs. +my $divCount = 0; =head2 Public Methods =head3 new -C<< my $shelp = SearchHelper->new($query); >> +C<< my $shelp = SearchHelper->new($cgi); >> Construct a new SearchHelper object. =over 4 -=item query +=item cgi The CGI query object for the current script. @@ -262,22 +283,32 @@ sub new { # Get the parameters. - my ($class, $query) = @_; + my ($class, $cgi) = @_; # Check for a session ID. - my $session_id = $query->param("SessionID"); + my $session_id = $cgi->param("SessionID"); my $type = "old"; if (! $session_id) { + Trace("No session ID found.") if T(3); # Here we're starting a new session. We create the session ID and # store it in the query object. $session_id = NewSessionID(); $type = "new"; - $query->param(-name => 'SessionID', -value => $session_id); + $cgi->param(-name => 'SessionID', -value => $session_id); + } else { + Trace("Session ID is $session_id.") if T(3); } # Compute the subclass name. - $class =~ /SH(.+)$/; - my $subClass = $1; + my $subClass; + if ($class =~ /SH(.+)$/) { + # Here we have a real search class. + $subClass = $1; + } else { + # Here we have a bare class. The bare class cannot search, but it can + # process search results. + $subClass = 'SearchHelper'; + } # Insure everybody knows we're in Sprout mode. - $query->param(-name => 'SPROUT', -value => 1); + $cgi->param(-name => 'SPROUT', -value => 1); # Generate the form name. my $formName = "$class$formCount"; $formCount++; @@ -285,7 +316,7 @@ # as well as an indicator as to whether or not the session is new, plus the # class name and a placeholder for the Sprout object. my $retVal = { - query => $query, + query => $cgi, type => $type, class => $subClass, sprout => undef, @@ -295,6 +326,7 @@ genomeList => undef, genomeParms => [], filtered => 0, + extraPos => {}, }; # Bless and return it. bless $retVal, $class; @@ -355,6 +387,31 @@ return ($self->{type} eq 'new'); } +=head3 SetExtraPos + +C<< $shelp->SetExtraPos(@columnMap); >> + +Indicate whether the extra columns should be in the front (C<0>) or end (C<1>) columns of the results. + +=over 4 + +=item columnMap + +A list of extra columns to display at the end. + +=back + +=cut + +sub SetExtraPos { + # Get the parameters. + my ($self, @columnMap) = @_; + # Convert the column map to a hash. + my %map = map { $_ => 1 } @columnMap; + # Save a reference to it. + $self->{extraPos} = \%map; +} + =head3 ID C<< my $sessionID = $shelp->ID(); >> @@ -449,13 +506,15 @@ my ($self, $title) = @_; # Get the CGI object. my $cgi = $self->Q(); - # Start the form. + # Start the form. Note we use the override option on the Class value, in + # case the Advanced button was used. my $retVal = "
\n" . $cgi->start_form(-method => 'POST', -action => $cgi->url(-relative => 1), -name => $self->FormName()) . $cgi->hidden(-name => 'Class', - -value => $self->{class}) . + -value => $self->{class}, + -override => 1) . $cgi->hidden(-name => 'SPROUT', -value => 1) . $cgi->h3($title); @@ -609,7 +668,7 @@ =head3 PutFeature -C<< $shelp->PutFeature($fquery); >> +C<< $shelp->PutFeature($fdata); >> Store a feature in the result cache. This is the workhorse method for most searches, since the primary data item in the database is features. @@ -620,8 +679,8 @@ the feature query object using the B method. For example, the following code adds columns for essentiality and virulence. - $fq->AddExtraColumns(essential => $essentialFlag, virulence => $vfactor); - $shelp->PutFeature($fq); + $fd->AddExtraColumns(essential => $essentialFlag, virulence => $vfactor); + $shelp->PutFeature($fd); For correct results, all values should be specified for all extra columns in all calls to B. (In particular, the column header names are computed on the first @@ -631,14 +690,14 @@ if (! $essentialFlag) { $essentialFlag = undef; } - $fq->AddExtraColumns(essential => $essentialFlag, virulence => $vfactor); - $shelp->PutFeature($fq); + $fd->AddExtraColumns(essential => $essentialFlag, virulence => $vfactor); + $shelp->PutFeature($fd); =over 4 -=item fquery +=item fdata -FeatureQuery object containing the current feature data. +B object containing the current feature data. =back @@ -646,38 +705,61 @@ sub PutFeature { # Get the parameters. - my ($self, $fq) = @_; + my ($self, $fd) = @_; # Get the CGI query object. my $cgi = $self->Q(); # Get the feature data. - my $record = $fq->Feature(); - my $extraCols = $fq->ExtraCols(); + my $record = $fd->Feature(); + my $extraCols = $fd->ExtraCols(); # Check for a first-call situation. if (! defined $self->{cols}) { - # Here we need to set up the column information. Start with the defaults. - $self->{cols} = $self->DefaultFeatureColumns(); - # Add the externals if they were requested. - if ($cgi->param('ShowAliases')) { - push @{$self->{cols}}, 'alias'; - } - # Append the extras, sorted by column name. + Trace("Setting up the columns.") if T(3); + # Tell the user what's happening. + $self->PrintLine("Creating output columns.
"); + # Here we need to set up the column information. First we accumulate the extras, + # sorted by column name and separate by whether they go in the beginning or the + # end. + my @xtraNamesFront = (); + my @xtraNamesEnd = (); + my $xtraPosMap = $self->{extraPos}; for my $col (sort keys %{$extraCols}) { - push @{$self->{cols}}, "X=$col"; + if ($xtraPosMap->{$col}) { + push @xtraNamesEnd, "X=$col"; + } else { + push @xtraNamesFront, "X=$col"; + } } - # Write out the column headers. This also prepares the cache file to receive + # Set up the column name array. + my @colNames = (); + # Put in the extra columns that go in the beginning. + push @colNames, @xtraNamesFront; + # Add the default columns. + push @colNames, $self->DefaultFeatureColumns(); + # Add any additional columns requested by the feature filter. + push @colNames, FeatureQuery::AdditionalColumns($self); + # If extras go at the end, put them in here. + push @colNames, @xtraNamesEnd; + Trace("Full column list determined.") if T(3); + # Save the full list. + $self->{cols} = \@colNames; + # Write out the column names. This also prepares the cache file to receive # output. - $self->WriteColumnHeaders(map { $self->FeatureColumnTitle($_) } @{$self->{cols}}); + Trace("Writing column headers.") if T(3); + $self->WriteColumnHeaders(@{$self->{cols}}); + Trace("Column headers written.") if T(3); } # Get the feature ID. - my ($fid) = $record->Value('Feature(id)'); - # Loop through the column headers, producing the desired data. - my @output = (); + my $fid = $fd->FID(); + # Loop through the column headers, producing the desired data. The first column + # is the feature ID. The feature ID does not show up in the output: its purpose + # is to help the various output formatters. + my @output = ($fid); for my $colName (@{$self->{cols}}) { push @output, $self->FeatureColumnValue($colName, $record, $extraCols); } # Compute the sort key. The sort key usually floats NMPDR organism features to the # top of the return list. - my $key = $self->SortKey($record); + my $key = $self->SortKey($fd); # Write the feature data. $self->WriteColumnData($key, @output); } @@ -760,6 +842,9 @@ # We found one, so close it. Trace("Closing session file.") if T(2); close $self->{fileHandle}; + # Tell the user. + my $cgi = $self->Q(); + $self->PrintLine("Output formatting complete.
"); } } @@ -826,20 +911,9 @@ ['Genome(genus)', 'Genome(species)', 'Genome(unique-characterization)', 'Genome(primary-group)']); - # Null out the supporting group. - $group = "" if ($group eq $FIG_Config::otherGroup); - # If the organism does not exist, format an unknown name. - 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]; + # Format and cache the name and display group. + ($orgName, $group) = $self->SaveOrganismData($group, $genomeID, $genus, $species, + $strain); } # Return the result. return ($orgName, $group); @@ -950,22 +1024,15 @@ =head3 ComputeFASTA -C<< my $fasta = $shelp->ComputeFASTA($incomingType, $desiredType, $sequence); >> +C<< my $fasta = $shelp->ComputeFASTA($desiredType, $sequence); >> -Parse a sequence input and convert it into a FASTA string of the desired type. Note -that it is possible to convert a DNA sequence into a protein sequence, but the reverse -is not possible. +Parse a sequence input and convert it into a FASTA string of the desired type. =over 4 -=item incomingType - -C if this is a DNA sequence, C if this is a protein sequence. - =item desiredType -C to return a DNA sequence, C to return a protein sequence. If the -I<$incomingType> is C and this value is C, an error will be thrown. +C to return a DNA sequence, C to return a protein sequence. =item sequence @@ -987,75 +1054,238 @@ sub ComputeFASTA { # Get the parameters. - my ($self, $incomingType, $desiredType, $sequence) = @_; + my ($self, $desiredType, $sequence) = @_; # Declare the return variable. If an error occurs, it will remain undefined. my $retVal; + # This variable will be cleared if an error is detected. + my $okFlag = 1; # Create variables to hold the FASTA label and data. my ($fastaLabel, $fastaData); - # Check for a feature specification. + Trace("FASTA desired type is $desiredType.") if T(4); + # Check for a feature specification. The smoking gun for that is a vertical bar. if ($sequence =~ /^\s*(\w+\|\S+)\s*$/) { # Here we have a feature ID in $1. We'll need the Sprout object to process # it. my $fid = $1; + Trace("Feature ID for fasta is $fid.") if T(3); my $sprout = $self->DB(); # Get the FIG ID. Note that we only use the first feature found. We are not # supposed to have redundant aliases, though we may have an ID that doesn't # exist. my ($figID) = $sprout->FeaturesByAlias($fid); if (! $figID) { - $self->SetMessage("No feature found with the ID \"$fid\"."); + $self->SetMessage("No gene found with the ID \"$fid\"."); + $okFlag = 0; } else { - # Set the FASTA label. - my $fastaLabel = $fid; + # Set the FASTA label. The ID is the first favored alias. + my $favored = $self->Q()->param('FavoredAlias') || 'fig'; + my $favorLen = length $favored; + ($fastaLabel) = grep { substr($_, 0, $favorLen) eq $favored } $sprout->FeatureAliases($fid); + if (! $fastaLabel) { + # In an emergency, fall back to the original ID. + $fastaLabel = $fid; + } # Now proceed according to the sequence type. - if ($desiredType =~ /prot/i) { + if ($desiredType eq 'prot') { # We want protein, so get the translation. $fastaData = $sprout->FeatureTranslation($figID); + Trace(length $fastaData . " characters returned for translation of $fastaLabel.") if T(3); } else { # We want DNA, so get the DNA sequence. This is a two-step process. my @locList = $sprout->FeatureLocation($figID); $fastaData = $sprout->DNASeq(\@locList); + Trace(length $fastaData . " characters returned for DNA of $fastaLabel.") if T(3); } } - } elsif ($incomingType =~ /prot/ && $desiredType =~ /dna/) { - # Here we're being asked to do an impossible conversion. - $self->SetMessage("Cannot convert a protein sequence to DNA."); } else { + Trace("Analyzing FASTA sequence.") if T(4); # Here we are expecting a FASTA. We need to see if there's a label. - if ($sequence =~ /^>\s*(\S.*)\s*\n(.+)$/) { + if ($sequence =~ /^>[\n\s]*(\S[^\n]*)\n(.+)$/s) { + Trace("Label \"$1\" found in match to sequence:\n$sequence") if T(4); # Here we have a label, so we split it from the data. $fastaLabel = $1; $fastaData = $2; } else { + Trace("No label found in match to sequence:\n$sequence") if T(4); # Here we have no label, so we create one and use the entire sequence # as data. - $fastaLabel = "User-specified $incomingType sequence"; + $fastaLabel = "User-specified $desiredType sequence"; $fastaData = $sequence; } # The next step is to clean the junk out of the sequence. $fastaData =~ s/\n//g; $fastaData =~ s/\s+//g; - # Finally, if the user wants to convert to protein, we do it here. Note that - # we've already prevented a conversion from protein to DNA. - if ($incomingType ne $desiredType) { - $fastaData = Sprout::Protein($fastaData); + # Finally, verify that it's DNA if we're doing DNA stuff. + if ($desiredType eq 'dna' && $fastaData =~ /[^agctxn]/i) { + $self->SetMessage("Invalid characters detected. Is the input really a DNA sequence?"); + $okFlag = 0; } } - # At this point, either "$fastaLabel" and "$fastaData" have values or an error is - # in progress. - if (defined $fastaLabel) { + Trace("FASTA data sequence: $fastaData") if T(4); + # Only proceed if no error was detected. + if ($okFlag) { # We need to format the sequence into 60-byte chunks. We use the infamous # grep-split trick. The split, because of the presence of the parentheses, # includes the matched delimiters in the output list. The grep strips out # the empty list items that appear between the so-called delimiters, since # the delimiters are what we want. my @chunks = grep { $_ } split /(.{1,60})/, $fastaData; - my $retVal = join("\n", ">$fastaLabel", @chunks, ""); + $retVal = join("\n", ">$fastaLabel", @chunks, ""); } # Return the result. return $retVal; } +=head3 SubsystemTree + +C<< my $tree = SearchHelper::SubsystemTree($sprout, %options); >> + +This method creates a subsystem selection tree suitable for passing to +L. Each leaf node in the tree will have a link to the +subsystem display page. In addition, each node can have a radio button. The +radio button alue is either CI, where I is +a classification string, or CI, where I is a subsystem ID. +Thus, it can either be used to filter by a group of related subsystems or a +single subsystem. + +=over 4 + +=item sprout + +Sprout database object used to get the list of subsystems. + +=item options + +Hash containing options for building the tree. + +=item RETURN + +Returns a reference to a tree list suitable for passing to L. + +=back + +The supported options are as follows. + +=over 4 + +=item radio + +TRUE if the tree should be configured for radio buttons. The default is FALSE. + +=item links + +TRUE if the tree should be configured for links. The default is TRUE. + +=back + +=cut + +sub SubsystemTree { + # Get the parameters. + my ($sprout, %options) = @_; + # Process the options. + my $optionThing = Tracer::GetOptions({ radio => 0, links => 1 }, \%options); + # Read in the subsystems. + my @subs = $sprout->GetAll(['Subsystem'], "ORDER BY Subsystem(classification), Subsystem(id)", [], + ['Subsystem(classification)', 'Subsystem(id)']); + # Put any unclassified subsystems at the end. They will always be at the beginning, so if one + # is at the end, ALL subsystems are unclassified and we don't bother. + if ($#subs >= 0 && $subs[$#subs]->[0] ne '') { + while ($subs[0]->[0] eq '') { + my $classLess = shift @subs; + push @subs, $classLess; + } + } + # Declare the return variable. + my @retVal = (); + # Each element in @subs represents a leaf node, so as we loop through it we will be + # producing one leaf node at a time. The leaf node is represented as a 2-tuple. The + # first element is a semi-colon-delimited list of the classifications for the + # subsystem. There will be a stack of currently-active classifications, which we will + # compare to the incoming classifications from the end backward. A new classification + # requires starting a new branch. A different classification requires closing an old + # branch and starting a new one. Each classification in the stack will also contain + # that classification's current branch. We'll add a fake classification at the + # beginning that we can use to represent the tree as a whole. + my $rootName = ''; + # Create the classification stack. Note the stack is a pair of parallel lists, + # one containing names and the other containing content. + my @stackNames = ($rootName); + my @stackContents = (\@retVal); + # Add a null entry at the end of the subsystem list to force an unrolling. + push @subs, ['', undef]; + # Loop through the subsystems. + for my $sub (@subs) { + # Pull out the classification list and the subsystem ID. + my ($classString, $id) = @{$sub}; + Trace("Processing class \"$classString\" and subsystem $id.") if T(4); + # Convert the classification string to a list with the root classification in + # the front. + my @classList = ($rootName, split($FIG_Config::splitter, $classString)); + # Find the leftmost point at which the class list differs from the stack. + my $matchPoint = 0; + while ($matchPoint <= $#stackNames && $matchPoint <= $#classList && + $stackNames[$matchPoint] eq $classList[$matchPoint]) { + $matchPoint++; + } + Trace("Match point is $matchPoint. Stack length is " . scalar(@stackNames) . + ". Class List length is " . scalar(@classList) . ".") if T(4); + # Unroll the stack to the matchpoint. + while ($#stackNames >= $matchPoint) { + my $popped = pop @stackNames; + pop @stackContents; + Trace("\"$popped\" popped from stack.") if T(4); + } + # Start branches for any new classifications. + while ($#stackNames < $#classList) { + # The branch for a new classification contains its radio button + # data and then a list of children. So, at this point, if radio buttons + # are desired, we put them into the content. + my $newLevel = scalar(@stackNames); + my @newClassContent = (); + if ($optionThing->{radio}) { + my $newClassString = join($FIG_Config::splitter, @classList[1..$newLevel]); + push @newClassContent, { value => "classification=$newClassString%" }; + } + # The new classification node is appended to its parent's content + # and then pushed onto the stack. First, we need the node name. + my $nodeName = $classList[$newLevel]; + # Add the classification to its parent. This makes it part of the + # tree we'll be returning to the user. + push @{$stackContents[$#stackNames]}, $nodeName, \@newClassContent; + # Push the classification onto the stack. + push @stackContents, \@newClassContent; + push @stackNames, $nodeName; + Trace("\"$nodeName\" pushed onto stack.") if T(4); + } + # Now the stack contains all our parent branches. We add the subsystem to + # the branch at the top of the stack, but only if it's NOT the dummy node. + if (defined $id) { + # Compute the node name from the ID. + my $nodeName = $id; + $nodeName =~ s/_/ /g; + # Create the node's leaf hash. This depends on the value of the radio + # and link options. + my $nodeContent = {}; + if ($optionThing->{links}) { + # Compute the link value. + my $linkable = uri_escape($id); + $nodeContent->{link} = "../FIG/display_subsys.cgi?ssa_name=$linkable;request=show_ssa;sort=by_phylo;show_clusters=1;SPROUT=1"; + } + if ($optionThing->{radio}) { + # Compute the radio value. + $nodeContent->{value} = "id=$id"; + } + # Push the node into its parent branch. + Trace("\"$nodeName\" added to node list.") if T(4); + push @{$stackContents[$#stackNames]}, $nodeName, $nodeContent; + } + } + # Return the result. + return \@retVal; +} + + =head3 NmpdrGenomeMenu C<< my $htmlText = $shelp->NmpdrGenomeMenu($menuName, $multiple, \@selected, $rows); >> @@ -1136,12 +1366,11 @@ for my $genome (@genomeList) { # Get the genome data. my ($group, $genomeID, $genus, $species, $strain) = @{$genome}; - # Form the genome name. - my $name = "$genus $species"; - if ($strain) { - $name .= " $strain"; - } - # Push the genome into the group's list. + # Compute and cache its name and display group. + my ($name, $displayGroup) = $self->SaveOrganismData($group, $genomeID, $genus, $species, + $strain); + # Push the genome into the group's list. Note that we use the real group + # name here, not the display group name. push @{$gHash{$group}}, [$genomeID, $name]; } # Save the genome list for future use. @@ -1158,7 +1387,10 @@ if (defined $selected) { %selectedHash = map { $_ => 1 } grep { defined($_) } @{$selected}; } - # Now it gets complicated. We need a way to mark all the NMPDR genomes. + # Now it gets complicated. We need a way to mark all the NMPDR genomes. We take advantage + # of the fact they come first in the list. We'll accumulate a count of the NMPDR genomes + # and use that to make the selections. + my $nmpdrCount = 0; # Create the type counters. my $groupCount = 1; # Compute the ID for the status display. @@ -1168,31 +1400,32 @@ # If multiple selection is supported, create an onChange event. my $onChange = ""; if ($cross) { + # Here we have a paired menu. Selecting something in our menu unselects it in the + # other and redisplays the status of both. $onChange = " onChange=\"crossUnSelect($menuName, '$divID', $cross, '${formName}_${cross}_status', 1000)\""; } elsif ($multiple) { + # This is an unpaired menu, so all we do is redisplay our status. $onChange = " onChange=\"$showSelect\""; } # Create the SELECT tag and stuff it into the output array. - my $select = ""); # Loop through the groups. for my $group (@groups) { # Create the option group tag. my $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, so we can't use it. - my $label = ($group eq $FIG_Config::otherGroup ? "other" : "nmpdr"); # Get the genomes in the group. for my $genome (@{$groupHash->{$group}}) { + # Count this organism if it's NMPDR. + if ($group ne $FIG_Config::otherGroup) { + $nmpdrCount++; + } + # Get the organism ID and name. my ($genomeID, $name) = @{$genome}; # See if it's selected. my $select = ($selectedHash{$genomeID} ? " selected" : ""); # Generate the option tag. - my $optionTag = ""; + my $optionTag = ""; push @lines, " $optionTag"; } # Close the option group. @@ -1202,17 +1435,19 @@ push @lines, ""; # Check for multiple selection. if ($multiple) { - # Since multi-select is on, we set up some buttons to set and clear selections. - push @lines, "
"; - push @lines, ""; - push @lines, ""; - push @lines, ""; - push @lines, ""; - # Now add the search box. This allows the user to type text and have all genomes containing + # Multi-select is on, so we need to add some selection helpers. First is + # the search box. This allows the user to type text and have all genomes containing # the text selected automatically. my $searchThingName = "${menuName}_SearchThing"; - push @lines, "
Select genomes containing  " . - ""; + push @lines, "
" . + " " . + ""; + # Next are the buttons to set and clear selections. + push @lines, "
"; + push @lines, ""; + push @lines, ""; + push @lines, ""; + push @lines, ""; # Add the status display, too. push @lines, "
"; # Queue to update the status display when the form loads. We need to modify the show statement @@ -1299,8 +1534,8 @@ =item rows Reference to a list of table rows. Each table row must be in HTML form with all -the TR and TD tags set up. The first TD or TH tag in each row will be modified to -set the width. Everything else will be left as is. +the TR and TD tags set up. The first TD or TH tag in the first non-colspanned row +will be modified to set the width. Everything else will be left as is. =item RETURN @@ -1315,11 +1550,26 @@ my ($self, $rows) = @_; # Get the CGI object. my $cgi = $self->Q(); - # Fix the widths on the first column. Note that we eschew the use of the "g" + # The first column of the first row must have its width fixed. + # This flag will be set to FALSE when that happens. + my $needWidth = 1; # modifier becase we only want to change the first tag. Also, if a width # is already specified on the first column bad things will happen. for my $row (@{$rows}) { - $row =~ s/(]+)>/i) { + # Here we have a first cell and its tag parameters are in $2. + my $elements = $2; + if ($elements !~ /colspan/i) { + Trace("No colspan tag found in element \'$elements\'.") if T(3); + # Here there's no colspan, so we plug in the width. We + # eschew the "g" modifier on the substitution because we + # only want to update the first cell. + $row =~ s/(<(td|th))/$1 width="150"/i; + # Denote we don't need this any more. + $needWidth = 0; + } + } } # Create the table. my $retVal = $cgi->table({border => 2, cellspacing => 2, @@ -1331,18 +1581,33 @@ =head3 SubmitRow -C<< my $htmlText = $shelp->SubmitRow(); >> +C<< my $htmlText = $shelp->SubmitRow($caption); >> Returns the HTML text for the row containing the page size control and the submit button. All searches should have this row somewhere near the top of the form. +=over 4 + +=item caption (optional) + +Caption to be put on the search button. The default is C. + +=item RETURN + +Returns a table row containing the controls for submitting the search +and tuning the results. + +=back + =cut sub SubmitRow { # Get the parameters. - my ($self) = @_; + my ($self, $caption) = @_; my $cgi = $self->Q(); + # Compute the button caption. + my $realCaption = (defined $caption ? $caption : 'Go'); # Get the current page size. my $pageSize = $cgi->param('PageSize'); # Get the incoming external-link flag. @@ -1351,32 +1616,46 @@ my $retVal = $cgi->Tr($cgi->td("Results/Page"), $cgi->td($cgi->popup_menu(-name => 'PageSize', -values => [10, 25, 50, 100, 1000], - -default => $pageSize) . " " . - $cgi->checkbox(-name => 'ShowURL', - -value => 1, - -label => 'Show URL')), + -default => $pageSize)), $cgi->td($cgi->submit(-class => 'goButton', -name => 'Search', - -value => 'Go'))); + -value => $realCaption))); # Return the result. return $retVal; } =head3 FeatureFilterRows -C<< my $htmlText = $shelp->FeatureFilterRows(); >> +C<< my $htmlText = $shelp->FeatureFilterRows(@subset); >> + +This method creates table rows that can be used to filter features. The form +values can be used to select features by genome using the B +object. + +=over 4 -This method creates table rows that can be used to filter features. There are -two rows returned, and the values can be used to select features by genome -using the B object. +=item subset + +List of rows to display. The default (C) is to display all rows. +C displays the word search box, C displays the subsystem +selector, and C displays the options row. + +=item RETURN + +Returns the html text for table rows containing the desired feature filtering controls. + +=back =cut sub FeatureFilterRows { # Get the parameters. - my ($self) = @_; + my ($self, @subset) = @_; + if (@subset == 0 || $subset[0] eq 'all') { + @subset = qw(words subsys options); + } # Return the result. - return FeatureQuery::FilterRows($self); + return FeatureQuery::FilterRows($self, @subset); } =head3 GBrowseFeatureURL @@ -1451,7 +1730,7 @@ $seg_id =~ s/:/--/g; Trace("Show limits are ($show_start,$show_stop) in genome $genomeID with ref $seg_id.") if T(3); # Assemble all the pieces. - $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"; } # Return the result. return $retVal; @@ -1544,7 +1823,7 @@ =head3 ComputeSearchURL -C<< my $url = $shelp->ComputeSearchURL(); >> +C<< my $url = $shelp->ComputeSearchURL(%overrides); >> Compute the GET-style URL for the current search. In order for this to work, there must be a copy of the search form on the current page. This will always be the @@ -1554,11 +1833,25 @@ main complication is that if the user specified all genomes, we'll want to remove the parameter entirely from a get-style URL. +=over 4 + +=item overrides + +Hash containing override values for the parameters, where the parameter name is +the key and the parameter value is the override value. If the override value is +C, the parameter will be deleted from the result. + +=item RETURN + +Returns a GET-style URL for invoking the search with the specified overrides. + +=back + =cut sub ComputeSearchURL { # Get the parameters. - my ($self) = @_; + my ($self, %overrides) = @_; # Get the database and CGI query object. my $cgi = $self->Q(); my $sprout = $self->DB(); @@ -1585,21 +1878,7 @@ # a singleton list, but that's okay. my @values = split (/\0/, $parms{$parmKey}); # Check for special cases. - if ($parmKey eq 'featureTypes') { - # Here we need to see if the user wants all the feature types. If he - # does, we erase all the values so that the parameter is not output. - my %valueCheck = map { $_ => 1 } @values; - my @list = FeatureQuery::AllFeatureTypes(); - my $okFlag = 1; - for (my $i = 0; $okFlag && $i <= $#list; $i++) { - if (! $valueCheck{$list[$i]}) { - $okFlag = 0; - } - } - if ($okFlag) { - @values = (); - } - } elsif (grep { $_ eq $parmKey } qw(SessionID ResultCount Page PageSize Trace TF ShowURL)) { + if (grep { $_ eq $parmKey } qw(SessionID ResultCount Page PageSize Trace TF)) { # These are bookkeeping parameters we don't need to start a search. @values = (); } elsif ($parmKey =~ /_SearchThing$/) { @@ -1613,12 +1892,22 @@ if ($allFlag) { @values = (); } + } elsif (exists $overrides{$parmKey}) { + # Here the value is being overridden, so we skip it for now. + @values = (); } # If we still have values, create the URL parameters. if (@values) { push @urlList, map { "$parmKey=" . uri_escape($_) } @values; } } + # Now do the overrides. + for my $overKey (keys %overrides) { + # Only use this override if it's not a delete marker. + if (defined $overrides{$overKey}) { + push @urlList, "$overKey=" . uri_escape($overrides{$overKey}); + } + } # Add the parameters to the URL. $retVal .= "?" . join(";", @urlList); # Return the result. @@ -1661,45 +1950,422 @@ return $retVal; } -=head3 FeatureTypeMap +=head3 AdvancedClassList -C<< my %features = SearchHelper::FeatureTypeMap(); >> +C<< my @classes = SearchHelper::AdvancedClassList(); >> -Return a map of feature types to descriptions. The feature type data is stored -in the B file. Currently, it only contains a space-delimited list of -feature types. The map returned by this method is a hash mapping the type codes to -descriptive names. +Return a list of advanced class names. This list is used to generate the directory +of available searches on the search page. -The reason we have to convert the list from a string is that the B -script is only able to insert strings into the generated B file. +We use the %INC variable to accomplish this. =cut -sub FeatureTypeMap { - my @list = split /\s+/, $FIG_Config::feature_types; - my %retVal = map { $_ => $_ } @list; - return %retVal; +sub AdvancedClassList { + my @retVal = map { $_ =~ /^SH(\w+)\.pm/; $1 } grep { $_ =~ /^SH/ } keys %INC; + return sort @retVal; } -=head3 AdvancedClassList +=head3 SelectionTree -C<< my @classes = SearchHelper::AdvancedClassList(); >> +C<< my $htmlText = SearchHelper::SelectionTree($cgi, \%tree, %options); >> -Return a list of advanced class names. This list is used to generate the directory -of available searches on the search page. +Display a selection tree. + +This method creates the HTML for a tree selection control. The tree is implemented as a set of +nested HTML unordered lists. Each selectable element of the tree will contain a radio button. In +addition, some of the tree nodes can contain hyperlinks. + +The tree itself is passed in as a multi-level list containing node names followed by +contents. Each content element is a reference to a similar list. The first element of +each list may be a hash reference. If so, it should contain one or both of the following +keys. + +=over 4 + +=item link + +The navigation URL to be popped up if the user clicks on the node name. + +=item value + +The form value to be returned if the user selects the tree node. + +=back + +The presence of a C key indicates the node name will be hyperlinked. The presence of +a C key indicates the node name will have a radio button. If a node has no children, +you may pass it a hash reference instead of a list reference. + +The following example shows the hash for a three-level tree with links on the second level and +radio buttons on the third. + + [ Objects => [ + Entities => [ + {link => "../docs/WhatIsAnEntity.html"}, + Genome => {value => 'GenomeData'}, + Feature => {value => 'FeatureData'}, + Contig => {value => 'ContigData'}, + ], + Relationships => [ + {link => "../docs/WhatIsARelationShip.html"}, + HasFeature => {value => 'GenomeToFeature'}, + IsOnContig => {value => 'FeatureToContig'}, + ] + ] + ] + +Note how each leaf of the tree has a hash reference for its value, while the branch nodes +all have list references. + +This next example shows how to set up a taxonomy selection field. The value returned +by the tree control will be the taxonomy string for the selected node ready for use +in a LIKE-style SQL filter. Only the single branch ending in campylobacter is shown for +reasons of space. + + [ All => [ + {value => "%"}, + Bacteria => [ + {value => "Bacteria%"}, + Proteobacteria => [ + {value => "Bacteria; Proteobacteria%"}, + Epsilonproteobacteria => [ + {value => "Bacteria; Proteobacteria;Epsilonproteobacteria%"}, + Campylobacterales => [ + {value => "Bacteria; Proteobacteria; Epsilonproteobacteria; Campylobacterales%"}, + Campylobacteraceae => + {value => "Bacteria; Proteobacteria; Epsilonproteobacteria; Campylobacterales; Campylobacteraceae%"}, + ... + ] + ... + ] + ... + ] + ... + ] + ... + ] + ] + + +This method of tree storage allows the caller to control the order in which the tree nodes +are displayed and to completely control value selection and use of hyperlinks. It is, however +a bit complicated. Eventually, tree-building classes will be provided to simplify things. + +The parameters to this method are as follows. + +=over 4 + +=item cgi + +CGI object used to generate the HTML. + +=item tree + +Reference to a hash describing a tree. See the description above. + +=item options + +Hash containing options for the tree display. + +=back + +The allowable options are as follows + +=over 4 + +=item nodeImageClosed + +URL of the image to display next to the tree nodes when they are collapsed. Clicking +on the image will expand a section of the tree. The default is C<../FIG/Html/plus.gif>. + +=item nodeImageOpen + +URL of the image to display next to the tree nodes when they are expanded. Clicking +on the image will collapse a section of the tree. The default is C<../FIG/Html/minus.gif>. + +=item style + +Style to use for the tree. The default is C. Because the tree style is implemented +as nested lists, the key components of this style are the definitions for the C
    and +C
  • tags. The default style file contains the following definitions. + + .tree ul { + margin-left: 0; padding-left: 22px + } + .tree li { + list-style-type: none; + } + +The default image is 22 pixels wide, so in the above scheme each tree level is indented from its +parent by the width of the node image. This use of styles limits the things we can do in formatting +the tree, but it has the advantage of vastly simplifying the tree creation. + +=item name + +Field name to give to the radio buttons in the tree. The default is C. + +=item target + +Frame target for links. The default is C<_self>. + +=item selected -The reason we have to convert the list from a string is that the B -script is only able to insert strings into the generated B file. +If specified, the value of the radio button to be pre-selected. + +=back =cut -sub AdvancedClassList { - return split /\s+/, $FIG_Config::advanced_classes; +sub SelectionTree { + # Get the parameters. + my ($cgi, $tree, %options) = @_; + # Get the options. + my $optionThing = Tracer::GetOptions({ name => 'selection', + nodeImageClosed => '../FIG/Html/plus.gif', + nodeImageOpen => '../FIG/Html/minus.gif', + style => 'tree', + target => '_self', + selected => undef}, + \%options); + # Declare the return variable. We'll do the standard thing with creating a list + # of HTML lines and rolling them together at the end. + my @retVal = (); + # Only proceed if the tree is present. + if (defined($tree)) { + # Validate the tree. + if (ref $tree ne 'ARRAY') { + Confess("Selection tree is not a list reference."); + } elsif (scalar @{$tree} == 0) { + # The tree is empty, so we do nothing. + } elsif ($tree->[0] eq 'HASH') { + Confess("Hash reference found at start of selection tree. The tree as a whole cannot have attributes, only tree nodes."); + } else { + # Here we have a real tree. Apply the tree style. + push @retVal, $cgi->start_div({ class => $optionThing->{style} }); + # Give us a DIV ID. + my $divID = GetDivID($optionThing->{name}); + # Show the tree. + push @retVal, ShowBranch($cgi, "(root)", $divID, $tree, $optionThing, 'block'); + # Close the DIV block. + push @retVal, $cgi->end_div(); + } + } + # Return the result. + return join("\n", @retVal, ""); +} + +=head3 ShowBranch + +C<< my @htmlLines = SearchHelper::ShowBranch($cgi, $label, $id, $branch, $options, $displayType); >> + +This is a recursive method that displays a branch of the tree. + +=over 4 + +=item cgi + +CGI object used to format HTML. + +=item label + +Label of this tree branch. It is only used in error messages. + +=item id + +ID to be given to this tree branch. The ID is used in the code that expands and collapses +tree nodes. + +=item branch + +Reference to a list containing the content of the tree branch. The list contains an optional +hash reference that is ignored and the list of children, each child represented by a name +and then its contents. The contents could by a hash reference (indicating the attributes +of a leaf node), or another tree branch. + +=item options + +Options from the original call to L. + +=item displayType + +C if the contents of this list are to be displayed, C if they are to be +hidden. + +=item RETURN + +Returns one or more HTML lines that can be used to display the tree branch. + +=back + +=cut + +sub ShowBranch { + # Get the parameters. + my ($cgi, $label, $id, $branch, $options, $displayType) = @_; + # Declare the return variable. + my @retVal = (); + # Start the branch. + push @retVal, $cgi->start_ul({ id => $id, style => "display:$displayType" }); + # Check for the hash and choose the start location accordingly. + my $i0 = (ref $branch->[0] eq 'HASH' ? 1 : 0); + # Get the list length. + my $i1 = scalar(@{$branch}); + # Verify we have an even number of elements. + if (($i1 - $i0) % 2 != 0) { + Trace("Branch elements are from $i0 to $i1.") if T(3); + Confess("Odd number of elements in tree branch $label."); + } else { + # Loop through the elements. + for (my $i = $i0; $i < $i1; $i += 2) { + # Get this node's label and contents. + my ($myLabel, $myContent) = ($branch->[$i], $branch->[$i+1]); + # Get an ID for this node's children (if any). + my $myID = GetDivID($options->{name}); + # Now we need to find the list of children and the options hash. + # This is a bit ugly because we allow the shortcut of a hash without an + # enclosing list. First, we need some variables. + my $attrHash = {}; + my @childHtml = (); + my $hasChildren = 0; + if (! ref $myContent) { + Confess("Invalid tree definition. Scalar found as content of node \"$myLabel\"."); + } elsif (ref $myContent eq 'HASH') { + # Here the node is a leaf and its content contains the link/value hash. + $attrHash = $myContent; + } elsif (ref $myContent eq 'ARRAY') { + # Here the node may be a branch. Its content is a list. + my $len = scalar @{$myContent}; + if ($len >= 1) { + # Here the first element of the list could by the link/value hash. + if (ref $myContent->[0] eq 'HASH') { + $attrHash = $myContent->[0]; + # If there's data in the list besides the hash, it's our child list. + # We can pass the entire thing as the child list, because the hash + # is ignored. + if ($len > 1) { + $hasChildren = 1; + } + } else { + $hasChildren = 1; + } + # If we have children, create the child list with a recursive call. + if ($hasChildren) { + Trace("Processing children of $myLabel.") if T(4); + push @childHtml, ShowBranch($cgi, $myLabel, $myID, $myContent, $options, 'none'); + Trace("Children of $myLabel finished.") if T(4); + } + } + } + # Okay, it's time to pause and take stock. We have the label of the current node + # in $myLabel, its attributes in $attrHash, and if it is NOT a leaf node, we + # have a child list in @childHtml. If it IS a leaf node, $hasChildren is 0. + # Compute the image HTML. It's tricky, because we have to deal with the open and + # closed images. + my @images = ($options->{nodeImageOpen}, $options->{nodeImageClosed}); + my $image = $images[$hasChildren]; + my $prefixHtml = $cgi->img({src => $image, id => "${myID}img"}); + if ($hasChildren) { + # If there are children, we wrap the image in a toggle hyperlink. + $prefixHtml = $cgi->a({ onClick => "javascript:treeToggle('$myID','$images[0]', '$images[1]')" }, + $prefixHtml); + } + # Now the radio button, if any. Note we use "defined" in case the user wants the + # value to be 0. + if (defined $attrHash->{value}) { + # Due to a glitchiness in the CGI stuff, we have to build the attribute + # hash for the "input" method. If the item is pre-selected, we add + # "checked => undef" to the hash. Otherwise, we can't have "checked" + # at all. + my $radioParms = { type => 'radio', + name => $options->{name}, + value => $attrHash->{value}, + }; + if (defined $options->{selected} && $options->{selected} eq $attrHash->{value}) { + $radioParms->{checked} = undef; + } + $prefixHtml .= $cgi->input($radioParms); + } + # Next, we format the label. + my $labelHtml = $myLabel; + Trace("Formatting tree node for \"$myLabel\".") if T(4); + # Apply a hyperlink if necessary. + if (defined $attrHash->{link}) { + $labelHtml = $cgi->a({ href => $attrHash->{link}, target => $options->{target} }, + $labelHtml); + } + # Finally, roll up the child HTML. If there are no children, we'll get a null string + # here. + my $childHtml = join("\n", @childHtml); + # Now we have all the pieces, so we can put them together. + push @retVal, $cgi->li("$prefixHtml$labelHtml$childHtml"); + } + } + # Close the tree branch. + push @retVal, $cgi->end_ul(); + # Return the result. + return @retVal; +} + +=head3 GetDivID + +C<< my $idString = SearchHelper::GetDivID($name); >> + +Return a new HTML ID string. + +=over 4 + +=item name + +Name to be prefixed to the ID string. + +=item RETURN + +Returns a hopefully-unique ID string. + +=back + +=cut + +sub GetDivID { + # Get the parameters. + my ($name) = @_; + # Compute the ID. + my $retVal = "elt_$name$divCount"; + # Increment the counter to make sure this ID is not re-used. + $divCount++; + # Return the result. + return $retVal; +} + + +=head3 PrintLine + +C<< $shelp->PrintLine($message); >> + +Print a line of CGI output. This is used during the operation of the B method while +searching, so the user sees progress in real-time. + +=over 4 + +=item message + +HTML text to display. + +=back + +=cut + +sub PrintLine { + # Get the parameters. + my ($self, $message) = @_; + # Send them to the output. + print "$message\n"; } =head2 Feature Column Methods -The methods in this column manage feature column data. If you want to provide the +The methods in this section manage feature column data. If you want to provide the 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. @@ -1707,21 +2373,27 @@ the name for the protein page link column is C. If the column is to appear in the default list of feature columns, add it to the list returned by L. Then add code to produce the column title to -L and code to produce its value to L, and -everything else will happen automatically. +L and code to produce its value to L. If the +feature column should be excluded from downloads, add it to the C +hash. Everything else will happen automatically. -There is one special column name syntax for extra columns (that is, nonstandard +There is a special column name syntax for extra columns (that is, nonstandard feature columns). If the column name begins with C, then it is presumed to be an extra column. The column title is the text after the C, and its value is pulled from the extra column hash. +=cut + +# This hash is used to determine which columns should not be included in downloads. +my %FeatureColumnSkip = map { $_ => 1 } qw(gblink viewerlink protlink); + =head3 DefaultFeatureColumns -C<< my $colNames = $shelp->DefaultFeatureColumns(); >> +C<< my @colNames = $shelp->DefaultFeatureColumns(); >> -Return a reference to a list of the default feature column identifiers. These -identifiers can be passed to L and L in -order to produce the column titles and row values. +Return a list of the default feature column identifiers. These identifiers can +be passed to L and L in order to +produce the column titles and row values. =cut @@ -1729,8 +2401,7 @@ # Get the parameters. my ($self) = @_; # Return the result. - return ['orgName', 'function', 'gblink', 'protlink', - FeatureQuery::AdditionalColumns($self)]; + return qw(orgName function gblink protlink); } =head3 FeatureColumnTitle @@ -1762,25 +2433,63 @@ if ($colName =~ /^X=(.+)$/) { # Here we have an extra column. $retVal = $1; - } elsif ($colName eq 'orgName') { - $retVal = "Name"; - } elsif ($colName eq 'fid') { - $retVal = "FIG ID"; } elsif ($colName eq 'alias') { $retVal = "External Aliases"; + } elsif ($colName eq 'fid') { + $retVal = "FIG ID"; } 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"; + } elsif ($colName =~ /^keyword:(.+)$/) { + $retVal = ucfirst $1; + } elsif ($colName eq 'orgName') { + $retVal = "Organism and Gene ID"; + } elsif ($colName eq 'protlink') { + $retVal = "NMPDR Protein Page"; + } elsif ($colName eq 'viewerlink') { + $retVal = "Annotation Page"; + } elsif ($colName eq 'subsystem') { + $retVal = "Subsystems"; + } elsif ($colName eq 'pdb') { + $retVal = "Best PDB Match"; } # Return the result. return $retVal; } +=head3 FeatureColumnDownload + +C<< my $keep = $shelp->FeatureColumnDownload($colName); >> + +Return TRUE if the named feature column is to be kept when downloading, else FALSE. + +=over 4 + +=item colName + +Name of the relevant feature column. + +=item RETURN + +Return TRUE if the named column should be kept while downloading, else FALSE. In general, +FALSE is returned if the column generates a button, image, or other purely-HTML value. + +=back + +=cut + +sub FeatureColumnDownload { + # Get the parameters. + my ($self, $colName) = @_; + # Return the determination. We download the column if it's not in the skip-hash. + # Note we return 0 and 1 instead of 1 and undef because it simplifies some tracing. + return (exists $FeatureColumnSkip{$colName} ? 0 : 1); +} + + =head3 FeatureColumnValue C<< my $value = $shelp->FeatureColumnValue($colName, $fid, \%extraCols); >> @@ -1795,7 +2504,7 @@ =item record -DBObject record for the feature being displayed in the current row. +ERDBObject record for the feature being displayed in the current row. =item extraCols @@ -1831,33 +2540,23 @@ if (defined $extraCols->{$1}) { $retVal = $extraCols->{$1}; } - } elsif ($colName eq 'orgName') { - # Here we want the formatted organism name and feature number. - $retVal = $self->FeatureName($fid); - } elsif ($colName eq 'fid') { - # Here we have the raw feature ID. We hyperlink it to the protein page. - $retVal = HTML::set_prot_links($fid); } elsif ($colName eq 'alias') { # In this case, the user wants a list of external aliases for the feature. # These are very expensive, so we compute them when the row is displayed. - $retVal = "%%aliases=$fid"; + # To do the computation, we need to know the favored alias type and the + # feature ID. + my $favored = $cgi->param("FavoredAlias") || "fig"; + $retVal = "%%alias=$fid,$favored"; + } elsif ($colName eq 'fid') { + # Here we have the raw feature ID. We hyperlink it to the protein page. + $retVal = HTML::set_prot_links($fid); } elsif ($colName eq 'function') { # The functional assignment is just a matter of getting some text. ($retVal) = $record->Value('Feature(assignment)'); } elsif ($colName eq 'gblink') { # Here we want a link to the GBrowse page using the official GBrowse button. - my $gurl = "GetGBrowse.cgi?fid=$fid"; - $retVal = $cgi->a({ href => $gurl, title => "GBrowse for $fid" }, - $cgi->img({ src => "../images/button-gbrowse.png", - border => 0 }) - ); - } 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 }) - ); + $retVal = FakeButton('GBrowse', "GetGBrowse.cgi", undef, + fid => $fid); } elsif ($colName eq 'group') { # Get the NMPDR group name. my (undef, $group) = $self->OrganismData($fid); @@ -1865,6 +2564,27 @@ my $nurl = $sprout->GroupPageName($group); $retVal = $cgi->a({ href => $nurl, title => "$group summary" }, $group); + } elsif ($colName =~ /^keyword:(.+)$/) { + # Here we want keyword-related values. This is also expensive, so + # we compute them when the row is displayed. + $retVal = "%%$colName=$fid"; + } elsif ($colName eq 'orgName') { + # Here we want the formatted organism name and feature number. + $retVal = $self->FeatureName($fid); + } elsif ($colName eq 'protlink') { + # Here we want a link to the protein page using the official NMPDR button. + $retVal = FakeButton('NMPDR', "protein.cgi", undef, + prot => $fid, SPROUT => 1, new_framework => 0, + user => ''); + } elsif ($colName eq 'viewerlink') { + # Here we want a link to the SEED viewer page using the official viewer button. + $retVal = FakeButton('Annotation', "index.cgi", undef, + action => 'ShowAnnotation', prot => $fid); + } elsif ($colName eq 'subsystem') { + # Another run-time column: subsystem list. + $retVal = "%%subsystem=$fid"; + } elsif ($colName eq 'pdb') { + $retVal = "%%pdb=$fid"; } # Return the result. return $retVal; @@ -1903,22 +2623,347 @@ # Get the Sprout and CGI objects. my $sprout = $self->DB(); my $cgi = $self->Q(); + Trace("Runtime column $type with text \"$text\" found.") if T(4); # Separate the text into a type and data. - if ($type eq 'aliases') { + if ($type eq 'alias') { # Here the caller wants external alias links for a feature. The text - # is the feature ID. - my $fid = $text; - # The complicated part is we have to hyperlink them. First, get the - # aliases. + # parameter for computing the alias is the feature ID followed by + # the favored alias type. + my ($fid, $favored) = split /\s*,\s*/, $text; + # The complicated part is we have to hyperlink them and handle the + # favorites. First, get the aliases. Trace("Generating aliases for feature $fid.") if T(4); - my @aliases = $sprout->FeatureAliases($fid); + my @aliases = sort $sprout->FeatureAliases($fid); # Only proceed if we found some. if (@aliases) { - # Join the aliases into a comma-delimited list. - my $aliasList = join(", ", @aliases); + # Split the aliases into favored and unfavored. + my @favored = (); + my @unfavored = (); + for my $alias (@aliases) { + # Use substr instead of pattern match because $favored is specified by the user + # and we don't want him to put funny meta-characters in there. + if (substr($alias, 0, length($favored)) eq $favored) { + push @favored, $alias; + } else { + push @unfavored, $alias; + } + } + # Rejoin the aliases into a comma-delimited list, with the favored ones first. + my $aliasList = join(", ", @favored, @unfavored); # Ask the HTML processor to hyperlink them. $retVal = HTML::set_prot_links($cgi, $aliasList); } + } elsif ($type eq 'subsystem') { + # Here the caller wants the subsystems in which this feature participates. + # The text is the feature ID. We will list the subsystem names with links + # to the subsystem's summary page. + my $fid = $text; + # Get the subsystems. + Trace("Generating subsystems for feature $fid.") if T(4); + my %subs = $sprout->SubsystemsOf($fid); + # Extract the subsystem names. + my @names = map { HTML::sub_link($cgi, $_) } sort keys %subs; + # String them into a list. + $retVal = join(", ", @names); + } elsif ($type =~ /^keyword:(.+)$/) { + # Here the caller wants the value of the named keyword. The text is the + # feature ID. + my $keywordName = $1; + my $fid = $text; + # Get the attribute values. + Trace("Getting $keywordName values for feature $fid.") if T(4); + my @values = $sprout->GetFlat(['Feature'], "Feature(id) = ?", [$fid], + "Feature($keywordName)"); + # String them into a list. + $retVal = join(", ", @values); + } elsif ($type eq 'pdb') { + # Here the caller wants the best PDB match to this feature. The text + # is the feature ID. We will display the PDB with a link to the + # PDB page along with the match score. If there are docking results we + # will display a link to the docking result search. + my $fid = $text; + # Ask for the best PDB. + my ($bestPDB) = $sprout->GetAll(['IsProteinForFeature', 'PDB'], + "IsProteinForFeature(from-link) = ? ORDER BY IsProteinForFeature(score) LIMIT 1", + [$fid], ['PDB(id)', 'PDB(docking-count)', 'IsProteinForFeature(score)']); + # Only proceed if there is a PDB. + if ($bestPDB) { + my ($pdbID, $dockingCount, $score) = @{$bestPDB}; + # Convert the PDB ID to a hyperlink. + my $pdbLink = SHDrugSearch::PDBLink($cgi, $pdbID); + # Append the score. + $retVal = "$pdbLink ($score)"; + # If there are docking results, append a docking results link. + if ($dockingCount > 0) { + my $dockString = "$dockingCount docking results"; + my $dockLink = $cgi->a({ href => $cgi->url() . "?Class=DrugSearch;PDB=$pdbID;NoForm=1", + alt => "View computed docking results for $pdbID", + title => "View computed docking results for $pdbID", + target => "_blank"}, + $dockString); + } + } + } + # Return the result. + return $retVal; +} + +=head3 SaveOrganismData + +C<< my ($name, $displayGroup) = $shelp->SaveOrganismData($group, $genomeID, $genus, $species, $strain); >> + +Format the name of an organism and the display version of its group name. The incoming +data should be the relevant fields from the B record in the database. The +data will also be stored in the genome cache for later use in posting search results. + +=over 4 + +=item group + +Name of the genome's group as it appears in the database. + +=item genomeID + +ID of the relevant genome. + +=item genus + +Genus of the genome's organism. If undefined or null, it will be assumed the genome is not +in the database. In this case, the organism name is derived from the genomeID and the group +is automatically the supporting-genomes group. + +=item species + +Species of the genome's organism. + +=item strain + +Strain of the species represented by the genome. + +=item RETURN + +Returns a two-element list. The first element is the formatted genome name. The second +element is the display name of the genome's group. + +=back + +=cut + +sub SaveOrganismData { + # Get the parameters. + my ($self, $group, $genomeID, $genus, $species, $strain) = @_; + # Declare the return values. + my ($name, $displayGroup); + # If the organism does not exist, format an unknown name and a blank group. + if (! defined($genus)) { + $name = "Unknown Genome $genomeID"; + $displayGroup = ""; + } else { + # It does exist, so format the organism name. + $name = "$genus $species"; + if ($strain) { + $name .= " $strain"; + } + # Compute the display group. This is currently the same as the incoming group + # name unless it's the supporting group, which is nulled out. + $displayGroup = ($group eq $FIG_Config::otherGroup ? "" : $group); + } + # Cache the group and organism data. + my $cache = $self->{orgs}; + $cache->{$genomeID} = [$name, $displayGroup]; + # Return the result. + return ($name, $displayGroup); +} + +=head3 ValidateKeywords + +C<< my $okFlag = $shelp->ValidateKeywords($keywordString, $required); >> + +Insure that a keyword string is reasonably valid. If it is invalid, a message will be +set. + +=over 4 + +=item keywordString + +Keyword string specified as a parameter to the current search. + +=item required + +TRUE if there must be at least one keyword specified, else FALSE. + +=item RETURN + +Returns TRUE if the keyword string is valid, else FALSE. Note that a null keyword string +is acceptable if the I<$required> parameter is not specified. + +=back + +=cut + +sub ValidateKeywords { + # Get the parameters. + my ($self, $keywordString, $required) = @_; + # Declare the return variable. + my $retVal = 0; + my @wordList = split /\s+/, $keywordString; + # Right now our only real worry is a list of all minus words. The problem with it is that + # it will return an incorrect result. + my @plusWords = grep { $_ =~ /^[^\-]/ } @wordList; + if (! @wordList) { + if ($required) { + $self->SetMessage("No search words specified."); + } else { + $retVal = 1; + } + } elsif (! @plusWords) { + $self->SetMessage("At least one keyword must be positive. All the keywords entered are preceded by minus signs."); + } else { + $retVal = 1; + } + # Return the result. + return $retVal; +} + +=head3 FakeButton + +C<< my $html = SearchHelper::FakeButton($caption, $url, $target, %parms); >> + +Create a fake button that hyperlinks to the specified URL with the specified parameters. +Unlike a real button, this one won't visibly click, but it will take the user to the +correct place. + +The parameters of this method are deliberately identical to L so that we +can switch easily from real buttons to fake ones in the code. + +=over 4 + +=item caption + +Caption to be put on the button. + +=item url + +URL for the target page or script. + +=item target + +Frame or target in which the new page should appear. If C is specified, +the default target will be used. + +=item parms + +Hash containing the parameter names as keys and the parameter values as values. +These will be appended to the URL. + +=back + +=cut + +sub FakeButton { + # Get the parameters. + my ($caption, $url, $target, %parms) = @_; + # Declare the return variable. + my $retVal; + # Compute the target URL. + my $targetUrl = "$url?" . join(";", map { "$_=" . uri_escape($parms{$_}) } keys %parms); + # Compute the target-frame HTML. + my $targetHtml = ($target ? " target=\"$target\"" : ""); + # Assemble the result. + return "
    $caption
    "; +} + +=head3 Formlet + +C<< my $html = SearchHelper::Formlet($caption, $url, $target, %parms); >> + +Create a mini-form that posts to the specified URL with the specified parameters. The +parameters will be stored in hidden fields, and the form's only visible control will +be a submit button with the specified caption. + +Note that we don't use B services here because they generate forms with extra characters +and tags that we don't want to deal with. + +=over 4 + +=item caption + +Caption to be put on the form button. + +=item url + +URL to be put in the form's action parameter. + +=item target + +Frame or target in which the form results should appear. If C is specified, +the default target will be used. + +=item parms + +Hash containing the parameter names as keys and the parameter values as values. + +=back + +=cut + +sub Formlet { + # Get the parameters. + my ($caption, $url, $target, %parms) = @_; + # Compute the target HTML. + my $targetHtml = ($target ? " target=\"$target\"" : ""); + # Start the form. + my $retVal = "
    "; + # Add the parameters. + for my $parm (keys %parms) { + $retVal .= ""; + } + # Put in the button. + $retVal .= ""; + # Close the form. + $retVal .= "
    "; + # Return the result. + return $retVal; +} + +=head3 TuningParameters + +C<< my $options = $shelp->TuningParameters(%parmHash); >> + +Retrieve tuning parameters from the CGI query object. The parameter is a hash that maps parameter names +to their default values. The parameters and their values will be returned as a hash reference. + +=over 4 + +=item parmHash + +Hash mapping parameter names to their default values. + +=item RETURN + +Returns a reference to a hash containing the parameter names mapped to their actual values. + +=back + +=cut + +sub TuningParameters { + # Get the parameters. + my ($self, %parmHash) = @_; + # Declare the return variable. + my $retVal = {}; + # Get the CGI Query Object. + my $cgi = $self->Q(); + # Loop through the parameter names. + for my $parm (keys %parmHash) { + # Get the incoming value for this parameter. + my $value = $cgi->param($parm); + # Zero might be a valid value, so we do an is-defined check rather than an OR. + if (defined($value)) { + $retVal->{$parm} = $value; + } else { + $retVal->{$parm} = $parmHash{$parm}; + } } # Return the result. return $retVal; @@ -1951,19 +2996,20 @@ =head3 SortKey -C<< my $key = $shelp->SortKey($record); >> +C<< my $key = $shelp->SortKey($fdata); >> -Return the sort key for the specified record. The default is to sort by feature name, -floating NMPDR organisms to the top. This sort may be overridden by the search class -to provide fancier functionality. This method is called by B, so it -is only used for feature searches. A non-feature search would presumably have its -own sort logic. +Return the sort key for the specified feature data. The default is to sort by feature name, +floating NMPDR organisms to the top. If a full-text search is used, then the default +sort is by relevance followed by feature name. This sort may be overridden by the +search class to provide fancier functionality. This method is called by +B, so it is only used for feature searches. A non-feature search +would presumably have its own sort logic. =over 4 =item record -The C from which the current row of data is derived. +The C containing the current feature. =item RETURN @@ -1975,16 +3021,65 @@ sub SortKey { # Get the parameters. - my ($self, $record) = @_; + my ($self, $fdata) = @_; # Get the feature ID from the record. - my ($fid) = $record->Value('Feature(id)'); + my $fid = $fdata->FID(); # Get the group from the feature ID. my $group = $self->FeatureGroup($fid); # Ask the feature query object to form the sort key. - my $retVal = FeatureQuery::SortKey($self, $group, $record); + my $retVal = $fdata->SortKey($self, $group); # Return the result. return $retVal; } +=head3 SearchTitle + +C<< my $titleHtml = $shelp->SearchTitle(); >> + +Return the display title for this search. The display title appears above the search results. +If no result is returned, no title will be displayed. The result should be an html string +that can be legally put inside a block tag such as C

    or C

    . + +=cut + +sub SearchTitle { + # Get the parameters. + my ($self) = @_; + # Declare the return variable. + my $retVal; + # Return it. + return $retVal; +} + +=head3 DownloadFormatAvailable + +C<< my $okFlag = $shelp->DownloadFormatAvailable($format); >> + +This method returns TRUE if a specified download format is legal for this type of search +and FALSE otherwise. For any feature-based search, there is no need to override this +method. + +=over 4 + +=item format + +Download format type code. + +=item RETURN + +Returns TRUE if the download format is legal for this search and FALSE otherwise. + +=back + +=cut + +sub DownloadFormatAvailable { + # Get the parameters. + my ($self, $format) = @_; + # Declare the return variable. + my $retVal = 1; + # Return the result. + return $retVal; +} 1; \ No newline at end of file