[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.28, Tue Apr 10 06:05:40 2007 UTC revision 1.33, Tue Jun 19 21:28:21 2007 UTC
# Line 19  Line 19 
19      use FeatureQuery;      use FeatureQuery;
20      use URI::Escape;      use URI::Escape;
21      use PageBuilder;      use PageBuilder;
22        use POSIX;
23    
24  =head1 Search Helper Base Class  =head1 Search Helper Base Class
25    
# Line 90  Line 91 
91    
92  =item extraPos  =item extraPos
93    
94  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
95  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>
96    method to change this option.
97    
98  =back  =back
99    
# Line 325  Line 327 
327                    genomeList => undef,                    genomeList => undef,
328                    genomeParms => [],                    genomeParms => [],
329                    filtered => 0,                    filtered => 0,
330                    extraPos => 0,                    extraPos => {},
331                   };                   };
332      # Bless and return it.      # Bless and return it.
333      bless $retVal, $class;      bless $retVal, $class;
# Line 388  Line 390 
390    
391  =head3 SetExtraPos  =head3 SetExtraPos
392    
393  C<< $shelp->SetExtraPos($newValue); >>  C<< $shelp->SetExtraPos(@columnMap); >>
394    
395  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.
396    
397  =over 4  =over 4
398    
399  =item newValue  =item columnMap
400    
401  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.
402    
403  =back  =back
404    
405  =cut  =cut
406    
407  sub SetExtraPos {  sub SetExtraPos {
408      my ($self, $newValue) = @_;      # Get the parameters.
409      $self->{extraPos} = $newValue;      my ($self, @columnMap) = @_;
410        # Convert the column map to a hash.
411        my %map = map { $_ => 1 } @columnMap;
412        # Save a reference to it.
413        $self->{extraPos} = \%map;
414  }  }
415    
416  =head3 ID  =head3 ID
# Line 712  Line 718 
718          # Tell the user what's happening.          # Tell the user what's happening.
719          $self->PrintLine("Creating output columns.<br />");          $self->PrintLine("Creating output columns.<br />");
720          # 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,
721          # sorted by column name.          # sorted by column name and separate by whether they go in the beginning or the
722          my @xtraNames = ();          # end.
723            my @xtraNamesFront = ();
724            my @xtraNamesEnd = ();
725            my $xtraPosMap = $self->{extraPos};
726          for my $col (sort keys %{$extraCols}) {          for my $col (sort keys %{$extraCols}) {
727              push @xtraNames, "X=$col";              if ($xtraPosMap->{$col}) {
728                    push @xtraNamesEnd, "X=$col";
729                } else {
730                    push @xtraNamesFront, "X=$col";
731                }
732          }          }
733          # Set up the column name array.          # Set up the column name array.
734          my @colNames = ();          my @colNames = ();
735          # If extras go at the beginning, put them in first.          # Put in the extra columns that go in the beginning.
736          if (! $self->{extraPos}) {          push @colNames, @xtraNamesFront;
             push @colNames, @xtraNames;  
         }  
737          # Add the default columns.          # Add the default columns.
738          push @colNames, $self->DefaultFeatureColumns();          push @colNames, $self->DefaultFeatureColumns();
739          # Add any additional columns requested by the feature filter.          # Add any additional columns requested by the feature filter.
740          push @colNames, FeatureQuery::AdditionalColumns($self);          push @colNames, FeatureQuery::AdditionalColumns($self);
741          # If extras go at the end, put them in here.          # If extras go at the end, put them in here.
742          if ($self->{extraPos}) {          push @colNames, @xtraNamesEnd;
             push @colNames, @xtraNames;  
         }  
743          Trace("Full column list determined.") if T(3);          Trace("Full column list determined.") if T(3);
744          # Save the full list.          # Save the full list.
745          $self->{cols} = \@colNames;          $self->{cols} = \@colNames;
# Line 742  Line 751 
751      }      }
752      # Get the feature ID.      # Get the feature ID.
753      my $fid = $fd->FID();      my $fid = $fd->FID();
754      # Loop through the column headers, producing the desired data.      # Loop through the column headers, producing the desired data. The first column
755      my @output = ();      # is the feature ID. The feature ID does not show up in the output: its purpose
756        # is to help the various output formatters.
757        my @output = ($fid);
758      for my $colName (@{$self->{cols}}) {      for my $colName (@{$self->{cols}}) {
759          push @output, $self->FeatureColumnValue($colName, $record, $extraCols);          push @output, $self->FeatureColumnValue($colName, $record, $extraCols);
760      }      }
# Line 781  Line 792 
792      # Write the column headers and close the file.      # Write the column headers and close the file.
793      Tracer::PutLine($handle1, \@colNames);      Tracer::PutLine($handle1, \@colNames);
794      close $handle1;      close $handle1;
795        Trace("Column headers are: " . join("; ", @colNames) . ".") if T(3);
796      # Now open the sort pipe and save the file handle. Note how we append the      # Now open the sort pipe and save the file handle. Note how we append the
797      # sorted data to the column header row already in place. The output will      # sorted data to the column header row already in place. The output will
798      # contain a sort key followed by the real columns. The sort key is      # contain a sort key followed by the real columns. The sort key is
# Line 814  Line 826 
826      my ($self, $key, @colValues) = @_;      my ($self, $key, @colValues) = @_;
827      # Write them to the cache file.      # Write them to the cache file.
828      Tracer::PutLine($self->{fileHandle}, [$key, @colValues]);      Tracer::PutLine($self->{fileHandle}, [$key, @colValues]);
829        Trace("Column data is " . join("; ", $key, @colValues) . ".") if T(4);
830  }  }
831    
832  =head3 CloseSession  =head3 CloseSession
# Line 863  Line 876 
876    
877  =head3 OrganismData  =head3 OrganismData
878    
879  C<< my ($orgName, $group) = $shelp->Organism($genomeID); >>  C<< my ($orgName, $group, $domain) = $shelp->Organism($genomeID); >>
880    
881  Return the name and status of the organism corresponding to the specified genome ID.  Return the name and status of the organism corresponding to the specified genome ID.
882  For performance reasons, this information is cached in a special hash table, so we  For performance reasons, this information is cached in a special hash table, so we
# Line 877  Line 890 
890    
891  =item RETURN  =item RETURN
892    
893  Returns a list of two items. The first item in the list is the organism name,  Returns a list of three items. The first item in the list is the organism name,
894  and the second is the name of the NMPDR group, or an empty string if the  and the second is the name of the NMPDR group, or an empty string if the
895  organism is not in an NMPDR group.  organism is not in an NMPDR group. The third item is the organism's domain.
896    
897  =back  =back
898    
# Line 889  Line 902 
902      # Get the parameters.      # Get the parameters.
903      my ($self, $genomeID) = @_;      my ($self, $genomeID) = @_;
904      # Declare the return variables.      # Declare the return variables.
905      my ($orgName, $group);      my ($orgName, $group, $domain);
906      # Check the cache.      # Check the cache.
907      my $cache = $self->{orgs};      my $cache = $self->{orgs};
908      if (exists $cache->{$genomeID}) {      if (exists $cache->{$genomeID}) {
909          ($orgName, $group) = @{$cache->{$genomeID}};          ($orgName, $group, $domain) = @{$cache->{$genomeID}};
910      } else {      } else {
911          # Here we have to use the database.          # Here we have to use the database.
912          my $sprout = $self->DB();          my $sprout = $self->DB();
913          my ($genus, $species, $strain, $group) = $sprout->GetEntityValues('Genome', $genomeID,          my ($genus, $species, $strain, $group, $taxonomy) = $sprout->GetEntityValues('Genome', $genomeID,
914                                                      ['Genome(genus)', 'Genome(species)',                                                      ['Genome(genus)', 'Genome(species)',
915                                                       'Genome(unique-characterization)',                                                       'Genome(unique-characterization)',
916                                                       'Genome(primary-group)']);                                                                   'Genome(primary-group)',
917                                                                     'Genome(taxonomy)']);
918          # Format and cache the name and display group.          # Format and cache the name and display group.
919          ($orgName, $group) = $self->SaveOrganismData($group, $genomeID, $genus, $species,          ($orgName, $group, $domain) = $self->SaveOrganismData($group, $genomeID, $genus, $species,
920                                                              $strain);                                                                $strain, $taxonomy);
921      }      }
922      # Return the result.      # Return the result.
923      return ($orgName, $group);      return ($orgName, $group, $domain);
924  }  }
925    
926  =head3 Organism  =head3 Organism
# Line 934  Line 948 
948      # Get the parameters.      # Get the parameters.
949      my ($self, $genomeID) = @_;      my ($self, $genomeID) = @_;
950      # Get the organism data.      # Get the organism data.
951      my ($retVal, $group) = $self->OrganismData($genomeID);      my ($retVal) = $self->OrganismData($genomeID);
952      # Return the result.      # Return the result.
953      return $retVal;      return $retVal;
954  }  }
# Line 1014  Line 1028 
1028    
1029  =head3 ComputeFASTA  =head3 ComputeFASTA
1030    
1031  C<< my $fasta = $shelp->ComputeFASTA($desiredType, $sequence); >>  C<< my $fasta = $shelp->ComputeFASTA($desiredType, $sequence, $flankingWidth); >>
1032    
1033  Parse a sequence input and convert it into a FASTA string of the desired type.  Parse a sequence input and convert it into a FASTA string of the desired type with
1034    the desired flanking width.
1035    
1036  =over 4  =over 4
1037    
# Line 1032  Line 1047 
1047  if the input does not begin with a greater-than sign (FASTA label line), a default label  if the input does not begin with a greater-than sign (FASTA label line), a default label
1048  line will be provided.  line will be provided.
1049    
1050    =item flankingWidth
1051    
1052    If the DNA FASTA of a feature is desired, the number of base pairs to either side of the
1053    feature that should be included. Currently we can't do this for Proteins because the
1054    protein translation of a feature doesn't always match the DNA and is taken directly
1055    from the database.
1056    
1057  =item RETURN  =item RETURN
1058    
1059  Returns a string in FASTA format representing the content of the desired sequence with  Returns a string in FASTA format representing the content of the desired sequence with
# Line 1044  Line 1066 
1066    
1067  sub ComputeFASTA {  sub ComputeFASTA {
1068      # Get the parameters.      # Get the parameters.
1069      my ($self, $desiredType, $sequence) = @_;      my ($self, $desiredType, $sequence, $flankingWidth) = @_;
1070      # Declare the return variable. If an error occurs, it will remain undefined.      # Declare the return variable. If an error occurs, it will remain undefined.
1071      my $retVal;      my $retVal;
1072      # This variable will be cleared if an error is detected.      # This variable will be cleared if an error is detected.
# Line 1052  Line 1074 
1074      # Create variables to hold the FASTA label and data.      # Create variables to hold the FASTA label and data.
1075      my ($fastaLabel, $fastaData);      my ($fastaLabel, $fastaData);
1076      Trace("FASTA desired type is $desiredType.") if T(4);      Trace("FASTA desired type is $desiredType.") if T(4);
1077      # Check for a feature specification.      # Check for a feature specification. The smoking gun for that is a vertical bar.
1078      if ($sequence =~ /^\s*(\w+\|\S+)\s*$/) {      if ($sequence =~ /^\s*(\w+\|\S+)\s*$/) {
1079          # 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
1080          # it.          # it.
# Line 1067  Line 1089 
1089              $self->SetMessage("No gene found with the ID \"$fid\".");              $self->SetMessage("No gene found with the ID \"$fid\".");
1090              $okFlag = 0;              $okFlag = 0;
1091          } else {          } else {
1092              # Set the FASTA label.              # Set the FASTA label. The ID is the first favored alias.
1093              my $fastaLabel = $fid;              my $favored = $self->Q()->param('FavoredAlias') || 'fig';
1094                my $favorLen = length $favored;
1095                ($fastaLabel) = grep { substr($_, 0, $favorLen) eq $favored } $sprout->FeatureAliases($fid);
1096                if (! $fastaLabel) {
1097                    # In an emergency, fall back to the original ID.
1098                    $fastaLabel = $fid;
1099                }
1100              # Now proceed according to the sequence type.              # Now proceed according to the sequence type.
1101              if ($desiredType eq 'prot') {              if ($desiredType =~ /prot/) {
1102                  # We want protein, so get the translation.                  # We want protein, so get the translation.
1103                  $fastaData = $sprout->FeatureTranslation($figID);                  $fastaData = $sprout->FeatureTranslation($figID);
1104                  Trace(length $fastaData . " characters returned for translation of $fastaLabel.") if T(3);                  Trace(length $fastaData . " characters returned for translation of $fastaLabel.") if T(3);
1105              } else {              } else {
1106                  # We want DNA, so get the DNA sequence. This is a two-step process.                  # We want DNA, so get the DNA sequence. This is a two-step process. First, we get the
1107                    # locations.
1108                  my @locList = $sprout->FeatureLocation($figID);                  my @locList = $sprout->FeatureLocation($figID);
1109                    if ($flankingWidth > 0) {
1110                        # Here we need to add flanking data. Convert the locations to a list
1111                        # of location objects.
1112                        my @locObjects = map { BasicLocation->new($_) } @locList;
1113                        # Initialize the return variable. We will put the DNA in here segment by segment.
1114                        $fastaData = "";
1115                        # Now we widen each location by the flanking width and stash the results. This
1116                        # requires getting the contig length for each contig so we don't fall off the end.
1117                        for my $locObject (@locObjects) {
1118                            Trace("Current location is " . $locObject->String . ".") if T(4);
1119                            # Remember the current start and length.
1120                            my ($start, $len) = ($locObject->Left, $locObject->Length);
1121                            # Get the contig length.
1122                            my $contigLen = $sprout->ContigLength($locObject->Contig);
1123                            # Widen the location and get its DNA.
1124                            $locObject->Widen($flankingWidth, $contigLen);
1125                            my $fastaSegment = $sprout->DNASeq([$locObject->String()]);
1126                            # Now we need to do some case changing. The main DNA is upper case and
1127                            # the flanking DNA is lower case.
1128                            my $leftFlank = $start - $locObject->Left;
1129                            my $rightFlank = $leftFlank + $len;
1130                            Trace("Wide location is " . $locObject->String . ". Flanks are $leftFlank and $rightFlank. Contig len is $contigLen.") if T(4);
1131                            my $fancyFastaSegment = lc(substr($fastaSegment, 0, $leftFlank)) .
1132                                                    uc(substr($fastaSegment, $leftFlank, $rightFlank - $leftFlank)) .
1133                                                    lc(substr($fastaSegment, $rightFlank));
1134                            $fastaData .= $fancyFastaSegment;
1135                        }
1136                    } else {
1137                        # Here we have just the raw sequence.
1138                  $fastaData = $sprout->DNASeq(\@locList);                  $fastaData = $sprout->DNASeq(\@locList);
1139                  Trace(length $fastaData . " characters returned for DNA of $fastaLabel.") if T(3);                  }
1140                    Trace((length $fastaData) . " characters returned for DNA of $fastaLabel.") if T(3);
1141              }              }
1142          }          }
1143      } else {      } else {
# Line 1108  Line 1167 
1167      Trace("FASTA data sequence: $fastaData") if T(4);      Trace("FASTA data sequence: $fastaData") if T(4);
1168      # Only proceed if no error was detected.      # Only proceed if no error was detected.
1169      if ($okFlag) {      if ($okFlag) {
1170            if ($desiredType =~ /pattern/i) {
1171                # We're doing a scan, so only the data is passed in.
1172                $retVal = $fastaData;
1173            } else {
1174          # We need to format the sequence into 60-byte chunks. We use the infamous          # We need to format the sequence into 60-byte chunks. We use the infamous
1175          # grep-split trick. The split, because of the presence of the parentheses,          # grep-split trick. The split, because of the presence of the parentheses,
1176          # includes the matched delimiters in the output list. The grep strips out          # includes the matched delimiters in the output list. The grep strips out
# Line 1116  Line 1179 
1179          my @chunks = grep { $_ } split /(.{1,60})/, $fastaData;          my @chunks = grep { $_ } split /(.{1,60})/, $fastaData;
1180          $retVal = join("\n", ">$fastaLabel", @chunks, "");          $retVal = join("\n", ">$fastaLabel", @chunks, "");
1181      }      }
1182        }
1183      # Return the result.      # Return the result.
1184      return $retVal;      return $retVal;
1185  }  }
# Line 1329  Line 1393 
1393      # Get the form name.      # Get the form name.
1394      my $formName = $self->FormName();      my $formName = $self->FormName();
1395      # Check to see if we already have a genome list in memory.      # Check to see if we already have a genome list in memory.
     my $genomes = $self->{genomeList};  
1396      my $groupHash;      my $groupHash;
1397        my @groups;
1398        my $nmpdrGroupCount;
1399        my $genomes = $self->{genomeList};
1400      if (defined $genomes) {      if (defined $genomes) {
1401          # We have a list ready to use.          # We have a list ready to use.
1402          $groupHash = $genomes;          $groupHash = $genomes;
1403            @groups = @{$self->{groupList}};
1404            $nmpdrGroupCount = $self->{groupCount};
1405      } else {      } else {
1406          # Get a list of all the genomes in group order. In fact, we only need them ordered          # Get a list of all the genomes in group order. In fact, we only need them ordered
1407          # by name (genus,species,strain), but putting primary-group in front enables us to          # by name (genus,species,strain), but putting primary-group in front enables us to
# Line 1342  Line 1410 
1410                                           "ORDER BY Genome(primary-group), Genome(genus), Genome(species), Genome(unique-characterization)",                                           "ORDER BY Genome(primary-group), Genome(genus), Genome(species), Genome(unique-characterization)",
1411                                           [], ['Genome(primary-group)', 'Genome(id)',                                           [], ['Genome(primary-group)', 'Genome(id)',
1412                                                'Genome(genus)', 'Genome(species)',                                                'Genome(genus)', 'Genome(species)',
1413                                                'Genome(unique-characterization)']);                                                'Genome(unique-characterization)',
1414                                                  'Genome(taxonomy)']);
1415          # Create a hash to organize the genomes by group. Each group will contain a list of          # Create a hash to organize the genomes by group. Each group will contain a list of
1416          # 2-tuples, the first element being the genome ID and the second being the genome          # 2-tuples, the first element being the genome ID and the second being the genome
1417          # name.          # name.
1418          my %gHash = ();          my %gHash = ();
1419          for my $genome (@genomeList) {          for my $genome (@genomeList) {
1420              # Get the genome data.              # Get the genome data.
1421              my ($group, $genomeID, $genus, $species, $strain) = @{$genome};              my ($group, $genomeID, $genus, $species, $strain, $taxonomy) = @{$genome};
1422              # Compute and cache its name and display group.              # Compute and cache its name and display group.
1423              my ($name, $displayGroup) = $self->SaveOrganismData($group, $genomeID, $genus, $species,              my ($name, $displayGroup, $domain) = $self->SaveOrganismData($group, $genomeID, $genus, $species,
1424                                                                  $strain);                                                                           $strain, $taxonomy);
1425              # Push the genome into the group's list. Note that we use the real group              # Push the genome into the group's list. Note that we use the real group
1426              # name here, not the display group name.              # name here, not the display group name.
1427              push @{$gHash{$group}}, [$genomeID, $name];              push @{$gHash{$group}}, [$genomeID, $name, $domain];
1428          }          }
1429            # We are almost ready to unroll the menu out of the group hash. The final step is to separate
1430            # the supporting genomes by domain. First, we sort the NMPDR groups.
1431            @groups = sort grep { $_ ne $FIG_Config::otherGroup } keys %gHash;
1432            # Remember the number of NMPDR groups.
1433            $nmpdrGroupCount = scalar @groups;
1434            # Loop through the supporting genomes, classifying them by domain. We'll also keep a list
1435            # of the domains found.
1436            my @otherGenomes = @{$gHash{$FIG_Config::otherGroup}};
1437            my @domains = ();
1438            for my $genomeData (@otherGenomes) {
1439                my ($genomeID, $name, $domain) = @{$genomeData};
1440                if (exists $gHash{$domain}) {
1441                    push @{$gHash{$domain}}, $genomeData;
1442                } else {
1443                    $gHash{$domain} = [$genomeData];
1444                    push @domains, $domain;
1445                }
1446            }
1447            # Add the domain groups at the end of the main group list. The main group list will now
1448            # contain all the categories we need to display the genomes.
1449            push @groups, sort @domains;
1450            # Delete the supporting group.
1451            delete $gHash{$FIG_Config::otherGroup};
1452          # Save the genome list for future use.          # Save the genome list for future use.
1453          $self->{genomeList} = \%gHash;          $self->{genomeList} = \%gHash;
1454            $self->{groupList} = \@groups;
1455            $self->{groupCount} = $nmpdrGroupCount;
1456          $groupHash = \%gHash;          $groupHash = \%gHash;
1457      }      }
     # Now we are ready to unroll the menu out of the group hash. First, we sort the groups, putting  
     # the supporting-genome group last.  
     my @groups = sort grep { $_ ne $FIG_Config::otherGroup } keys %{$groupHash};  
     push @groups, $FIG_Config::otherGroup;  
1458      # Next, create a hash that specifies the pre-selected entries. Note that we need to deal      # Next, create a hash that specifies the pre-selected entries. Note that we need to deal
1459      # with the possibility of undefined values in the incoming list.      # with the possibility of undefined values in the incoming list.
1460      my %selectedHash = ();      my %selectedHash = ();
# Line 1401  Line 1491 
1491          # Get the genomes in the group.          # Get the genomes in the group.
1492          for my $genome (@{$groupHash->{$group}}) {          for my $genome (@{$groupHash->{$group}}) {
1493              # Count this organism if it's NMPDR.              # Count this organism if it's NMPDR.
1494              if ($group ne $FIG_Config::otherGroup) {              if ($nmpdrGroupCount > 0) {
1495                  $nmpdrCount++;                  $nmpdrCount++;
1496              }              }
1497              # Get the organism ID and name.              # Get the organism ID, name, and domain.
1498              my ($genomeID, $name) = @{$genome};              my ($genomeID, $name, $domain) = @{$genome};
1499              # See if it's selected.              # See if it's selected.
1500              my $select = ($selectedHash{$genomeID} ? " selected" : "");              my $select = ($selectedHash{$genomeID} ? " selected" : "");
1501              # Generate the option tag.              # Generate the option tag.
1502              my $optionTag = "<OPTION value=\"$genomeID\"$select>$name <em>($genomeID)</em></OPTION>";              my $optionTag = "<OPTION class=\"$domain\" value=\"$genomeID\"$select>$name <em>($genomeID)</em></OPTION>";
1503              push @lines, "    $optionTag";              push @lines, "    $optionTag";
1504          }          }
1505          # Close the option group.          # Close the option group.
1506          push @lines, "  </OPTGROUP>";          push @lines, "  </OPTGROUP>";
1507            # Record this group in the nmpdrGroup count. When that gets to 0, we've finished the NMPDR
1508            # groups.
1509            $nmpdrGroupCount--;
1510      }      }
1511      # Close the SELECT tag.      # Close the SELECT tag.
1512      push @lines, "</SELECT>";      push @lines, "</SELECT>";
# Line 1518  Line 1611 
1611  =item rows  =item rows
1612    
1613  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
1614  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
1615  set the width. Everything else will be left as is.  will be modified to set the width. Everything else will be left as is.
1616    
1617  =item RETURN  =item RETURN
1618    
# Line 1534  Line 1627 
1627      my ($self, $rows) = @_;      my ($self, $rows) = @_;
1628      # Get the CGI object.      # Get the CGI object.
1629      my $cgi = $self->Q();      my $cgi = $self->Q();
1630      # 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.
1631        # This flag will be set to FALSE when that happens.
1632        my $needWidth = 1;
1633      # 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
1634      # is already specified on the first column bad things will happen.      # is already specified on the first column bad things will happen.
1635      for my $row (@{$rows}) {      for my $row (@{$rows}) {
1636          $row =~ s/(<td|th)/$1 width="150"/i;          # See if this row needs a width.
1637            if ($needWidth && $row =~ /<(td|th) ([^>]+)>/i) {
1638                # Here we have a first cell and its tag parameters are in $2.
1639                my $elements = $2;
1640                if ($elements !~ /colspan/i) {
1641                    Trace("No colspan tag found in element \'$elements\'.") if T(3);
1642                    # Here there's no colspan, so we plug in the width. We
1643                    # eschew the "g" modifier on the substitution because we
1644                    # only want to update the first cell.
1645                    $row =~ s/(<(td|th))/$1 width="150"/i;
1646                    # Denote we don't need this any more.
1647                    $needWidth = 0;
1648                }
1649            }
1650      }      }
1651      # Create the table.      # Create the table.
1652      my $retVal = $cgi->table({border => 2, cellspacing => 2,      my $retVal = $cgi->table({border => 2, cellspacing => 2,
# Line 1932  Line 2040 
2040    
2041  sub AdvancedClassList {  sub AdvancedClassList {
2042      my @retVal = map { $_ =~ /^SH(\w+)\.pm/; $1 } grep { $_ =~ /^SH/ } keys %INC;      my @retVal = map { $_ =~ /^SH(\w+)\.pm/; $1 } grep { $_ =~ /^SH/ } keys %INC;
2043      return @retVal;      return sort @retVal;
2044  }  }
2045    
2046  =head3 SelectionTree  =head3 SelectionTree
# Line 2307  Line 2415 
2415      return $retVal;      return $retVal;
2416  }  }
2417    
2418    
2419    =head3 PrintLine
2420    
2421    C<< $shelp->PrintLine($message); >>
2422    
2423    Print a line of CGI output. This is used during the operation of the B<Find> method while
2424    searching, so the user sees progress in real-time.
2425    
2426    =over 4
2427    
2428    =item message
2429    
2430    HTML text to display.
2431    
2432    =back
2433    
2434    =cut
2435    
2436    sub PrintLine {
2437        # Get the parameters.
2438        my ($self, $message) = @_;
2439        # Send them to the output.
2440        print "$message\n";
2441    }
2442    
2443  =head2 Feature Column Methods  =head2 Feature Column Methods
2444    
2445  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 2397  Line 2530 
2530          $retVal = "Annotation Page";          $retVal = "Annotation Page";
2531      } elsif ($colName eq 'subsystem') {      } elsif ($colName eq 'subsystem') {
2532          $retVal = "Subsystems";          $retVal = "Subsystems";
2533        } elsif ($colName eq 'pdb') {
2534            $retVal = "Best PDB Match";
2535      }      }
2536      # Return the result.      # Return the result.
2537      return $retVal;      return $retVal;
# Line 2485  Line 2620 
2620      } elsif ($colName eq 'alias') {      } elsif ($colName eq 'alias') {
2621          # 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.
2622          # 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.
2623          $retVal = "%%alias=$fid";          # To do the computation, we need to know the favored alias type and the
2624            # feature ID.
2625            my $favored = $cgi->param("FavoredAlias") || "fig";
2626            $retVal = "%%alias=$fid,$favored";
2627      } elsif ($colName eq 'fid') {      } elsif ($colName eq 'fid') {
2628          # 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.
2629          $retVal = HTML::set_prot_links($fid);          $retVal = HTML::set_prot_links($fid);
# Line 2522  Line 2660 
2660      } elsif ($colName eq 'subsystem') {      } elsif ($colName eq 'subsystem') {
2661          # Another run-time column: subsystem list.          # Another run-time column: subsystem list.
2662          $retVal = "%%subsystem=$fid";          $retVal = "%%subsystem=$fid";
2663        } elsif ($colName eq 'pdb') {
2664            $retVal = "%%pdb=$fid";
2665      }      }
2666      # Return the result.      # Return the result.
2667      return $retVal;      return $retVal;
# Line 2564  Line 2704 
2704      # Separate the text into a type and data.      # Separate the text into a type and data.
2705      if ($type eq 'alias') {      if ($type eq 'alias') {
2706          # Here the caller wants external alias links for a feature. The text          # Here the caller wants external alias links for a feature. The text
2707          # is the feature ID.          # parameter for computing the alias is the feature ID followed by
2708          my $fid = $text;          # the favored alias type.
2709          # The complicated part is we have to hyperlink them. First, get the          my ($fid, $favored) = split /\s*,\s*/, $text;
2710          # aliases.          # The complicated part is we have to hyperlink them and handle the
2711            # favorites. First, get the aliases.
2712          Trace("Generating aliases for feature $fid.") if T(4);          Trace("Generating aliases for feature $fid.") if T(4);
2713          my @aliases = $sprout->FeatureAliases($fid);          my @aliases = sort $sprout->FeatureAliases($fid);
2714          # Only proceed if we found some.          # Only proceed if we found some.
2715          if (@aliases) {          if (@aliases) {
2716              # Join the aliases into a comma-delimited list.              # Split the aliases into favored and unfavored.
2717              my $aliasList = join(", ", @aliases);              my @favored = ();
2718                my @unfavored = ();
2719                for my $alias (@aliases) {
2720                    # Use substr instead of pattern match because $favored is specified by the user
2721                    # and we don't want him to put funny meta-characters in there.
2722                    if (substr($alias, 0, length($favored)) eq $favored) {
2723                        push @favored, $alias;
2724                    } else {
2725                        push @unfavored, $alias;
2726                    }
2727                }
2728                # Rejoin the aliases into a comma-delimited list, with the favored ones first.
2729                my $aliasList = join(", ", @favored, @unfavored);
2730              # Ask the HTML processor to hyperlink them.              # Ask the HTML processor to hyperlink them.
2731              $retVal = HTML::set_prot_links($cgi, $aliasList);              $retVal = HTML::set_prot_links($cgi, $aliasList);
2732          }          }
# Line 2600  Line 2753 
2753                                        "Feature($keywordName)");                                        "Feature($keywordName)");
2754          # String them into a list.          # String them into a list.
2755          $retVal = join(", ", @values);          $retVal = join(", ", @values);
2756        } elsif ($type eq 'pdb') {
2757            # Here the caller wants the best PDB match to this feature. The text
2758            # is the feature ID. We will display the PDB with a link to the
2759            # PDB page along with the match score. If there are docking results we
2760            # will display a link to the docking result search.
2761            my $fid = $text;
2762            # Ask for the best PDB.
2763            my ($bestPDB) = $sprout->GetAll(['IsProteinForFeature', 'PDB'],
2764                                            "IsProteinForFeature(from-link) = ? ORDER BY IsProteinForFeature(score) LIMIT 1",
2765                                            [$fid], ['PDB(id)', 'PDB(docking-count)', 'IsProteinForFeature(score)']);
2766            # Only proceed if there is a PDB.
2767            if ($bestPDB) {
2768                my ($pdbID, $dockingCount, $score) = @{$bestPDB};
2769                # Convert the PDB ID to a hyperlink.
2770                my $pdbLink = SHDrugSearch::PDBLink($cgi, $pdbID);
2771                # Append the score.
2772                $retVal = "$pdbLink ($score)";
2773                # If there are docking results, append a docking results link.
2774                if ($dockingCount > 0) {
2775                    my $dockString = "$dockingCount docking results";
2776                    my $dockLink = $cgi->a({ href =>  $cgi->url() . "?Class=DrugSearch;PDB=$pdbID;NoForm=1",
2777                                             alt =>   "View computed docking results for $pdbID",
2778                                             title => "View computed docking results for $pdbID",
2779                                             target => "_blank"},
2780                                           $dockString);
2781                }
2782            }
2783        } elsif ($type eq 'role') {
2784            # Here the caller wants a functional role assignment. The key is the feature ID.
2785            $retVal = $sprout->FunctionOf($text);
2786        } elsif ($type eq 'loc') {
2787            # This is a tough one. We need to find the nearest feature in the appropriate direction
2788            # on the contig, and then output its id, functional role, and link button.
2789            if ($text =~ /^(.)\/(.+)/) {
2790                my ($direction, $locString) = ($1, $2);
2791                Trace("Location request of type $direction for $locString.") if T(3);
2792                # Convert the location string into a location object.
2793                my $loc = BasicLocation->new($locString);
2794                # Get the contig ID.
2795                my $contigID = $loc->Contig;
2796                # Compute the contig length.
2797                my $contigLen = $sprout->ContigLength($contigID);
2798                # Widen by the area to search in both directions.
2799                $loc->Widen(5000);
2800                # Now, if we're doing a before (-) search, we set the end point to the area's mid point.
2801                # If we're doing an after (+) search, we set the begin point to the area's mid point.
2802                my $mid = ($loc->Left + $loc->Right) / 2;
2803                # Compute the search direction.
2804                my $searchDir = ($direction eq $loc->Dir ? 1 : -1);
2805                # Adjust the midpoint so that it is different in the before direction from what it would
2806                # be in the after direction.
2807                if ($mid != int($mid)) {
2808                    # Here we need to round. The thing here is we want to round in a way that separates
2809                    # the after-search choice from the before-search choice.
2810                    if ($direction eq $loc->Dir) {
2811                        $mid = ceil($mid);
2812                    } else {
2813                        $mid = floor($mid);
2814                    }
2815                } elsif ($direction eq '+') {
2816                    # Here the midpoint is on a nucleotide and we are doing the after search. We bump the
2817                    # midpoint toward the end point.
2818                    $mid += $loc->NumDirection;
2819                }
2820                # Now put the midpoint on the proper end of the region.
2821                if ($direction eq '+') {
2822                    $loc->SetBegin($mid);
2823                } else {
2824                    $loc->SetEnd($mid);
2825                }
2826                Trace("Search region is " . $loc->String . ".") if T(3);
2827                # Find all the genes in the region.
2828                my ($fidList, $beg, $end) = $sprout->GenesInRegion($loc->Contig, $loc->Left, $loc->Right);
2829                Trace(scalar(@{$fidList}) . " features found.") if T(3);
2830                # Look for the best match.
2831                my $distance = 5000;
2832                my $chosenFid = undef;
2833                for my $fid (@{$fidList}) {
2834                    # Get the feature's location.
2835                    my ($locString) = $sprout->FeatureLocation($fid);
2836                    my $locObject = BasicLocation->new($locString);
2837                    # Check its begin point to see if we should keep it.
2838                    my $newDistance = ($mid - $locObject->Begin) * $searchDir;
2839                    Trace("Distance from $mid to $locString is $newDistance.") if T(4);
2840                    if ($newDistance > 0 && $newDistance < $distance) {
2841                        $distance = $newDistance;
2842                        $chosenFid = $fid;
2843                    }
2844                }
2845                # Only proceed if we found something.
2846                if (defined $chosenFid) {
2847                    my $role = $sprout->FunctionOf($chosenFid);
2848                    my $linkButton = SearchHelper::FakeButton('NMPDR', "protein.cgi", undef,
2849                                                               prot => $chosenFid, SPROUT => 1,
2850                                                               new_framework => 0, user => '');
2851                    $retVal = "$chosenFid&nbsp;$linkButton&nbsp;$role";
2852                }
2853            } else {
2854                Confess("Invalid location request %%loc=$text.");
2855            }
2856      }      }
2857      # Return the result.      # Return the result.
2858      return $retVal;      return $retVal;
# Line 2607  Line 2860 
2860    
2861  =head3 SaveOrganismData  =head3 SaveOrganismData
2862    
2863  C<< my ($name, $displayGroup) = $shelp->SaveOrganismData($group, $genomeID, $genus, $species, $strain); >>  C<< my ($name, $displayGroup) = $shelp->SaveOrganismData($group, $genomeID, $genus, $species, $strain, $taxonomy); >>
2864    
2865  Format the name of an organism and the display version of its group name. The incoming  Format the name of an organism and the display version of its group name. The incoming
2866  data should be the relevant fields from the B<Genome> record in the database. The  data should be the relevant fields from the B<Genome> record in the database. The
# Line 2637  Line 2890 
2890    
2891  Strain of the species represented by the genome.  Strain of the species represented by the genome.
2892    
2893    =item taxonomy
2894    
2895    Taxonomy of the species represented by the genome.
2896    
2897  =item RETURN  =item RETURN
2898    
2899  Returns a two-element list. The first element is the formatted genome name. The second  Returns a three-element list. The first element is the formatted genome name. The second
2900  element is the display name of the genome's group.  element is the display name of the genome's group. The third is the genome's domain.
2901    
2902  =back  =back
2903    
# Line 2648  Line 2905 
2905    
2906  sub SaveOrganismData {  sub SaveOrganismData {
2907      # Get the parameters.      # Get the parameters.
2908      my ($self, $group, $genomeID, $genus, $species, $strain) = @_;      my ($self, $group, $genomeID, $genus, $species, $strain, $taxonomy) = @_;
2909      # Declare the return values.      # Declare the return values.
2910      my ($name, $displayGroup);      my ($name, $displayGroup);
2911      # If the organism does not exist, format an unknown name and a blank group.      # If the organism does not exist, format an unknown name and a blank group.
# Line 2665  Line 2922 
2922          # name unless it's the supporting group, which is nulled out.          # name unless it's the supporting group, which is nulled out.
2923          $displayGroup = ($group eq $FIG_Config::otherGroup ? "" : $group);          $displayGroup = ($group eq $FIG_Config::otherGroup ? "" : $group);
2924      }      }
2925        # Compute the domain from the taxonomy.
2926        my ($domain) = split /\s*;\s*/, $taxonomy, 2;
2927      # Cache the group and organism data.      # Cache the group and organism data.
2928      my $cache = $self->{orgs};      my $cache = $self->{orgs};
2929      $cache->{$genomeID} = [$name, $displayGroup];      $cache->{$genomeID} = [$name, $displayGroup, $domain];
2930      # Return the result.      # Return the result.
2931      return ($name, $displayGroup);      return ($name, $displayGroup, $domain);
2932  }  }
2933    
2934  =head3 ValidateKeywords  =head3 ValidateKeywords
# Line 2767  Line 3026 
3026      # Compute the target-frame HTML.      # Compute the target-frame HTML.
3027      my $targetHtml = ($target ? " target=\"$target\"" : "");      my $targetHtml = ($target ? " target=\"$target\"" : "");
3028      # Assemble the result.      # Assemble the result.
3029      return "<a href=\"$targetUrl\" $targetHtml><div class=\"button2 button\">$caption</div></a>";      return "<a href=\"$targetUrl\" $targetHtml><span class=\"button2 button\">$caption</span></a>";
3030  }  }
3031    
3032  =head3 Formlet  =head3 Formlet
# Line 2823  Line 3082 
3082      return $retVal;      return $retVal;
3083  }  }
3084    
3085    =head3 TuningParameters
3086    
3087    C<< my $options = $shelp->TuningParameters(%parmHash); >>
3088    
3089    Retrieve tuning parameters from the CGI query object. The parameter is a hash that maps parameter names
3090    to their default values. The parameters and their values will be returned as a hash reference.
3091    
3092    =over 4
3093    
3094    =item parmHash
3095    
3096    Hash mapping parameter names to their default values.
3097    
3098    =item RETURN
3099    
3100    Returns a reference to a hash containing the parameter names mapped to their actual values.
3101    
3102    =back
3103    
3104    =cut
3105    
3106    sub TuningParameters {
3107        # Get the parameters.
3108        my ($self, %parmHash) = @_;
3109        # Declare the return variable.
3110        my $retVal = {};
3111        # Get the CGI Query Object.
3112        my $cgi = $self->Q();
3113        # Loop through the parameter names.
3114        for my $parm (keys %parmHash) {
3115            # Get the incoming value for this parameter.
3116            my $value = $cgi->param($parm);
3117            # Zero might be a valid value, so we do an is-defined check rather than an OR.
3118            if (defined($value)) {
3119                $retVal->{$parm} = $value;
3120            } else {
3121                $retVal->{$parm} = $parmHash{$parm};
3122            }
3123        }
3124        # Return the result.
3125        return $retVal;
3126    }
3127    
3128  =head2 Virtual Methods  =head2 Virtual Methods
3129    
3130  =head3 Form  =head3 Form
# Line 2886  Line 3188 
3188      return $retVal;      return $retVal;
3189  }  }
3190    
3191  =head3 PrintLine  =head3 SearchTitle
3192    
3193  C<< $shelp->PrintLine($message); >>  C<< my $titleHtml = $shelp->SearchTitle(); >>
3194    
3195  Print a line of CGI output. This is used during the operation of the B<Find> method while  Return the display title for this search. The display title appears above the search results.
3196  searching, so the user sees progress in real-time.  If no result is returned, no title will be displayed. The result should be an html string
3197    that can be legally put inside a block tag such as C<h3> or C<p>.
3198    
3199    =cut
3200    
3201    sub SearchTitle {
3202        # Get the parameters.
3203        my ($self) = @_;
3204        # Declare the return variable.
3205        my $retVal;
3206        # Return it.
3207        return $retVal;
3208    }
3209    
3210    =head3 DownloadFormatAvailable
3211    
3212    C<< my $okFlag = $shelp->DownloadFormatAvailable($format); >>
3213    
3214    This method returns TRUE if a specified download format is legal for this type of search
3215    and FALSE otherwise. For any feature-based search, there is no need to override this
3216    method.
3217    
3218  =over 4  =over 4
3219    
3220  =item message  =item format
3221    
3222  HTML text to display.  Download format type code.
3223    
3224    =item RETURN
3225    
3226    Returns TRUE if the download format is legal for this search and FALSE otherwise.
3227    
3228  =back  =back
3229    
3230  =cut  =cut
3231    
3232  sub PrintLine {  sub DownloadFormatAvailable {
3233      # Get the parameters.      # Get the parameters.
3234      my ($self, $message) = @_;      my ($self, $format) = @_;
3235      # Send them to the output.      # Declare the return variable.
3236      print "$message\n";      my $retVal = 1;
3237        # Return the result.
3238        return $retVal;
3239    }
3240    
3241    =head3 ColumnTitle
3242    
3243    C<< my $title = $shelp->ColumnTitle($colName); >>
3244    
3245    Return the column heading title to be used for the specified column name. The
3246    default implementation is to simply call L</FeatureColumnTitle>.
3247    
3248    =over 4
3249    
3250    =item colName
3251    
3252    Name of the desired column.
3253    
3254    =item RETURN
3255    
3256    Returns the title to be used as the column header for the named column.
3257    
3258    =back
3259    
3260    =cut
3261    
3262    sub ColumnTitle {
3263        my ($self, $colName) = @_;
3264        return $self->FeatureColumnTitle($colName);
3265  }  }
3266    
3267    

Legend:
Removed from v.1.28  
changed lines
  Added in v.1.33

MCS Webmaster
ViewVC Help
Powered by ViewVC 1.0.3