[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.30, Thu Apr 19 00:05:51 2007 UTC
# Line 90  Line 90 
90    
91  =item extraPos  =item extraPos
92    
93  C<0> if the extra columns are to be at the beginning, else C<1>. The  Hash indicating which extra columns should be put at the end. Extra columns
94  default is zero; use the L</SetExtraPos> method to change this option.  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    
# Line 235  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 256  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 315  Line 326 
326                    genomeList => undef,                    genomeList => undef,
327                    genomeParms => [],                    genomeParms => [],
328                    filtered => 0,                    filtered => 0,
329                    extraPos => 0,                    extraPos => {},
330                   };                   };
331      # Bless and return it.      # Bless and return it.
332      bless $retVal, $class;      bless $retVal, $class;
# Line 378  Line 389 
389    
390  =head3 SetExtraPos  =head3 SetExtraPos
391    
392  C<< $shelp->SetExtraPos($newValue); >>  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.  Indicate whether the extra columns should be in the front (C<0>) or end (C<1>) columns of the results.
395    
396  =over 4  =over 4
397    
398  =item newValue  =item columnMap
399    
400  C<1> if the extra columns should be displayed at the end, else C<0>.  A list of extra columns to display at the end.
401    
402  =back  =back
403    
404  =cut  =cut
405    
406  sub SetExtraPos {  sub SetExtraPos {
407      my ($self, $newValue) = @_;      # Get the parameters.
408      $self->{extraPos} = $newValue;      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
# Line 699  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            # Tell the user what's happening.
718            $self->PrintLine("Creating output columns.<br />");
719          # 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,
720          # sorted by column name.          # sorted by column name and separate by whether they go in the beginning or the
721          my @xtraNames = ();          # 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 @xtraNames, "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.          # Set up the column name array.
733          my @colNames = ();          my @colNames = ();
734          # If extras go at the beginning, put them in first.          # Put in the extra columns that go in the beginning.
735          if (! $self->{extraPos}) {          push @colNames, @xtraNamesFront;
             push @colNames, @xtraNames;  
         }  
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.          # If extras go at the end, put them in here.
741          if ($self->{extraPos}) {          push @colNames, @xtraNamesEnd;
             push @colNames, @xtraNames;  
         }  
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 820  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 1037  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 1052  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 1239  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 1503  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 1519  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 1917  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 2302  Line 2348 
2348  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
2349  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
2350  L</DefaultFeatureColumns>. Then add code to produce the column title to  L</DefaultFeatureColumns>. Then add code to produce the column title to
2351  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
2352  everything else will happen automatically.  feature column should be excluded from downloads, add it to the C<FeatureColumnSkip>
2353    hash. Everything else will happen automatically.
2354    
2355  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
2356  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
2357  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
2358  pulled from the extra column hash.  pulled from the extra column hash.
2359    
2360    =cut
2361    
2362    # This hash is used to determine which columns should not be included in downloads.
2363    my %FeatureColumnSkip = map { $_ => 1 } qw(gblink viewerlink protlink);
2364    
2365  =head3 DefaultFeatureColumns  =head3 DefaultFeatureColumns
2366    
2367  C<< my @colNames = $shelp->DefaultFeatureColumns(); >>  C<< my @colNames = $shelp->DefaultFeatureColumns(); >>
# Line 2372  Line 2424 
2424          $retVal = "Organism and Gene ID";          $retVal = "Organism and Gene ID";
2425      } elsif ($colName eq 'protlink') {      } elsif ($colName eq 'protlink') {
2426          $retVal = "NMPDR Protein Page";          $retVal = "NMPDR Protein Page";
2427        } elsif ($colName eq 'viewerlink') {
2428            $retVal = "Annotation Page";
2429      } elsif ($colName eq 'subsystem') {      } elsif ($colName eq 'subsystem') {
2430          $retVal = "Subsystems";          $retVal = "Subsystems";
2431      }      }
# Line 2379  Line 2433 
2433      return $retVal;      return $retVal;
2434  }  }
2435    
2436    =head3 FeatureColumnDownload
2437    
2438    C<< my $keep = $shelp->FeatureColumnDownload($colName); >>
2439    
2440    Return TRUE if the named feature column is to be kept when downloading, else FALSE.
2441    
2442    =over 4
2443    
2444    =item colName
2445    
2446    Name of the relevant feature column.
2447    
2448    =item RETURN
2449    
2450    Return TRUE if the named column should be kept while downloading, else FALSE. In general,
2451    FALSE is returned if the column generates a button, image, or other purely-HTML value.
2452    
2453    =back
2454    
2455    =cut
2456    
2457    sub FeatureColumnDownload {
2458        # Get the parameters.
2459        my ($self, $colName) = @_;
2460        # Return the determination. We download the column if it's not in the skip-hash.
2461        # Note we return 0 and 1 instead of 1 and undef because it simplifies some tracing.
2462        return (exists $FeatureColumnSkip{$colName} ? 0 : 1);
2463    }
2464    
2465    
2466  =head3 FeatureColumnValue  =head3 FeatureColumnValue
2467    
# Line 2394  Line 2477 
2477    
2478  =item record  =item record
2479    
2480  DBObject record for the feature being displayed in the current row.  ERDBObject record for the feature being displayed in the current row.
2481    
2482  =item extraCols  =item extraCols
2483    
# Line 2433  Line 2516 
2516      } elsif ($colName eq 'alias') {      } elsif ($colName eq 'alias') {
2517          # 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.
2518          # 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.
2519          $retVal = "%%alias=$fid";          # To do the computation, we need to know the favored alias type and the
2520            # feature ID.
2521            my $favored = $cgi->param("FavoredAlias") || "fig";
2522            $retVal = "%%alias=$fid,$favored";
2523      } elsif ($colName eq 'fid') {      } elsif ($colName eq 'fid') {
2524          # 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.
2525          $retVal = HTML::set_prot_links($fid);          $retVal = HTML::set_prot_links($fid);
# Line 2463  Line 2549 
2549          $retVal = FakeButton('NMPDR', "protein.cgi", undef,          $retVal = FakeButton('NMPDR', "protein.cgi", undef,
2550                            prot => $fid, SPROUT => 1, new_framework => 0,                            prot => $fid, SPROUT => 1, new_framework => 0,
2551                            user => '');                            user => '');
2552        } elsif ($colName eq 'viewerlink') {
2553            # Here we want a link to the SEED viewer page using the official viewer button.
2554            $retVal = FakeButton('Annotation', "index.cgi", undef,
2555                                 action => 'ShowAnnotation', prot => $fid);
2556      }elsif ($colName eq 'subsystem') {      }elsif ($colName eq 'subsystem') {
2557          # Another run-time column: subsystem list.          # Another run-time column: subsystem list.
2558          $retVal = "%%subsystem=$fid";          $retVal = "%%subsystem=$fid";
# Line 2508  Line 2598 
2598      # Separate the text into a type and data.      # Separate the text into a type and data.
2599      if ($type eq 'alias') {      if ($type eq 'alias') {
2600          # Here the caller wants external alias links for a feature. The text          # Here the caller wants external alias links for a feature. The text
2601          # is the feature ID.          # parameter for computing the alias is the feature ID followed by
2602          my $fid = $text;          # the favored alias type.
2603          # The complicated part is we have to hyperlink them. First, get the          my ($fid, $favored) = split /\s*,\s*/, $text;
2604          # aliases.          # The complicated part is we have to hyperlink them and handle the
2605            # favorites. First, get the aliases.
2606          Trace("Generating aliases for feature $fid.") if T(4);          Trace("Generating aliases for feature $fid.") if T(4);
2607          my @aliases = $sprout->FeatureAliases($fid);          my @aliases = sort $sprout->FeatureAliases($fid);
2608          # Only proceed if we found some.          # Only proceed if we found some.
2609          if (@aliases) {          if (@aliases) {
2610              # Join the aliases into a comma-delimited list.              # Split the aliases into favored and unfavored.
2611              my $aliasList = join(", ", @aliases);              my @favored = ();
2612                my @unfavored = ();
2613                for my $alias (@aliases) {
2614                    # Use substr instead of pattern match because $favored is specified by the user
2615                    # and we don't want him to put funny meta-characters in there.
2616                    if (substr($alias, 0, length($favored)) eq $favored) {
2617                        push @favored, $alias;
2618                    } else {
2619                        push @unfavored, $alias;
2620                    }
2621                }
2622                # Rejoin the aliases into a comma-delimited list, with the favored ones first.
2623                my $aliasList = join(", ", @favored, @unfavored);
2624              # Ask the HTML processor to hyperlink them.              # Ask the HTML processor to hyperlink them.
2625              $retVal = HTML::set_prot_links($cgi, $aliasList);              $retVal = HTML::set_prot_links($cgi, $aliasList);
2626          }          }
# Line 2767  Line 2870 
2870      return $retVal;      return $retVal;
2871  }  }
2872    
2873    =head3 TuningParameters
2874    
2875    C<< my $options = $shelp->TuningParameters(%parmHash); >>
2876    
2877    Retrieve tuning parameters from the CGI query object. The parameter is a hash that maps parameter names
2878    to their default values. The parameters and their values will be returned as a hash reference.
2879    
2880    =over 4
2881    
2882    =item parmHash
2883    
2884    Hash mapping parameter names to their default values.
2885    
2886    =item RETURN
2887    
2888    Returns a reference to a hash containing the parameter names mapped to their actual values.
2889    
2890    =back
2891    
2892    =cut
2893    
2894    sub TuningParameters {
2895        # Get the parameters.
2896        my ($self, %parmHash) = @_;
2897        # Declare the return variable.
2898        my $retVal = {};
2899        # Get the CGI Query Object.
2900        my $cgi = $self->Q();
2901        # Loop through the parameter names.
2902        for my $parm (keys %parmHash) {
2903            # Get the incoming value for this parameter.
2904            my $value = $cgi->param($parm);
2905            # Zero might be a valid value, so we do an is-defined check rather than an OR.
2906            if (defined($value)) {
2907                $retVal->{$parm} = $value;
2908            } else {
2909                $retVal->{$parm} = $parmHash{$parm};
2910            }
2911        }
2912        # Return the result.
2913        return $retVal;
2914    }
2915    
2916  =head2 Virtual Methods  =head2 Virtual Methods
2917    
2918  =head3 Form  =head3 Form
# Line 2830  Line 2976 
2976      return $retVal;      return $retVal;
2977  }  }
2978    
2979    =head3 PrintLine
2980    
2981    C<< $shelp->PrintLine($message); >>
2982    
2983    Print a line of CGI output. This is used during the operation of the B<Find> method while
2984    searching, so the user sees progress in real-time.
2985    
2986    =over 4
2987    
2988    =item message
2989    
2990    HTML text to display.
2991    
2992    =back
2993    
2994    =cut
2995    
2996    sub PrintLine {
2997        # Get the parameters.
2998        my ($self, $message) = @_;
2999        # Send them to the output.
3000        print "$message\n";
3001    }
3002    
3003    
3004  1;  1;

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

MCS Webmaster
ViewVC Help
Powered by ViewVC 1.0.3