[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.102, Thu Dec 6 14:56:23 2007 UTC revision 1.114, Wed Sep 3 20:59:57 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
88  I<fig> with a password of I<admin>. The database load files are in the directory  I<fig> with a password of I<admin>. The database load files are in the directory
89  F</usr/fig/SproutData>.  F</usr/fig/SproutData>.
90    
91      my $sprout = Sprout->new('Sprout', { userData =>; 'fig/admin', dataDir => '/usr/fig/SproutData' });      my $sprout = Sprout->new('Sprout', { userData => 'fig/admin', dataDir => '/usr/fig/SproutData' });
92    
93  =cut  =cut
94    
# Line 108  Line 112 
112                         port         => $FIG_Config::dbport,                         port         => $FIG_Config::dbport,
113                                                          # database connection port                                                          # database connection port
114                         sock         => $FIG_Config::dbsock,                         sock         => $FIG_Config::dbsock,
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 143  Line 148 
148          my $user = ($FIG_Config::arch eq 'win' ? 'self' : scalar(getpwent()));          my $user = ($FIG_Config::arch eq 'win' ? 'self' : scalar(getpwent()));
149          $retVal->{_ca} = CustomAttributes->new(user => $user);          $retVal->{_ca} = CustomAttributes->new(user => $user);
150      }      }
151        # Insure we have access to the stem module.
152        WikiUse('Lingua::Stem');
153        $retVal->{stemmer} = Lingua::Stem->new();
154        $retVal->{stemmer}->stem_caching({ -level => 2 });
155      # Return it.      # Return it.
156      return $retVal;      return $retVal;
157  }  }
158    
159    =head3 CoreGenomes
160    
161        my @genomes = $sprout->CoreGenomes($scope);
162    
163    Return the IDs of NMPDR genomes in the specified scope.
164    
165    =over 4
166    
167    =item scope
168    
169    Scope of the desired genomes. C<core> covers the original core genomes,
170    C<nmpdr> covers all genomes in NMPDR groups, and C<all> covers all
171    genomes in the system.
172    
173    =item RETURN
174    
175    Returns a list of the IDs for the genomes in the specified scope.
176    
177    =back
178    
179    =cut
180    
181    sub CoreGenomes {
182        # Get the parameters.
183        my ($self, $scope) = @_;
184        # Declare the return variable.
185        my @retVal = ();
186        # If we want all genomes, then this is easy.
187        if ($scope eq 'all') {
188            @retVal = $self->Genomes();
189        } else {
190            # Here we're dealing with groups. Get the hash of all the
191            # genome groups.
192            my %groups = $self->GetGroups();
193            # Loop through the groups, keeping the ones that we want.
194            for my $group (keys %groups) {
195                # Decide if we want to keep this group.
196                my $keepGroup = 0;
197                if ($scope eq 'nmpdr') {
198                    # NMPDR mode: keep all groups.
199                    $keepGroup = 1;
200                } elsif ($scope eq 'core') {
201                    # CORE mode. Only keep real core groups.
202                    if (grep { $group =~ /$_/ } @{$FIG_Config::realCoreGroups}) {
203                        $keepGroup = 1;
204                    }
205                }
206                # Add this group if we're keeping it.
207                if ($keepGroup) {
208                    push @retVal, @{$groups{$group}};
209                }
210            }
211        }
212        # Return the result.
213        return @retVal;
214    }
215    
216    =head3 SuperGroup
217    
218        my $superGroup = $sprout->SuperGroup($groupName);
219    
220    Return the name of the super-group containing the specified NMPDR genome
221    group. If no appropriate super-group can be found, an error will be
222    thrown.
223    
224    =over 4
225    
226    =item groupName
227    
228    Name of the group whose super-group is desired.
229    
230    =item RETURN
231    
232    Returns the name of the super-group containing the incoming group.
233    
234    =back
235    
236    =cut
237    
238    sub SuperGroup {
239        # Get the parameters.
240        my ($self, $groupName) = @_;
241        # Declare the return variable.
242        my $retVal;
243        # Get the group hash.
244        my %groupHash = $self->CheckGroupFile();
245        # Find the super-group genus.
246        $groupName =~ /([A-Z]\w+)/;
247        my $nameThing = $1;
248        # See if it's directly in the group hash.
249        if (exists $groupHash{$nameThing}) {
250            # Yes, then it's our result.
251            $retVal = $nameThing;
252        } else {
253            # No, so we have to search.
254            for my $superGroup (keys %groupHash) {
255                # Get this super-group's item list.
256                my $list = $groupHash{$superGroup}->{contents};
257                # Search it.
258                if (grep { $_->[0] eq $nameThing } @{$list}) {
259                    $retVal = $superGroup;
260                }
261            }
262            # Make sure we found something.
263            if (! $retVal) {
264                Confess("No super-group found for \"$groupName\".");
265            }
266        }
267        # Return the result.
268        return $retVal;
269    }
270    
271  =head3 MaxSegment  =head3 MaxSegment
272    
273      my $length = $sprout->MaxSegment();      my $length = $sprout->MaxSegment();
# Line 267  Line 388 
388              Trace("No load file found for $tableName in $dataDir.") if T(0);              Trace("No load file found for $tableName in $dataDir.") if T(0);
389          } else {          } else {
390              # Attempt to load this table.              # Attempt to load this table.
391              my $result = $self->LoadTable($fileName, $tableName, $truncateFlag);              my $result = $self->LoadTable($fileName, $tableName, truncate => $truncateFlag);
392              # Accumulate the resulting statistics.              # Accumulate the resulting statistics.
393              $retVal->Accumulate($result);              $retVal->Accumulate($result);
394          }          }
# Line 350  Line 471 
471      return $retVal;      return $retVal;
472  }  }
473    
474  =head3 GeneMenu  =head3 GenomeMenu
475    
476      my $selectHtml = $sprout->GeneMenu(\%attributes, $filterString, \@params, $selected);      my $html = $sprout->GenomeMenu(%options);
477    
478  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.
479  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
480  value will be the genome ID. The genomes will be sorted by genus/species name.  B<SearchHelper> class. Eventually, the two will be combined.
481    
482  =over 4  =over 4
483    
484  =item attributes  =item options
485    
486    Optional parameters for the control (see below).
487    
488    =item RETURN
489    
490  Reference to a hash mapping attributes to values for the SELECT tag generated.  Returns the HTML for a genome selection control on a form (sometimes called a popup menu).
491    
492  =item filterString  =back
493    
494  A filter string for use in selecting the genomes. The filter string must conform  The valid options are as follows.
 to the rules for the C<< ERDB->Get >> method.  
495    
496  =item params  =over 4
497    
498  Reference to a list of values to be substituted in for the parameter marks in  =item name
 the filter string.  
499    
500  =item selected (optional)  Name to give this control for use in passing it to the form. The default is C<myGenomeControl>.
501    Terrible things will happen if you have two controls with the same name on the same page.
502    
503  ID of the genome to be initially selected.  =item filter
504    
505  =item fast (optional)  If specified, a filter for the list of genomes to display. The filter should be in the form of a
506    list reference. The first element of the list should be the filter string, and the remaining elements
507    the filter parameters.
508    
509  If specified and TRUE, the contig counts will be omitted to improve performance.  =item multiSelect
510    
511  =item RETURN  If TRUE, then the user can select multiple genomes. If FALSE, the user can only select one genome.
512    
513  Returns an HTML select menu with the specified genomes as selectable options.  =item size
514    
515    Number of rows to display in the control. The default is C<10>
516    
517    =item id
518    
519    ID to give this control. The default is the value of the C<name> option. Nothing will work correctly
520    unless this ID is unique.
521    
522    =item selected
523    
524    A comma-delimited list of selected genomes, or a reference to a list of selected genomes. The
525    default is none.
526    
527    =item class
528    
529    If specified, a style class to assign to the genome control.
530    
531  =back  =back
532    
533  =cut  =cut
534    
535  sub GeneMenu {  sub GenomeMenu {
536      # Get the parameters.      # Get the parameters.
537      my ($self, $attributes, $filterString, $params, $selected, $fast) = @_;      my ($self, %options) = @_;
538      my $slowMode = ! $fast;      # Get the control's name and ID.
539      # Default to nothing selected. This prevents an execution warning if "$selected"      my $menuName = $options{name} || $options{id} || 'myGenomeControl';
540      # is undefined.      my $menuID = $options{id} || $menuName;
541      $selected = "" unless defined $selected;      Trace("Genome menu name = $menuName with ID $menuID.") if T(3);
542      Trace("Gene Menu called with slow mode \"$slowMode\" and selection \"$selected\".") if T(3);      # Compute the IDs for the status display.
543      # Start the menu.      my $divID = "${menuID}_status";
544      my $retVal = "<select " .      my $urlID = "${menuID}_url";
545          join(" ", map { "$_=\"$attributes->{$_}\"" } keys %{$attributes}) .      # Compute the code to show selected genomes in the status area.
546          ">\n";      my $showSelect = "showSelected('$menuID', '$divID', '$urlID', 1000)";
547      # Get the genomes.      # Check for single-select or multi-select.
548      my @genomes = $self->GetAll(['Genome'], $filterString, $params, ['Genome(id)',      my $multiSelect = $options{multiSelect} || 0;
549                                                                       'Genome(genus)',      # Get the style data.
550                                                                       'Genome(species)',      my $class = $options{class} || '';
551                                                                       'Genome(unique-characterization)']);      # Get the list of pre-selected items.
552      # Sort them by name.      my $selections = $options{selected} || [];
553      my @sorted = sort { lc("$a->[1] $a->[2]") cmp lc("$b->[1] $b->[2]") } @genomes;      if (ref $selections ne 'ARRAY') {
554      # Loop through the genomes, creating the option tags.          $selections = [ split /\s*,\s*/, $selections ];
555      for my $genomeData (@sorted) {      }
556          # Get the data for this genome.      my %selected = map { $_ => 1 } @{$selections};
557          my ($genomeID, $genus, $species, $strain) = @{$genomeData};      # Extract the filter information. The default is no filtering. It can be passed as a tab-delimited
558          # Get the contig count.      # string or a list reference.
559          my $contigInfo = "";      my $filterParms = $options{filter} || "";
560          if ($slowMode) {      if (! ref $filterParms) {
561              my $count = $self->ContigCount($genomeID);          $filterParms = [split /\t|\\t/, $filterParms];
562              my $counting = ($count == 1 ? "contig" : "contigs");      }
563              $contigInfo = "[$count $counting]";      my $filterString = shift @{$filterParms};
564          }      # Get a list of all the genomes in group order. In fact, we only need them ordered
565          # Find out if we're selected.      # by name (genus,species,strain), but putting primary-group in front enables us to
566          my $selectOption = ($selected eq $genomeID ? " selected" : "");      # take advantage of an existing index.
567          # Build the option tag.      my @genomeList = $self->GetAll(['Genome'], "$filterString ORDER BY Genome(primary-group), Genome(genus), Genome(species), Genome(unique-characterization)",
568          $retVal .= "<option value=\"$genomeID\"$selectOption>$genus $species $strain ($genomeID)$contigInfo</option>\n";                                     $filterParms,
569                                       [qw(Genome(primary-group) Genome(id) Genome(genus) Genome(species) Genome(unique-characterization) Genome(taxonomy) Genome(contigs))]);
570        # Create a hash to organize the genomes by group. Each group will contain a list of
571        # 2-tuples, the first element being the genome ID and the second being the genome
572        # name.
573        my %gHash = ();
574        for my $genome (@genomeList) {
575            # Get the genome data.
576            my ($group, $genomeID, $genus, $species, $strain, $taxonomy, $contigs) = @{$genome};
577            # Compute its name. This is the genus, species, strain (if any), and the contig count.
578            my $name = "$genus $species ";
579            $name .= "$strain " if $strain;
580            my $contigCount = ($contigs == 1 ? "" : ", $contigs contigs");
581            # Now we get the domain. The domain tells us the display style of the organism.
582            my ($domain) = split /\s*;\s*/, $taxonomy, 2;
583            # Now compute the display group. This is normally the primary group, but if the
584            # organism is supporting, we blank it out.
585            my $displayGroup = ($group eq $FIG_Config::otherGroup ? "" : $group);
586            # Push the genome into the group's list. Note that we use the real group
587            # name for the hash key here, not the display group name.
588            push @{$gHash{$group}}, [$genomeID, $name, $contigCount, $domain];
589        }
590        # We are almost ready to unroll the menu out of the group hash. The final step is to separate
591        # the supporting genomes by domain. First, we extract the NMPDR groups and sort them. They
592        # are sorted by the first capitalized word. Groups with "other" are sorted after groups
593        # that aren't "other". At some point, we will want to make this less complicated.
594        my %sortGroups = map { $_ =~ /(other)?(.*)([A-Z].+)/; "$3$1$2" => $_ }
595                             grep { $_ ne $FIG_Config::otherGroup } keys %gHash;
596        my @groups = map { $sortGroups{$_} } sort keys %sortGroups;
597        # Remember the number of NMPDR groups.
598        my $nmpdrGroupCount = scalar @groups;
599        # Loop through the supporting genomes, classifying them by domain. We'll also keep a list
600        # of the domains found.
601        my @otherGenomes = @{$gHash{$FIG_Config::otherGroup}};
602        my @domains = ();
603        for my $genomeData (@otherGenomes) {
604            my ($genomeID, $name, $contigCount, $domain) = @{$genomeData};
605            if (exists $gHash{$domain}) {
606                push @{$gHash{$domain}}, $genomeData;
607            } else {
608                $gHash{$domain} = [$genomeData];
609                push @domains, $domain;
610            }
611        }
612        # Add the domain groups at the end of the main group list. The main group list will now
613        # contain all the categories we need to display the genomes.
614        push @groups, sort @domains;
615        # Delete the supporting group.
616        delete $gHash{$FIG_Config::otherGroup};
617        # Now it gets complicated. We need a way to mark all the NMPDR genomes. We take advantage
618        # of the fact they come first in the list. We'll accumulate a count of the NMPDR genomes
619        # and use that to make the selections.
620        my $nmpdrCount = 0;
621        # Create the type counters.
622        my $groupCount = 1;
623        # Get the number of rows to display.
624        my $rows = $options{size} || 10;
625        # If we're multi-row, create an onChange event.
626        my $onChangeTag = ( $rows > 1 ? " onChange=\"$showSelect;\" onFocus=\"$showSelect;\"" : "" );
627        # Set up the multiple-select flag.
628        my $multipleTag = ($multiSelect ? " multiple" : "" );
629        # Set up the style class.
630        my $classTag = ($class ? " class=\"$class\"" : "" );
631        # Create the SELECT tag and stuff it into the output array.
632        my @lines = ("<SELECT name=\"$menuName\" id=\"$menuID\" $onChangeTag$multipleTag$classTag size=\"$rows\">");
633        # Loop through the groups.
634        for my $group (@groups) {
635            # Get the genomes in the group.
636            for my $genome (@{$gHash{$group}}) {
637                # If this is an NMPDR organism, we add an extra style and count it.
638                my $nmpdrStyle = "";
639                if ($nmpdrGroupCount > 0) {
640                    $nmpdrCount++;
641                    $nmpdrStyle = " Core";
642                }
643                # Get the organism ID, name, contig count, and domain.
644                my ($genomeID, $name, $contigCount, $domain) = @{$genome};
645                # See if we're pre-selected.
646                my $selectTag = ($selected{$genomeID} ? " SELECTED" : "");
647                # Compute the display name.
648                my $nameString = "$name ($genomeID$contigCount)";
649                # Generate the option tag.
650                my $optionTag = "<OPTION class=\"$domain$nmpdrStyle\" title=\"$group\" value=\"$genomeID\"$selectTag>$nameString</OPTION>";
651                push @lines, "    $optionTag";
652            }
653            # Record this group in the nmpdrGroup count. When that gets to 0, we've finished the NMPDR
654            # groups.
655            $nmpdrGroupCount--;
656      }      }
657      # Close the SELECT tag.      # Close the SELECT tag.
658      $retVal .= "</select>\n";      push @lines, "</SELECT>";
659        if ($rows > 1) {
660            # We're in a non-compact mode, so we need to add some selection helpers. First is
661            # the search box. This allows the user to type text and change which genomes are
662            # displayed. For multiple-select mode, we include a button that selects the displayed
663            # genes. For single-select mode, we use a plain label instead.
664            my $searchThingName = "${menuID}_SearchThing";
665            my $searchThingLabel = ($multiSelect ? "<INPUT type=\"button\" name=\"MacroSearch\" class=\"button\" value=\"Select genomes containing\" onClick=\"selectShowing('$menuID', '$searchThingName'); $showSelect;\" />"
666                                                 : "Show genomes containing");
667            push @lines, "<br />$searchThingLabel&nbsp;" .
668                         "<INPUT type=\"text\" id=\"$searchThingName\" name=\"$searchThingName\" size=\"30\" onKeyup=\"showTyped('$menuID', '$searchThingName');\" />" .
669                         Hint("GenomeControl", "Type here to filter the genomes displayed.") . "<br />";
670            # For multi-select mode, we also have buttons to set and clear selections.
671            if ($multiSelect) {
672                push @lines, "<INPUT type=\"button\" name=\"ClearAll\" class=\"bigButton\"  value=\"Clear All\" onClick=\"clearAll('$menuID'); $showSelect\" />";
673                push @lines, "<INPUT type=\"button\" name=\"SelectAll\" class=\"bigButton\" value=\"Select All\" onClick=\"selectAll('$menuID'); $showSelect\" />";
674                push @lines, "<INPUT type=\"button\" name=\"NMPDROnly\" class=\"bigButton\"  value=\"Select NMPDR\" onClick=\"selectSome('$menuID', $nmpdrCount, true); $showSelect;\" />";
675            }
676            # Add a hidden field we can use to generate organism page hyperlinks.
677            push @lines, "<INPUT type=\"hidden\" id=\"$urlID\" value=\"$FIG_Config::cgi_url/wiki/rest.cgi/NmpdrPlugin/SeedViewer?page=Organism;organism=\" />";
678            # Add the status display. This tells the user what's selected no matter where the list is scrolled.
679            push @lines, "<DIV id=\"$divID\" class=\"Panel\"></DIV>";
680        }
681        # Assemble all the lines into a string.
682        my $retVal = join("\n", @lines, "");
683        # Return the result.
684        return $retVal;
685    }
686    
687    
688    =head3 Stem
689    
690        my $stem = $sprout->Stem($word);
691    
692    Return the stem of the specified word, or C<undef> if the word is not
693    stemmable. Note that even if the word is stemmable, the stem may be
694    the same as the original word.
695    
696    =over 4
697    
698    =item word
699    
700    Word to convert into a stem.
701    
702    =item RETURN
703    
704    Returns a stem of the word (which may be the word itself), or C<undef> if
705    the word is not stemmable.
706    
707    =back
708    
709    =cut
710    
711    sub Stem {
712        # Get the parameters.
713        my ($self, $word) = @_;
714        # Declare the return variable.
715        my $retVal;
716        # See if it's stemmable.
717        if ($word =~ /^[A-Za-z]+$/) {
718            # Compute the stem.
719            my $stemList = $self->{stemmer}->stem($word);
720            my $stem = $stemList->[0];
721            # Check to see if it's long enough.
722            if (length $stem >= 3) {
723                # Yes, keep it.
724                $retVal = $stem;
725            } else {
726                # No, use the original word.
727                $retVal = $word;
728            }
729        }
730      # Return the result.      # Return the result.
731      return $retVal;      return $retVal;
732  }  }
733    
734    
735  =head3 Build  =head3 Build
736    
737      $sprout->Build();      $sprout->Build();
# Line 568  Line 869 
869  =item RETURN  =item RETURN
870    
871  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
872  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
873    wasn't found.
874    
875  =back  =back
876    
# Line 577  Line 879 
879  sub FeatureLocation {  sub FeatureLocation {
880      # Get the parameters.      # Get the parameters.
881      my ($self, $featureID) = @_;      my ($self, $featureID) = @_;
882        # Declare the return variable.
883        my @retVal = ();
884      # Get the feature record.      # Get the feature record.
885      my $object = $self->GetEntity('Feature', $featureID);      my $object = $self->GetEntity('Feature', $featureID);
886      Confess("Feature $featureID not found.") if ! defined($object);      # Only proceed if we found it.
887        if (defined $object) {
888      # Get the location string.      # Get the location string.
889      my $locString = $object->PrimaryValue('Feature(location-string)');      my $locString = $object->PrimaryValue('Feature(location-string)');
890      # Create the return list.      # Create the return list.
891      my @retVal = split /\s*,\s*/, $locString;          @retVal = split /\s*,\s*/, $locString;
892        }
893      # Return the list in the format indicated by the context.      # Return the list in the format indicated by the context.
894      return (wantarray ? @retVal : join(',', @retVal));      return (wantarray ? @retVal : join(',', @retVal));
895  }  }
# Line 1658  Line 1964 
1964      if ($featureID =~ /^fig\|(\d+\.\d+)/) {      if ($featureID =~ /^fig\|(\d+\.\d+)/) {
1965          $retVal = $1;          $retVal = $1;
1966      } else {      } else {
1967            # Find the feature by alias.
1968            my ($realFeatureID) = $self->FeaturesByAlias($featureID);
1969            if ($realFeatureID && $realFeatureID =~ /^fig\|(\d+\.\d+)/) {
1970                $retVal = $1;
1971            } else {
1972                # Use the external table.
1973                my ($org) = $self->GetFlat(['ExternalAliasOrg'], "ExternalAliasOrg(id) = ?",
1974                                           [$featureID], "ExternalAliasOrg(org)");
1975                if ($org) {
1976                    $retVal = $org;
1977                } else {
1978          Confess("Invalid feature ID $featureID.");          Confess("Invalid feature ID $featureID.");
1979      }      }
1980            }
1981        }
1982      # Return the value found.      # Return the value found.
1983      return $retVal;      return $retVal;
1984  }  }
# Line 2498  Line 2817 
2817      return @retVal;      return @retVal;
2818  }  }
2819    
 =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;  
 }  
   
2820  =head3 FeatureProperties  =head3 FeatureProperties
2821    
2822      my @properties = $sprout->FeatureProperties($featureID);      my @properties = $sprout->FeatureProperties($featureID);
# Line 3039  Line 3272 
3272          my ($taxonomy) = $self->GetFlat(['IsLocatedIn', 'HasContig', 'Genome'], "IsLocatedIn(from-link) = ?",          my ($taxonomy) = $self->GetFlat(['IsLocatedIn', 'HasContig', 'Genome'], "IsLocatedIn(from-link) = ?",
3273                                          [$fid], 'Genome(taxonomy)');                                          [$fid], 'Genome(taxonomy)');
3274          # Add this feature to the hash buffer.          # Add this feature to the hash buffer.
3275          Tracer::AddToListMap(\%hashBuffer, $taxonomy, $fid);          push @{$hashBuffer{$taxonomy}}, $fid;
3276      }      }
3277      # Sort the keys and get the elements.      # Sort the keys and get the elements.
3278      my @retVal = ();      my @retVal = ();
# Line 3618  Line 3851 
3851      my ($self, %groupHash) = @_;      my ($self, %groupHash) = @_;
3852      # Create the result hash.      # Create the result hash.
3853      my %retVal = ();      my %retVal = ();
     # Get the super-group table.  
     my %superTable = $self->CheckGroupFile();  
3854      # Copy over the genomes.      # Copy over the genomes.
3855      for my $groupID (keys %groupHash) {      for my $groupID (keys %groupHash) {
3856          # Get the super-group name.          # Get the super-group name.
3857          my $realGroupID;          my $realGroupID = $self->SuperGroup($groupID);
3858          if ($groupID =~ /([A-Z]\w+)/) {          # Append this group's genomes into the result hash
3859              my $sortOfGroup = $1;          # using the super-group name.
             if (! defined($superTable{$1})) {  
                 Confess("Super-group name not found for group $groupID.");  
             } else {  
                 $realGroupID = $superTable{$1}->{superGroup};  
             }  
         } else {  
             Confess("Invalid group name $groupID.");  
         }  
         # Append this group's genomes into the result hash.  
3860          push @{$retVal{$realGroupID}}, @{$groupHash{$groupID}};          push @{$retVal{$realGroupID}}, @{$groupHash{$groupID}};
3861      }      }
3862      # Return the result hash.      # Return the result hash.
# Line 3665  Line 3887 
3887  sub GroupPageName {  sub GroupPageName {
3888      # Get the parameters.      # Get the parameters.
3889      my ($self, $group) = @_;      my ($self, $group) = @_;
     # Declare the return variable.  
     my $retVal;  
3890      # Check for the group file data.      # Check for the group file data.
3891      my %superTable = $self->CheckGroupFile();      my %superTable = $self->CheckGroupFile();
3892      # Compute the real group name.      # Compute the real group name.
3893      my ($realGroup, $pageLink);      my $realGroup = $self->SuperGroup($group);
3894      if ($group =~ /([A-Z]\w+)/) {      # Get the associated page name.
3895          my $sortOfGroup = $1;      my $retVal = "../content/$superTable{$realGroup}->{page}";
         if (! defined($superTable{$1})) {  
             Confess("No sort-of group found for \"$group\".");  
         } else {  
             $pageLink = $superTable{$1}->{page};  
         }  
     } else {  
         Confess("\"group\" is not a valid group name.");  
     }  
     # Return the page name.  
     $retVal = "../content/" . $pageLink;  
3896      # Return the result.      # Return the result.
3897      return $retVal;      return $retVal;
3898  }  }
# Line 3725  Line 3935 
3935    
3936  Get the group file hash. The group file hash describes the relationship  Get the group file hash. The group file hash describes the relationship
3937  between a group and the super-group to which it belongs for purposes of  between a group and the super-group to which it belongs for purposes of
3938  display. The super-group name is computed from the sort-of group name,  display. The super-group name is computed from the first capitalized word
3939  which is the first capitalized word in the actual group name. For each  in the actual group name. For each super-group, the group file contains
3940  sort-of group, the group file contains the super-group name, the group  the page name and a list of the species expected to be in the group.
3941  genus, the list of applicable species (if any), and the name of the NMPDR  Each species is specified by a genus and a species name. A species name
3942  display page for the super-group.  of C<0> implies an entire genus.
3943    
3944  This method returns a hash from sort-of group names to hash reference. Each  This method returns a hash from super-group names to a hash reference. Each
3945  resulting hash reference contains the following fields.  resulting hash reference contains the following fields.
3946    
3947  =over 4  =over 4
3948    
 =item superGroup  
   
 Super-group name.  
   
3949  =item page  =item page
3950    
3951  The super-group's web page in the NMPDR.  The super-group's web page in the NMPDR.
3952    
3953  =item genus  =item contents
   
 The genus of the sort-of group.  
   
 =item species  
3954    
3955  A reference to a list of the species for the sort-of group.  A list of 2-tuples, each containing a genus name followed by a species name
3956    (or 0, indicating all species). This list indicates which organisms belong
3957    in the super-group.
3958    
3959  =back  =back
3960    
# Line 3767  Line 3971 
3971          my @groupLines = Tracer::GetFile("$FIG_Config::sproutData/groups.tbl");          my @groupLines = Tracer::GetFile("$FIG_Config::sproutData/groups.tbl");
3972          # Loop through the list of sort-of groups.          # Loop through the list of sort-of groups.
3973          for my $groupLine (@groupLines) {          for my $groupLine (@groupLines) {
3974              my ($mainName, $name, $page, $genus, $species) = split(/\t/, $groupLine);              my ($name, $page, @contents) = split /\t/, $groupLine;
3975              $groupHash{$name} = { page => $page,              $groupHash{$name} = { page => $page,
3976                                 genus => $genus,                                    contents => [ map { [ split /\s*,\s*/, $_ ] } @contents ]
3977                                 species => [ split(/\s*,\s*/, $species) ],                                  };
                                superGroup => $mainName };  
3978          }          }
3979          # Save the hash.          # Save the hash.
3980          $self->{groupHash} = \%groupHash;          $self->{groupHash} = \%groupHash;
# Line 3811  Line 4014 
4014      # Get the parameters.      # Get the parameters.
4015      my ($self, $searchExpression) = @_;      my ($self, $searchExpression) = @_;
4016      # Perform the standard cleanup.      # Perform the standard cleanup.
4017      my $retVal = $self->ERDB::CleanKeywords($searchExpression);      my $words = $self->ERDB::CleanKeywords($searchExpression);
4018      # Fix the periods in EC and TC numbers.      # Fix the periods in EC and TC numbers.
4019      $retVal =~ s/(\d+|\-)\.(\d+|-)\.(\d+|-)\.(\d+|-)/$1_$2_$3_$4/g;      $words =~ s/(\d+|\-)\.(\d+|-)\.(\d+|-)\.(\d+|-)/$1_$2_$3_$4/g;
4020      # Fix non-trailing periods.      # Fix non-trailing periods.
4021      $retVal =~ s/\.(\w)/_$1/g;      $words =~ s/\.(\w)/_$1/g;
4022      # Fix non-leading minus signs.      # Fix non-leading minus signs.
4023      $retVal =~ s/(\w)[\-]/$1_/g;      $words =~ s/(\w)[\-]/$1_/g;
4024      # Fix the vertical bars and colons      # Fix the vertical bars and colons
4025      $retVal =~ s/(\w)[|:](\w)/$1'$2/g;      $words =~ s/(\w)[|:](\w)/$1'$2/g;
4026        # Now split up the list so that each keyword is in its own string. We keep the delimiters
4027        # because they may contain boolean expression data.
4028        my @words = split /([^A-Za-z'0-9_]+)/, $words;
4029        # We'll convert the stemmable words into stems and re-assemble the result.
4030        my $retVal = "";
4031        for my $word (@words) {
4032            my $stem = $self->Stem($word);
4033            if (defined $stem) {
4034                $retVal .= $stem;
4035            } else {
4036                $retVal .= $word;
4037            }
4038        }
4039        Trace("Cleaned keyword list for \"$searchExpression\" is \"$retVal\".") if T(3);
4040      # Return the result.      # Return the result.
4041      return $retVal;      return $retVal;
4042  }  }
# Line 3949  Line 4166 
4166  }  }
4167    
4168    
4169    =head3 Hint
4170    
4171        my $htmlText = SearchHelper::Hint($wikiPage, $hintText);
4172    
4173    Return the HTML for a small question mark that displays the specified hint text when it is clicked.
4174    This HTML can be put in forms to provide a useful hinting mechanism.
4175    
4176    =over 4
4177    
4178    =item wikiPage
4179    
4180    Name of the wiki page to be popped up when the hint mark is clicked.
4181    
4182    =item hintText
4183    
4184    Text to display for the hint. It is raw html, but may not contain any double quotes.
4185    
4186    =item RETURN
4187    
4188    Returns the html for the hint facility. The resulting html shows a small button-like thing that
4189    uses the standard FIG popup technology.
4190    
4191    =back
4192    
4193    =cut
4194    
4195    sub Hint {
4196        # Get the parameters.
4197        my ($wikiPage, $hintText) = @_;
4198        # Escape the single quotes in the hint text.
4199        my $quotedText = $hintText;
4200        $quotedText =~ s/'/\\'/g;
4201        # Convert the wiki page name to a URL.
4202        my $wikiURL = join("", map { ucfirst $_ } split /\s+/, $wikiPage);
4203        $wikiURL = "$FIG_Config::cgi_url/wiki/view.cgi/FIG/$wikiURL";
4204        # Compute the mouseover script.
4205        my $mouseOver = "doTooltip(this, '$quotedText')";
4206        # Create the html.
4207        my $retVal = "&nbsp;<a href=\"$wikiURL\"><img src=\"$FIG_Config::cgi_url/Html/button-h.png\" class=\"helpicon\" onmouseover=\"$mouseOver\"/></a>";
4208        # Return it.
4209        return $retVal;
4210    }
4211    
4212  1;  1;

Legend:
Removed from v.1.102  
changed lines
  Added in v.1.114

MCS Webmaster
ViewVC Help
Powered by ViewVC 1.0.3