[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.109, Sun Mar 23 16:32:05 2008 UTC revision 1.115, Sun Sep 7 03:13:32 2008 UTC
# Line 15  Line 15 
15      use CustomAttributes;      use CustomAttributes;
16      use RemoteCustomAttributes;      use RemoteCustomAttributes;
17      use CGI;      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 147  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  }  }
# Line 519  Line 524 
524  A comma-delimited list of selected genomes, or a reference to a list of selected genomes. The  A comma-delimited list of selected genomes, or a reference to a list of selected genomes. The
525  default is none.  default is none.
526    
527  =item inTable  =item class
528    
529  If TRUE, then backslashes will be included at the end of each line in the resulting HTML. This enables the control  If specified, a style class to assign to the genome control.
 to be used in TWiki tables.  
530    
531  =back  =back
532    
# Line 532  Line 536 
536      # Get the parameters.      # Get the parameters.
537      my ($self, %options) = @_;      my ($self, %options) = @_;
538      # Get the control's name and ID.      # Get the control's name and ID.
539      my $menuName = $options{name} || 'myGenomeControl';      my $menuName = $options{name} || $options{id} || 'myGenomeControl';
540      my $menuID = $options{id} || $menuName;      my $menuID = $options{id} || $menuName;
541        Trace("Genome menu name = $menuName with ID $menuID.") if T(3);
542      # Compute the IDs for the status display.      # Compute the IDs for the status display.
543      my $divID = "${menuID}_status";      my $divID = "${menuID}_status";
544      my $urlID = "${menuID}_url";      my $urlID = "${menuID}_url";
# Line 541  Line 546 
546      my $showSelect = "showSelected('$menuID', '$divID', '$urlID', 1000)";      my $showSelect = "showSelected('$menuID', '$divID', '$urlID', 1000)";
547      # Check for single-select or multi-select.      # Check for single-select or multi-select.
548      my $multiSelect = $options{multiSelect} || 0;      my $multiSelect = $options{multiSelect} || 0;
549        # Get the style data.
550        my $class = $options{class} || '';
551      # Get the list of pre-selected items.      # Get the list of pre-selected items.
552      my $selections = $options{selected} || [];      my $selections = $options{selected} || [];
553      if (ref $selections ne 'ARRAY') {      if (ref $selections ne 'ARRAY') {
554          $selections = [ split /\s*,\s*/, $selections ];          $selections = [ split /\s*,\s*/, $selections ];
555      }      }
556      my %selected = map { $_ => } @{$selections};      my %selected = map { $_ => 1 } @{$selections};
557      # Extract the filter information. The default is no filtering. It can be passed as a tab-delimited      # Extract the filter information. The default is no filtering. It can be passed as a tab-delimited
558      # string or a list reference.      # string or a list reference.
559      my $filterParms = $options{filter} || "";      my $filterParms = $options{filter} || "";
# Line 619  Line 626 
626      my $onChangeTag = ( $rows > 1 ? " onChange=\"$showSelect;\" onFocus=\"$showSelect;\"" : "" );      my $onChangeTag = ( $rows > 1 ? " onChange=\"$showSelect;\" onFocus=\"$showSelect;\"" : "" );
627      # Set up the multiple-select flag.      # Set up the multiple-select flag.
628      my $multipleTag = ($multiSelect ? " multiple" : "" );      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.      # Create the SELECT tag and stuff it into the output array.
632      my @lines = ("<SELECT name=\"$menuID\" id=\"$menuID\" $onChangeTag$multipleTag size=\"$rows\" style=\"width: 100%\">");      my @lines = ("<SELECT name=\"$menuName\" id=\"$menuID\" $onChangeTag$multipleTag$classTag size=\"$rows\">");
633      # Loop through the groups.      # Loop through the groups.
634      for my $group (@groups) {      for my $group (@groups) {
635          # Get the genomes in the group.          # Get the genomes in the group.
# Line 656  Line 665 
665          my $searchThingLabel = ($multiSelect ? "<INPUT type=\"button\" name=\"MacroSearch\" class=\"button\" value=\"Select genomes containing\" onClick=\"selectShowing('$menuID', '$searchThingName'); $showSelect;\" />"          my $searchThingLabel = ($multiSelect ? "<INPUT type=\"button\" name=\"MacroSearch\" class=\"button\" value=\"Select genomes containing\" onClick=\"selectShowing('$menuID', '$searchThingName'); $showSelect;\" />"
666                                               : "Show genomes containing");                                               : "Show genomes containing");
667          push @lines, "<br />$searchThingLabel&nbsp;" .          push @lines, "<br />$searchThingLabel&nbsp;" .
668                       "<INPUT type=\"text\" id=\"$searchThingName\" name=\"$searchThingName\" size=\"30\" onKeyup=\"showTyped('$menuID', '$searchThingName');\" />";                       "<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.          # For multi-select mode, we also have buttons to set and clear selections.
671          if ($multiSelect) {          if ($multiSelect) {
672              push @lines, "<INPUT type=\"button\" name=\"ClearAll\" class=\"bigButton\"  value=\"Clear All\" onClick=\"clearAll('$menuID'); $showSelect\" />";              push @lines, "<INPUT type=\"button\" name=\"ClearAll\" class=\"bigButton\"  value=\"Clear All\" onClick=\"clearAll('$menuID'); $showSelect\" />";
# Line 664  Line 674 
674              push @lines, "<INPUT type=\"button\" name=\"NMPDROnly\" class=\"bigButton\"  value=\"Select NMPDR\" onClick=\"selectSome('$menuID', $nmpdrCount, true); $showSelect;\" />";              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.          # 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/seedviewer.cgi?page=Organism;organism=\" />";          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.          # 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>";          push @lines, "<DIV id=\"$divID\" class=\"Panel\"></DIV>";
680      }      }
681      # Assemble all the lines into a string. This is where we do the "inTable" thing to insure we don't mess up TWiki tables.      # Assemble all the lines into a string.
682      my $delim = ($options{inTable} ? "\\" : "" ) . "\n";      my $retVal = join("\n", @lines, "");
683      my $retVal = join($delim, @lines, "");      # 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  }  }
# Line 813  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 822  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 1903  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 2743  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 3130  Line 3118 
3118      # Get the parameters.      # Get the parameters.
3119      my ($self, $featureID) = @_;      my ($self, $featureID) = @_;
3120      # Get the list of names.      # Get the list of names.
3121      my @retVal = $self->GetFlat(['HasRoleInSubsystem'], "HasRoleInSubsystem(from-link) = ?",      ##HACK: we do a join to the Subsystem table because we have missing subsystems in
3122        ## the Sprout database!
3123        my @retVal = $self->GetFlat(['HasRoleInSubsystem', 'Subsystem'], "HasRoleInSubsystem(from-link) = ?",
3124                                  [$featureID], 'HasRoleInSubsystem(to-link)');                                  [$featureID], 'HasRoleInSubsystem(to-link)');
3125      # Return the result, sorted.      # Return the result, sorted.
3126      return sort @retVal;      return sort @retVal;
# Line 4026  Line 4016 
4016      # Get the parameters.      # Get the parameters.
4017      my ($self, $searchExpression) = @_;      my ($self, $searchExpression) = @_;
4018      # Perform the standard cleanup.      # Perform the standard cleanup.
4019      my $retVal = $self->ERDB::CleanKeywords($searchExpression);      my $words = $self->ERDB::CleanKeywords($searchExpression);
4020      # Fix the periods in EC and TC numbers.      # Fix the periods in EC and TC numbers.
4021      $retVal =~ s/(\d+|\-)\.(\d+|-)\.(\d+|-)\.(\d+|-)/$1_$2_$3_$4/g;      $words =~ s/(\d+|\-)\.(\d+|-)\.(\d+|-)\.(\d+|-)/$1_$2_$3_$4/g;
4022      # Fix non-trailing periods.      # Fix non-trailing periods.
4023      $retVal =~ s/\.(\w)/_$1/g;      $words =~ s/\.(\w)/_$1/g;
4024      # Fix non-leading minus signs.      # Fix non-leading minus signs.
4025      $retVal =~ s/(\w)[\-]/$1_/g;      $words =~ s/(\w)[\-]/$1_/g;
4026      # Fix the vertical bars and colons      # Fix the vertical bars and colons
4027      $retVal =~ s/(\w)[|:](\w)/$1'$2/g;      $words =~ s/(\w)[|:](\w)/$1'$2/g;
4028        # Now split up the list so that each keyword is in its own string. We keep the delimiters
4029        # because they may contain boolean expression data.
4030        my @words = split /([^A-Za-z'0-9_]+)/, $words;
4031        # We'll convert the stemmable words into stems and re-assemble the result.
4032        my $retVal = "";
4033        for my $word (@words) {
4034            my $stem = $self->Stem($word);
4035            if (defined $stem) {
4036                $retVal .= $stem;
4037            } else {
4038                $retVal .= $word;
4039            }
4040        }
4041        Trace("Cleaned keyword list for \"$searchExpression\" is \"$retVal\".") if T(3);
4042      # Return the result.      # Return the result.
4043      return $retVal;      return $retVal;
4044  }  }
# Line 4164  Line 4168 
4168  }  }
4169    
4170    
4171    =head3 Hint
4172    
4173        my $htmlText = SearchHelper::Hint($wikiPage, $hintText);
4174    
4175    Return the HTML for a small question mark that displays the specified hint text when it is clicked.
4176    This HTML can be put in forms to provide a useful hinting mechanism.
4177    
4178    =over 4
4179    
4180    =item wikiPage
4181    
4182    Name of the wiki page to be popped up when the hint mark is clicked.
4183    
4184    =item hintText
4185    
4186    Text to display for the hint. It is raw html, but may not contain any double quotes.
4187    
4188    =item RETURN
4189    
4190    Returns the html for the hint facility. The resulting html shows a small button-like thing that
4191    uses the standard FIG popup technology.
4192    
4193    =back
4194    
4195    =cut
4196    
4197    sub Hint {
4198        # Get the parameters.
4199        my ($wikiPage, $hintText) = @_;
4200        # Escape the single quotes in the hint text.
4201        my $quotedText = $hintText;
4202        $quotedText =~ s/'/\\'/g;
4203        # Convert the wiki page name to a URL.
4204        my $wikiURL = join("", map { ucfirst $_ } split /\s+/, $wikiPage);
4205        $wikiURL = "$FIG_Config::cgi_url/wiki/view.cgi/FIG/$wikiURL";
4206        # Compute the mouseover script.
4207        my $mouseOver = "doTooltip(this, '$quotedText')";
4208        # Create the html.
4209        my $retVal = "&nbsp;<a href=\"$wikiURL\"><img src=\"$FIG_Config::cgi_url/Html/button-h.png\" class=\"helpicon\" onmouseover=\"$mouseOver\"/></a>";
4210        # Return it.
4211        return $retVal;
4212    }
4213    
4214  1;  1;

Legend:
Removed from v.1.109  
changed lines
  Added in v.1.115

MCS Webmaster
ViewVC Help
Powered by ViewVC 1.0.3