[Bioperl-guts-l] bioperl commit

[Lincoln Stein]

lstein
Tue Jul 20 18:00:10 EDT 2004
Update of /home/repository/bioperl/bioperl-live/Bio/DB/GFF
In directory pub.open-bio.org:/tmp/cvs-serv8771/Bio/DB/GFF

Modified Files:
	Aggregator.pm 
Log Message:
fixed a problem in which features with same groups but different sources got aggregated together even when user requests sources explicitly

bioperl-live/Bio/DB/GFF Aggregator.pm,1.28,1.29
===================================================================
RCS file: /home/repository/bioperl/bioperl-live/Bio/DB/GFF/Aggregator.pm,v
retrieving revision 1.28
retrieving revision 1.29
diff -u -r1.28 -r1.29
--- /home/repository/bioperl/bioperl-live/Bio/DB/GFF/Aggregator.pm	2004/05/28 13:23:25	1.28
+++ /home/repository/bioperl/bioperl-live/Bio/DB/GFF/Aggregator.pm	2004/07/20 22:00:09	1.29
@@ -290,16 +290,20 @@
 
   my $main_method = $self->get_main_name;
   my $matchsub    = $self->match_sub($factory) or return;
+  my $strictmatch = $self->strict_match();
   my $passthru    = $self->passthru_sub($factory);
 
   my (%aggregates, at result);
   for my $feature (@$features) {
 
     if ($feature->group && $matchsub->($feature)) {
+      my $key = $strictmatch->{lc $feature->method,lc $feature->source} 
+          ? join ($;,$feature->group,$feature->refseq,$feature->source)
+          : join ($;,$feature->group,$feature->refseq);
       if ($main_method && lc $feature->method eq lc $main_method) {
-	$aggregates{$feature->group,$feature->refseq}{base} ||= $feature->clone;
+	$aggregates{$key}{base} ||= $feature->clone;
       } else {
-	push @{$aggregates{$feature->group,$feature->refseq}{subparts}},$feature;
+	push @{$aggregates{$key}{subparts}},$feature;
       }
       push @result,$feature if $passthru && $passthru->($feature);
 
@@ -444,6 +448,28 @@
   return $factory->make_match_sub($types_to_aggregate);
 }
 
+=head2 strict_match
+
+ Title   : strict_match
+ Usage   : $strict = $a->strict_match
+ Function: generate a hashref that indicates which subfeatures
+           need to be tested strictly for matching sources before
+           aggregating
+ Returns : a hash ref
+ Status  : Internal
+
+=cut
+
+sub strict_match {
+  my $self = shift;
+  my $types_to_aggregate = $self->components();
+  my %strict;
+  for my $t (@$types_to_aggregate) {
+    $strict{lc $t->[0],lc $t->[1]}++ if defined $t->[1];
+  }
+  \%strict;
+}
+
 sub passthru_sub {
   my $self    = shift;
   my $factory = shift;