[Bio] / Sprout / Sprout.pm Repository:
ViewVC logotype

Diff of /Sprout/Sprout.pm

Parent Directory Parent Directory | Revision Log Revision Log | View Patch Patch

revision 1.104, Wed Jan 23 00:56:31 2008 UTC revision 1.116, Tue Sep 9 21:02:10 2008 UTC
# Line 14  Line 14 
14      use BasicLocation;      use BasicLocation;
15      use CustomAttributes;      use CustomAttributes;
16      use RemoteCustomAttributes;      use RemoteCustomAttributes;
17        use CGI;
18        use WikiTools;
19      use base qw(ERDB);      use base qw(ERDB);
20    
21  =head1 Sprout Database Manipulation Object  =head1 Sprout Database Manipulation Object
# Line 78  Line 80 
80    
81  * B<noDBOpen> suppresses the connection to the database if TRUE, else FALSE  * B<noDBOpen> suppresses the connection to the database if TRUE, else FALSE
82    
83    * B<host> name of the database host
84    
85  =back  =back
86    
87  For example, the following constructor call specifies a database named I<Sprout> and a user name of  For example, the following constructor call specifies a database named I<Sprout> and a user name of
# Line 103  Line 107 
107                                                          # data file directory                                                          # data file directory
108                         xmlFileName  => "$dbd_dir/SproutDBD.xml",                         xmlFileName  => "$dbd_dir/SproutDBD.xml",
109                                                          # database definition file name                                                          # database definition file name
110                         userData     => "$FIG_Config::dbuser/$FIG_Config::dbpass",                         userData     => "$FIG_Config::sproutUser/$FIG_Config::sproutPass",
111                                                          # user name and password                                                          # user name and password
112                         port         => $FIG_Config::dbport,                         port         => $FIG_Config::sproutPort,
113                                                          # database connection port                                                          # database connection port
114                         sock         => $FIG_Config::dbsock,                         sock         => $FIG_Config::sproutSock,
115                         host         => $FIG_Config::dbhost,                         host         => $FIG_Config::sprout_host,
116                         maxSegmentLength => 4500,        # maximum feature segment length                         maxSegmentLength => 4500,        # maximum feature segment length
117                         maxSequenceLength => 8000,       # maximum contig sequence length                         maxSequenceLength => 8000,       # maximum contig sequence length
118                         noDBOpen     => 0,               # 1 to suppress the database open                         noDBOpen     => 0,               # 1 to suppress the database open
# Line 121  Line 125 
125      # Connect to the database.      # Connect to the database.
126      my $dbh;      my $dbh;
127      if (! $optionTable->{noDBOpen}) {      if (! $optionTable->{noDBOpen}) {
128            Trace("Connect data: host = $optionTable->{host}, port = $optionTable->{port}.") if T(3);
129          $dbh = DBKernel->new($optionTable->{dbType}, $dbName, $userName,          $dbh = DBKernel->new($optionTable->{dbType}, $dbName, $userName,
130                                  $password, $optionTable->{port}, $optionTable->{host}, $optionTable->{sock});                                  $password, $optionTable->{port}, $optionTable->{host}, $optionTable->{sock});
131      }      }
# Line 147  Line 152 
152      return $retVal;      return $retVal;
153  }  }
154    
155    =head3 CoreGenomes
156    
157        my @genomes = $sprout->CoreGenomes($scope);
158    
159    Return the IDs of NMPDR genomes in the specified scope.
160    
161    =over 4
162    
163    =item scope
164    
165    Scope of the desired genomes. C<core> covers the original core genomes,
166    C<nmpdr> covers all genomes in NMPDR groups, and C<all> covers all
167    genomes in the system.
168    
169    =item RETURN
170    
171    Returns a list of the IDs for the genomes in the specified scope.
172    
173    =back
174    
175    =cut
176    
177    sub CoreGenomes {
178        # Get the parameters.
179        my ($self, $scope) = @_;
180        # Declare the return variable.
181        my @retVal = ();
182        # If we want all genomes, then this is easy.
183        if ($scope eq 'all') {
184            @retVal = $self->Genomes();
185        } else {
186            # Here we're dealing with groups. Get the hash of all the
187            # genome groups.
188            my %groups = $self->GetGroups();
189            # Loop through the groups, keeping the ones that we want.
190            for my $group (keys %groups) {
191                # Decide if we want to keep this group.
192                my $keepGroup = 0;
193                if ($scope eq 'nmpdr') {
194                    # NMPDR mode: keep all groups.
195                    $keepGroup = 1;
196                } elsif ($scope eq 'core') {
197                    # CORE mode. Only keep real core groups.
198                    if (grep { $group =~ /$_/ } @{$FIG_Config::realCoreGroups}) {
199                        $keepGroup = 1;
200                    }
201                }
202                # Add this group if we're keeping it.
203                if ($keepGroup) {
204                    push @retVal, @{$groups{$group}};
205                }
206            }
207        }
208        # Return the result.
209        return @retVal;
210    }
211    
212    =head3 SuperGroup
213    
214        my $superGroup = $sprout->SuperGroup($groupName);
215    
216    Return the name of the super-group containing the specified NMPDR genome
217    group. If no appropriate super-group can be found, an error will be
218    thrown.
219    
220    =over 4
221    
222    =item groupName
223    
224    Name of the group whose super-group is desired.
225    
226    =item RETURN
227    
228    Returns the name of the super-group containing the incoming group.
229    
230    =back
231    
232    =cut
233    
234    sub SuperGroup {
235        # Get the parameters.
236        my ($self, $groupName) = @_;
237        # Declare the return variable.
238        my $retVal;
239        # Get the group hash.
240        my %groupHash = $self->CheckGroupFile();
241        # Find the super-group genus.
242        $groupName =~ /([A-Z]\w+)/;
243        my $nameThing = $1;
244        # See if it's directly in the group hash.
245        if (exists $groupHash{$nameThing}) {
246            # Yes, then it's our result.
247            $retVal = $nameThing;
248        } else {
249            # No, so we have to search.
250            for my $superGroup (keys %groupHash) {
251                # Get this super-group's item list.
252                my $list = $groupHash{$superGroup}->{contents};
253                # Search it.
254                if (grep { $_->[0] eq $nameThing } @{$list}) {
255                    $retVal = $superGroup;
256                }
257            }
258            # Make sure we found something.
259            if (! $retVal) {
260                Confess("No super-group found for \"$groupName\".");
261            }
262        }
263        # Return the result.
264        return $retVal;
265    }
266    
267  =head3 MaxSegment  =head3 MaxSegment
268    
269      my $length = $sprout->MaxSegment();      my $length = $sprout->MaxSegment();
# Line 350  Line 467 
467      return $retVal;      return $retVal;
468  }  }
469    
470  =head3 GeneMenu  =head3 GenomeMenu
471    
472      my $selectHtml = $sprout->GeneMenu(\%attributes, $filterString, \@params, $selected);      my $html = $sprout->GenomeMenu(%options);
473    
474  Return an HTML select menu of genomes. Each genome will be an option in the menu,  Generate a genome selection control with the specified name and options.
475  and will be displayed by name with the ID and a contig count attached. The selection  This control is almost but not quite the same as the genome control in the
476  value will be the genome ID. The genomes will be sorted by genus/species name.  B<SearchHelper> class. Eventually, the two will be combined.
477    
478  =over 4  =over 4
479    
480  =item attributes  =item options
481    
482  Reference to a hash mapping attributes to values for the SELECT tag generated.  Optional parameters for the control (see below).
483    
484  =item filterString  =item RETURN
485    
486  A filter string for use in selecting the genomes. The filter string must conform  Returns the HTML for a genome selection control on a form (sometimes called a popup menu).
 to the rules for the C<< ERDB->Get >> method.  
487    
488  =item params  =back
489    
490  Reference to a list of values to be substituted in for the parameter marks in  The valid options are as follows.
 the filter string.  
491    
492  =item selected (optional)  =over 4
493    
494  ID of the genome to be initially selected.  =item name
495    
496  =item fast (optional)  Name to give this control for use in passing it to the form. The default is C<myGenomeControl>.
497    Terrible things will happen if you have two controls with the same name on the same page.
498    
499  If specified and TRUE, the contig counts will be omitted to improve performance.  =item filter
500    
501  =item RETURN  If specified, a filter for the list of genomes to display. The filter should be in the form of a
502    list reference. The first element of the list should be the filter string, and the remaining elements
503    the filter parameters.
504    
505  Returns an HTML select menu with the specified genomes as selectable options.  =item multiSelect
506    
507    If TRUE, then the user can select multiple genomes. If FALSE, the user can only select one genome.
508    
509    =item size
510    
511    Number of rows to display in the control. The default is C<10>
512    
513    =item id
514    
515    ID to give this control. The default is the value of the C<name> option. Nothing will work correctly
516    unless this ID is unique.
517    
518    =item selected
519    
520    A comma-delimited list of selected genomes, or a reference to a list of selected genomes. The
521    default is none.
522    
523    =item class
524    
525    If specified, a style class to assign to the genome control.
526    
527  =back  =back
528    
529  =cut  =cut
530    
531  sub GeneMenu {  sub GenomeMenu {
532      # Get the parameters.      # Get the parameters.
533      my ($self, $attributes, $filterString, $params, $selected, $fast) = @_;      my ($self, %options) = @_;
534      my $slowMode = ! $fast;      # Get the control's name and ID.
535      # Default to nothing selected. This prevents an execution warning if "$selected"      my $menuName = $options{name} || $options{id} || 'myGenomeControl';
536      # is undefined.      my $menuID = $options{id} || $menuName;
537      $selected = "" unless defined $selected;      Trace("Genome menu name = $menuName with ID $menuID.") if T(3);
538      Trace("Gene Menu called with slow mode \"$slowMode\" and selection \"$selected\".") if T(3);      # Compute the IDs for the status display.
539      # Start the menu.      my $divID = "${menuID}_status";
540      my $retVal = "<select " .      my $urlID = "${menuID}_url";
541          join(" ", map { "$_=\"$attributes->{$_}\"" } keys %{$attributes}) .      # Compute the code to show selected genomes in the status area.
542          ">\n";      my $showSelect = "showSelected('$menuID', '$divID', '$urlID', 1000)";
543      # Get the genomes.      # Check for single-select or multi-select.
544      my @genomes = $self->GetAll(['Genome'], $filterString, $params, ['Genome(id)',      my $multiSelect = $options{multiSelect} || 0;
545                                                                       'Genome(genus)',      # Get the style data.
546                                                                       'Genome(species)',      my $class = $options{class} || '';
547                                                                       'Genome(unique-characterization)']);      # Get the list of pre-selected items.
548      # Sort them by name.      my $selections = $options{selected} || [];
549      my @sorted = sort { lc("$a->[1] $a->[2]") cmp lc("$b->[1] $b->[2]") } @genomes;      if (ref $selections ne 'ARRAY') {
550      # Loop through the genomes, creating the option tags.          $selections = [ split /\s*,\s*/, $selections ];
551      for my $genomeData (@sorted) {      }
552          # Get the data for this genome.      my %selected = map { $_ => 1 } @{$selections};
553          my ($genomeID, $genus, $species, $strain) = @{$genomeData};      # Extract the filter information. The default is no filtering. It can be passed as a tab-delimited
554          # Get the contig count.      # string or a list reference.
555          my $contigInfo = "";      my $filterParms = $options{filter} || "";
556          if ($slowMode) {      if (! ref $filterParms) {
557              my $count = $self->ContigCount($genomeID);          $filterParms = [split /\t|\\t/, $filterParms];
558              my $counting = ($count == 1 ? "contig" : "contigs");      }
559              $contigInfo = "[$count $counting]";      my $filterString = shift @{$filterParms};
560          }      # Get a list of all the genomes in group order. In fact, we only need them ordered
561          # Find out if we're selected.      # by name (genus,species,strain), but putting primary-group in front enables us to
562          my $selectOption = ($selected eq $genomeID ? " selected" : "");      # take advantage of an existing index.
563          # Build the option tag.      my @genomeList = $self->GetAll(['Genome'], "$filterString ORDER BY Genome(primary-group), Genome(genus), Genome(species), Genome(unique-characterization)",
564          $retVal .= "<option value=\"$genomeID\"$selectOption>$genus $species $strain ($genomeID)$contigInfo</option>\n";                                     $filterParms,
565                                       [qw(Genome(primary-group) Genome(id) Genome(genus) Genome(species) Genome(unique-characterization) Genome(taxonomy) Genome(contigs))]);
566        # Create a hash to organize the genomes by group. Each group will contain a list of
567        # 2-tuples, the first element being the genome ID and the second being the genome
568        # name.
569        my %gHash = ();
570        for my $genome (@genomeList) {
571            # Get the genome data.
572            my ($group, $genomeID, $genus, $species, $strain, $taxonomy, $contigs) = @{$genome};
573            # Compute its name. This is the genus, species, strain (if any), and the contig count.
574            my $name = "$genus $species ";
575            $name .= "$strain " if $strain;
576            my $contigCount = ($contigs == 1 ? "" : ", $contigs contigs");
577            # Now we get the domain. The domain tells us the display style of the organism.
578            my ($domain) = split /\s*;\s*/, $taxonomy, 2;
579            # Now compute the display group. This is normally the primary group, but if the
580            # organism is supporting, we blank it out.
581            my $displayGroup = ($group eq $FIG_Config::otherGroup ? "" : $group);
582            # Push the genome into the group's list. Note that we use the real group
583            # name for the hash key here, not the display group name.
584            push @{$gHash{$group}}, [$genomeID, $name, $contigCount, $domain];
585        }
586        # We are almost ready to unroll the menu out of the group hash. The final step is to separate
587        # the supporting genomes by domain. First, we extract the NMPDR groups and sort them. They
588        # are sorted by the first capitalized word. Groups with "other" are sorted after groups
589        # that aren't "other". At some point, we will want to make this less complicated.
590        my %sortGroups = map { $_ =~ /(other)?(.*)([A-Z].+)/; "$3$1$2" => $_ }
591                             grep { $_ ne $FIG_Config::otherGroup } keys %gHash;
592        my @groups = map { $sortGroups{$_} } sort keys %sortGroups;
593        # Remember the number of NMPDR groups.
594        my $nmpdrGroupCount = scalar @groups;
595        # Loop through the supporting genomes, classifying them by domain. We'll also keep a list
596        # of the domains found.
597        my @otherGenomes = @{$gHash{$FIG_Config::otherGroup}};
598        my @domains = ();
599        for my $genomeData (@otherGenomes) {
600            my ($genomeID, $name, $contigCount, $domain) = @{$genomeData};
601            if (exists $gHash{$domain}) {
602                push @{$gHash{$domain}}, $genomeData;
603            } else {
604                $gHash{$domain} = [$genomeData];
605                push @domains, $domain;
606            }
607        }
608        # Add the domain groups at the end of the main group list. The main group list will now
609        # contain all the categories we need to display the genomes.
610        push @groups, sort @domains;
611        # Delete the supporting group.
612        delete $gHash{$FIG_Config::otherGroup};
613        # Now it gets complicated. We need a way to mark all the NMPDR genomes. We take advantage
614        # of the fact they come first in the list. We'll accumulate a count of the NMPDR genomes
615        # and use that to make the selections.
616        my $nmpdrCount = 0;
617        # Create the type counters.
618        my $groupCount = 1;
619        # Get the number of rows to display.
620        my $rows = $options{size} || 10;
621        # If we're multi-row, create an onChange event.
622        my $onChangeTag = ( $rows > 1 ? " onChange=\"$showSelect;\" onFocus=\"$showSelect;\"" : "" );
623        # Set up the multiple-select flag.
624        my $multipleTag = ($multiSelect ? " multiple" : "" );
625        # Set up the style class.
626        my $classTag = ($class ? " class=\"$class\"" : "" );
627        # Create the SELECT tag and stuff it into the output array.
628        my @lines = ("<SELECT name=\"$menuName\" id=\"$menuID\" $onChangeTag$multipleTag$classTag size=\"$rows\">");
629        # Loop through the groups.
630        for my $group (@groups) {
631            # Get the genomes in the group.
632            for my $genome (@{$gHash{$group}}) {
633                # If this is an NMPDR organism, we add an extra style and count it.
634                my $nmpdrStyle = "";
635                if ($nmpdrGroupCount > 0) {
636                    $nmpdrCount++;
637                    $nmpdrStyle = " Core";
638                }
639                # Get the organism ID, name, contig count, and domain.
640                my ($genomeID, $name, $contigCount, $domain) = @{$genome};
641                # See if we're pre-selected.
642                my $selectTag = ($selected{$genomeID} ? " SELECTED" : "");
643                # Compute the display name.
644                my $nameString = "$name ($genomeID$contigCount)";
645                # Generate the option tag.
646                my $optionTag = "<OPTION class=\"$domain$nmpdrStyle\" title=\"$group\" value=\"$genomeID\"$selectTag>$nameString</OPTION>";
647                push @lines, "    $optionTag";
648            }
649            # Record this group in the nmpdrGroup count. When that gets to 0, we've finished the NMPDR
650            # groups.
651            $nmpdrGroupCount--;
652      }      }
653      # Close the SELECT tag.      # Close the SELECT tag.
654      $retVal .= "</select>\n";      push @lines, "</SELECT>";
655        if ($rows > 1) {
656            # We're in a non-compact mode, so we need to add some selection helpers. First is
657            # the search box. This allows the user to type text and change which genomes are
658            # displayed. For multiple-select mode, we include a button that selects the displayed
659            # genes. For single-select mode, we use a plain label instead.
660            my $searchThingName = "${menuID}_SearchThing";
661            my $searchThingLabel = ($multiSelect ? "<INPUT type=\"button\" name=\"MacroSearch\" class=\"button\" value=\"Select genomes containing\" onClick=\"selectShowing('$menuID', '$searchThingName'); $showSelect;\" />"
662                                                 : "Show genomes containing");
663            push @lines, "<br />$searchThingLabel&nbsp;" .
664                         "<INPUT type=\"text\" id=\"$searchThingName\" name=\"$searchThingName\" size=\"30\" onKeyup=\"showTyped('$menuID', '$searchThingName');\" />" .
665                         Hint("GenomeControl", "Type here to filter the genomes displayed.") . "<br />";
666            # For multi-select mode, we also have buttons to set and clear selections.
667            if ($multiSelect) {
668                push @lines, "<INPUT type=\"button\" name=\"ClearAll\" class=\"bigButton\"  value=\"Clear All\" onClick=\"clearAll('$menuID'); $showSelect\" />";
669                push @lines, "<INPUT type=\"button\" name=\"SelectAll\" class=\"bigButton\" value=\"Select All\" onClick=\"selectAll('$menuID'); $showSelect\" />";
670                push @lines, "<INPUT type=\"button\" name=\"NMPDROnly\" class=\"bigButton\"  value=\"Select NMPDR\" onClick=\"selectSome('$menuID', $nmpdrCount, true); $showSelect;\" />";
671            }
672            # Add a hidden field we can use to generate organism page hyperlinks.
673            push @lines, "<INPUT type=\"hidden\" id=\"$urlID\" value=\"$FIG_Config::cgi_url/wiki/rest.cgi/NmpdrPlugin/SeedViewer?page=Organism;organism=\" />";
674            # Add the status display. This tells the user what's selected no matter where the list is scrolled.
675            push @lines, "<DIV id=\"$divID\" class=\"Panel\"></DIV>";
676        }
677        # Assemble all the lines into a string.
678        my $retVal = join("\n", @lines, "");
679      # Return the result.      # Return the result.
680      return $retVal;      return $retVal;
681  }  }
682    
683    
684    =head3 Stem
685    
686        my $stem = $sprout->Stem($word);
687    
688    Return the stem of the specified word, or C<undef> if the word is not
689    stemmable. Note that even if the word is stemmable, the stem may be
690    the same as the original word.
691    
692    =over 4
693    
694    =item word
695    
696    Word to convert into a stem.
697    
698    =item RETURN
699    
700    Returns a stem of the word (which may be the word itself), or C<undef> if
701    the word is not stemmable.
702    
703    =back
704    
705    =cut
706    
707    sub Stem {
708        # Get the parameters.
709        my ($self, $word) = @_;
710        # Declare the return variable.
711        my $retVal;
712        # See if it's stemmable.
713        if ($word =~ /^[A-Za-z]+$/) {
714            # Compute the stem. Currently, it's just the word.
715            my $stem = $word;
716            # Check to see if it's long enough.
717            if (length $stem >= 3) {
718                # Yes, keep it.
719                $retVal = $stem;
720            } else {
721                # No, use the original word.
722                $retVal = $word;
723            }
724        }
725        # Return the result.
726        return $retVal;
727    }
728    
729    
730  =head3 Build  =head3 Build
731    
732      $sprout->Build();      $sprout->Build();
# Line 568  Line 864 
864  =item RETURN  =item RETURN
865    
866  Returns a list of the feature's contig segments. The locations are returned as a list in a list  Returns a list of the feature's contig segments. The locations are returned as a list in a list
867  context and as a comma-delimited string in a scalar context.  context and as a comma-delimited string in a scalar context. An empty list means the feature
868    wasn't found.
869    
870  =back  =back
871    
# Line 577  Line 874 
874  sub FeatureLocation {  sub FeatureLocation {
875      # Get the parameters.      # Get the parameters.
876      my ($self, $featureID) = @_;      my ($self, $featureID) = @_;
877        # Declare the return variable.
878        my @retVal = ();
879      # Get the feature record.      # Get the feature record.
880      my $object = $self->GetEntity('Feature', $featureID);      my $object = $self->GetEntity('Feature', $featureID);
881      Confess("Feature $featureID not found.") if ! defined($object);      # Only proceed if we found it.
882        if (defined $object) {
883      # Get the location string.      # Get the location string.
884      my $locString = $object->PrimaryValue('Feature(location-string)');      my $locString = $object->PrimaryValue('Feature(location-string)');
885      # Create the return list.      # Create the return list.
886      my @retVal = split /\s*,\s*/, $locString;          @retVal = split /\s*,\s*/, $locString;
887        }
888      # Return the list in the format indicated by the context.      # Return the list in the format indicated by the context.
889      return (wantarray ? @retVal : join(',', @retVal));      return (wantarray ? @retVal : join(',', @retVal));
890  }  }
# Line 1658  Line 1959 
1959      if ($featureID =~ /^fig\|(\d+\.\d+)/) {      if ($featureID =~ /^fig\|(\d+\.\d+)/) {
1960          $retVal = $1;          $retVal = $1;
1961      } else {      } else {
1962            # Find the feature by alias.
1963            my ($realFeatureID) = $self->FeaturesByAlias($featureID);
1964            if ($realFeatureID && $realFeatureID =~ /^fig\|(\d+\.\d+)/) {
1965                $retVal = $1;
1966            } else {
1967                # Use the external table.
1968                my ($org) = $self->GetFlat(['ExternalAliasOrg'], "ExternalAliasOrg(id) = ?",
1969                                           [$featureID], "ExternalAliasOrg(org)");
1970                if ($org) {
1971                    $retVal = $org;
1972                } else {
1973          Confess("Invalid feature ID $featureID.");          Confess("Invalid feature ID $featureID.");
1974      }      }
1975            }
1976        }
1977      # Return the value found.      # Return the value found.
1978      return $retVal;      return $retVal;
1979  }  }
# Line 2498  Line 2812 
2812      return @retVal;      return @retVal;
2813  }  }
2814    
 =head3 GetProperties  
   
     my @list = $sprout->GetProperties($fid, $key, $value, $url);  
   
 Return a list of the properties with the specified characteristics.  
   
 Properties are the Sprout analog of the FIG attributes. The call is  
 passed directly to the CustomAttributes or RemoteCustomAttributes object  
 contained in this object.  
   
 This method returns a series of tuples that match the specified criteria. Each tuple  
 will contain an object ID, a key, and one or more values. The parameters to this  
 method therefore correspond structurally to the values expected in each tuple. In  
 addition, you can ask for a generic search by suffixing a percent sign (C<%>) to any  
 of the parameters. So, for example,  
   
     my @attributeList = $sprout->GetProperties('fig|100226.1.peg.1004', 'structure%', 1, 2);  
   
 would return something like  
   
     ['fig}100226.1.peg.1004', 'structure', 1, 2]  
     ['fig}100226.1.peg.1004', 'structure1', 1, 2]  
     ['fig}100226.1.peg.1004', 'structure2', 1, 2]  
     ['fig}100226.1.peg.1004', 'structureA', 1, 2]  
   
 Use of C<undef> in any position acts as a wild card (all values). You can also specify  
 a list reference in the ID column. Thus,  
   
     my @attributeList = $sprout->GetProperties(['100226.1', 'fig|100226.1.%'], 'PUBMED');  
   
 would get the PUBMED attribute data for Streptomyces coelicolor A3(2) and all its  
 features.  
   
 In addition to values in multiple sections, a single attribute key can have multiple  
 values, so even  
   
     my @attributeList = $sprout->GetProperties($peg, 'virulent');  
   
 which has no wildcard in the key or the object ID, may return multiple tuples.  
   
 =over 4  
   
 =item objectID  
   
 ID of object whose attributes are desired. If the attributes are desired for multiple  
 objects, this parameter can be specified as a list reference. If the attributes are  
 desired for all objects, specify C<undef> or an empty string. Finally, you can specify  
 attributes for a range of object IDs by putting a percent sign (C<%>) at the end.  
   
 =item key  
   
 Attribute key name. A value of C<undef> or an empty string will match all  
 attribute keys. If the values are desired for multiple keys, this parameter can be  
 specified as a list reference. Finally, you can specify attributes for a range of  
 keys by putting a percent sign (C<%>) at the end.  
   
 =item values  
   
 List of the desired attribute values, section by section. If C<undef>  
 or an empty string is specified, all values in that section will match. A  
 generic match can be requested by placing a percent sign (C<%>) at the end.  
 In that case, all values that match up to and not including the percent sign  
 will match. You may also specify a regular expression enclosed  
 in slashes. All values that match the regular expression will be returned. For  
 performance reasons, only values have this extra capability.  
   
 =item RETURN  
   
 Returns a list of tuples. The first element in the tuple is an object ID, the  
 second is an attribute key, and the remaining elements are the sections of  
 the attribute value. All of the tuples will match the criteria set forth in  
 the parameter list.  
   
 =back  
   
 =cut  
   
 sub GetProperties {  
     # Get the parameters.  
     my ($self, @parms) = @_;  
     # Declare the return variable.  
     my @retVal = $self->{_ca}->GetAttributes(@parms);  
     # Return the result.  
     return @retVal;  
 }  
   
2815  =head3 FeatureProperties  =head3 FeatureProperties
2816    
2817      my @properties = $sprout->FeatureProperties($featureID);      my @properties = $sprout->FeatureProperties($featureID);
# Line 2885  Line 3113 
3113      # Get the parameters.      # Get the parameters.
3114      my ($self, $featureID) = @_;      my ($self, $featureID) = @_;
3115      # Get the list of names.      # Get the list of names.
3116      my @retVal = $self->GetFlat(['HasRoleInSubsystem'], "HasRoleInSubsystem(from-link) = ?",      ##HACK: we do a join to the Subsystem table because we have missing subsystems in
3117        ## the Sprout database!
3118        my @retVal = $self->GetFlat(['HasRoleInSubsystem', 'Subsystem'], "HasRoleInSubsystem(from-link) = ?",
3119                                  [$featureID], 'HasRoleInSubsystem(to-link)');                                  [$featureID], 'HasRoleInSubsystem(to-link)');
3120      # Return the result, sorted.      # Return the result, sorted.
3121      return sort @retVal;      return sort @retVal;
# Line 3039  Line 3269 
3269          my ($taxonomy) = $self->GetFlat(['IsLocatedIn', 'HasContig', 'Genome'], "IsLocatedIn(from-link) = ?",          my ($taxonomy) = $self->GetFlat(['IsLocatedIn', 'HasContig', 'Genome'], "IsLocatedIn(from-link) = ?",
3270                                          [$fid], 'Genome(taxonomy)');                                          [$fid], 'Genome(taxonomy)');
3271          # Add this feature to the hash buffer.          # Add this feature to the hash buffer.
3272          Tracer::AddToListMap(\%hashBuffer, $taxonomy, $fid);          push @{$hashBuffer{$taxonomy}}, $fid;
3273      }      }
3274      # Sort the keys and get the elements.      # Sort the keys and get the elements.
3275      my @retVal = ();      my @retVal = ();
# Line 3618  Line 3848 
3848      my ($self, %groupHash) = @_;      my ($self, %groupHash) = @_;
3849      # Create the result hash.      # Create the result hash.
3850      my %retVal = ();      my %retVal = ();
     # Get the super-group table.  
     my %superTable = $self->CheckGroupFile();  
3851      # Copy over the genomes.      # Copy over the genomes.
3852      for my $groupID (keys %groupHash) {      for my $groupID (keys %groupHash) {
3853          # Get the super-group name.          # Get the super-group name.
3854          my $realGroupID;          my $realGroupID = $self->SuperGroup($groupID);
3855          if ($groupID =~ /([A-Z]\w+)/) {          # Append this group's genomes into the result hash
3856              if (! defined($superTable{$1})) {          # using the super-group name.
                 Confess("Super-group name not found for group $groupID.");  
             } else {  
                 $realGroupID = $1;  
             }  
         } else {  
             Confess("Invalid group name $groupID.");  
         }  
         # Append this group's genomes into the result hash.  
3857          push @{$retVal{$realGroupID}}, @{$groupHash{$groupID}};          push @{$retVal{$realGroupID}}, @{$groupHash{$groupID}};
3858      }      }
3859      # Return the result hash.      # Return the result hash.
# Line 3664  Line 3884 
3884  sub GroupPageName {  sub GroupPageName {
3885      # Get the parameters.      # Get the parameters.
3886      my ($self, $group) = @_;      my ($self, $group) = @_;
     # Declare the return variable.  
     my $retVal;  
3887      # Check for the group file data.      # Check for the group file data.
3888      my %superTable = $self->CheckGroupFile();      my %superTable = $self->CheckGroupFile();
3889      # Compute the real group name.      # Compute the real group name.
3890      if ($group =~ /([A-Z]\w+)/) {      my $realGroup = $self->SuperGroup($group);
3891          my $realGroup = $1;      # Get the associated page name.
3892          if (! defined($superTable{$1})) {      my $retVal = "../content/$superTable{$realGroup}->{page}";
             Confess("No super-group found for \"$group\".");  
         } else {  
             $retVal = "../content/$superTable{$1}->{page}";  
         }  
     } else {  
         Confess("\"group\" is not a valid group name.");  
     }  
3893      # Return the result.      # Return the result.
3894      return $retVal;      return $retVal;
3895  }  }
# Line 3800  Line 4011 
4011      # Get the parameters.      # Get the parameters.
4012      my ($self, $searchExpression) = @_;      my ($self, $searchExpression) = @_;
4013      # Perform the standard cleanup.      # Perform the standard cleanup.
4014      my $retVal = $self->ERDB::CleanKeywords($searchExpression);      my $words = $self->ERDB::CleanKeywords($searchExpression);
4015      # Fix the periods in EC and TC numbers.      # Fix the periods in EC and TC numbers.
4016      $retVal =~ s/(\d+|\-)\.(\d+|-)\.(\d+|-)\.(\d+|-)/$1_$2_$3_$4/g;      $words =~ s/(\d+|\-)\.(\d+|-)\.(\d+|-)\.(\d+|-)/$1_$2_$3_$4/g;
4017      # Fix non-trailing periods.      # Fix non-trailing periods.
4018      $retVal =~ s/\.(\w)/_$1/g;      $words =~ s/\.(\w)/_$1/g;
4019      # Fix non-leading minus signs.      # Fix non-leading minus signs.
4020      $retVal =~ s/(\w)[\-]/$1_/g;      $words =~ s/(\w)[\-]/$1_/g;
4021      # Fix the vertical bars and colons      # Fix the vertical bars and colons
4022      $retVal =~ s/(\w)[|:](\w)/$1'$2/g;      $words =~ s/(\w)[|:](\w)/$1'$2/g;
4023        # Now split up the list so that each keyword is in its own string. We keep the delimiters
4024        # because they may contain boolean expression data.
4025        my @words = split /([^A-Za-z'0-9_]+)/, $words;
4026        # We'll convert the stemmable words into stems and re-assemble the result.
4027        my $retVal = "";
4028        for my $word (@words) {
4029            my $stem = $self->Stem($word);
4030            if (defined $stem) {
4031                $retVal .= $stem;
4032            } else {
4033                $retVal .= $word;
4034            }
4035        }
4036        Trace("Cleaned keyword list for \"$searchExpression\" is \"$retVal\".") if T(3);
4037      # Return the result.      # Return the result.
4038      return $retVal;      return $retVal;
4039  }  }
# Line 3938  Line 4163 
4163  }  }
4164    
4165    
4166    =head3 Hint
4167    
4168        my $htmlText = SearchHelper::Hint($wikiPage, $hintText);
4169    
4170    Return the HTML for a small question mark that displays the specified hint text when it is clicked.
4171    This HTML can be put in forms to provide a useful hinting mechanism.
4172    
4173    =over 4
4174    
4175    =item wikiPage
4176    
4177    Name of the wiki page to be popped up when the hint mark is clicked.
4178    
4179    =item hintText
4180    
4181    Text to display for the hint. It is raw html, but may not contain any double quotes.
4182    
4183    =item RETURN
4184    
4185    Returns the html for the hint facility. The resulting html shows a small button-like thing that
4186    uses the standard FIG popup technology.
4187    
4188    =back
4189    
4190    =cut
4191    
4192    sub Hint {
4193        # Get the parameters.
4194        my ($wikiPage, $hintText) = @_;
4195        # Escape the single quotes in the hint text.
4196        my $quotedText = $hintText;
4197        $quotedText =~ s/'/\\'/g;
4198        # Convert the wiki page name to a URL.
4199        my $wikiURL = join("", map { ucfirst $_ } split /\s+/, $wikiPage);
4200        $wikiURL = "$FIG_Config::cgi_url/wiki/view.cgi/FIG/$wikiURL";
4201        # Compute the mouseover script.
4202        my $mouseOver = "doTooltip(this, '$quotedText')";
4203        # Create the html.
4204        my $retVal = "&nbsp;<a href=\"$wikiURL\"><img src=\"$FIG_Config::cgi_url/Html/button-h.png\" class=\"helpicon\" onmouseover=\"$mouseOver\"/></a>";
4205        # Return it.
4206        return $retVal;
4207    }
4208    
4209  1;  1;

Legend:
Removed from v.1.104  
changed lines
  Added in v.1.116

MCS Webmaster
ViewVC Help
Powered by ViewVC 1.0.3