[Bio] / FigKernelPackages / FIG.pm Repository:
ViewVC logotype

Diff of /FigKernelPackages/FIG.pm

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

revision 1.433, Mon Jan 30 19:36:04 2006 UTC revision 1.434, Tue Jan 31 04:09:13 2006 UTC
# Line 1380  Line 1380 
1380      if (! defined $distance) {      if (! defined $distance) {
1381          $distance = 5000;          $distance = 5000;
1382      }      }
1383      # Create a hash of the PEG IDs we're considering for cluster membership.  
1384      my %myPeg = map { $_ => 1 } @{$pegList};      my($peg,%by_contig);
1385      # This next hash serves as our connection graph. We map each PEG to a list of      foreach $peg (@$pegList)
1386      # the PEGs that are near it. The GREP filter insures that a PEG is not      {
1387      # connected to itself and that only PEGs from the caller's list are          my $loc;
1388      # included.          if ($loc = $self->feature_location($peg))
1389      my %conn = ();          {
1390      for my $peg (keys %myPeg) {              my ($contig,$beg,$end) = &FIG::boundaries_of($loc);
1391          $conn{$peg} =              my $genome = &FIG::genome_of($peg);
1392              [grep { $myPeg{$_} && ($_ ne $peg) } $self->close_genes($peg, $distance)];              push(@{$by_contig{"$genome\t$contig"}},[($beg+$end)/2,$peg]);
1393      }          }
1394      # Our third and final hash tracks the PEGs we've already processed. This prevents      }
1395      # a PEG from being put in more than one cluster or in the same cluster twice.  
     my %seen = ();  
     # Now we create the list of clusters.  
1396      my @clusters = ();      my @clusters = ();
1397      # Loop through the pegs.      foreach my $tuple (keys(%by_contig))
1398      for my $peg (keys %myPeg) {      {
1399          # Only proceed if this PEG has not been put into a cluster.          my $x = $by_contig{$tuple};
1400          if (! $seen{$peg}) {          my @pegs = sort { $a->[0] <=> $b->[0] } @$x;
1401              # Create a new cluster for this PEG.          while ($x = shift @pegs)
1402              my $subList = [$peg];          {
1403              # Denote we've seen it.              my $clust = [$x->[1]];
1404              $seen{$peg} = 1;              while ((@pegs > 0) && (abs($pegs[0]->[0] - $x->[0]) <= $distance))
1405              # Now we recursively build this cluster. The "$subList" acts as a              {
1406              # queue. We run through it from the beginning, adding connected                  $x = shift @pegs;
1407              # pegs to the list. The process stops when we run out of new PEGs to                  push(@$clust,$x->[1]);
             # add.  
             for (my $i=0; $i < @$subList; $i++) {  
                 # Get a list of the PEGs connected to the current cluster PEG.  
                 # Only PEGs we haven't clustered yet will be processed.  
                 my $subPeg = $subList->[$i];  
                 my @tmp = grep { ! $seen{$_} } @{$conn{$subPeg}};  
                 # Only proceed if we found at least one new PEG.  
                 if (@tmp > 0) {  
                     # For each new PEG, denote we've seen it and  
                     # stuff it into the queue.  
                     for my $peg1 (@tmp) { $seen{$peg1} = 1 }  
                     push @$subList, @tmp;  
                 }  
             }  
             # If the queue we've built is not a singleton, we push it on  
             # the master cluster list.  
             if (@$subList > 1) {  
                 push @clusters, $subList;  
1408              }              }
1409    
1410                if (@$clust > 1)
1411                {
1412                    push(@clusters,$clust);
1413          }          }
1414      }      }
1415      # Sort the clusters by length. The shortest clusters will be bubbled to      }
1416      # the front.      return sort { @$b <=> @$a }  @clusters;
     my @retVal = sort { @$a <=> @$b } @clusters;  
     # Return the sorted and pruned cluster list.  
     return @retVal;  
1417  }  }
1418    
1419  =head3 get_sim_pool_info  =head3 get_sim_pool_info

Legend:
Removed from v.1.433  
changed lines
  Added in v.1.434

MCS Webmaster
ViewVC Help
Powered by ViewVC 1.0.3