[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.19, Sun Aug 14 23:32:08 2005 UTC revision 1.27, Wed Sep 14 12:56:13 2005 UTC
# Line 70  Line 70 
70    
71  * B<maxSequenceLength> maximum number of residues per sequence, (default C<8000>)  * B<maxSequenceLength> maximum number of residues per sequence, (default C<8000>)
72    
73    * B<noDBOpen> suppresses the connection to the database if TRUE, else FALSE
74    
75  =back  =back
76    
77  For example, the following constructor call specifies a database named I<Sprout> and a user name of  For example, the following constructor call specifies a database named I<Sprout> and a user name of
# Line 98  Line 100 
100                                                          # database connection port                                                          # database connection port
101                         maxSegmentLength => 4500,        # maximum feature segment length                         maxSegmentLength => 4500,        # maximum feature segment length
102                         maxSequenceLength => 8000,       # maximum contig sequence length                         maxSequenceLength => 8000,       # maximum contig sequence length
103                           noDBOpen     => 0,               # 1 to suppress the database open
104                        }, $options);                        }, $options);
105      # Get the data directory.      # Get the data directory.
106      my $dataDir = $optionTable->{dataDir};      my $dataDir = $optionTable->{dataDir};
# Line 105  Line 108 
108      $optionTable->{userData} =~ m!([^/]*)/(.*)$!;      $optionTable->{userData} =~ m!([^/]*)/(.*)$!;
109      my ($userName, $password) = ($1, $2);      my ($userName, $password) = ($1, $2);
110      # Connect to the database.      # Connect to the database.
111      my $dbh = DBKernel->new($optionTable->{dbType}, $dbName, $userName, $password, $optionTable->{port});      my $dbh;
112        if (! $optionTable->{noDBOpen}) {
113            $dbh = DBKernel->new($optionTable->{dbType}, $dbName, $userName,
114                                    $password, $optionTable->{port});
115        }
116      # Create the ERDB object.      # Create the ERDB object.
117      my $xmlFileName = "$optionTable->{xmlFileName}";      my $xmlFileName = "$optionTable->{xmlFileName}";
118      my $erdb = ERDB->new($dbh, $xmlFileName);      my $erdb = ERDB->new($dbh, $xmlFileName);
# Line 576  Line 583 
583  =item RETURN  =item RETURN
584    
585  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
586  context and as a space-delimited string in a scalar context.  context and as a comma-delimited string in a scalar context.
587    
588  =back  =back
589    
# Line 619  Line 626 
626          push @retVal, "${contigID}_$beg$dir$len";          push @retVal, "${contigID}_$beg$dir$len";
627      }      }
628      # Return the list in the format indicated by the context.      # Return the list in the format indicated by the context.
629      return (wantarray ? @retVal : join(' ', @retVal));      return (wantarray ? @retVal : join(',', @retVal));
630  }  }
631    
632  =head3 ParseLocation  =head3 ParseLocation
# Line 786  Line 793 
793          if ($dir eq '+') {          if ($dir eq '+') {
794              $retVal .= $locationDNA;              $retVal .= $locationDNA;
795          } else {          } else {
796              $locationDNA = join('', reverse split //, $locationDNA);              $retVal .= FIG::reverse_comp($locationDNA);
             $retVal .= $locationDNA;  
797          }          }
798      }      }
799      # Return the result.      # Return the result.
# Line 1521  Line 1527 
1527          # Determine the ordering to place on the evidence items. If we're          # Determine the ordering to place on the evidence items. If we're
1528          # inverted, we want to see feature 2 before feature 1 (descending); otherwise,          # inverted, we want to see feature 2 before feature 1 (descending); otherwise,
1529          # we want feature 1 before feature 2 (normal).          # we want feature 1 before feature 2 (normal).
1530            Trace("Coupling evidence for ($peg1, $peg2) with inversion flag $inverted.") if T(Coupling => 4);
1531          my $ordering = ($inverted ? "DESC" : "");          my $ordering = ($inverted ? "DESC" : "");
1532          # Get the coupling evidence.          # Get the coupling evidence.
1533          my @evidenceList = $self->GetAll(['IsEvidencedBy', 'PCH', 'UsesAsEvidence'],          my @evidenceList = $self->GetAll(['IsEvidencedBy', 'PCH', 'UsesAsEvidence'],
# Line 1534  Line 1541 
1541          while (@evidenceList > 0) {          while (@evidenceList > 0) {
1542              my $peg1Data = shift @evidenceList;              my $peg1Data = shift @evidenceList;
1543              my $peg2Data = shift @evidenceList;              my $peg2Data = shift @evidenceList;
1544                Trace("Peg 1 is " . $peg1Data->[1] . " and Peg 2 is " . $peg2Data->[1] . ".") if T(Coupling => 4);
1545              push @retVal, [$peg1Data->[1], $peg2Data->[1], $peg1Data->[0]];              push @retVal, [$peg1Data->[1], $peg2Data->[1], $peg1Data->[0]];
1546          }          }
1547            Trace("Last index in evidence result is is $#retVal.") if T(Coupling => 4);
1548      }      }
1549      # Return the result.      # Return the result.
1550      return @retVal;      return @retVal;
# Line 1585  Line 1594 
1594                                   [$retVal], ["ParticipatesInCoupling(from-link)", "Coupling(score)"]);                                   [$retVal], ["ParticipatesInCoupling(from-link)", "Coupling(score)"]);
1595      # Check to see if we found anything.      # Check to see if we found anything.
1596      if (!@pegs) {      if (!@pegs) {
1597            Trace("No coupling found.") if T(Coupling => 4);
1598          # No coupling, so undefine the return value.          # No coupling, so undefine the return value.
1599          $retVal = undef;          $retVal = undef;
1600      } else {      } else {
1601          # We have a coupling! Get the score and check for inversion.          # We have a coupling! Get the score and check for inversion.
1602          $score = $pegs[0]->[1];          $score = $pegs[0]->[1];
1603          $inverted = ($pegs[0]->[0] eq $peg1);          my $firstFound = $pegs[0]->[0];
1604            $inverted = ($firstFound ne $peg1);
1605            Trace("Coupling score is $score. First peg is $firstFound, peg 1 is $peg1.") if T(Coupling => 4);
1606      }      }
1607      # Return the result.      # Return the result.
1608      return ($retVal, $inverted, $score);      return ($retVal, $inverted, $score);
# Line 1695  Line 1707 
1707          if ($line =~ m/^>\s*(.+?)(\s|\n)/) {          if ($line =~ m/^>\s*(.+?)(\s|\n)/) {
1708              # Here we have a new header. Store the current sequence if we have one.              # Here we have a new header. Store the current sequence if we have one.
1709              if ($id) {              if ($id) {
1710                  $retVal{$id} = uc $sequence;                  $retVal{$id} = lc $sequence;
1711              }              }
1712              # Clear the sequence accumulator and save the new ID.              # Clear the sequence accumulator and save the new ID.
1713              ($id, $sequence) = ("$prefix$1", "");              ($id, $sequence) = ("$prefix$1", "");
1714          } else {          } else {
1715              # Here we have a data line, so we add it to the sequence accumulator.              # Here we have a data line, so we add it to the sequence accumulator.
1716              # First, we get the actual data out. Note that we normalize to upper              # First, we get the actual data out. Note that we normalize to lower
1717              # case.              # case.
1718              $line =~ /^\s*(.*?)(\s|\n)/;              $line =~ /^\s*(.*?)(\s|\n)/;
1719              $sequence .= $1;              $sequence .= $1;
# Line 1709  Line 1721 
1721      }      }
1722      # Flush out the last sequence (if any).      # Flush out the last sequence (if any).
1723      if ($sequence) {      if ($sequence) {
1724          $retVal{$id} = uc $sequence;          $retVal{$id} = lc $sequence;
1725      }      }
1726      # Close the file.      # Close the file.
1727      close FASTAFILE;      close FASTAFILE;
# Line 2035  Line 2047 
2047      # Get the parameters.      # Get the parameters.
2048      my ($self, $entityName, $entityID) = @_;      my ($self, $entityName, $entityID) = @_;
2049      # Check for the entity instance.      # Check for the entity instance.
2050        Trace("Checking existence of $entityName with ID=$entityID.") if T(4);
2051      my $testInstance = $self->GetEntity($entityName, $entityID);      my $testInstance = $self->GetEntity($entityName, $entityID);
2052      # Return an existence indicator.      # Return an existence indicator.
2053      my $retVal = ($testInstance ? 1 : 0);      my $retVal = ($testInstance ? 1 : 0);
# Line 2503  Line 2516 
2516  C<< my %subsystems = $sprout->SubsystemsOf($featureID); >>  C<< my %subsystems = $sprout->SubsystemsOf($featureID); >>
2517    
2518  Return a hash describing all the subsystems in which a feature participates. Each subsystem is mapped  Return a hash describing all the subsystems in which a feature participates. Each subsystem is mapped
2519  to the role the feature performs.  to the roles the feature performs.
2520    
2521  =over 4  =over 4
2522    
# Line 2513  Line 2526 
2526    
2527  =item RETURN  =item RETURN
2528    
2529  Returns a hash mapping all the feature's subsystems to the feature's role.  Returns a hash mapping all the feature's subsystems to a list of the feature's roles.
2530    
2531  =back  =back
2532    
2533  =cut  =cut
2534  #: Return Type %;  #: Return Type %@;
2535  sub SubsystemsOf {  sub SubsystemsOf {
2536      # Get the parameters.      # Get the parameters.
2537      my ($self, $featureID) = @_;      my ($self, $featureID) = @_;
# Line 2530  Line 2543 
2543      my %retVal = ();      my %retVal = ();
2544      # Loop through the results, adding them to the hash.      # Loop through the results, adding them to the hash.
2545      for my $record (@subsystems) {      for my $record (@subsystems) {
2546          $retVal{$record->[0]} = $record->[1];          my ($subsys, $role) = @{$record};
2547            if (exists $retVal{$subsys}) {
2548                push @{$retVal{$subsys}}, $role;
2549            } else {
2550                $retVal{$subsys} = [$role];
2551            }
2552      }      }
2553      # Return the hash.      # Return the hash.
2554      return %retVal;      return %retVal;

Legend:
Removed from v.1.19  
changed lines
  Added in v.1.27

MCS Webmaster
ViewVC Help
Powered by ViewVC 1.0.3