[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.73, Sun Jun 25 02:44:43 2006 UTC revision 1.96, Wed Dec 6 03:37:26 2006 UTC
# Line 15  Line 15 
15      use FidCheck;      use FidCheck;
16      use Stats;      use Stats;
17      use POSIX qw(strftime);      use POSIX qw(strftime);
18        use BasicLocation;
19    
20  =head1 Sprout Database Manipulation Object  =head1 Sprout Database Manipulation Object
21    
# Line 92  Line 92 
92  sub new {  sub new {
93      # Get the parameters.      # Get the parameters.
94      my ($class, $dbName, $options) = @_;      my ($class, $dbName, $options) = @_;
95        # Compute the DBD directory.
96        my $dbd_dir = (defined($FIG_Config::dbd_dir) ? $FIG_Config::dbd_dir :
97                                                      $FIG_Config::fig );
98      # Compute the options. We do this by starting with a table of defaults and overwriting with      # Compute the options. We do this by starting with a table of defaults and overwriting with
99      # the incoming data.      # the incoming data.
100      my $optionTable = Tracer::GetOptions({      my $optionTable = Tracer::GetOptions({
# Line 99  Line 102 
102                                                          # database type                                                          # database type
103                         dataDir      => $FIG_Config::sproutData,                         dataDir      => $FIG_Config::sproutData,
104                                                          # data file directory                                                          # data file directory
105                         xmlFileName  => "$FIG_Config::fig/SproutDBD.xml",                         xmlFileName  => "$dbd_dir/SproutDBD.xml",
106                                                          # database definition file name                                                          # database definition file name
107                         userData     => "$FIG_Config::dbuser/$FIG_Config::dbpass",                         userData     => "$FIG_Config::dbuser/$FIG_Config::dbpass",
108                                                          # user name and password                                                          # user name and password
109                         port         => $FIG_Config::dbport,                         port         => $FIG_Config::dbport,
110                                                          # database connection port                                                          # database connection port
111                         sock         => $FIG_Config::dbsock,                         sock         => $FIG_Config::dbsock,
112                           host         => $FIG_Config::dbhost,
113                         maxSegmentLength => 4500,        # maximum feature segment length                         maxSegmentLength => 4500,        # maximum feature segment length
114                         maxSequenceLength => 8000,       # maximum contig sequence length                         maxSequenceLength => 8000,       # maximum contig sequence length
115                         noDBOpen     => 0,               # 1 to suppress the database open                         noDBOpen     => 0,               # 1 to suppress the database open
# Line 119  Line 123 
123      my $dbh;      my $dbh;
124      if (! $optionTable->{noDBOpen}) {      if (! $optionTable->{noDBOpen}) {
125          $dbh = DBKernel->new($optionTable->{dbType}, $dbName, $userName,          $dbh = DBKernel->new($optionTable->{dbType}, $dbName, $userName,
126                                  $password, $optionTable->{port}, undef, $optionTable->{sock});                                  $password, $optionTable->{port}, $optionTable->{host}, $optionTable->{sock});
127      }      }
128      # Create the ERDB object.      # Create the ERDB object.
129      my $xmlFileName = "$optionTable->{xmlFileName}";      my $xmlFileName = "$optionTable->{xmlFileName}";
# Line 127  Line 131 
131      # Add the option table and XML file name.      # Add the option table and XML file name.
132      $retVal->{_options} = $optionTable;      $retVal->{_options} = $optionTable;
133      $retVal->{_xmlName} = $xmlFileName;      $retVal->{_xmlName} = $xmlFileName;
134        # Set up space for the group file data.
135        $retVal->{groupHash} = undef;
136      # Return it.      # Return it.
137      return $retVal;      return $retVal;
138  }  }
# Line 336  Line 342 
342    
343  =head3 GeneMenu  =head3 GeneMenu
344    
345  C<< my $selectHtml = $sprout->GeneMenu(\%attributes, $filterString, \@params); >>  C<< my $selectHtml = $sprout->GeneMenu(\%attributes, $filterString, \@params, $selected); >>
346    
347  Return an HTML select menu of genomes. Each genome will be an option in the menu,  Return an HTML select menu of genomes. Each genome will be an option in the menu,
348  and will be displayed by name with the ID and a contig count attached. The selection  and will be displayed by name with the ID and a contig count attached. The selection
# Line 358  Line 364 
364  Reference to a list of values to be substituted in for the parameter marks in  Reference to a list of values to be substituted in for the parameter marks in
365  the filter string.  the filter string.
366    
367    =item selected (optional)
368    
369    ID of the genome to be initially selected.
370    
371    =item fast (optional)
372    
373    If specified and TRUE, the contig counts will be omitted to improve performance.
374    
375  =item RETURN  =item RETURN
376    
377  Returns an HTML select menu with the specified genomes as selectable options.  Returns an HTML select menu with the specified genomes as selectable options.
# Line 368  Line 382 
382    
383  sub GeneMenu {  sub GeneMenu {
384      # Get the parameters.      # Get the parameters.
385      my ($self, $attributes, $filterString, $params) = @_;      my ($self, $attributes, $filterString, $params, $selected, $fast) = @_;
386        my $slowMode = ! $fast;
387        # Default to nothing selected. This prevents an execution warning if "$selected"
388        # is undefined.
389        $selected = "" unless defined $selected;
390        Trace("Gene Menu called with slow mode \"$slowMode\" and selection \"$selected\".") if T(3);
391      # Start the menu.      # Start the menu.
392      my $retVal = "<select " .      my $retVal = "<select " .
393          join(" ", map { "$_=\"$attributes->{$_}\"" } keys %{$attributes}) .          join(" ", map { "$_=\"$attributes->{$_}\"" } keys %{$attributes}) .
# Line 385  Line 404 
404          # Get the data for this genome.          # Get the data for this genome.
405          my ($genomeID, $genus, $species, $strain) = @{$genomeData};          my ($genomeID, $genus, $species, $strain) = @{$genomeData};
406          # Get the contig count.          # Get the contig count.
407            my $contigInfo = "";
408            if ($slowMode) {
409          my $count = $self->ContigCount($genomeID);          my $count = $self->ContigCount($genomeID);
410          my $counting = ($count == 1 ? "contig" : "contigs");          my $counting = ($count == 1 ? "contig" : "contigs");
411                $contigInfo = "[$count $counting]";
412            }
413            # Find out if we're selected.
414            my $selectOption = ($selected eq $genomeID ? " selected" : "");
415          # Build the option tag.          # Build the option tag.
416          $retVal .= "<option value=\"$genomeID\">$genus $species $strain ($genomeID) [$count $counting]</option>\n";          $retVal .= "<option value=\"$genomeID\"$selectOption>$genus $species $strain ($genomeID)$contigInfo</option>\n";
         Trace("Option tag built for $genomeID: $genus $species $strain.") if T(3);  
417      }      }
418      # Close the SELECT tag.      # Close the SELECT tag.
419      $retVal .= "</select>\n";      $retVal .= "</select>\n";
420      # Return the result.      # Return the result.
421      return $retVal;      return $retVal;
422  }  }
423    
424  =head3 Build  =head3 Build
425    
426  C<< $sprout->Build(); >>  C<< $sprout->Build(); >>
# Line 630  Line 655 
655      return ($contigID, $start, $dir, $len);      return ($contigID, $start, $dir, $len);
656  }  }
657    
658    
659    
660  =head3 PointLocation  =head3 PointLocation
661    
662  C<< my $found = Sprout::PointLocation($location, $point); >>  C<< my $found = Sprout::PointLocation($location, $point); >>
# Line 894  Line 921 
921      my ($self, $genomeID) = @_;      my ($self, $genomeID) = @_;
922      # Declare the return variable.      # Declare the return variable.
923      my $retVal = {};      my $retVal = {};
924      # Query the genome's features and annotations. We'll put the oldest annotations      # Query the genome's features.
925      # first so that the last assignment to go into the hash will be the correct one.      my $query = $self->Get(['HasFeature', 'Feature'], "HasFeature(from-link) = ?",
     my $query = $self->Get(['HasFeature', 'IsTargetOfAnnotation', 'Annotation'],  
                            "HasFeature(from-link) = ? ORDER BY Annotation(time)",  
926                             [$genomeID]);                             [$genomeID]);
927      # Loop through the annotations.      # Loop through the features.
928      while (my $data = $query->Fetch) {      while (my $data = $query->Fetch) {
929          # Get the feature ID and annotation text.          # Get the feature ID and assignment.
930          my ($fid, $annotation) = $data->Values(['HasFeature(to-link)',          my ($fid, $assignment) = $data->Values(['Feature(id)', 'Feature(assignment)']);
931                                                  'Annotation(annotation)']);          if ($assignment) {
         # Check to see if this is an assignment. Note that the user really  
         # doesn't matter to us, other than we use it to determine whether or  
         # not this is an assignment.  
         my ($user, $assignment) = _ParseAssignment('fig', $annotation);  
         if ($user) {  
             # Here it's an assignment. We put it in the return hash, overwriting  
             # any older assignment that might be present.  
932              $retVal->{$fid} = $assignment;              $retVal->{$fid} = $assignment;
933          }          }
934      }      }
# Line 1272  Line 1290 
1290  Return the most recently-determined functional assignment of a particular feature.  Return the most recently-determined functional assignment of a particular feature.
1291    
1292  The functional assignment is handled differently depending on the type of feature. If  The functional assignment is handled differently depending on the type of feature. If
1293  the feature is identified by a FIG ID (begins with the string C<fig|>), then a functional  the feature is identified by a FIG ID (begins with the string C<fig|>), then the functional
1294  assignment is a type of annotation. The format of an assignment is described in  assignment is taken from the B<Feature> or C<Annotation> table, depending.
 L</ParseAssignment>. Its worth noting that we cannot filter on the content of the  
 annotation itself because it's a text field; however, this is not a big problem because  
 most features only have a small number of annotations.  
1295    
1296  Each user has an associated list of trusted users. The assignment returned will be the most  Each user has an associated list of trusted users. The assignment returned will be the most
1297  recent one by at least one of the trusted users. If no trusted user list is available, then  recent one by at least one of the trusted users. If no trusted user list is available, then
# Line 1295  Line 1310 
1310    
1311  =item userID (optional)  =item userID (optional)
1312    
1313  ID of the user whose function determination is desired. If omitted, only the latest  ID of the user whose function determination is desired. If omitted, the primary
1314  C<FIG> assignment will be returned.  functional assignment in the B<Feature> table will be returned.
1315    
1316  =item RETURN  =item RETURN
1317    
# Line 1313  Line 1328 
1328      my $retVal;      my $retVal;
1329      # Determine the ID type.      # Determine the ID type.
1330      if ($featureID =~ m/^fig\|/) {      if ($featureID =~ m/^fig\|/) {
1331          # Here we have a FIG feature ID. We must build the list of trusted          # Here we have a FIG feature ID.
1332          # users.          if (!$userID) {
1333                # Use the primary assignment.
1334                ($retVal) = $self->GetEntityValues('Feature', $featureID, ['Feature(assignment)']);
1335            } else {
1336                # We must build the list of trusted users.
1337          my %trusteeTable = ();          my %trusteeTable = ();
1338          # Check the user ID.          # Check the user ID.
1339          if (!$userID) {          if (!$userID) {
# Line 1357  Line 1376 
1376                  }                  }
1377              }              }
1378          }          }
1379            }
1380      } else {      } else {
1381          # Here we have a non-FIG feature ID. In this case the user ID does not          # Here we have a non-FIG feature ID. In this case the user ID does not
1382          # matter. We simply get the information from the External Alias Function          # matter. We simply get the information from the External Alias Function
# Line 1472  Line 1492 
1492      my %retVal = ();      my %retVal = ();
1493      # Loop through the incoming features.      # Loop through the incoming features.
1494      for my $featureID (@{$featureList}) {      for my $featureID (@{$featureList}) {
1495          # Create a query to get the feature's best hit.          # Ask the server for the feature's best hit.
1496          my $query = $self->Get(['IsBidirectionalBestHitOf'],          my @bbhData = FIGRules::BBHData($featureID);
                                "IsBidirectionalBestHitOf(from-link) = ? AND IsBidirectionalBestHitOf(genome) = ?",  
                                [$featureID, $genomeID]);  
1497          # Peel off the BBHs found.          # Peel off the BBHs found.
1498          my @found = ();          my @found = ();
1499          while (my $bbh = $query->Fetch) {          for my $bbh (@bbhData) {
1500              push @found, $bbh->Value('IsBidirectionalBestHitOf(to-link)');              my $fid = $bbh->[0];
1501                my $bbGenome = $self->GenomeOf($fid);
1502                if ($bbGenome eq $genomeID) {
1503                    push @found, $fid;
1504                }
1505          }          }
1506          $retVal{$featureID} = \@found;          $retVal{$featureID} = \@found;
1507      }      }
# Line 1493  Line 1515 
1515    
1516  Return a list of the similarities to the specified feature.  Return a list of the similarities to the specified feature.
1517    
1518  Sprout does not support real similarities, so this method just returns the bidirectional  This method just returns the bidirectional best hits for performance reasons.
 best hits.  
1519    
1520  =over 4  =over 4
1521    
# Line 1514  Line 1535 
1535      # Get the parameters.      # Get the parameters.
1536      my ($self, $featureID, $count) = @_;      my ($self, $featureID, $count) = @_;
1537      # Ask for the best hits.      # Ask for the best hits.
1538      my @lists = $self->GetAll(['IsBidirectionalBestHitOf'],      my @lists = FIGRules::BBHData($featureID);
                               "IsBidirectionalBestHitOf(from-link) = ? ORDER BY IsBidirectionalBestHitOf(score) DESC",  
                               [$featureID], ['IsBidirectionalBestHitOf(to-link)', 'IsBidirectionalBestHitOf(score)'],  
                               $count);  
1539      # Create the return value.      # Create the return value.
1540      my %retVal = ();      my %retVal = ();
1541      for my $tuple (@lists) {      for my $tuple (@lists) {
# Line 1527  Line 1545 
1545      return %retVal;      return %retVal;
1546  }  }
1547    
   
   
1548  =head3 IsComplete  =head3 IsComplete
1549    
1550  C<< my $flag = $sprout->IsComplete($genomeID); >>  C<< my $flag = $sprout->IsComplete($genomeID); >>
# Line 1656  Line 1672 
1672  sub CoupledFeatures {  sub CoupledFeatures {
1673      # Get the parameters.      # Get the parameters.
1674      my ($self, $featureID) = @_;      my ($self, $featureID) = @_;
1675        Trace("Looking for features coupled to $featureID.") if T(coupling => 3);
1676      # Create a query to retrieve the functionally-coupled features.      # Create a query to retrieve the functionally-coupled features.
1677      my $query = $self->Get(['ParticipatesInCoupling', 'Coupling'],      my $query = $self->Get(['ParticipatesInCoupling', 'Coupling'],
1678                             "ParticipatesInCoupling(from-link) = ?", [$featureID]);                             "ParticipatesInCoupling(from-link) = ?", [$featureID]);
# Line 1668  Line 1685 
1685          # Get the ID and score of the coupling.          # Get the ID and score of the coupling.
1686          my ($couplingID, $score) = $clustering->Values(['Coupling(id)',          my ($couplingID, $score) = $clustering->Values(['Coupling(id)',
1687                                                          'Coupling(score)']);                                                          'Coupling(score)']);
1688            Trace("$featureID coupled with score $score to ID $couplingID.") if T(coupling => 4);
1689          # Get the other feature that participates in the coupling.          # Get the other feature that participates in the coupling.
1690          my ($otherFeatureID) = $self->GetFlat(['ParticipatesInCoupling'],          my ($otherFeatureID) = $self->GetFlat(['ParticipatesInCoupling'],
1691                                             "ParticipatesInCoupling(to-link) = ? AND ParticipatesInCoupling(from-link) <> ?",                                             "ParticipatesInCoupling(to-link) = ? AND ParticipatesInCoupling(from-link) <> ?",
1692                                             [$couplingID, $featureID], 'ParticipatesInCoupling(from-link)');                                             [$couplingID, $featureID], 'ParticipatesInCoupling(from-link)');
1693            Trace("$couplingID target feature is $otherFeatureID.") if T(coupling => 4);
1694          # Attach the other feature's score to its ID.          # Attach the other feature's score to its ID.
1695          $retVal{$otherFeatureID} = $score;          $retVal{$otherFeatureID} = $score;
1696          $found = 1;          $found = 1;
# Line 1825  Line 1844 
1844      return ($retVal, $inverted, $score);      return ($retVal, $inverted, $score);
1845  }  }
1846    
1847    =head3 GetSynonymGroup
1848    
1849    C<< my $id = $sprout->GetSynonymGroup($fid); >>
1850    
1851    Return the synonym group name for the specified feature.
1852    
1853    =over 4
1854    
1855    =item fid
1856    
1857    ID of the feature whose synonym group is desired.
1858    
1859    =item RETURN
1860    
1861    The name of the synonym group to which the feature belongs. If the feature does
1862    not belong to a synonym group, the feature ID itself is returned.
1863    
1864    =back
1865    
1866    =cut
1867    
1868    sub GetSynonymGroup {
1869        # Get the parameters.
1870        my ($self, $fid) = @_;
1871        # Declare the return variable.
1872        my $retVal;
1873        # Find the synonym group.
1874        my @groups = $self->GetFlat(['IsSynonymGroupFor'], "IsSynonymGroupFor(to-link) = ?",
1875                                       [$fid], 'IsSynonymGroupFor(from-link)');
1876        # Check to see if we found anything.
1877        if (@groups) {
1878            $retVal = $groups[0];
1879        } else {
1880            $retVal = $fid;
1881        }
1882        # Return the result.
1883        return $retVal;
1884    }
1885    
1886    =head3 GetBoundaries
1887    
1888    C<< my ($contig, $beg, $end) = $sprout->GetBoundaries(@locList); >>
1889    
1890    Determine the begin and end boundaries for the locations in a list. All of the
1891    locations must belong to the same contig and have mostly the same direction in
1892    order for this method to produce a meaningful result. The resulting
1893    begin/end pair will contain all of the bases in any of the locations.
1894    
1895    =over 4
1896    
1897    =item locList
1898    
1899    List of locations to process.
1900    
1901    =item RETURN
1902    
1903    Returns a 3-tuple consisting of the contig ID, the beginning boundary,
1904    and the ending boundary. The beginning boundary will be left of the
1905    end for mostly-forward locations and right of the end for mostly-backward
1906    locations.
1907    
1908    =back
1909    
1910    =cut
1911    
1912    sub GetBoundaries {
1913        # Get the parameters.
1914        my ($self, @locList) = @_;
1915        # Set up the counters used to determine the most popular direction.
1916        my %counts = ( '+' => 0, '-' => 0 );
1917        # Get the last location and parse it.
1918        my $locObject = BasicLocation->new(pop @locList);
1919        # Prime the loop with its data.
1920        my ($contig, $beg, $end) = ($locObject->Contig, $locObject->Left, $locObject->Right);
1921        # Count its direction.
1922        $counts{$locObject->Dir}++;
1923        # Loop through the remaining locations. Note that in most situations, this loop
1924        # will not iterate at all, because most of the time we will be dealing with a
1925        # singleton list.
1926        for my $loc (@locList) {
1927            # Create a location object.
1928            my $locObject = BasicLocation->new($loc);
1929            # Count the direction.
1930            $counts{$locObject->Dir}++;
1931            # Get the left end and the right end.
1932            my $left = $locObject->Left;
1933            my $right = $locObject->Right;
1934            # Merge them into the return variables.
1935            if ($left < $beg) {
1936                $beg = $left;
1937            }
1938            if ($right > $end) {
1939                $end = $right;
1940            }
1941        }
1942        # If the most common direction is reverse, flip the begin and end markers.
1943        if ($counts{'-'} > $counts{'+'}) {
1944            ($beg, $end) = ($end, $beg);
1945        }
1946        # Return the result.
1947        return ($contig, $beg, $end);
1948    }
1949    
1950  =head3 CouplingID  =head3 CouplingID
1951    
1952  C<< my $couplingID = $sprout->CouplingID($peg1, $peg2); >>  C<< my $couplingID = $sprout->CouplingID($peg1, $peg2); >>
# Line 2554  Line 2676 
2676      return $retVal;      return $retVal;
2677  }  }
2678    
2679    =head3 PropertyID
2680    
2681    C<< my $id = $sprout->PropertyID($propName, $propValue); >>
2682    
2683    Return the ID of the specified property name and value pair, if the
2684    pair exists.
2685    
2686    =over 4
2687    
2688    =item propName
2689    
2690    Name of the desired property.
2691    
2692    =item propValue
2693    
2694    Value expected for the desired property.
2695    
2696    =item RETURN
2697    
2698    Returns the ID of the name/value pair, or C<undef> if the pair does not exist.
2699    
2700    =back
2701    
2702    =cut
2703    
2704    sub PropertyID {
2705        # Get the parameters.
2706        my ($self, $propName, $propValue) = @_;
2707        # Try to find the ID.
2708        my ($retVal) = $self->GetFlat(['Property'],
2709                                      "Property(property-name) = ? AND Property(property-value) = ?",
2710                                      [$propName, $propValue], 'Property(id)');
2711        # Return the result.
2712        return $retVal;
2713    }
2714    
2715  =head3 MergedAnnotations  =head3 MergedAnnotations
2716    
2717  C<< my @annotationList = $sprout->MergedAnnotations(\@list); >>  C<< my @annotationList = $sprout->MergedAnnotations(\@list); >>
# Line 2751  Line 2909 
2909      # Get the parameters.      # Get the parameters.
2910      my ($self, $featureID) = @_;      my ($self, $featureID) = @_;
2911      # Get the list of names.      # Get the list of names.
2912      my @retVal = $self->GetFlat(['ContainsFeature', 'HasSSCell'], "ContainsFeature(to-link) = ?",      my @retVal = $self->GetFlat(['HasRoleInSubsystem'], "HasRoleInSubsystem(from-link) = ?",
2913                                  [$featureID], 'HasSSCell(from-link)');                                  [$featureID], 'HasRoleInSubsystem(to-link)');
2914        # Return the result, sorted.
2915        return sort @retVal;
2916    }
2917    
2918    =head3 GenomeSubsystemData
2919    
2920    C<< my %featureData = $sprout->GenomeSubsystemData($genomeID); >>
2921    
2922    Return a hash mapping genome features to their subsystem roles.
2923    
2924    =over 4
2925    
2926    =item genomeID
2927    
2928    ID of the genome whose subsystem feature map is desired.
2929    
2930    =item RETURN
2931    
2932    Returns a hash mapping each feature of the genome to a list of 2-tuples. Eacb
2933    2-tuple contains a subsystem name followed by a role ID.
2934    
2935    =back
2936    
2937    =cut
2938    
2939    sub GenomeSubsystemData {
2940        # Get the parameters.
2941        my ($self, $genomeID) = @_;
2942        # Declare the return variable.
2943        my %retVal = ();
2944        # Get a list of the genome features that participate in subsystems. For each
2945        # feature we get its spreadsheet cells and the corresponding roles.
2946        my @roleData = $self->GetAll(['HasFeature', 'ContainsFeature', 'IsRoleOf'],
2947                                 "HasFeature(from-link) = ?", [$genomeID],
2948                                 ['HasFeature(to-link)', 'IsRoleOf(to-link)', 'IsRoleOf(from-link)']);
2949        # Now we get a list of the spreadsheet cells and their associated subsystems. Subsystems
2950        # with an unknown variant code (-1) are skipped. Note the genome ID is at both ends of the
2951        # list. We use it at the beginning to get all the spreadsheet cells for the genome and
2952        # again at the end to filter out participation in subsystems with a negative variant code.
2953        my @cellData = $self->GetAll(['IsGenomeOf', 'HasSSCell', 'ParticipatesIn'],
2954                                     "IsGenomeOf(from-link) = ? AND ParticipatesIn(variant-code) >= 0 AND ParticipatesIn(from-link) = ?",
2955                                     [$genomeID, $genomeID], ['HasSSCell(to-link)', 'HasSSCell(from-link)']);
2956        # Now "@roleData" lists the spreadsheet cell and role for each of the genome's features.
2957        # "@cellData" lists the subsystem name for each of the genome's spreadsheet cells. We
2958        # link these two lists together to create the result. First, we want a hash mapping
2959        # spreadsheet cells to subsystem names.
2960        my %subHash = map { $_->[0] => $_->[1] } @cellData;
2961        # We loop through @cellData to build the hash.
2962        for my $roleEntry (@roleData) {
2963            # Get the data for this feature and cell.
2964            my ($fid, $cellID, $role) = @{$roleEntry};
2965            # Check for a subsystem name.
2966            my $subsys = $subHash{$cellID};
2967            if ($subsys) {
2968                # Insure this feature has an entry in the return hash.
2969                if (! exists $retVal{$fid}) { $retVal{$fid} = []; }
2970                # Merge in this new data.
2971                push @{$retVal{$fid}}, [$subsys, $role];
2972            }
2973        }
2974      # Return the result.      # Return the result.
2975      return @retVal;      return %retVal;
2976  }  }
2977    
2978  =head3 RelatedFeatures  =head3 RelatedFeatures
# Line 2792  Line 3010 
3010      # Get the parameters.      # Get the parameters.
3011      my ($self, $featureID, $function, $userID) = @_;      my ($self, $featureID, $function, $userID) = @_;
3012      # Get a list of the features that are BBHs of the incoming feature.      # Get a list of the features that are BBHs of the incoming feature.
3013      my @bbhFeatures = $self->GetFlat(['IsBidirectionalBestHitOf'],      my @bbhFeatures = map { $_->[0] } FIGRules::BBHData($featureID);
                                      "IsBidirectionalBestHitOf(from-link) = ?", [$featureID],  
                                      'IsBidirectionalBestHitOf(to-link)');  
3014      # Now we loop through the features, pulling out the ones that have the correct      # Now we loop through the features, pulling out the ones that have the correct
3015      # functional assignment.      # functional assignment.
3016      my @retVal = ();      my @retVal = ();
# Line 2930  Line 3146 
3146      # Loop through the input triples.      # Loop through the input triples.
3147      my $n = length $sequence;      my $n = length $sequence;
3148      for (my $i = 0; $i < $n; $i += 3) {      for (my $i = 0; $i < $n; $i += 3) {
3149          # Get the current triple from the sequence.          # Get the current triple from the sequence. Note we convert to
3150          my $triple = substr($sequence, $i, 3);          # upper case to insure a match.
3151            my $triple = uc substr($sequence, $i, 3);
3152          # Translate it using the table.          # Translate it using the table.
3153          my $protein = "X";          my $protein = "X";
3154          if (exists $table->{$triple}) { $protein = $table->{$triple}; }          if (exists $table->{$triple}) { $protein = $table->{$triple}; }
# Line 2964  Line 3181 
3181      return @retVal;      return @retVal;
3182  }  }
3183    
3184    =head3 BBHMatrix
3185    
3186    C<< my %bbhMap = $sprout->BBHMatrix($genomeID, $cutoff, @targets); >>
3187    
3188    Find all the bidirectional best hits for the features of a genome in a
3189    specified list of target genomes. The return value will be a hash mapping
3190    features in the original genome to their bidirectional best hits in the
3191    target genomes.
3192    
3193    =over 4
3194    
3195    =item genomeID
3196    
3197    ID of the genome whose features are to be examined for bidirectional best hits.
3198    
3199    =item cutoff
3200    
3201    A cutoff value. Only hits with a score lower than the cutoff will be returned.
3202    
3203    =item targets
3204    
3205    List of target genomes. Only pairs originating in the original
3206    genome and landing in one of the target genomes will be returned.
3207    
3208    =item RETURN
3209    
3210    Returns a hash mapping each feature in the original genome to a hash mapping its
3211    BBH pegs in the target genomes to their scores.
3212    
3213    =back
3214    
3215    =cut
3216    
3217    sub BBHMatrix {
3218        # Get the parameters.
3219        my ($self, $genomeID, $cutoff, @targets) = @_;
3220        # Declare the return variable.
3221        my %retVal = ();
3222        # Ask for the BBHs.
3223        my @bbhList = FIGRules::BatchBBHs("fig|$genomeID.%", $cutoff, @targets);
3224        # We now have a set of 4-tuples that we need to convert into a hash of hashes.
3225        for my $bbhData (@bbhList) {
3226            my ($peg1, $peg2, $score) = @{$bbhData};
3227            if (! exists $retVal{$peg1}) {
3228                $retVal{$peg1} = { $peg2 => $score };
3229            } else {
3230                $retVal{$peg1}->{$peg2} = $score;
3231            }
3232        }
3233        # Return the result.
3234        return %retVal;
3235    }
3236    
3237  =head3 LowBBHs  =head3 LowBBHs
3238    
3239  C<< my %bbhMap = $sprout->LowBBHs($featureID, $cutoff); >>  C<< my %bbhMap = $sprout->LowBBHs($featureID, $cutoff); >>
# Line 2995  Line 3265 
3265      my ($self, $featureID, $cutoff) = @_;      my ($self, $featureID, $cutoff) = @_;
3266      # Create the return hash.      # Create the return hash.
3267      my %retVal = ();      my %retVal = ();
3268      # Create a query to get the desired BBHs.      # Query for the desired BBHs.
3269      my @bbhList = $self->GetAll(['IsBidirectionalBestHitOf'],      my @bbhList = FIGRules::BBHData($featureID, $cutoff);
                                 'IsBidirectionalBestHitOf(sc) <= ? AND IsBidirectionalBestHitOf(from-link) = ?',  
                                 [$cutoff, $featureID],  
                                 ['IsBidirectionalBestHitOf(to-link)', 'IsBidirectionalBestHitOf(sc)']);  
3270      # Form the results into the return hash.      # Form the results into the return hash.
3271      for my $pair (@bbhList) {      for my $pair (@bbhList) {
3272          $retVal{$pair->[0]} = $pair->[1];          my $fid = $pair->[0];
3273            if ($self->Exists('Feature', $fid)) {
3274                $retVal{$fid} = $pair->[1];
3275            }
3276      }      }
3277      # Return the result.      # Return the result.
3278      return %retVal;      return %retVal;
# Line 3073  Line 3343 
3343      return $retVal;      return $retVal;
3344  }  }
3345    
3346    =head3 IsAllGenomes
3347    
3348    C<< my $flag = $sprout->IsAllGenomes(\@list, \@checkList); >>
3349    
3350    Return TRUE if all genomes in the second list are represented in the first list at
3351    least one. Otherwise, return FALSE. If the second list is omitted, the first list is
3352    compared to a list of all the genomes.
3353    
3354    =over 4
3355    
3356    =item list
3357    
3358    Reference to the list to be compared to the second list.
3359    
3360    =item checkList (optional)
3361    
3362    Reference to the comparison target list. Every genome ID in this list must occur at
3363    least once in the first list. If this parameter is omitted, a list of all the genomes
3364    is used.
3365    
3366    =item RETURN
3367    
3368    Returns TRUE if every item in the second list appears at least once in the
3369    first list, else FALSE.
3370    
3371    =back
3372    
3373    =cut
3374    
3375    sub IsAllGenomes {
3376        # Get the parameters.
3377        my ($self, $list, $checkList) = @_;
3378        # Supply the checklist if it was omitted.
3379        $checkList = [$self->Genomes()] if ! defined($checkList);
3380        # Create a hash of the original list.
3381        my %testList = map { $_ => 1 } @{$list};
3382        # Declare the return variable. We assume that the representation
3383        # is complete and stop at the first failure.
3384        my $retVal = 1;
3385        my $n = scalar @{$checkList};
3386        for (my $i = 0; $retVal && $i < $n; $i++) {
3387            if (! $testList{$checkList->[$i]}) {
3388                $retVal = 0;
3389            }
3390        }
3391        # Return the result.
3392        return $retVal;
3393    }
3394    
3395  =head3 GetGroups  =head3 GetGroups
3396    
3397  C<< my %groups = $sprout->GetGroups(\@groupList); >>  C<< my %groups = $sprout->GetGroups(\@groupList); >>
# Line 3094  Line 3413 
3413          # Here we have a group list. Loop through them individually,          # Here we have a group list. Loop through them individually,
3414          # getting a list of the relevant genomes.          # getting a list of the relevant genomes.
3415          for my $group (@{$groupList}) {          for my $group (@{$groupList}) {
3416              my @genomeIDs = $self->GetFlat(['Genome'], "Genome(group-name) = ?",              my @genomeIDs = $self->GetFlat(['Genome'], "Genome(primary-group) = ?",
3417                  [$group], "Genome(id)");                  [$group], "Genome(id)");
3418              $retVal{$group} = \@genomeIDs;              $retVal{$group} = \@genomeIDs;
3419          }          }
# Line 3102  Line 3421 
3421          # Here we need all of the groups. In this case, we run through all          # Here we need all of the groups. In this case, we run through all
3422          # of the genome records, putting each one found into the appropriate          # of the genome records, putting each one found into the appropriate
3423          # group. Note that we use a filter clause to insure that only genomes          # group. Note that we use a filter clause to insure that only genomes
3424          # in groups are included in the return set.          # in real NMPDR groups are included in the return set.
3425          my @genomes = $self->GetAll(['Genome'], "Genome(group-name) > ' '", [],          my @genomes = $self->GetAll(['Genome'], "Genome(primary-group) <> ?",
3426                                      ['Genome(id)', 'Genome(group-name)']);                                      [$FIG_Config::otherGroup], ['Genome(id)', 'Genome(primary-group)']);
3427          # Loop through the genomes found.          # Loop through the genomes found.
3428          for my $genome (@genomes) {          for my $genome (@genomes) {
3429              # Pop this genome's ID off the current list.              # Pop this genome's ID off the current list.
# Line 3222  Line 3541 
3541      # Get the parameters.      # Get the parameters.
3542      my ($self, $genomeID, $testFlag) = @_;      my ($self, $genomeID, $testFlag) = @_;
3543      # Perform the delete for the genome's features.      # Perform the delete for the genome's features.
3544      my $retVal = $self->Delete('Feature', "fig|$genomeID.%", $testFlag);      my $retVal = $self->Delete('Feature', "fig|$genomeID.%", testMode => $testFlag);
3545      # Perform the delete for the primary genome data.      # Perform the delete for the primary genome data.
3546      my $stats = $self->Delete('Genome', $genomeID, $testFlag);      my $stats = $self->Delete('Genome', $genomeID, testMode => $testFlag);
3547      $retVal->Accumulate($stats);      $retVal->Accumulate($stats);
3548      # Return the result.      # Return the result.
3549      return $retVal;      return $retVal;
3550  }  }
3551    
3552  =head2 Internal Utility Methods  =head3 Fix
3553    
3554  =head3 ParseAssignment  C<< my %fixedHash = Sprout::Fix(%groupHash); >>
3555    
3556  Parse annotation text to determine whether or not it is a functional assignment. If it is,  Prepare a genome group hash (like that returned by L</GetGroups> for processing.
3557  the user, function text, and assigning user will be returned as a 3-element list. If it  Groups with the same primary name will be combined. The primary name is the
3558  isn't, an empty list will be returned.  first capitalized word in the group name.
3559    
3560  A functional assignment is always of the form  =over 4
3561    
3562      C<set >I<YYYY>C< function to\n>I<ZZZZZ>  =item groupHash
3563    
3564  where I<YYYY> is the B<user>, and I<ZZZZ> is the actual functional role. In most cases,  Hash to be fixed up.
 the user and the assigning user (from MadeAnnotation) will be the same, but that is  
 not always the case.  
3565    
3566  In addition, the functional role may contain extra data that is stripped, such as  =item RETURN
 terminating spaces or a comment separated from the rest of the text by a tab.  
3567    
3568  This is a static method.  Returns a fixed-up version of the hash.
3569    
3570  =over 4  =back
3571    
3572  =item user  =cut
3573    
3574  Name of the assigning user.  sub Fix {
3575        # Get the parameters.
3576        my (%groupHash) = @_;
3577        # Create the result hash.
3578        my %retVal = ();
3579        # Copy over the genomes.
3580        for my $groupID (keys %groupHash) {
3581            # Make a safety copy of the group ID.
3582            my $realGroupID = $groupID;
3583            # Yank the primary name.
3584            if ($groupID =~ /([A-Z]\w+)/) {
3585                $realGroupID = $1;
3586            }
3587            # Append this group's genomes into the result hash.
3588            Tracer::AddToListMap(\%retVal, $realGroupID, @{$groupHash{$groupID}});
3589        }
3590        # Return the result hash.
3591        return %retVal;
3592    }
3593    
3594  =item text  =head3 GroupPageName
3595    
3596  Text of the annotation.  C<< my $name = $sprout->GroupPageName($group); >>
3597    
3598    Return the name of the page for the specified NMPDR group.
3599    
3600    =over 4
3601    
3602    =item group
3603    
3604    Name of the relevant group.
3605    
3606  =item RETURN  =item RETURN
3607    
3608  Returns an empty list if the annotation is not a functional assignment; otherwise, returns  Returns the relative page name (e.g. C<../content/campy.php>). If the group file is not in
3609  a two-element list containing the user name and the function text.  memory it will be read in.
3610    
3611  =back  =back
3612    
3613  =cut  =cut
3614    
3615  sub _ParseAssignment {  sub GroupPageName {
3616      # Get the parameters.      # Get the parameters.
3617      my ($user, $text) = @_;      my ($self, $group) = @_;
3618      # Declare the return value.      # Declare the return variable.
3619      my @retVal = ();      my $retVal;
3620      # Check to see if this is a functional assignment.      # Check for the group file data.
3621      my ($type, $function) = split(/\n/, $text);      if (! defined $self->{groupHash}) {
3622      if ($type =~ m/^set function to$/i) {          # Read the group file.
3623          # Here we have an assignment without a user, so we use the incoming user ID.          my %groupData = Sprout::ReadGroupFile($self->{_options}->{dataDir} . "/groups.tbl");
3624          @retVal = ($user, $function);          # Store it in our object.
3625      } elsif ($type =~ m/^set (\S+) function to$/i) {          $self->{groupHash} = \%groupData;
         # Here we have an assignment with a user that is passed back to the caller.  
         @retVal = ($1, $function);  
3626      }      }
3627      # If we have an assignment, we need to clean the function text. There may be      # Compute the real group name.
3628      # extra junk at the end added as a note from the user.      my $realGroup = $group;
3629      if (@retVal) {      if ($group =~ /([A-Z]\w+)/) {
3630          $retVal[1] =~ s/(\t\S)?\s*$//;          $realGroup = $1;
3631      }      }
3632      # Return the result list.      # Return the page name.
3633      return @retVal;      $retVal = "../content/" . $self->{groupHash}->{$realGroup}->[1];
3634        # Return the result.
3635        return $retVal;
3636  }  }
3637    
3638  =head3 FriendlyTimestamp  =head3 ReadGroupFile
3639    
3640  Convert a time number to a user-friendly time stamp for display.  C<< my %groupData = Sprout::ReadGroupFile($groupFileName); >>
3641    
3642  This is a static method.  Read in the data from the specified group file. The group file contains information
3643    about each of the NMPDR groups.
3644    
3645  =over 4  =over 4
3646    
3647  =item timeValue  =item name
3648    
3649  Numeric time value.  Name of the group.
3650    
3651    =item page
3652    
3653    Name of the group's page on the web site (e.g. C<campy.php> for
3654    Campylobacter)
3655    
3656    =item genus
3657    
3658    Genus of the group
3659    
3660    =item species
3661    
3662    Species of the group, or an empty string if the group is for an entire
3663    genus. If the group contains more than one species, the species names
3664    should be separated by commas.
3665    
3666    =back
3667    
3668    The parameters to this method are as follows
3669    
3670    =over 4
3671    
3672    =item groupFile
3673    
3674    Name of the file containing the group data.
3675    
3676  =item RETURN  =item RETURN
3677    
3678  Returns a string containing the same time in user-readable format.  Returns a hash keyed on group name. The value of each hash
3679    
3680  =back  =back
3681    
3682  =cut  =cut
3683    
3684  sub FriendlyTimestamp {  sub ReadGroupFile {
3685      my ($timeValue) = @_;      # Get the parameters.
3686      my $retVal = localtime($timeValue);      my ($groupFileName) = @_;
3687      return $retVal;      # Declare the return variable.
3688        my %retVal;
3689        # Read the group file.
3690        my @groupLines = Tracer::GetFile($groupFileName);
3691        for my $groupLine (@groupLines) {
3692            my ($name, $page, $genus, $species) = split(/\t/, $groupLine);
3693            $retVal{$name} = [$page, $genus, $species];
3694        }
3695        # Return the result.
3696        return %retVal;
3697  }  }
3698    
3699  =head3 AddProperty  =head3 AddProperty
# Line 3376  Line 3753 
3753      $self->Insert('HasProperty', { 'from-link' => $featureID, 'to-link' => $propID, evidence => $url });      $self->Insert('HasProperty', { 'from-link' => $featureID, 'to-link' => $propID, evidence => $url });
3754  }  }
3755    
3756    =head2 Virtual Methods
3757    
3758    =head3 CleanKeywords
3759    
3760    C<< my $cleanedString = $sprout->CleanKeywords($searchExpression); >>
3761    
3762    Clean up a search expression or keyword list. This involves converting the periods
3763    in EC numbers to underscores, converting non-leading minus signs to underscores,
3764    a vertical bar or colon to an apostrophe, and forcing lower case for all alphabetic
3765    characters. In addition, any extra spaces are removed.
3766    
3767    =over 4
3768    
3769    =item searchExpression
3770    
3771    Search expression or keyword list to clean. Note that a search expression may
3772    contain boolean operators which need to be preserved. This includes leading
3773    minus signs.
3774    
3775    =item RETURN
3776    
3777    Cleaned expression or keyword list.
3778    
3779    =back
3780    
3781    =cut
3782    
3783    sub CleanKeywords {
3784        # Get the parameters.
3785        my ($self, $searchExpression) = @_;
3786        # Perform the standard cleanup.
3787        my $retVal = $self->ERDB::CleanKeywords($searchExpression);
3788        # Fix the periods in EC and TC numbers.
3789        $retVal =~ s/(\d+|\-)\.(\d+|-)\.(\d+|-)\.(\d+|-)/$1_$2_$3_$4/g;
3790        # Fix non-trailing periods.
3791        $retVal =~ s/\.(\w)/_$1/g;
3792        # Fix non-leading minus signs.
3793        $retVal =~ s/(\w)[\-]/$1_/g;
3794        # Fix the vertical bars and colons
3795        $retVal =~ s/(\w)[|:](\w)/$1'$2/g;
3796        # Return the result.
3797        return $retVal;
3798    }
3799    
3800    =head2 Internal Utility Methods
3801    
3802    =head3 ParseAssignment
3803    
3804    Parse annotation text to determine whether or not it is a functional assignment. If it is,
3805    the user, function text, and assigning user will be returned as a 3-element list. If it
3806    isn't, an empty list will be returned.
3807    
3808    A functional assignment is always of the form
3809    
3810        C<set >I<YYYY>C< function to\n>I<ZZZZZ>
3811    
3812    where I<YYYY> is the B<user>, and I<ZZZZ> is the actual functional role. In most cases,
3813    the user and the assigning user (from MadeAnnotation) will be the same, but that is
3814    not always the case.
3815    
3816    In addition, the functional role may contain extra data that is stripped, such as
3817    terminating spaces or a comment separated from the rest of the text by a tab.
3818    
3819    This is a static method.
3820    
3821    =over 4
3822    
3823    =item user
3824    
3825    Name of the assigning user.
3826    
3827    =item text
3828    
3829    Text of the annotation.
3830    
3831    =item RETURN
3832    
3833    Returns an empty list if the annotation is not a functional assignment; otherwise, returns
3834    a two-element list containing the user name and the function text.
3835    
3836    =back
3837    
3838    =cut
3839    
3840    sub _ParseAssignment {
3841        # Get the parameters.
3842        my ($user, $text) = @_;
3843        # Declare the return value.
3844        my @retVal = ();
3845        # Check to see if this is a functional assignment.
3846        my ($type, $function) = split(/\n/, $text);
3847        if ($type =~ m/^set function to$/i) {
3848            # Here we have an assignment without a user, so we use the incoming user ID.
3849            @retVal = ($user, $function);
3850        } elsif ($type =~ m/^set (\S+) function to$/i) {
3851            # Here we have an assignment with a user that is passed back to the caller.
3852            @retVal = ($1, $function);
3853        }
3854        # If we have an assignment, we need to clean the function text. There may be
3855        # extra junk at the end added as a note from the user.
3856        if (defined( $retVal[1] )) {
3857            $retVal[1] =~ s/(\t\S)?\s*$//;
3858        }
3859        # Return the result list.
3860        return @retVal;
3861    }
3862    
3863    =head3 FriendlyTimestamp
3864    
3865    Convert a time number to a user-friendly time stamp for display.
3866    
3867    This is a static method.
3868    
3869    =over 4
3870    
3871    =item timeValue
3872    
3873    Numeric time value.
3874    
3875    =item RETURN
3876    
3877    Returns a string containing the same time in user-readable format.
3878    
3879    =back
3880    
3881    =cut
3882    
3883    sub FriendlyTimestamp {
3884        my ($timeValue) = @_;
3885        my $retVal = localtime($timeValue);
3886        return $retVal;
3887    }
3888    
3889    
3890  1;  1;

Legend:
Removed from v.1.73  
changed lines
  Added in v.1.96

MCS Webmaster
ViewVC Help
Powered by ViewVC 1.0.3