commit changes in place, may revert back to master

cjfields · Feb 10, 2012 · 145fa86 · 145fa86
1 parent a384c7c
commit 145fa86
Show file tree

Hide file tree

Showing 7 changed files with 73 additions and 56 deletions.
diff --git a/Build.PL b/Build.PL
@@ -17,36 +17,36 @@ my $build = Module::Build->new(
     dist_abstract       => 'Moose-based implementation of core BioPerl modules',
     license             => 'perl',
     requires            => {'perl'                      => 5.010,
-                            
+
                             # replacement for pushback in IO streams
                             'IO::Unread'                => 0,
-                            
+
                             # needed for Native Types (replacement for MXAH)
                             'Moose'                         => '1.00',
                             # tentative list of MooseX modules, for comments
                             # see CONVENTIONS
                             #'MooseX::Singleton'             => 0,
-                            
+
                             # use sparingly (instances where this is used may be
                             # switched over to something simpler)
                             'MooseX::ClassAttribute'        => 0,
-                            
+
                             # compat with Moose 0.90
                             'MooseX::Types'                 => 0.20,
                             #'MooseX::Types::Structured'     => 0,  # extended types
-                            
+
                             # Flexibility for attribute definitions
                             'MooseX::Role::Parameterized'   => 0,
-                            
+
                             # init, attribute, method aliases
                             'MooseX::Aliases'               => 0.03,
-                            
+
                             # not used ATM, but worth considering
                             #'MooseX::Params::Validate'      => 0,  # replace rearrange?
 
                             # general use
                             'Modern::Perl'                  => 0,
-                            'List::MoreUtils'               => 0, 
+                            'List::MoreUtils'               => 0,
                             'Data::Stag'                    => 0
                            },
     build_requires      => {
@@ -57,4 +57,3 @@ my $build = Module::Build->new(
 
 # Create the build script and exit
 $build->create_build_script;
-
diff --git a/lib/Biome/Role/Location/Locatable.pm b/lib/Biome/Role/Location/Locatable.pm
@@ -2,7 +2,7 @@ package Biome::Role::Location::Locatable;
 
 use Biome::Role;
 use namespace::clean -except => 'meta';
-use List::Util qw(max min);
+use List::Util qw(max min reduce);
 
 requires qw(start end strand from_string to_string);
 
@@ -130,14 +130,11 @@ sub union {
     if (ref $given ne 'ARRAY') {
         $given = [$given];
     }
-    # strand test doesn't matter here
 
     $self->_eval_ranges(@$given);
 
-    my $id = $self->seq_id;
-
-    my $start = min map { $_->start() } ($self, @$given);
-    my $end   = max map { $_->end()   } ($self, @$given);
+	# cannot give union if a contained location is remote
+	return if grep { $_->is_remote } ($self, @$given);
 
     my $union_strand = $self->strand;  # Strand for the union range object.
 
@@ -147,15 +144,30 @@ sub union {
             last;
         }
     }
-    return unless $start || $end;
-    if( wantarray() ) {
-		return ( $start,$end,$union_strand);
-    } else {
-        return (blessed $self)->new('-start' => $start,
-                          '-end' => $end,
-                          '-strand' => $union_strand
+
+	my $five_prime = reduce { $a->start < $b->start ? $a : $b } ($self, @$given);
+	my $three_prime = reduce { $a->end > $b->end ? $a : $b } ($self, @$given);
+
+	print STDERR "5':".$five_prime->to_string."\n";
+	print STDERR "3':".$three_prime->to_string."\n";
+
+	#my ($start, $end) = ($five_prime->start, $three_prime->end);
+	return unless $five_prime || $three_prime;
+
+#    if( wantarray() ) {
+#		return ( $start,$end,$union_strand);
+#    } else {
+        return (blessed $self)->new(-start => $five_prime->start,
+									#-min_start	=> $five_prime->min_start,
+									#-max_start	=> $five_prime->max_start,
+									#-start_pos_type	=> $five_prime->start_pos_type,
+									-end => $three_prime->end,
+									-min_end => $three_prime->min_end,
+									-max_end => $three_prime->max_end,
+									#-end_pos_type	=> $five_prime->end_pos_type,
+									'-strand' => $union_strand
                           );
-    }
+    #}
 }
 
 ### Other methods

diff --git a/lib/Biome/Role/Location/Simple.pm b/lib/Biome/Role/Location/Simple.pm
@@ -17,7 +17,7 @@ has 'start' => (
     is          => 'rw',
     default     => 0,
 
-    # may remove these and move to a validate() root method (see below)
+    # TODO: may remove these and move to a validate() root method (see below)
     trigger     => sub {
         my ($self, $start) = @_;
         my $end = $self->end;
@@ -35,7 +35,7 @@ has 'end' => (
     is          => 'rw',
     default     => 0,
 
-    # may remove these and add a validate() root method (see below)
+    # TODO: may remove these and add a validate() root method (see below)
     trigger     => sub {
         my ($self, $end) = @_;
         my $start = $self->start;

diff --git a/lib/Biome/Role/Location/Split.pm b/lib/Biome/Role/Location/Split.pm
@@ -7,8 +7,8 @@ use Biome::Type::Sequence qw(Maybe_Sequence_Strand);
 use List::Util qw(reduce);
 use namespace::clean -except => 'meta';
 
-# TODO: This will be made a parameterized role at some point, as the
-# attribute should be named based on the consuming class
+# TODO: make this a parameterized role at some point? The
+# attributes and methods could be named based on the consuming class...
 
 has     'locations'  => (
     is          => 'ro',
@@ -18,7 +18,7 @@ has     'locations'  => (
     writer      => '_set_locations',
     handles     => {
         #  override this to allow for expansion of parent location
-        push_sub_Location     => 'push',
+        #push_sub_Location     => 'push',
         sub_Locations         => 'elements',
         remove_sub_Locations  => 'clear',
         get_sub_Location      => 'get',
@@ -43,20 +43,27 @@ sub add_sub_Location {
 
     my $locs = $self->locations;
 
-    if ($self->auto_expand) {
-        if (@$locs) {
-            if (!$loc->is_remote) {
-                my ($start,$end,$strand) = $self->union($loc);
-                $self->strand($strand);
-                $self->start($start);
-                $self->end($end);
-            }
-        } else {
-            $self->start($loc->start);
-            $self->end($loc->end);
-            $self->strand($loc->strand);
-            $self->seq_id($loc->seq_id) if $loc->seq_id;
-        }
+    #if ($self->auto_expand && !$loc->is_remote) {
+    #    my ($start,$end,$strand) = @$locs ? ($self->union($loc)) :
+    #        ($loc->start, $loc->end, $loc->strand);
+    #    $self->strand($strand);
+    #    $self->start($start);
+    #    $self->end($end);
+    #    $self->seq_id($loc->seq_id) if $loc->seq_id && @$locs;
+    #}
+
+    if ($self->auto_expand && !$loc->is_remote) {
+        my $union_loc =  @$locs ? $self->union($locs) : $loc;
+        print STDERR "Union:".$union_loc->to_string."\n";
+
+        $self->strand($union_loc->strand);
+        $self->start($union_loc->start);
+        $self->end($union_loc->end);
+        #$self->max_start($loc->max_start);
+        #$self->min_start($loc->min_start);
+        #$self->start_pos_type($loc->start_pos_type);
+        #$self->end_pos_type($loc->end_pos_type);
+        $self->seq_id($loc->seq_id) if $loc->seq_id && @$locs;
     }
 
     push @$locs, $loc;

diff --git a/lib/Biome/Role/Location/Stranded.pm b/lib/Biome/Role/Location/Stranded.pm
@@ -28,11 +28,11 @@ a strand attribute (i.e. DNA)
        with 'Biome::Role::Location::Stranded';
        # other stuff here
    }
-   
+
    my $thingy = Foo->new(-strand => 1);
 
    # later...
-   
+
    if ($thingy->does('Biome::Role::Location::Stranded') {
         ....
    }
@@ -99,12 +99,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

diff --git a/lib/Biome/Type/Location.pm b/lib/Biome/Type/Location.pm
@@ -17,8 +17,7 @@ use MooseX::Types -declare => [qw(
                                Split_Location_Type
 
                                Locatable
-                               ArrayRef_of_Locatable
-							   )];
+                               ArrayRef_of_Locatable)];
 
 use MooseX::Types::Moose qw(Int Str Object CodeRef Any ArrayRef);
 

diff --git a/t/Factory/FTLocationFactory.t b/t/Factory/FTLocationFactory.t
@@ -72,17 +72,17 @@ my %testcases = (
 
     # SPLITS
 
-    # this isn't a legal location string (can't have two remote locations),
-    # though it is handled; in this case the leftmost string is assumed to be
-    # the 'home' location
+    # this isn't a legal split location string AFAIK (can't have two remote
+    # locations), though it is handled. In this case the parent location can't
+    # be used in any location-based analyses (has no start, end, etc.)
 
     "join(AY016290.1:108..185,AY016291.1:1546..1599)"=> [0,
-        108, 108, "EXACT", 185, 185, "EXACT", "JOIN", 2, undef, 'AY016290.1'],
+        undef, undef, "EXACT", undef, undef, "EXACT", "JOIN", 2, 0, undef],
 
     "join(12..78,134..202)" => [0,
         12, 12, "EXACT", 202, 202, "EXACT", "JOIN", 2, 1, undef],
-    #"join(<12..78,134..202)" => [0,
-    #    undef, 12, undef, 202, 202, "EXACT", "JOIN", 2, 1, undef],
+    "join(<12..78,134..202)" => [0,
+        undef, 12, undef, 202, 202, "EXACT", "JOIN", 2, 1, undef],
     "complement(join(2691..4571,4918..5163))" => [0,
         2691, 2691, "EXACT", 5163, 5163, "EXACT", "JOIN", 2, -1, undef],
     "complement(join(4918..5163,2691..4571))" => [0,