[Bioperl-guts-l] bioperl-live/Bio/Graphics/Glyph segments.pm, 1.49, 1.50

[Lincoln Stein]

Update of /home/repository/bioperl/bioperl-live/Bio/Graphics/Glyph
In directory dev.open-bio.org:/tmp/cvs-serv4016/Bio/Graphics/Glyph

Modified Files:
	segments.pm 
Log Message:
fixed boundaries of parent target (in an alignment) to span boundaries of child targets

Index: segments.pm
===================================================================
RCS file: /home/repository/bioperl/bioperl-live/Bio/Graphics/Glyph/segments.pm,v
retrieving revision 1.49
retrieving revision 1.50
diff -C2 -d -r1.49 -r1.50
*** segments.pm	27 Sep 2006 20:23:50 -0000	1.49
--- segments.pm	28 Sep 2006 01:17:42 -0000	1.50
***************
*** 123,127 ****
    my ($left,$top,$partno,$total_parts) = @_;
  
- 
    my $flipped              = $self->flip;
    my $ragged_extra         = $self->option('ragged_start') 
--- 123,126 ----
***************
*** 142,152 ****
    my $drew_sequence;
  
!   my ($bl,$bt,$br,$bb)     = $self->bounds($left,$top);
!   $self->filled_box($gd,$bl,$bt,$br,$bb,$self->bgcolor,$self->bgcolor);
  
    $top = $bt;
  
    my @s                     = $self->_subfeat($feature);
!   # workaround for features in which top level featuare does not have a hit but
    # subfeatures do. There is total breakage of encapsulation here because sometimes
    # a chado alignment places the aligned segment in the top-level feature, and sometimes
--- 141,158 ----
    my $drew_sequence;
  
!   warn "TGT_START..TGT_END = $tgt_start..$tgt_end" if DEBUG;
  
+   my ($bl,$bt,$br,$bb)     = $self->bounds($left,$top);
    $top = $bt;
  
+   for my $p ($self->parts) {
+     my @bounds = $p->bounds($left,$top);
+     $self->filled_box($gd, at bounds,$self->bgcolor,$self->bgcolor);
+   }
+ 
    my @s                     = $self->_subfeat($feature);
! 
!   # FIX ME
!   # workaround for features in which top level feature does not have a hit but
    # subfeatures do. There is total breakage of encapsulation here because sometimes
    # a chado alignment places the aligned segment in the top-level feature, and sometimes
***************
*** 165,168 ****
--- 171,175 ----
  
      my ($tgt_start,$tgt_end) = ($target->start,$target->end);
+ 
      unless (exists $strands{$target}) {
        my $strand = $feature->strand;
***************
*** 283,287 ****
      }
  
!     warn "Clipping gives [@$seg]\n"if DEBUG;
    }
  
--- 290,294 ----
      }
  
!     warn "Clipping gives [@$seg], tgt_start = $tgt_start\n" if DEBUG;
    }
  
***************
*** 297,300 ****
--- 304,309 ----
      $seg->[TGT_START] -= $tgt_start - 1;
      $seg->[TGT_END]   -= $tgt_start - 1;
+ 
+     warn $seg->[TGT_START],"..",$seg->[TGT_END] if DEBUG;
      if ($strand < 0) {
        ($seg->[TGT_START],$seg->[TGT_END]) = (length($tgt_dna)-$seg->[TGT_END]+1,length($tgt_dna)-$seg->[TGT_START]+1);
***************
*** 330,334 ****
    my ($tgt_last_end,$src_last_end);
    for my $seg (sort {$a->[SRC_START]<=>$b->[SRC_START]} @segments) {
- 
      my $y = $top-1;
  
--- 339,342 ----
***************
*** 337,340 ****
--- 345,349 ----
        my $src_base = $self->_subsequence($ref_dna,$seg->[SRC_START]+$i,$seg->[SRC_START]+$i);
        my $tgt_base = $self->_subsequence($tgt_dna,$seg->[TGT_START]+$i,$seg->[TGT_START]+$i);
+       # warn $seg->[TGT_START]+$i,' ',$seg->[TGT_START]+$i;
        my $x = $base2pixel->($seg->[SRC_START],$i);
  
***************
*** 365,369 ****
  
  	$self->filled_box($gd,$gap_left,$y+1,
! 			      $gap_right-2,$y+$lineheight,$mismatch,$mismatch) if $show_mismatch && $gap_left >= $panel_left;
  
  
--- 374,379 ----
  
  	$self->filled_box($gd,$gap_left,$y+1,
! 			      $gap_right-2,$y+$lineheight,$mismatch,$mismatch) if 
! 				$show_mismatch && $gap_left >= $panel_left && $gap_right <= $panel_right;