[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.25, Wed Dec 20 20:06:17 2006 UTC revision 1.31, Fri May 11 06:28:21 2007 UTC
# Line 88  Line 88 
88  TRUE if this is a feature-filtered search, else FALSE. B<NOTE> that this  TRUE if this is a feature-filtered search, else FALSE. B<NOTE> that this
89  field is updated by the B<FeatureQuery> object.  field is updated by the B<FeatureQuery> object.
90    
91    =item extraPos
92    
93    Hash indicating which extra columns should be put at the end. Extra columns
94    not mentioned in this hash are put at the beginning. Use the L</SetExtraPos>
95    method to change this option.
96    
97  =back  =back
98    
99  =head2 Adding a new Search Tool  =head2 Adding a new Search Tool
# Line 230  Line 236 
236  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
237  above code is just a loose framework.  above code is just a loose framework.
238    
239    In addition to the finding and filtering, it is necessary to send status messages
240    to the output so that the user does not get bored waiting for results. The L</PrintLine>
241    method performs this function. The single parameter should be text to be
242    output to the browser. In general, you'll invoke it as follows.
243    
244        $self->PrintLine("...my message text...<br />");
245    
246    The break tag is optional. When the Find method gets control, a paragraph will
247    have been started so that everything is XHTML-compliant.
248    
249  If you wish to add your own extra columns to the output, use the B<AddExtraColumns>  If you wish to add your own extra columns to the output, use the B<AddExtraColumns>
250  method of the feature query object.  method of the feature query object.
251    
# Line 251  Line 267 
267    
268  =head3 new  =head3 new
269    
270  C<< my $shelp = SearchHelper->new($query); >>  C<< my $shelp = SearchHelper->new($cgi); >>
271    
272  Construct a new SearchHelper object.  Construct a new SearchHelper object.
273    
# Line 272  Line 288 
288      my $session_id = $cgi->param("SessionID");      my $session_id = $cgi->param("SessionID");
289      my $type = "old";      my $type = "old";
290      if (! $session_id) {      if (! $session_id) {
291            Trace("No session ID found.") if T(3);
292          # Here we're starting a new session. We create the session ID and          # Here we're starting a new session. We create the session ID and
293          # store it in the query object.          # store it in the query object.
294          $session_id = NewSessionID();          $session_id = NewSessionID();
295          $type = "new";          $type = "new";
296          $cgi->param(-name => 'SessionID', -value => $session_id);          $cgi->param(-name => 'SessionID', -value => $session_id);
297        } else {
298            Trace("Session ID is $session_id.") if T(3);
299      }      }
300      # Compute the subclass name.      # Compute the subclass name.
301      my $subClass;      my $subClass;
# Line 307  Line 326 
326                    genomeList => undef,                    genomeList => undef,
327                    genomeParms => [],                    genomeParms => [],
328                    filtered => 0,                    filtered => 0,
329                      extraPos => {},
330                   };                   };
331      # Bless and return it.      # Bless and return it.
332      bless $retVal, $class;      bless $retVal, $class;
# Line 367  Line 387 
387      return ($self->{type} eq 'new');      return ($self->{type} eq 'new');
388  }  }
389    
390    =head3 SetExtraPos
391    
392    C<< $shelp->SetExtraPos(@columnMap); >>
393    
394    Indicate whether the extra columns should be in the front (C<0>) or end (C<1>) columns of the results.
395    
396    =over 4
397    
398    =item columnMap
399    
400    A list of extra columns to display at the end.
401    
402    =back
403    
404    =cut
405    
406    sub SetExtraPos {
407        # Get the parameters.
408        my ($self, @columnMap) = @_;
409        # Convert the column map to a hash.
410        my %map = map { $_ => 1 } @columnMap;
411        # Save a reference to it.
412        $self->{extraPos} = \%map;
413    }
414    
415  =head3 ID  =head3 ID
416    
417  C<< my $sessionID = $shelp->ID(); >>  C<< my $sessionID = $shelp->ID(); >>
# Line 669  Line 714 
714      # Check for a first-call situation.      # Check for a first-call situation.
715      if (! defined $self->{cols}) {      if (! defined $self->{cols}) {
716          Trace("Setting up the columns.") if T(3);          Trace("Setting up the columns.") if T(3);
717          # Here we need to set up the column information. Start with the extras,          # Tell the user what's happening.
718          # sorted by column name.          $self->PrintLine("Creating output columns.<br />");
719          my @colNames = ();          # Here we need to set up the column information. First we accumulate the extras,
720            # sorted by column name and separate by whether they go in the beginning or the
721            # end.
722            my @xtraNamesFront = ();
723            my @xtraNamesEnd = ();
724            my $xtraPosMap = $self->{extraPos};
725          for my $col (sort keys %{$extraCols}) {          for my $col (sort keys %{$extraCols}) {
726              push @colNames, "X=$col";              if ($xtraPosMap->{$col}) {
727                    push @xtraNamesEnd, "X=$col";
728                } else {
729                    push @xtraNamesFront, "X=$col";
730                }
731          }          }
732            # Set up the column name array.
733            my @colNames = ();
734            # Put in the extra columns that go in the beginning.
735            push @colNames, @xtraNamesFront;
736          # Add the default columns.          # Add the default columns.
737          push @colNames, $self->DefaultFeatureColumns();          push @colNames, $self->DefaultFeatureColumns();
738          # Add any additional columns requested by the feature filter.          # Add any additional columns requested by the feature filter.
739          push @colNames, FeatureQuery::AdditionalColumns($self);          push @colNames, FeatureQuery::AdditionalColumns($self);
740            # If extras go at the end, put them in here.
741            push @colNames, @xtraNamesEnd;
742          Trace("Full column list determined.") if T(3);          Trace("Full column list determined.") if T(3);
743          # Save the full list.          # Save the full list.
744          $self->{cols} = \@colNames;          $self->{cols} = \@colNames;
745          # Write out the column headers. This also prepares the cache file to receive          # Write out the column names. This also prepares the cache file to receive
746          # output.          # output.
747          Trace("Writing column headers.") if T(3);          Trace("Writing column headers.") if T(3);
748          $self->WriteColumnHeaders(map { $self->FeatureColumnTitle($_) } @{$self->{cols}});          $self->WriteColumnHeaders(@{$self->{cols}});
749          Trace("Column headers written.") if T(3);          Trace("Column headers written.") if T(3);
750      }      }
751      # Get the feature ID.      # Get the feature ID.
752      my $fid = $fd->FID();      my $fid = $fd->FID();
753      # Loop through the column headers, producing the desired data.      # Loop through the column headers, producing the desired data. The first column
754      my @output = ();      # is the feature ID. The feature ID does not show up in the output: its purpose
755        # is to help the various output formatters.
756        my @output = ($fid);
757      for my $colName (@{$self->{cols}}) {      for my $colName (@{$self->{cols}}) {
758          push @output, $self->FeatureColumnValue($colName, $record, $extraCols);          push @output, $self->FeatureColumnValue($colName, $record, $extraCols);
759      }      }
# Line 780  Line 842 
842          # We found one, so close it.          # We found one, so close it.
843          Trace("Closing session file.") if T(2);          Trace("Closing session file.") if T(2);
844          close $self->{fileHandle};          close $self->{fileHandle};
845            # Tell the user.
846            my $cgi = $self->Q();
847            $self->PrintLine("Output formatting complete.<br />");
848      }      }
849  }  }
850    
# Line 997  Line 1062 
1062      # Create variables to hold the FASTA label and data.      # Create variables to hold the FASTA label and data.
1063      my ($fastaLabel, $fastaData);      my ($fastaLabel, $fastaData);
1064      Trace("FASTA desired type is $desiredType.") if T(4);      Trace("FASTA desired type is $desiredType.") if T(4);
1065      # Check for a feature specification.      # Check for a feature specification. The smoking gun for that is a vertical bar.
1066      if ($sequence =~ /^\s*(\w+\|\S+)\s*$/) {      if ($sequence =~ /^\s*(\w+\|\S+)\s*$/) {
1067          # 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
1068          # it.          # it.
# Line 1012  Line 1077 
1077              $self->SetMessage("No gene found with the ID \"$fid\".");              $self->SetMessage("No gene found with the ID \"$fid\".");
1078              $okFlag = 0;              $okFlag = 0;
1079          } else {          } else {
1080              # Set the FASTA label.              # Set the FASTA label. The ID is the first favored alias.
1081              my $fastaLabel = $fid;              my $favored = $self->Q()->param('FavoredAlias') || 'fig';
1082                my $favorLen = length $favored;
1083                ($fastaLabel) = grep { substr($_, 0, $favorLen) eq $favored } $sprout->FeatureAliases($fid);
1084                if (! $fastaLabel) {
1085                    # In an emergency, fall back to the original ID.
1086                    $fastaLabel = $fid;
1087                }
1088              # Now proceed according to the sequence type.              # Now proceed according to the sequence type.
1089              if ($desiredType eq 'prot') {              if ($desiredType eq 'prot') {
1090                  # We want protein, so get the translation.                  # We want protein, so get the translation.
# Line 1117  Line 1188 
1188      # Read in the subsystems.      # Read in the subsystems.
1189      my @subs = $sprout->GetAll(['Subsystem'], "ORDER BY Subsystem(classification), Subsystem(id)", [],      my @subs = $sprout->GetAll(['Subsystem'], "ORDER BY Subsystem(classification), Subsystem(id)", [],
1190                                 ['Subsystem(classification)', 'Subsystem(id)']);                                 ['Subsystem(classification)', 'Subsystem(id)']);
1191        # Put any unclassified subsystems at the end. They will always be at the beginning, so if one
1192        # is at the end, ALL subsystems are unclassified and we don't bother.
1193        if ($#subs >= 0 && $subs[$#subs]->[0] ne '') {
1194            while ($subs[0]->[0] eq '') {
1195                my $classLess = shift @subs;
1196                push @subs, $classLess;
1197            }
1198        }
1199      # Declare the return variable.      # Declare the return variable.
1200      my @retVal = ();      my @retVal = ();
1201      # Each element in @subs represents a leaf node, so as we loop through it we will be      # Each element in @subs represents a leaf node, so as we loop through it we will be
# Line 1191  Line 1270 
1270              if ($optionThing->{links}) {              if ($optionThing->{links}) {
1271                  # Compute the link value.                  # Compute the link value.
1272                  my $linkable = uri_escape($id);                  my $linkable = uri_escape($id);
1273                  $nodeContent->{link} = "../FIG/display_subsys.cgi?ssa_name=$linkable;request=show_ssa;sort=by_phylo;SPROUT=1";                  $nodeContent->{link} = "../FIG/display_subsys.cgi?ssa_name=$linkable;request=show_ssa;sort=by_phylo;show_clusters=1;SPROUT=1";
1274              }              }
1275              if ($optionThing->{radio}) {              if ($optionThing->{radio}) {
1276                  # Compute the radio value.                  # Compute the radio value.
# Line 1455  Line 1534 
1534  =item rows  =item rows
1535    
1536  Reference to a list of table rows. Each table row must be in HTML form with all  Reference to a list of table rows. Each table row must be in HTML form with all
1537  the TR and TD tags set up. The first TD or TH tag in each row will be modified to  the TR and TD tags set up. The first TD or TH tag in the first non-colspanned row
1538  set the width. Everything else will be left as is.  will be modified to set the width. Everything else will be left as is.
1539    
1540  =item RETURN  =item RETURN
1541    
# Line 1471  Line 1550 
1550      my ($self, $rows) = @_;      my ($self, $rows) = @_;
1551      # Get the CGI object.      # Get the CGI object.
1552      my $cgi = $self->Q();      my $cgi = $self->Q();
1553      # 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.
1554        # This flag will be set to FALSE when that happens.
1555        my $needWidth = 1;
1556      # modifier becase we only want to change the first tag. Also, if a width      # modifier becase we only want to change the first tag. Also, if a width
1557      # is already specified on the first column bad things will happen.      # is already specified on the first column bad things will happen.
1558      for my $row (@{$rows}) {      for my $row (@{$rows}) {
1559          $row =~ s/(<td|th)/$1 width="150"/i;          # See if this row needs a width.
1560            if ($needWidth && $row =~ /<(td|th) ([^>]+)>/i) {
1561                # Here we have a first cell and its tag parameters are in $2.
1562                my $elements = $2;
1563                if ($elements !~ /colspan/i) {
1564                    Trace("No colspan tag found in element \'$elements\'.") if T(3);
1565                    # Here there's no colspan, so we plug in the width. We
1566                    # eschew the "g" modifier on the substitution because we
1567                    # only want to update the first cell.
1568                    $row =~ s/(<(td|th))/$1 width="150"/i;
1569                    # Denote we don't need this any more.
1570                    $needWidth = 0;
1571                }
1572            }
1573      }      }
1574      # Create the table.      # Create the table.
1575      my $retVal = $cgi->table({border => 2, cellspacing => 2,      my $retVal = $cgi->table({border => 2, cellspacing => 2,
# Line 1532  Line 1626 
1626    
1627  =head3 FeatureFilterRows  =head3 FeatureFilterRows
1628    
1629  C<< my $htmlText = $shelp->FeatureFilterRows(); >>  C<< my $htmlText = $shelp->FeatureFilterRows(@subset); >>
1630    
1631  This method creates table rows that can be used to filter features. The form  This method creates table rows that can be used to filter features. The form
1632  values can be used to select features by genome using the B<FeatureQuery>  values can be used to select features by genome using the B<FeatureQuery>
1633  object.  object.
1634    
1635    =over 4
1636    
1637    =item subset
1638    
1639    List of rows to display. The default (C<all>) is to display all rows.
1640    C<words> displays the word search box, C<subsys> displays the subsystem
1641    selector, and C<options> displays the options row.
1642    
1643    =item RETURN
1644    
1645    Returns the html text for table rows containing the desired feature filtering controls.
1646    
1647    =back
1648    
1649  =cut  =cut
1650    
1651  sub FeatureFilterRows {  sub FeatureFilterRows {
1652      # Get the parameters.      # Get the parameters.
1653      my ($self) = @_;      my ($self, @subset) = @_;
1654        if (@subset == 0 || $subset[0] eq 'all') {
1655            @subset = qw(words subsys options);
1656        }
1657      # Return the result.      # Return the result.
1658      return FeatureQuery::FilterRows($self);      return FeatureQuery::FilterRows($self, @subset);
1659  }  }
1660    
1661  =head3 GBrowseFeatureURL  =head3 GBrowseFeatureURL
# Line 1767  Line 1878 
1878          # a singleton list, but that's okay.          # a singleton list, but that's okay.
1879          my @values = split (/\0/, $parms{$parmKey});          my @values = split (/\0/, $parms{$parmKey});
1880          # Check for special cases.          # Check for special cases.
1881          if (grep { $_ eq $parmKey } qw(SessionID ResultCount Page PageSize Trace TF ShowURL)) {          if (grep { $_ eq $parmKey } qw(SessionID ResultCount Page PageSize Trace TF)) {
1882              # These are bookkeeping parameters we don't need to start a search.              # These are bookkeeping parameters we don't need to start a search.
1883              @values = ();              @values = ();
1884          } elsif ($parmKey =~ /_SearchThing$/) {          } elsif ($parmKey =~ /_SearchThing$/) {
# Line 1852  Line 1963 
1963    
1964  sub AdvancedClassList {  sub AdvancedClassList {
1965      my @retVal = map { $_ =~ /^SH(\w+)\.pm/; $1 } grep { $_ =~ /^SH/ } keys %INC;      my @retVal = map { $_ =~ /^SH(\w+)\.pm/; $1 } grep { $_ =~ /^SH/ } keys %INC;
1966      return @retVal;      return sort @retVal;
1967  }  }
1968    
1969  =head3 SelectionTree  =head3 SelectionTree
# Line 2142  Line 2253 
2253                      if ($hasChildren) {                      if ($hasChildren) {
2254                          Trace("Processing children of $myLabel.") if T(4);                          Trace("Processing children of $myLabel.") if T(4);
2255                          push @childHtml, ShowBranch($cgi, $myLabel, $myID, $myContent, $options, 'none');                          push @childHtml, ShowBranch($cgi, $myLabel, $myID, $myContent, $options, 'none');
2256                            Trace("Children of $myLabel finished.") if T(4);
2257                      }                      }
2258                  }                  }
2259              }              }
# Line 2176  Line 2288 
2288              }              }
2289              # Next, we format the label.              # Next, we format the label.
2290              my $labelHtml = $myLabel;              my $labelHtml = $myLabel;
2291              Trace("Formatting tree node for $myLabel.") if T(4);              Trace("Formatting tree node for \"$myLabel\".") if T(4);
2292              # Apply a hyperlink if necessary.              # Apply a hyperlink if necessary.
2293              if (defined $attrHash->{link}) {              if (defined $attrHash->{link}) {
2294                  $labelHtml = $cgi->a({ href => $attrHash->{link}, target => $options->{target} },                  $labelHtml = $cgi->a({ href => $attrHash->{link}, target => $options->{target} },
# Line 2226  Line 2338 
2338      return $retVal;      return $retVal;
2339  }  }
2340    
2341    
2342    =head3 PrintLine
2343    
2344    C<< $shelp->PrintLine($message); >>
2345    
2346    Print a line of CGI output. This is used during the operation of the B<Find> method while
2347    searching, so the user sees progress in real-time.
2348    
2349    =over 4
2350    
2351    =item message
2352    
2353    HTML text to display.
2354    
2355    =back
2356    
2357    =cut
2358    
2359    sub PrintLine {
2360        # Get the parameters.
2361        my ($self, $message) = @_;
2362        # Send them to the output.
2363        print "$message\n";
2364    }
2365    
2366  =head2 Feature Column Methods  =head2 Feature Column Methods
2367    
2368  The methods in this section manage feature column data. If you want to provide the  The methods in this section manage feature column data. If you want to provide the
# Line 2236  Line 2373 
2373  the name for the protein page link column is C<protlink>. If the column is to appear  the name for the protein page link column is C<protlink>. If the column is to appear
2374  in the default list of feature columns, add it to the list returned by  in the default list of feature columns, add it to the list returned by
2375  L</DefaultFeatureColumns>. Then add code to produce the column title to  L</DefaultFeatureColumns>. Then add code to produce the column title to
2376  L</FeatureColumnTitle> and code to produce its value to L</FeatureColumnValue>, and  L</FeatureColumnTitle> and code to produce its value to L</FeatureColumnValue>. If the
2377  everything else will happen automatically.  feature column should be excluded from downloads, add it to the C<FeatureColumnSkip>
2378    hash. Everything else will happen automatically.
2379    
2380  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
2381  feature columns). If the column name begins with C<X=>, then it is presumed to be  feature columns). If the column name begins with C<X=>, then it is presumed to be
2382  an extra column. The column title is the text after the C<X=>, and its value is  an extra column. The column title is the text after the C<X=>, and its value is
2383  pulled from the extra column hash.  pulled from the extra column hash.
2384    
2385    =cut
2386    
2387    # This hash is used to determine which columns should not be included in downloads.
2388    my %FeatureColumnSkip = map { $_ => 1 } qw(gblink viewerlink protlink);
2389    
2390  =head3 DefaultFeatureColumns  =head3 DefaultFeatureColumns
2391    
2392  C<< my @colNames = $shelp->DefaultFeatureColumns(); >>  C<< my @colNames = $shelp->DefaultFeatureColumns(); >>
# Line 2306  Line 2449 
2449          $retVal = "Organism and Gene ID";          $retVal = "Organism and Gene ID";
2450      } elsif ($colName eq 'protlink') {      } elsif ($colName eq 'protlink') {
2451          $retVal = "NMPDR Protein Page";          $retVal = "NMPDR Protein Page";
2452        } elsif ($colName eq 'viewerlink') {
2453            $retVal = "Annotation Page";
2454      } elsif ($colName eq 'subsystem') {      } elsif ($colName eq 'subsystem') {
2455          $retVal = "Subsystems";          $retVal = "Subsystems";
2456        } elsif ($colName eq 'pdb') {
2457            $retVal = "Best PDB Match";
2458      }      }
2459      # Return the result.      # Return the result.
2460      return $retVal;      return $retVal;
2461  }  }
2462    
2463    =head3 FeatureColumnDownload
2464    
2465    C<< my $keep = $shelp->FeatureColumnDownload($colName); >>
2466    
2467    Return TRUE if the named feature column is to be kept when downloading, else FALSE.
2468    
2469    =over 4
2470    
2471    =item colName
2472    
2473    Name of the relevant feature column.
2474    
2475    =item RETURN
2476    
2477    Return TRUE if the named column should be kept while downloading, else FALSE. In general,
2478    FALSE is returned if the column generates a button, image, or other purely-HTML value.
2479    
2480    =back
2481    
2482    =cut
2483    
2484    sub FeatureColumnDownload {
2485        # Get the parameters.
2486        my ($self, $colName) = @_;
2487        # Return the determination. We download the column if it's not in the skip-hash.
2488        # Note we return 0 and 1 instead of 1 and undef because it simplifies some tracing.
2489        return (exists $FeatureColumnSkip{$colName} ? 0 : 1);
2490    }
2491    
2492    
2493  =head3 FeatureColumnValue  =head3 FeatureColumnValue
2494    
# Line 2328  Line 2504 
2504    
2505  =item record  =item record
2506    
2507  DBObject record for the feature being displayed in the current row.  ERDBObject record for the feature being displayed in the current row.
2508    
2509  =item extraCols  =item extraCols
2510    
# Line 2367  Line 2543 
2543      } elsif ($colName eq 'alias') {      } elsif ($colName eq 'alias') {
2544          # In this case, the user wants a list of external aliases for the feature.          # In this case, the user wants a list of external aliases for the feature.
2545          # These are very expensive, so we compute them when the row is displayed.          # These are very expensive, so we compute them when the row is displayed.
2546          $retVal = "%%alias=$fid";          # To do the computation, we need to know the favored alias type and the
2547            # feature ID.
2548            my $favored = $cgi->param("FavoredAlias") || "fig";
2549            $retVal = "%%alias=$fid,$favored";
2550      } elsif ($colName eq 'fid') {      } elsif ($colName eq 'fid') {
2551          # 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.
2552          $retVal = HTML::set_prot_links($fid);          $retVal = HTML::set_prot_links($fid);
# Line 2397  Line 2576 
2576          $retVal = FakeButton('NMPDR', "protein.cgi", undef,          $retVal = FakeButton('NMPDR', "protein.cgi", undef,
2577                            prot => $fid, SPROUT => 1, new_framework => 0,                            prot => $fid, SPROUT => 1, new_framework => 0,
2578                            user => '');                            user => '');
2579        } elsif ($colName eq 'viewerlink') {
2580            # Here we want a link to the SEED viewer page using the official viewer button.
2581            $retVal = FakeButton('Annotation', "index.cgi", undef,
2582                                 action => 'ShowAnnotation', prot => $fid);
2583      }elsif ($colName eq 'subsystem') {      }elsif ($colName eq 'subsystem') {
2584          # Another run-time column: subsystem list.          # Another run-time column: subsystem list.
2585          $retVal = "%%subsystem=$fid";          $retVal = "%%subsystem=$fid";
2586        } elsif ($colName eq 'pdb') {
2587            $retVal = "%%pdb=$fid";
2588      }      }
2589      # Return the result.      # Return the result.
2590      return $retVal;      return $retVal;
# Line 2442  Line 2627 
2627      # Separate the text into a type and data.      # Separate the text into a type and data.
2628      if ($type eq 'alias') {      if ($type eq 'alias') {
2629          # Here the caller wants external alias links for a feature. The text          # Here the caller wants external alias links for a feature. The text
2630          # is the feature ID.          # parameter for computing the alias is the feature ID followed by
2631          my $fid = $text;          # the favored alias type.
2632          # The complicated part is we have to hyperlink them. First, get the          my ($fid, $favored) = split /\s*,\s*/, $text;
2633          # aliases.          # The complicated part is we have to hyperlink them and handle the
2634            # favorites. First, get the aliases.
2635          Trace("Generating aliases for feature $fid.") if T(4);          Trace("Generating aliases for feature $fid.") if T(4);
2636          my @aliases = $sprout->FeatureAliases($fid);          my @aliases = sort $sprout->FeatureAliases($fid);
2637          # Only proceed if we found some.          # Only proceed if we found some.
2638          if (@aliases) {          if (@aliases) {
2639              # Join the aliases into a comma-delimited list.              # Split the aliases into favored and unfavored.
2640              my $aliasList = join(", ", @aliases);              my @favored = ();
2641                my @unfavored = ();
2642                for my $alias (@aliases) {
2643                    # Use substr instead of pattern match because $favored is specified by the user
2644                    # and we don't want him to put funny meta-characters in there.
2645                    if (substr($alias, 0, length($favored)) eq $favored) {
2646                        push @favored, $alias;
2647                    } else {
2648                        push @unfavored, $alias;
2649                    }
2650                }
2651                # Rejoin the aliases into a comma-delimited list, with the favored ones first.
2652                my $aliasList = join(", ", @favored, @unfavored);
2653              # Ask the HTML processor to hyperlink them.              # Ask the HTML processor to hyperlink them.
2654              $retVal = HTML::set_prot_links($cgi, $aliasList);              $retVal = HTML::set_prot_links($cgi, $aliasList);
2655          }          }
# Line 2478  Line 2676 
2676                                        "Feature($keywordName)");                                        "Feature($keywordName)");
2677          # String them into a list.          # String them into a list.
2678          $retVal = join(", ", @values);          $retVal = join(", ", @values);
2679        } elsif ($type eq 'pdb') {
2680            # Here the caller wants the best PDB match to this feature. The text
2681            # is the feature ID. We will display the PDB with a link to the
2682            # PDB page along with the match score. If there are docking results we
2683            # will display a link to the docking result search.
2684            my $fid = $text;
2685            # Ask for the best PDB.
2686            my ($bestPDB) = $sprout->GetAll(['IsProteinForFeature', 'PDB'],
2687                                            "IsProteinForFeature(from-link) = ? ORDER BY IsProteinForFeature(score) LIMIT 1",
2688                                            [$fid], ['PDB(id)', 'PDB(docking-count)', 'IsProteinForFeature(score)']);
2689            # Only proceed if there is a PDB.
2690            if ($bestPDB) {
2691                my ($pdbID, $dockingCount, $score) = @{$bestPDB};
2692                # Convert the PDB ID to a hyperlink.
2693                my $pdbLink = SHDrugSearch::PDBLink($cgi, $pdbID);
2694                # Append the score.
2695                $retVal = "$pdbLink ($score)";
2696                # If there are docking results, append a docking results link.
2697                if ($dockingCount > 0) {
2698                    my $dockString = "$dockingCount docking results";
2699                    my $dockLink = $cgi->a({ href =>  $cgi->url() . "?Class=DrugSearch;PDB=$pdbID;NoForm=1",
2700                                             alt =>   "View computed docking results for $pdbID",
2701                                             title => "View computed docking results for $pdbID",
2702                                             target => "_blank"},
2703                                           $dockString);
2704                }
2705            }
2706      }      }
2707      # Return the result.      # Return the result.
2708      return $retVal;      return $retVal;
# Line 2701  Line 2926 
2926      return $retVal;      return $retVal;
2927  }  }
2928    
2929    =head3 TuningParameters
2930    
2931    C<< my $options = $shelp->TuningParameters(%parmHash); >>
2932    
2933    Retrieve tuning parameters from the CGI query object. The parameter is a hash that maps parameter names
2934    to their default values. The parameters and their values will be returned as a hash reference.
2935    
2936    =over 4
2937    
2938    =item parmHash
2939    
2940    Hash mapping parameter names to their default values.
2941    
2942    =item RETURN
2943    
2944    Returns a reference to a hash containing the parameter names mapped to their actual values.
2945    
2946    =back
2947    
2948    =cut
2949    
2950    sub TuningParameters {
2951        # Get the parameters.
2952        my ($self, %parmHash) = @_;
2953        # Declare the return variable.
2954        my $retVal = {};
2955        # Get the CGI Query Object.
2956        my $cgi = $self->Q();
2957        # Loop through the parameter names.
2958        for my $parm (keys %parmHash) {
2959            # Get the incoming value for this parameter.
2960            my $value = $cgi->param($parm);
2961            # Zero might be a valid value, so we do an is-defined check rather than an OR.
2962            if (defined($value)) {
2963                $retVal->{$parm} = $value;
2964            } else {
2965                $retVal->{$parm} = $parmHash{$parm};
2966            }
2967        }
2968        # Return the result.
2969        return $retVal;
2970    }
2971    
2972  =head2 Virtual Methods  =head2 Virtual Methods
2973    
2974  =head3 Form  =head3 Form
# Line 2764  Line 3032 
3032      return $retVal;      return $retVal;
3033  }  }
3034    
3035    =head3 SearchTitle
3036    
3037    C<< my $titleHtml = $shelp->SearchTitle(); >>
3038    
3039    Return the display title for this search. The display title appears above the search results.
3040    If no result is returned, no title will be displayed. The result should be an html string
3041    that can be legally put inside a block tag such as C<h3> or C<p>.
3042    
3043    =cut
3044    
3045    sub SearchTitle {
3046        # Get the parameters.
3047        my ($self) = @_;
3048        # Declare the return variable.
3049        my $retVal;
3050        # Return it.
3051        return $retVal;
3052    }
3053    
3054    =head3 DownloadFormatAvailable
3055    
3056    C<< my $okFlag = $shelp->DownloadFormatAvailable($format); >>
3057    
3058    This method returns TRUE if a specified download format is legal for this type of search
3059    and FALSE otherwise. For any feature-based search, there is no need to override this
3060    method.
3061    
3062    =over 4
3063    
3064    =item format
3065    
3066    Download format type code.
3067    
3068    =item RETURN
3069    
3070    Returns TRUE if the download format is legal for this search and FALSE otherwise.
3071    
3072    =back
3073    
3074    =cut
3075    
3076    sub DownloadFormatAvailable {
3077        # Get the parameters.
3078        my ($self, $format) = @_;
3079        # Declare the return variable.
3080        my $retVal = 1;
3081        # Return the result.
3082        return $retVal;
3083    }
3084    
3085  1;  1;

Legend:
Removed from v.1.25  
changed lines
  Added in v.1.31

MCS Webmaster
ViewVC Help
Powered by ViewVC 1.0.3