|
0
|
1 package Bio::Graphics::Glyph::segments;
|
|
|
2 #$Id: segments.pm,v 1.21.2.1 2003/07/05 00:32:04 lstein Exp $
|
|
|
3
|
|
|
4 use strict;
|
|
|
5 use Bio::Location::Simple;
|
|
|
6 use Bio::Graphics::Glyph::generic;
|
|
|
7 use Bio::Graphics::Glyph::segmented_keyglyph;
|
|
|
8 use vars '@ISA';
|
|
|
9
|
|
|
10 use constant RAGGED_START_FUZZ => 25; # will show ragged ends of alignments
|
|
|
11 # up to this many bp.
|
|
|
12 use constant DEBUG => 0;
|
|
|
13
|
|
|
14 @ISA = qw( Bio::Graphics::Glyph::segmented_keyglyph
|
|
|
15 Bio::Graphics::Glyph::generic
|
|
|
16 );
|
|
|
17
|
|
|
18 my %complement = (g=>'c',a=>'t',t=>'a',c=>'g',n=>'n',
|
|
|
19 G=>'C',A=>'T',T=>'A',C=>'G',N=>'N');
|
|
|
20
|
|
|
21 sub pad_left {
|
|
|
22 my $self = shift;
|
|
|
23 return $self->SUPER::pad_left unless $self->option('draw_target') && $self->option('ragged_start') && $self->dna_fits;
|
|
|
24 return $self->SUPER::pad_left unless $self->level > 0;
|
|
|
25 my $target = eval {$self->feature->hit} or return $self->SUPER::pad_left;
|
|
|
26 return $self->SUPER::pad_left unless $target->start<$target->end && $target->start < RAGGED_START_FUZZ;
|
|
|
27 return ($target->start-1) * $self->scale;
|
|
|
28 }
|
|
|
29
|
|
|
30 sub pad_right {
|
|
|
31 my $self = shift;
|
|
|
32 return $self->SUPER::pad_right unless $self->level > 0;
|
|
|
33 return $self->SUPER::pad_right unless $self->option('draw_target') && $self->option('ragged_start') && $self->dna_fits;
|
|
|
34 my $target = eval {$self->feature->hit} or return $self->SUPER::pad_right;
|
|
|
35 return $self->SUPER::pad_right unless $target->end < $target->start && $target->start < RAGGED_START_FUZZ;
|
|
|
36 return ($target->end-1) * $self->scale;
|
|
|
37 }
|
|
|
38
|
|
|
39 # group sets connector to 'solid'
|
|
|
40 sub connector {
|
|
|
41 my $self = shift;
|
|
|
42 return $self->SUPER::connector(@_) if $self->all_callbacks;
|
|
|
43 return ($self->SUPER::connector(@_) || 'solid');
|
|
|
44 }
|
|
|
45
|
|
|
46 # never allow our components to bump
|
|
|
47 sub bump {
|
|
|
48 my $self = shift;
|
|
|
49 return $self->SUPER::bump(@_) if $self->all_callbacks;
|
|
|
50 return 0;
|
|
|
51 }
|
|
|
52
|
|
|
53 sub fontcolor {
|
|
|
54 my $self = shift;
|
|
|
55 return $self->SUPER::fontcolor unless $self->option('draw_target') || $self->option('draw_dna');
|
|
|
56 return $self->SUPER::fontcolor unless $self->dna_fits;
|
|
|
57 return $self->bgcolor;
|
|
|
58 }
|
|
|
59
|
|
|
60 sub draw_component {
|
|
|
61 my $self = shift;
|
|
|
62 my ($draw_dna,$draw_target) = ($self->option('draw_dna'),$self->option('draw_target'));
|
|
|
63 return $self->SUPER::draw_component(@_)
|
|
|
64 unless $draw_dna || $draw_target;
|
|
|
65 return $self->SUPER::draw_component(@_) unless $self->dna_fits;
|
|
|
66
|
|
|
67 my $dna = $draw_target ? eval {$self->feature->hit->seq}
|
|
|
68 : eval {$self->feature->seq};
|
|
|
69 return $self->SUPER::draw_component(@_) unless length $dna > 0; # safety
|
|
|
70
|
|
|
71 my $show_mismatch = $draw_target && $self->option('show_mismatch');
|
|
|
72 my $genomic = eval {$self->feature->seq} if $show_mismatch;
|
|
|
73
|
|
|
74 my $gd = shift;
|
|
|
75 my ($x1,$y1,$x2,$y2) = $self->bounds(@_);
|
|
|
76
|
|
|
77 # adjust for nonaligned left end (for ESTs...) The size given here is roughly sufficient
|
|
|
78 # to show a polyA end or a C. elegans trans-spliced leader.
|
|
|
79 my $offset = 0;
|
|
|
80 eval { # protect against data structures that don't implement the target() method.
|
|
|
81 if ($draw_target && $self->option('ragged_start')){
|
|
|
82 my $target = $self->feature->hit;
|
|
|
83 if ($target->start < $target->end && $target->start < RAGGED_START_FUZZ
|
|
|
84 && $self->{partno} == 0) {
|
|
|
85 $offset = $target->start - 1;
|
|
|
86 if ($offset > 0) {
|
|
|
87 $dna = $target->subseq(1-$offset,0)->seq . $dna;
|
|
|
88 $genomic = $self->feature->subseq(1-$offset,0)->seq . $genomic;
|
|
|
89 $x1 -= $offset * $self->scale;
|
|
|
90 }
|
|
|
91 }
|
|
|
92 elsif ($target->end < $target->start &&
|
|
|
93 $target->end < RAGGED_START_FUZZ && $self->{partno} == $self->{total_parts}) {
|
|
|
94 $offset = $target->end - 1;
|
|
|
95 if ($offset > 0) {
|
|
|
96 $dna .= $target->factory->get_dna($target,$offset,1);
|
|
|
97 $genomic = $self->feature->subseq(-$offset,0)->seq . $genomic;
|
|
|
98 $x2 += $offset * $self->scale;
|
|
|
99 $offset = 0;
|
|
|
100 }
|
|
|
101 }
|
|
|
102 }
|
|
|
103 };
|
|
|
104
|
|
|
105 $self->draw_dna($gd,$offset,lc $dna,lc $genomic,$x1,$y1,$x2,$y2);
|
|
|
106 }
|
|
|
107
|
|
|
108 sub draw_dna {
|
|
|
109 my $self = shift;
|
|
|
110
|
|
|
111 my ($gd,$start_offset,$dna,$genomic,$x1,$y1,$x2,$y2) = @_;
|
|
|
112 my $pixels_per_base = $self->scale;
|
|
|
113 my $feature = $self->feature;
|
|
|
114 my $target = $feature->target;
|
|
|
115 my $strand = $feature->strand;
|
|
|
116
|
|
|
117 my @segs;
|
|
|
118
|
|
|
119 my $complement = $strand < 0;
|
|
|
120
|
|
|
121 if ($self->{flip}) {
|
|
|
122 $dna = $self->reversec($dna);
|
|
|
123 $genomic = $self->reversec($genomic);
|
|
|
124 $strand *= -1;
|
|
|
125 }
|
|
|
126
|
|
|
127 warn "strand = $strand, complement = $complement" if DEBUG;
|
|
|
128
|
|
|
129 if ($genomic && length($genomic) != length($dna) && eval { require Bio::Graphics::Browser::Realign}) {
|
|
|
130 warn "$genomic\n$dna\n" if DEBUG;
|
|
|
131 warn "strand = $strand" if DEBUG;
|
|
|
132 @segs = Bio::Graphics::Browser::Realign::align_segs($genomic,$dna);
|
|
|
133 for my $seg (@segs) {
|
|
|
134 my $src = substr($genomic,$seg->[0],$seg->[1]-$seg->[0]+1);
|
|
|
135 my $tgt = substr($dna, $seg->[2],$seg->[3]-$seg->[2]+1);
|
|
|
136 warn "@$seg\n$src\n$tgt" if DEBUG;
|
|
|
137 }
|
|
|
138 } else {
|
|
|
139 @segs = [0,length($genomic)-1,0,length($dna)-1];
|
|
|
140 }
|
|
|
141
|
|
|
142 my $color = $self->fgcolor;
|
|
|
143 my $font = $self->font;
|
|
|
144 my $lineheight = $font->height;
|
|
|
145 my $fontwidth = $font->width;
|
|
|
146 $y1 -= $lineheight/2 - 3;
|
|
|
147 my $pink = $self->factory->translate_color('lightpink');
|
|
|
148 my $panel_end = $self->panel->right;
|
|
|
149
|
|
|
150 my $start = $self->map_no_trunc($self->feature->start- $start_offset);
|
|
|
151 my $end = $self->map_no_trunc($self->feature->end - $start_offset);
|
|
|
152
|
|
|
153 my ($last,$tlast);
|
|
|
154 for my $seg (@segs) {
|
|
|
155
|
|
|
156 # fill in misaligned bits with dashes and bases
|
|
|
157 if (defined $last) {
|
|
|
158 my $delta = $seg->[0] - $last - 1;
|
|
|
159 my $tdelta = $seg->[2] - $tlast - 1;
|
|
|
160 warn "src gap [$last,$seg->[0]], tgt gap [$tlast,$seg->[2]], delta = $delta, tdelta = $tdelta\n" if DEBUG;
|
|
|
161
|
|
|
162 my $gaps = $delta - $tdelta;
|
|
|
163 my @fill_in = split '',substr($dna,$tlast+1,$tdelta) if $tdelta > 0;
|
|
|
164 unshift @fill_in,('-')x$gaps if $gaps > 0;
|
|
|
165
|
|
|
166 warn "gaps = $gaps, fill_in = @fill_in\n" if DEBUG;
|
|
|
167
|
|
|
168 my $distance = $pixels_per_base * ($delta+1);
|
|
|
169 my $pixels_per_target = $gaps >= 0 ? $pixels_per_base : $distance/(@fill_in+1);
|
|
|
170
|
|
|
171 warn "pixels_per_base = $pixels_per_base, pixels_per_target=$pixels_per_target\n" if DEBUG;
|
|
|
172 my $offset = $self->{flip} ? $end + ($last-1)*$pixels_per_base : $start + $last*$pixels_per_base;
|
|
|
173
|
|
|
174 for (my $i=0; $i<@fill_in; $i++) {
|
|
|
175
|
|
|
176 my $x = $self->{flip} ? int($offset + ($i+1)*$pixels_per_target + 0.5)
|
|
|
177 : int($offset + ($i+1)*$pixels_per_target + 0.5);
|
|
|
178
|
|
|
179 $self->filled_box($gd,$x,$y1+3,$x+$fontwidth,$y1+$lineheight-3,$pink,$pink) unless $gaps;
|
|
|
180 $gd->char($font,$x,$y1,$complement? $complement{$fill_in[$i]} : $fill_in[$i],$color);
|
|
|
181 }
|
|
|
182 }
|
|
|
183
|
|
|
184 my @genomic = split '',substr($genomic,$seg->[0],$seg->[1]-$seg->[0]+1);
|
|
|
185 my @bases = split '',substr($dna, $seg->[2],$seg->[3]-$seg->[2]+1);
|
|
|
186 for (my $i = 0; $i<@bases; $i++) {
|
|
|
187 my $x = $self->{flip} ? int($end + ($seg->[0] + $i - 1)*$pixels_per_base + 0.5)
|
|
|
188 : int($start + ($seg->[0] + $i) *$pixels_per_base + 0.5);
|
|
|
189 next if $x+1 < $x1;
|
|
|
190 last if $x+1 > $x2;
|
|
|
191 if ($genomic[$i] && lc($bases[$i]) ne lc($complement ? $complement{$genomic[@genomic - $i - 1]} : $genomic[$i])) {
|
|
|
192 $self->filled_box($gd,$x,$y1+3,$x+$fontwidth,$y1+$lineheight-3,$pink,$pink);
|
|
|
193 }
|
|
|
194 $gd->char($font,$x,$y1,$complement ? $complement{$bases[$i]} || $bases[$i] : $bases[$i],$color);
|
|
|
195 }
|
|
|
196 $last = $seg->[1];
|
|
|
197 $tlast = $seg->[3];
|
|
|
198 }
|
|
|
199
|
|
|
200 }
|
|
|
201
|
|
|
202 # Override _subseq() method to make it appear that a top-level feature that
|
|
|
203 # has no subfeatures appears as a feature that has a single subfeature.
|
|
|
204 # Otherwise at high mags gaps will be drawn as components rather than
|
|
|
205 # as connectors. Because of differing representations of split features
|
|
|
206 # in Bio::DB::GFF::Feature and Bio::SeqFeature::Generic, there is
|
|
|
207 # some breakage of encapsulation here.
|
|
|
208 sub _subseq {
|
|
|
209 my $self = shift;
|
|
|
210 my $feature = shift;
|
|
|
211 my @subseq = $self->SUPER::_subseq($feature);
|
|
|
212 return @subseq if @subseq;
|
|
|
213 if ($self->level == 0 && !@subseq && !eval{$feature->compound}) {
|
|
|
214 my($start,$end) = ($feature->start,$feature->end);
|
|
|
215 ($start,$end) = ($end,$start) if $start > $end; # to keep Bio::Location::Simple from bitching
|
|
|
216 # return Bio::Location::Simple->new(-start=>$start,-end=>$end);
|
|
|
217 return $self->feature;
|
|
|
218 } else {
|
|
|
219 return;
|
|
|
220 }
|
|
|
221 }
|
|
|
222
|
|
|
223 1;
|
|
|
224
|
|
|
225 __END__
|
|
|
226
|
|
|
227 =head1 NAME
|
|
|
228
|
|
|
229 Bio::Graphics::Glyph::segments - The "segments" glyph
|
|
|
230
|
|
|
231 =head1 SYNOPSIS
|
|
|
232
|
|
|
233 See L<Bio::Graphics::Panel> and L<Bio::Graphics::Glyph>.
|
|
|
234
|
|
|
235 =head1 DESCRIPTION
|
|
|
236
|
|
|
237 This glyph is used for drawing features that consist of discontinuous
|
|
|
238 segments. Unlike "graded_segments" or "alignment", the segments are a
|
|
|
239 uniform color and not dependent on the score of the segment.
|
|
|
240
|
|
|
241 =head2 OPTIONS
|
|
|
242
|
|
|
243 The following options are standard among all Glyphs. See
|
|
|
244 L<Bio::Graphics::Glyph> for a full explanation.
|
|
|
245
|
|
|
246 Option Description Default
|
|
|
247 ------ ----------- -------
|
|
|
248
|
|
|
249 -fgcolor Foreground color black
|
|
|
250
|
|
|
251 -outlinecolor Synonym for -fgcolor
|
|
|
252
|
|
|
253 -bgcolor Background color turquoise
|
|
|
254
|
|
|
255 -fillcolor Synonym for -bgcolor
|
|
|
256
|
|
|
257 -linewidth Line width 1
|
|
|
258
|
|
|
259 -height Height of glyph 10
|
|
|
260
|
|
|
261 -font Glyph font gdSmallFont
|
|
|
262
|
|
|
263 -connector Connector type 0 (false)
|
|
|
264
|
|
|
265 -connector_color
|
|
|
266 Connector color black
|
|
|
267
|
|
|
268 -label Whether to draw a label 0 (false)
|
|
|
269
|
|
|
270 -description Whether to draw a description 0 (false)
|
|
|
271
|
|
|
272 -strand_arrow Whether to indicate 0 (false)
|
|
|
273 strandedness
|
|
|
274
|
|
|
275 -draw_dna If true, draw the dna residues 0 (false)
|
|
|
276 when magnification level
|
|
|
277 allows.
|
|
|
278
|
|
|
279 -draw_target If true, draw the dna residues 0 (false)
|
|
|
280 of the TARGET sequence when
|
|
|
281 magnification level allows.
|
|
|
282 SEE NOTE.
|
|
|
283
|
|
|
284 -ragged_start When combined with -draw_target, 0 (false)
|
|
|
285 draw a few bases beyond the end
|
|
|
286 of the alignment. SEE NOTE.
|
|
|
287
|
|
|
288 -show_mismatch When combined with -draw_target, 0 (false)
|
|
|
289 highlights mismatched bases in
|
|
|
290 pink. SEE NOTE.
|
|
|
291
|
|
|
292 The -draw_target and -ragged_start options only work with seqfeatures
|
|
|
293 that implement the hit() method (Bio::SeqFeature::SimilarityPair).
|
|
|
294 The -ragged_start option is mostly useful for looking for polyAs and
|
|
|
295 cloning sites at the beginning of ESTs and cDNAs. Currently there is
|
|
|
296 no way of activating ragged ends. The length of the ragged starts is
|
|
|
297 hard-coded at 25 bp, and the color of mismatches is hard-coded as
|
|
|
298 light pink.
|
|
|
299
|
|
|
300 =head1 BUGS
|
|
|
301
|
|
|
302 Please report them.
|
|
|
303
|
|
|
304 =head1 SEE ALSO
|
|
|
305
|
|
|
306
|
|
|
307 L<Bio::Graphics::Panel>,
|
|
|
308 L<Bio::Graphics::Glyph>,
|
|
|
309 L<Bio::Graphics::Glyph::arrow>,
|
|
|
310 L<Bio::Graphics::Glyph::cds>,
|
|
|
311 L<Bio::Graphics::Glyph::crossbox>,
|
|
|
312 L<Bio::Graphics::Glyph::diamond>,
|
|
|
313 L<Bio::Graphics::Glyph::dna>,
|
|
|
314 L<Bio::Graphics::Glyph::dot>,
|
|
|
315 L<Bio::Graphics::Glyph::ellipse>,
|
|
|
316 L<Bio::Graphics::Glyph::extending_arrow>,
|
|
|
317 L<Bio::Graphics::Glyph::generic>,
|
|
|
318 L<Bio::Graphics::Glyph::graded_segments>,
|
|
|
319 L<Bio::Graphics::Glyph::heterogeneous_segments>,
|
|
|
320 L<Bio::Graphics::Glyph::line>,
|
|
|
321 L<Bio::Graphics::Glyph::pinsertion>,
|
|
|
322 L<Bio::Graphics::Glyph::primers>,
|
|
|
323 L<Bio::Graphics::Glyph::rndrect>,
|
|
|
324 L<Bio::Graphics::Glyph::segments>,
|
|
|
325 L<Bio::Graphics::Glyph::ruler_arrow>,
|
|
|
326 L<Bio::Graphics::Glyph::toomany>,
|
|
|
327 L<Bio::Graphics::Glyph::transcript>,
|
|
|
328 L<Bio::Graphics::Glyph::transcript2>,
|
|
|
329 L<Bio::Graphics::Glyph::translation>,
|
|
|
330 L<Bio::Graphics::Glyph::triangle>,
|
|
|
331 L<Bio::DB::GFF>,
|
|
|
332 L<Bio::SeqI>,
|
|
|
333 L<Bio::SeqFeatureI>,
|
|
|
334 L<Bio::Das>,
|
|
|
335 L<GD>
|
|
|
336
|
|
|
337 =head1 AUTHOR
|
|
|
338
|
|
|
339 Lincoln Stein E<lt>lstein@cshl.orgE<gt>
|
|
|
340
|
|
|
341 Copyright (c) 2001 Cold Spring Harbor Laboratory
|
|
|
342
|
|
|
343 This library is free software; you can redistribute it and/or modify
|
|
|
344 it under the same terms as Perl itself. See DISCLAIMER.txt for
|
|
|
345 disclaimers of warranty.
|
|
|
346
|
|
|
347 =cut
|
