[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.27, Wed Feb 21 13:18:27 2007 UTC revision 1.29, Sat Apr 14 21:41:25 2007 UTC
# Line 235  Line 235 
235  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
236  above code is just a loose framework.  above code is just a loose framework.
237    
238    In addition to the finding and filtering, it is necessary to send status messages
239    to the output so that the user does not get bored waiting for results. The L</PrintLine>
240    method performs this function. The single parameter should be text to be
241    output to the browser. In general, you'll invoke it as follows.
242    
243        $self->PrintLine("...my message text...<br />");
244    
245    The break tag is optional. When the Find method gets control, a paragraph will
246    have been started so that everything is XHTML-compliant.
247    
248  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>
249  method of the feature query object.  method of the feature query object.
250    
# Line 256  Line 266 
266    
267  =head3 new  =head3 new
268    
269  C<< my $shelp = SearchHelper->new($query); >>  C<< my $shelp = SearchHelper->new($cgi); >>
270    
271  Construct a new SearchHelper object.  Construct a new SearchHelper object.
272    
# Line 699  Line 709 
709      # Check for a first-call situation.      # Check for a first-call situation.
710      if (! defined $self->{cols}) {      if (! defined $self->{cols}) {
711          Trace("Setting up the columns.") if T(3);          Trace("Setting up the columns.") if T(3);
712            # Tell the user what's happening.
713            $self->PrintLine("Creating output columns.<br />");
714          # Here we need to set up the column information. First we accumulate the extras,          # Here we need to set up the column information. First we accumulate the extras,
715          # sorted by column name.          # sorted by column name.
716          my @xtraNames = ();          my @xtraNames = ();
# Line 722  Line 734 
734          Trace("Full column list determined.") if T(3);          Trace("Full column list determined.") if T(3);
735          # Save the full list.          # Save the full list.
736          $self->{cols} = \@colNames;          $self->{cols} = \@colNames;
737          # 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
738          # output.          # output.
739          Trace("Writing column headers.") if T(3);          Trace("Writing column headers.") if T(3);
740          $self->WriteColumnHeaders(map { $self->FeatureColumnTitle($_) } @{$self->{cols}});          $self->WriteColumnHeaders(@{$self->{cols}});
741          Trace("Column headers written.") if T(3);          Trace("Column headers written.") if T(3);
742      }      }
743      # Get the feature ID.      # Get the feature ID.
744      my $fid = $fd->FID();      my $fid = $fd->FID();
745      # Loop through the column headers, producing the desired data.      # Loop through the column headers, producing the desired data. The first column
746      my @output = ();      # is the feature ID. The feature ID does not show up in the output: its purpose
747        # is to help the various output formatters.
748        my @output = ($fid);
749      for my $colName (@{$self->{cols}}) {      for my $colName (@{$self->{cols}}) {
750          push @output, $self->FeatureColumnValue($colName, $record, $extraCols);          push @output, $self->FeatureColumnValue($colName, $record, $extraCols);
751      }      }
# Line 820  Line 834 
834          # We found one, so close it.          # We found one, so close it.
835          Trace("Closing session file.") if T(2);          Trace("Closing session file.") if T(2);
836          close $self->{fileHandle};          close $self->{fileHandle};
837            # Tell the user.
838            my $cgi = $self->Q();
839            $self->PrintLine("Output formatting complete.<br />");
840      }      }
841  }  }
842    
# Line 1037  Line 1054 
1054      # Create variables to hold the FASTA label and data.      # Create variables to hold the FASTA label and data.
1055      my ($fastaLabel, $fastaData);      my ($fastaLabel, $fastaData);
1056      Trace("FASTA desired type is $desiredType.") if T(4);      Trace("FASTA desired type is $desiredType.") if T(4);
1057      # Check for a feature specification.      # Check for a feature specification. The smoking gun for that is a vertical bar.
1058      if ($sequence =~ /^\s*(\w+\|\S+)\s*$/) {      if ($sequence =~ /^\s*(\w+\|\S+)\s*$/) {
1059          # 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
1060          # it.          # it.
# Line 1052  Line 1069 
1069              $self->SetMessage("No gene found with the ID \"$fid\".");              $self->SetMessage("No gene found with the ID \"$fid\".");
1070              $okFlag = 0;              $okFlag = 0;
1071          } else {          } else {
1072              # Set the FASTA label.              # Set the FASTA label. The ID is the first favored alias.
1073              my $fastaLabel = $fid;              my $favored = $self->Q()->param('FavoredAlias') || 'fig';
1074                my $favorLen = length $favored;
1075                ($fastaLabel) = grep { substr($_, 0, $favorLen) eq $favored } $sprout->FeatureAliases($fid);
1076                if (! $fastaLabel) {
1077                    # In an emergency, fall back to the original ID.
1078                    $fastaLabel = $fid;
1079                }
1080              # Now proceed according to the sequence type.              # Now proceed according to the sequence type.
1081              if ($desiredType eq 'prot') {              if ($desiredType eq 'prot') {
1082                  # We want protein, so get the translation.                  # We want protein, so get the translation.
# Line 1239  Line 1262 
1262              if ($optionThing->{links}) {              if ($optionThing->{links}) {
1263                  # Compute the link value.                  # Compute the link value.
1264                  my $linkable = uri_escape($id);                  my $linkable = uri_escape($id);
1265                  $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";
1266              }              }
1267              if ($optionThing->{radio}) {              if ($optionThing->{radio}) {
1268                  # Compute the radio value.                  # Compute the radio value.
# Line 1503  Line 1526 
1526  =item rows  =item rows
1527    
1528  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
1529  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
1530  set the width. Everything else will be left as is.  will be modified to set the width. Everything else will be left as is.
1531    
1532  =item RETURN  =item RETURN
1533    
# Line 1519  Line 1542 
1542      my ($self, $rows) = @_;      my ($self, $rows) = @_;
1543      # Get the CGI object.      # Get the CGI object.
1544      my $cgi = $self->Q();      my $cgi = $self->Q();
1545      # 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.
1546        # This flag will be set to FALSE when that happens.
1547        my $needWidth = 1;
1548      # 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
1549      # is already specified on the first column bad things will happen.      # is already specified on the first column bad things will happen.
1550      for my $row (@{$rows}) {      for my $row (@{$rows}) {
1551          $row =~ s/(<td|th)/$1 width="150"/i;          # See if this row needs a width.
1552            if ($needWidth && $row =~ /<(td|th) ([^>]+)>/i) {
1553                # Here we have a first cell and its tag parameters are in $2.
1554                my $elements = $2;
1555                if ($elements !~ /colspan/i) {
1556                    Trace("No colspan tag found in element \'$elements\'.") if T(3);
1557                    # Here there's no colspan, so we plug in the width. We
1558                    # eschew the "g" modifier on the substitution because we
1559                    # only want to update the first cell.
1560                    $row =~ s/(<(td|th))/$1 width="150"/i;
1561                    # Denote we don't need this any more.
1562                    $needWidth = 0;
1563                }
1564            }
1565      }      }
1566      # Create the table.      # Create the table.
1567      my $retVal = $cgi->table({border => 2, cellspacing => 2,      my $retVal = $cgi->table({border => 2, cellspacing => 2,
# Line 2302  Line 2340 
2340  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
2341  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
2342  L</DefaultFeatureColumns>. Then add code to produce the column title to  L</DefaultFeatureColumns>. Then add code to produce the column title to
2343  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
2344  everything else will happen automatically.  feature column should be excluded from downloads, add it to the C<FeatureColumnSkip>
2345    hash. Everything else will happen automatically.
2346    
2347  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
2348  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
2349  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
2350  pulled from the extra column hash.  pulled from the extra column hash.
2351    
2352    =cut
2353    
2354    # This hash is used to determine which columns should not be included in downloads.
2355    my %FeatureColumnSkip = map { $_ => 1 } qw(gblink viewerlink protlink);
2356    
2357  =head3 DefaultFeatureColumns  =head3 DefaultFeatureColumns
2358    
2359  C<< my @colNames = $shelp->DefaultFeatureColumns(); >>  C<< my @colNames = $shelp->DefaultFeatureColumns(); >>
# Line 2372  Line 2416 
2416          $retVal = "Organism and Gene ID";          $retVal = "Organism and Gene ID";
2417      } elsif ($colName eq 'protlink') {      } elsif ($colName eq 'protlink') {
2418          $retVal = "NMPDR Protein Page";          $retVal = "NMPDR Protein Page";
2419        } elsif ($colName eq 'viewerlink') {
2420            $retVal = "Annotation Page";
2421      } elsif ($colName eq 'subsystem') {      } elsif ($colName eq 'subsystem') {
2422          $retVal = "Subsystems";          $retVal = "Subsystems";
2423      }      }
# Line 2379  Line 2425 
2425      return $retVal;      return $retVal;
2426  }  }
2427    
2428    =head3 FeatureColumnDownload
2429    
2430    C<< my $keep = $shelp->FeatureColumnDownload($colName); >>
2431    
2432    Return TRUE if the named feature column is to be kept when downloading, else FALSE.
2433    
2434    =over 4
2435    
2436    =item colName
2437    
2438    Name of the relevant feature column.
2439    
2440    =item RETURN
2441    
2442    Return TRUE if the named column should be kept while downloading, else FALSE. In general,
2443    FALSE is returned if the column generates a button, image, or other purely-HTML value.
2444    
2445    =back
2446    
2447    =cut
2448    
2449    sub FeatureColumnDownload {
2450        # Get the parameters.
2451        my ($self, $colName) = @_;
2452        # Return the determination. We download the column if it's not in the skip-hash.
2453        # Note we return 0 and 1 instead of 1 and undef because it simplifies some tracing.
2454        return (exists $FeatureColumnSkip{$colName} ? 0 : 1);
2455    }
2456    
2457    
2458  =head3 FeatureColumnValue  =head3 FeatureColumnValue
2459    
# Line 2394  Line 2469 
2469    
2470  =item record  =item record
2471    
2472  DBObject record for the feature being displayed in the current row.  ERDBObject record for the feature being displayed in the current row.
2473    
2474  =item extraCols  =item extraCols
2475    
# Line 2433  Line 2508 
2508      } elsif ($colName eq 'alias') {      } elsif ($colName eq 'alias') {
2509          # 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.
2510          # 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.
2511          $retVal = "%%alias=$fid";          # To do the computation, we need to know the favored alias type and the
2512            # feature ID.
2513            my $favored = $cgi->param("FavoredAlias") || "fig";
2514            $retVal = "%%alias=$fid,$favored";
2515      } elsif ($colName eq 'fid') {      } elsif ($colName eq 'fid') {
2516          # 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.
2517          $retVal = HTML::set_prot_links($fid);          $retVal = HTML::set_prot_links($fid);
# Line 2463  Line 2541 
2541          $retVal = FakeButton('NMPDR', "protein.cgi", undef,          $retVal = FakeButton('NMPDR', "protein.cgi", undef,
2542                            prot => $fid, SPROUT => 1, new_framework => 0,                            prot => $fid, SPROUT => 1, new_framework => 0,
2543                            user => '');                            user => '');
2544        } elsif ($colName eq 'viewerlink') {
2545            # Here we want a link to the SEED viewer page using the official viewer button.
2546            $retVal = FakeButton('Annotation', "index.cgi", undef,
2547                                 action => 'ShowAnnotation', prot => $fid);
2548      }elsif ($colName eq 'subsystem') {      }elsif ($colName eq 'subsystem') {
2549          # Another run-time column: subsystem list.          # Another run-time column: subsystem list.
2550          $retVal = "%%subsystem=$fid";          $retVal = "%%subsystem=$fid";
# Line 2508  Line 2590 
2590      # Separate the text into a type and data.      # Separate the text into a type and data.
2591      if ($type eq 'alias') {      if ($type eq 'alias') {
2592          # Here the caller wants external alias links for a feature. The text          # Here the caller wants external alias links for a feature. The text
2593          # is the feature ID.          # parameter for computing the alias is the feature ID followed by
2594          my $fid = $text;          # the favored alias type.
2595          # The complicated part is we have to hyperlink them. First, get the          my ($fid, $favored) = split /\s*,\s*/, $text;
2596          # aliases.          # The complicated part is we have to hyperlink them and handle the
2597            # favorites. First, get the aliases.
2598          Trace("Generating aliases for feature $fid.") if T(4);          Trace("Generating aliases for feature $fid.") if T(4);
2599          my @aliases = $sprout->FeatureAliases($fid);          my @aliases = sort $sprout->FeatureAliases($fid);
2600          # Only proceed if we found some.          # Only proceed if we found some.
2601          if (@aliases) {          if (@aliases) {
2602              # Join the aliases into a comma-delimited list.              # Split the aliases into favored and unfavored.
2603              my $aliasList = join(", ", @aliases);              my @favored = ();
2604                my @unfavored = ();
2605                for my $alias (@aliases) {
2606                    # Use substr instead of pattern match because $favored is specified by the user
2607                    # and we don't want him to put funny meta-characters in there.
2608                    if (substr($alias, 0, length($favored)) eq $favored) {
2609                        push @favored, $alias;
2610                    } else {
2611                        push @unfavored, $alias;
2612                    }
2613                }
2614                # Rejoin the aliases into a comma-delimited list, with the favored ones first.
2615                my $aliasList = join(", ", @favored, @unfavored);
2616              # Ask the HTML processor to hyperlink them.              # Ask the HTML processor to hyperlink them.
2617              $retVal = HTML::set_prot_links($cgi, $aliasList);              $retVal = HTML::set_prot_links($cgi, $aliasList);
2618          }          }
# Line 2830  Line 2925 
2925      return $retVal;      return $retVal;
2926  }  }
2927    
2928    =head3 PrintLine
2929    
2930    C<< $shelp->PrintLine($message); >>
2931    
2932    Print a line of CGI output. This is used during the operation of the B<Find> method while
2933    searching, so the user sees progress in real-time.
2934    
2935    =over 4
2936    
2937    =item message
2938    
2939    HTML text to display.
2940    
2941    =back
2942    
2943    =cut
2944    
2945    sub PrintLine {
2946        # Get the parameters.
2947        my ($self, $message) = @_;
2948        # Send them to the output.
2949        print "$message\n";
2950    }
2951    
2952    
2953  1;  1;

Legend:
Removed from v.1.27  
changed lines
  Added in v.1.29

MCS Webmaster
ViewVC Help
Powered by ViewVC 1.0.3