get Location expansion working

cjfields · Nov 20, 2011 · b3ac00c · b3ac00c
1 parent 8588113
commit b3ac00c
Show file tree

Hide file tree

Showing 10 changed files with 468 additions and 351 deletions.
diff --git a/lib/Biome/Factory/FTLocationFactory.pm b/lib/Biome/Factory/FTLocationFactory.pm
@@ -13,22 +13,22 @@ $LOCREG = qr{
             (??{$LOCREG})
             \)
             )*
-            }xmso;     
+            }xmso;
 
 # make global for now, allow for abstraction later
 our $SIMPLE_CLASS = 'Biome::Location::Simple';
 
-our $SPLIT_CLASS = 'Biome::Location::Split';
+#our $SPLIT_CLASS = 'Biome::Location::Split';
 
 sub BUILD {
     my ($self) = @_;
-    $self->load_modules($SIMPLE_CLASS,$SPLIT_CLASS);
+    $self->load_modules($SIMPLE_CLASS);
 }
 
 sub from_string {
     my ($self,$locstr,$op) = @_;
     my $loc;
-    
+
     # run on first pass only
     # Note : These location types are now deprecated in GenBank (Oct. 2006)
     if (!defined($op)) {
@@ -38,16 +38,16 @@ sub from_string {
         # we should never see the above
         $locstr =~ s{:\((\d+\.{2}\d+)\)}{:\[$1\]}g;
     }
-    
+
     if ($locstr =~ m{(.*?)\(($LOCREG)\)(.*)}o) { # any matching parentheses?
 
         my ($beg, $mid, $end) = ($1, $2, $3);
-        
+
         my @sublocs = grep {$_} (split(q(,),$beg), $mid, split(q(,),$end));
-        
+
         my @loc_objs;
         my $loc_obj;
-        
+
         SUBLOCS:
         while (@sublocs) {
             my $subloc = shift @sublocs;
@@ -64,7 +64,7 @@ sub from_string {
                         $self->throw("getting nested l") unless $oparg eq 'complement';
                         $loc_obj = $SIMPLE_CLASS->new(location_string => "complement($splitlocs[0])");
                     } else {
-                        $loc_obj = $SPLIT_CLASS->new(-verbose => 1,
+                        $loc_obj = $SIMPLE_CLASS->new(-verbose => 1,
                                                     -location_type => uc $oparg);
                         while (my $splitloc = shift @splitlocs) {
                             next unless $splitloc;
@@ -90,7 +90,7 @@ sub from_string {
                     }
                 }
             }
-            # no operator, simple or fuzzy 
+            # no operator, simple or fuzzy
             else {
                 $loc_obj = $self->from_string($subloc,1);
             }
@@ -104,7 +104,7 @@ sub from_string {
                          scalar(@loc_objs).", should be SplitLocationI");
         }
         if ($ct > 1) {
-            $loc = $SPLIT_CLASS->new();
+            $loc = $SIMPLE_CLASS->new();
             $loc->add_sub_Location(shift @loc_objs) while (@loc_objs);
             return $loc;
         } else {
@@ -166,7 +166,7 @@ May include numerous subsections (i.e., =head2, =head3, etc.).
  Title   : _parse_location
  Usage   : $loc = $locfactory->_parse_location( $loc_string)
 
- Function: Parses the given location string and returns a location object 
+ Function: Parses the given location string and returns a location object
            with start() and end() and strand() set appropriately.
            Note that this method is private.
  Returns : A Bio::LocationI implementing object or undef on failure
@@ -217,12 +217,12 @@ BioPerl mailing lists. Your participation is much appreciated.
 
 Patches are always welcome.
 
-=head2 Support 
- 
+=head2 Support
+
 Please direct usage questions or support issues to the mailing list:
-  
+
 L<bioperl-l@bioperl.org>
-  
+
 rather than to the module maintainer directly. Many experienced and reponsive
 experts will be able look at the problem and quickly address it. Please include
 a thorough description of the problem with code and data examples if at all
@@ -335,15 +335,15 @@ the Bioperl mailing list.  Your participation is much appreciated.
   bioperl-l@bioperl.org                  - General discussion
   http://bioperl.org/wiki/Mailing_lists  - About the mailing lists
 
-=head2 Support 
+=head2 Support
 
 Please direct usage questions or support issues to the mailing list:
 
 I<bioperl-l@bioperl.org>
 
-rather than to the module maintainer directly. Many experienced and 
-reponsive experts will be able look at the problem and quickly 
-address it. Please include a thorough description of the problem 
+rather than to the module maintainer directly. Many experienced and
+reponsive experts will be able look at the problem and quickly
+address it. Please include a thorough description of the problem
 with code and data examples if at all possible.
 
 =head2 Reporting Bugs
@@ -367,4 +367,3 @@ Chris Fields, cjfields-at-uiuc-dot-edu
 
 The rest of the documentation details each of the object methods.
 Internal methods are usually preceded with a _
-
diff --git a/lib/Biome/Location/Simple.pm b/lib/Biome/Location/Simple.pm
@@ -12,24 +12,25 @@ use namespace::clean -except => 'meta';
 # class can override
 
 with 'Biome::Role::Location::Simple';
+with 'Biome::Role::Location::Split';
 with 'Biome::Role::Location::Locatable';
 
 sub BUILD {
     my ($self, $params) = @_;
-    
+
     if ($params->{location_string}) {
         $self->throw("Can't use 'location_string' with other parameters")
             if (scalar(keys %$params) > 1);
         $self->from_string($params->{location_string});
     }
-    
+
     if ($params->{start} && $params->{end} && ($params->{end} < $params->{start})) {
         $self->warn('End is greater than start; flipping strands');
         $self->end($params->{start});
         $self->start($params->{end});
         $self->strand($self->strand * -1);
     }
-    
+
     $params->{location_type} && $self->location_type($params->{location_type});
 }
 

diff --git a/lib/Biome/Location/Split.pm b/lib/Biome/Location/Split.pm
@@ -4,20 +4,10 @@ package Biome::Location::Split;
 use Biome;
 use namespace::clean -except => 'meta';
 
-with 'Biome::Role::Location::Split';
-with 'Biome::Role::Location::Locatable';
-
-sub BUILD {
-    my ($self, $params) = @_;
-    if ($params->{location_string}) {
-        $self->throw("Can't use 'location_string' with other parameters")
-            if (scalar(keys %$params) > 1);
-        $self->from_string($params->{location_string});
-    }
-}
+extends 'Biome::Location::Simple';
 
 __PACKAGE__->meta->make_immutable;
 
 1;
 
-__END__
+__END__
diff --git a/lib/Biome/Role/Location/Locatable.pm b/lib/Biome/Role/Location/Locatable.pm
@@ -86,9 +86,9 @@ sub intersection {
         }
 
         my $compare = shift(@ranges);
-        
+
         last if !defined $compare;
-        
+
         if (!$compare->_testStrand($intersect, $so)) {
             return
         }
@@ -115,21 +115,28 @@ sub intersection {
                                     -strand => $intersect_strand);
         }
     }
-    return $intersect;     
+    if (wantarray()) {
+        return ($intersect->start, $intersect->end, $intersect->strand);
+    } else {
+        return $intersect;
+    }
 }
 
 sub union {
     my ($self, $given, $so) = @_;
-
-    # strand test doesn't matter here 
-
+
+    if (ref $given ne 'ARRAY') {
+        $given = [$given];
+    }
+    # strand test doesn't matter here
+
     $self->_eval_ranges(@$given);
-    
+
     my @start = sort {$a <=> $b} map { $_->start() } ($self, @$given);
     my @end   = sort {$a <=> $b} map { $_->end()   } ($self, @$given);
 
     my $start = shift @start;
-    while( !defined $start ) {
+    while( !$start ) {
         $start = shift @start;
     }
 
@@ -144,10 +151,14 @@ sub union {
         }
     }
     return unless $start || $end;
-    return (blessed $self)->new('-start' => $start,
-                      '-end' => $end,
-                      '-strand' => $union_strand
-                      );
+    if( wantarray() ) {
+		return ( $start,$end,$union_strand);
+    } else {
+        return (blessed $self)->new('-start' => $start,
+                          '-end' => $end,
+                          '-strand' => $union_strand
+                          );
+    }
 }
 
 ### Other methods
@@ -199,38 +210,38 @@ sub subtract {
         return $self;  # no Range; maybe this should be Range?
     }
 
-    # Subtracts everything (empty Range of length = 0 and strand = 0 
+    # Subtracts everything (empty Range of length = 0 and strand = 0
     if ($self->equals($range) || $range->contains($self)) {
         return (blessed $self)->new(-start => 0, -end => 0, -strand => 0);
     }
 
     my $int = $self->intersection($range, $so);
     my ($start, $end, $strand) = ($int->start, $int->end, $int->strand);
-    
+
     #Subtract intersection from $self
     my @outranges = ();
     if ($self->start < $start) {
-        push(@outranges, 
+        push(@outranges,
 		 (blessed $self)->new(
                 '-start'=> $self->start,
 			    '-end'=>$start - 1,
 			    '-strand'=>$self->strand,
 			   ));
     }
     if ($self->end > $end) {
-        push(@outranges, 
+        push(@outranges,
 		 (blessed $self)->new('-start'=>$end + 1,
 			    '-end'=>$self->end,
 			    '-strand'=>$self->strand,
-			   ));   
+			   ));
     }
     return @outranges;
 }
 
 # should be genericized for nonstranded Ranges.  I'm not sure about
 # modifying the object in place...
 
-sub offset_stranded { 
+sub offset_stranded {
     my ($self, $offset_fiveprime, $offset_threeprime) = @_;
     my ($offset_start, $offset_end) = $self->strand() eq -1 ?
         (- $offset_threeprime, - $offset_fiveprime) :
@@ -246,7 +257,7 @@ sub offset_stranded {
 sub _eval_ranges {
     my ($self, @ranges) = @_;
     #$self->throw("start is undefined in calling instance") if !defined $self->start;
-    #$self->throw("end is undefined in calling instance") if !defined $self->end;    
+    #$self->throw("end is undefined in calling instance") if !defined $self->end;
     for my $obj ($self, @ranges) {
         $self->throw("Not an object") unless ref($obj);
         $self->throw("start is undefined in instance ".$obj->to_string) if !defined $obj->start;
@@ -487,12 +498,12 @@ BioPerl mailing lists. Your participation is much appreciated.
 
 Patches are always welcome.
 
-=head2 Support 
- 
+=head2 Support
+
 Please direct usage questions or support issues to the mailing list:
-  
+
 L<bioperl-l@bioperl.org>
-  
+
 rather than to the module maintainer directly. Many experienced and reponsive
 experts will be able look at the problem and quickly address it. Please include
 a thorough description of the problem with code and data examples if at all