my
%complement
= (
g
=>
'c'
,
a
=>
't'
,
t
=>
'a'
,
c
=>
'g'
,
n
=>
'n'
,
G
=>
'C'
,
A
=>
'T'
,
T
=>
'A'
,
C
=>
'G'
,
N
=>
'N'
);
sub
pad_left {
my
$self
=
shift
;
return
$self
->SUPER::pad_left
unless
$self
->level > 0;
my
$ragged
=
$self
->option(
'ragged_start'
)
? RAGGED_START_FUZZ
:
$self
->option(
'ragged_extra'
);
return
$self
->SUPER::pad_left
unless
$self
->draw_target &&
$ragged
&&
$self
->dna_fits;
my
$target
=
eval
{
$self
->feature->hit} or
return
$self
->SUPER::pad_left;
return
$self
->SUPER::pad_left
unless
$target
->start<
$target
->end &&
$target
->start <
$ragged
;
return
(
$target
->start-1) *
$self
->scale;
}
sub
pad_right {
my
$self
=
shift
;
return
$self
->SUPER::pad_right
unless
$self
->level > 0;
my
$ragged
=
$self
->option(
'ragged_start'
)
? RAGGED_START_FUZZ
:
$self
->option(
'ragged_extra'
);
return
$self
->SUPER::pad_right
unless
$self
->draw_target &&
$ragged
&&
$self
->dna_fits;
my
$target
=
eval
{
$self
->feature->hit} or
return
$self
->SUPER::pad_right;
return
$self
->SUPER::pad_right
unless
$target
->end <
$target
->start &&
$target
->start <
$ragged
;
return
(
$target
->end-1) *
$self
->scale;
}
sub
draw_target {
my
$self
=
shift
;
return
if
$self
->option(
'draw_dna'
);
return
$self
->option(
'draw_target'
);
}
sub
draw_protein_target {
my
$self
=
shift
;
return
if
$self
->option(
'draw_protein'
);
return
$self
->option(
'draw_protein_target'
);
return
$self
->option(
'draw_target'
);
}
sub
height {
my
$self
=
shift
;
my
$height
=
$self
->SUPER::height;
return
$height
unless
$self
->draw_target ||
$self
->draw_protein_target;
if
(
$self
->draw_target) {
return
$height
unless
$self
->dna_fits;
}
if
(
$self
->draw_protein_target) {
return
$height
unless
$self
->protein_fits;
}
my
$fontheight
=
$self
->font->height;
return
$fontheight
if
$fontheight
>
$height
;
}
sub
connector {
my
$self
=
shift
;
return
$self
->SUPER::connector(
@_
)
if
$self
->all_callbacks;
return
(
$self
->SUPER::connector(
@_
) ||
'solid'
);
}
sub
bump {
my
$self
=
shift
;
return
$self
->SUPER::bump(
@_
)
if
$self
->all_callbacks;
return
0;
}
sub
maxdepth {
my
$self
=
shift
;
my
$md
=
$self
->Bio::Graphics::Glyph::maxdepth;
return
$md
if
defined
$md
;
return
1;
}
sub
draw {
my
$self
=
shift
;
my
$draw_target
=
$self
->draw_target;
return
$self
->SUPER::draw(
@_
)
unless
$draw_target
;
return
$self
->SUPER::draw(
@_
)
unless
$self
->dna_fits;
$self
->draw_label(
@_
)
if
$self
->option(
'label'
);
$self
->draw_description(
@_
)
if
$self
->option(
'description'
);
$self
->draw_part_labels(
@_
)
if
$self
->option(
'part_labels'
);
my
$drew_sequence
;
if
(
$draw_target
) {
return
$self
->SUPER::draw(
@_
)
unless
eval
{
$self
->feature->hit->seq};
$drew_sequence
=
$self
->draw_multiple_alignment(
@_
);
}
my
(
$gd
,
$x
,
$y
) =
@_
;
$y
+=
$self
->top +
$self
->pad_top
if
$drew_sequence
;
my
$connector
=
$self
->connector;
$self
->draw_connectors(
$gd
,
$x
,
$y
)
if
$connector
&&
$connector
ne
'none'
&&
$self
->level == 0;
}
sub
draw_component {
my
$self
=
shift
;
my
(
$gd
,
$l
,
$t
) =
@_
;
$self
->SUPER::draw_component(
@_
);
return
unless
$self
->option(
'draw_protein_target'
) &&
$self
->protein_fits;
my
$hit
=
eval
{
$self
->feature->hit} or
return
;
my
$protein
=
uc
eval
{
$hit
->seq->seq} or
return
;
my
(
$left
,
$top
,
$right
,
$bottom
) =
$self
->bounds(
$l
,
$t
);
my
$scale
=
$self
->scale;
warn
"scale = $scale"
;
my
@letters
=
split
''
,
$protein
;
my
$color
=
$self
->fgcolor;
my
$font
=
$self
->font;
my
$fw
=
$font
->width;
my
$strand
=
$self
->feature->strand || 0;
my
$panel_left
=
$self
->panel->left;
my
$panel_right
=
$self
->panel->right;
my
(
$x1
,
$x2
) =
$self
->map_no_trunc(
$self
->feature->start,
$self
->feature->end);
if
(
$strand
>= 0) {
for
(0..
@letters
-1) {
next
if
$x1
<
$panel_left
or
$x1
>
$panel_right
;
$gd
->char(
$font
,
$x1
+1,
$top
,
$letters
[
$_
],
$color
);
}
continue
{
$x1
+=
$scale
* 3;
}
}
else
{
for
(0..
@letters
-1) {
next
if
$x2
<
$panel_left
or
$x2
>
$panel_right
;
$gd
->char(
$font
,
$x2
+1,
$top
,
$letters
[
$_
],
$color
);
}
continue
{
$x2
-=
$scale
* 3;
}
}
}
sub
draw_multiple_alignment {
my
$self
=
shift
;
my
$gd
=
shift
;
my
(
$left
,
$top
,
$partno
,
$total_parts
) =
@_
;
my
$flipped
=
$self
->flip;
my
$ragged_extra
=
$self
->option(
'ragged_start'
)
? RAGGED_START_FUZZ :
$self
->option(
'ragged_extra'
);
my
$true_target
=
$self
->option(
'true_target'
);
my
$show_mismatch
=
$self
->option(
'show_mismatch'
);
my
$do_realign
=
$self
->option(
'realign'
);
my
$pixels_per_base
=
$self
->scale;
my
$feature
=
$self
->feature;
my
$panel
=
$self
->panel;
my
(
$abs_start
,
$abs_end
) = (
$feature
->start,
$feature
->end);
my
(
$tgt_start
,
$tgt_end
) = (
$feature
->hit->start,
$feature
->hit->end);
my
(
$panel_start
,
$panel_end
) = (
$self
->panel->start,
$self
->panel->end);
my
$strand
=
$feature
->strand;
my
$panel_left
=
$self
->panel->left;
my
$panel_right
=
$self
->panel->right;
my
$drew_sequence
;
if
(
$tgt_start
>
$tgt_end
) {
$strand
= -1;
(
$tgt_start
,
$tgt_end
) = (
$tgt_end
,
$tgt_start
);
}
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
,
@bounds
,
$self
->bgcolor,
$self
->bgcolor);
}
my
@s
=
$self
->_subfeat(
$feature
);
unless
(
@s
||
$feature
->isa(
'Bio::DB::GFF::Feature'
)) {
@s
= (
$feature
);
}
my
(
@segments
,
%strands
);
for
my
$s
(
@s
) {
my
$target
=
$s
->hit;
my
(
$src_start
,
$src_end
) = (
$s
->start,
$s
->end);
next
unless
$src_start
<=
$panel_end
&&
$src_end
>=
$panel_start
;
my
(
$tgt_start
,
$tgt_end
) = (
$target
->start,
$target
->end);
my
$strand_bug
;
unless
(
exists
$strands
{
$target
}) {
my
$strand
=
$feature
->strand;
if
(
$tgt_start
>
$tgt_end
) {
$strand
= -1;
(
$tgt_start
,
$tgt_end
) = (
$tgt_end
,
$tgt_start
);
$strand_bug
++;
}
$strands
{
$target
} =
$strand
;
}
if
(
$can_realign
) {
warn
"Realigning [$target,$src_start,$src_end,$tgt_start,$tgt_end].\n"
if
DEBUG;
my
(
$sdna
,
$tdna
) = (
$s
->dna,
$target
->dna);
my
@result
=
$self
->realign(
$sdna
,
$tdna
);
foreach
(
@result
) {
warn
"=========> [$target,@$_]\n"
if
DEBUG;
my
$a
=
$strands
{
$target
} >= 0 ? [
$target
,
$_
->[0]+
$src_start
,
$_
->[1]+
$src_start
,
$_
->[2]+
$tgt_start
,
$_
->[3]+
$tgt_start
]
: [
$target
,
$src_end
-
$_
->[1],
$src_end
-
$_
->[0],
$_
->[2]+
$tgt_start
,
$_
->[3]+
$tgt_start
];
warn
"[$target,$_->[0]+$src_start,$_->[1]+$src_start,$tgt_end-$_->[3],$tgt_end-$_->[2]]"
if
DEBUG;
warn
"=========> [@$a]\n"
if
DEBUG;
warn
substr
(
$sdna
,
$_
->[0],
$_
->[1]-
$_
->[0]+1),
"\n"
if
DEBUG;
warn
substr
(
$tdna
,
$_
->[2],
$_
->[3]-
$_
->[2]+1),
"\n"
if
DEBUG;
push
@segments
,
$a
;
}
}
else
{
push
@segments
,[
$target
,
$src_start
,
$src_end
,
$tgt_start
,
$tgt_end
];
}
}
@segments
=
sort
{
$a
->[TGT_START]<=>
$b
->[TGT_START]}
@segments
;
my
(
$offset_left
,
$offset_right
) = (0,0);
if
(
$ragged_extra
&&
$ragged_extra
> 0) {
$offset_left
=
$segments
[0]->[TGT_START] >
$ragged_extra
?
$ragged_extra
:
$segments
[0]->[TGT_START]-1;
if
(
$strand
>= 0) {
$offset_left
=
$segments
[0]->[SRC_START]-1
if
$segments
[0]->[SRC_START] -
$offset_left
< 1;
$abs_start
-=
$offset_left
;
$tgt_start
-=
$offset_left
;
$segments
[0]->[SRC_START] -=
$offset_left
;
$segments
[0]->[TGT_START] -=
$offset_left
;
}
else
{
$abs_end
+=
$offset_left
;
$tgt_start
-=
$offset_left
;
$segments
[0]->[SRC_END] +=
$offset_left
;
$segments
[0]->[TGT_START] -=
$offset_left
;
}
my
$current_end
=
$segments
[-1]->[TGT_END];
$offset_right
=
length
$segments
[-1]->[TARGET]->subseq(
$current_end
+1,
$current_end
+
$ragged_extra
)->seq;
if
(
$strand
>= 0) {
$abs_end
+=
$offset_right
;
$tgt_end
+=
$offset_left
;
$segments
[-1]->[TGT_END] +=
$offset_right
;
$segments
[-1]->[SRC_END] +=
$offset_right
;
}
else
{
$abs_start
-=
$offset_right
;
$tgt_end
+=
$offset_left
;
$segments
[-1]->[TGT_END] +=
$offset_right
;
$segments
[-1]->[SRC_START] -=
$offset_right
;
}
}
my
$ref_dna
=
$feature
->subseq(1-
$offset_left
,
$feature
->
length
+
$offset_right
)->seq;
my
$tgt_dna
=
$feature
->hit->subseq(1-
$offset_left
,
$feature
->
length
+
$offset_right
)->seq;
$ref_dna
=
$ref_dna
->seq
if
ref
$ref_dna
and
$ref_dna
->can(
'seq'
);
$tgt_dna
=
$tgt_dna
->seq
if
ref
$tgt_dna
and
$tgt_dna
->can(
'seq'
);
$ref_dna
=
lc
$ref_dna
;
$tgt_dna
=
lc
$tgt_dna
;
warn
"$feature dna sanity check:\n$ref_dna\n$tgt_dna\n"
if
DEBUG;
my
%clip
;
for
my
$seg
(
@segments
) {
my
$target
=
$seg
->[TARGET];
warn
"preclip [@$seg]\n"
if
DEBUG;
if
( (
my
$delta
=
$seg
->[SRC_START] -
$panel_start
) < 0 ) {
warn
"clip left delta = $delta"
if
DEBUG;
$seg
->[SRC_START] =
$panel_start
;
if
(
$strand
>= 0) {
$seg
->[TGT_START] -=
$delta
;
}
}
if
( (
my
$delta
=
$panel_end
-
$seg
->[SRC_END]) < 0) {
warn
"clip right delta = $delta"
if
DEBUG;
$seg
->[SRC_END] =
$panel_end
;
if
(
$strand
< 0) {
$seg
->[TGT_START] -=
$delta
;
}
}
my
$length
=
$seg
->[SRC_END]-
$seg
->[SRC_START]+1;
$seg
->[TGT_END] =
$seg
->[TGT_START]+
$length
-1;
warn
"Clipping gives [@$seg], tgt_start = $tgt_start\n"
if
DEBUG;
}
@segments
=
grep
{
$_
->[SRC_START]<=
$_
->[SRC_END] }
@segments
;
if
(
$strand
< 0) {
$ref_dna
=
$self
->reversec(
$ref_dna
);
$tgt_dna
=
$self
->reversec(
$tgt_dna
);
}
for
my
$seg
(
@segments
) {
$seg
->[SRC_START] -=
$abs_start
- 1;
$seg
->[SRC_END] -=
$abs_start
- 1;
$seg
->[TGT_START] -=
$tgt_start
- 1;
$seg
->[TGT_END] -=
$tgt_start
- 1;
warn
"src segment = $seg->[SRC_START]"
,
".."
,
$seg
->[SRC_END]
if
DEBUG;
warn
"tgt segment = $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);
}
if
(DEBUG) {
warn
"$feature: relativized coordinates = [@$seg]\n"
;
warn
$self
->_subsequence(
$ref_dna
,
$seg
->[SRC_START],
$seg
->[SRC_END]),
"\n"
;
warn
$self
->_subsequence(
$tgt_dna
,
$seg
->[TGT_START],
$seg
->[TGT_END]),
"\n"
;
}
}
my
$color
=
$self
->fgcolor;
my
$font
=
$self
->font;
my
$lineheight
=
$font
->height;
my
$fontwidth
=
$font
->width;
my
$mismatch
=
$self
->factory->translate_color(
$self
->option(
'mismatch_color'
) ||
'lightgrey'
);
my
$grey
=
$self
->factory->translate_color(
'gray'
);
my
$base2pixel
=
$self
->flip ?
sub
{
my
(
$src
,
$tgt
) =
@_
;
my
$a
=
$fontwidth
+ (
$abs_start
+
$src
-
$panel_start
-1 +
$tgt
) *
$pixels_per_base
- 1;
$panel_right
-
$a
;
}
:
sub
{
my
(
$src
,
$tgt
) =
@_
;
$fontwidth
/2 +
$left
+ (
$abs_start
+
$src
-
$panel_start
-1 +
$tgt
) *
$pixels_per_base
- 1;
};
my
(
$tgt_last_end
,
$src_last_end
,
$leftmost
,
$rightmost
);
for
my
$seg
(
sort
{
$a
->[SRC_START]<=>
$b
->[SRC_START]}
@segments
) {
my
$y
=
$top
-1;
for
(
my
$i
=0;
$i
<
$seg
->[SRC_END]-
$seg
->[SRC_START]+1;
$i
++) {
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
);
my
$x
=
$base2pixel
->(
$seg
->[SRC_START],
$i
);
$leftmost
=
$x
if
!
defined
$leftmost
||
$leftmost
>
$x
;
$rightmost
=
$x
if
!
defined
$rightmost
||
$rightmost
<
$x
;
next
unless
$tgt_base
&&
$x
>=
$panel_left
&&
$x
<=
$panel_right
;
$self
->filled_box(
$gd
,
$x
-
$pixels_per_base
/2+2,
$y
+1,
$x
+
$pixels_per_base
/2+1,
$y
+
$lineheight
,
$mismatch
,
$mismatch
)
if
$show_mismatch
&&
$tgt_base
&&
$src_base
ne
$tgt_base
&&
$tgt_base
!~ /[nN]/;
$tgt_base
=
$complement
{
$tgt_base
}
if
$true_target
&&
$strand
< 0;
$gd
->char(
$font
,
$x
,
$y
,
$tgt_base
,
$tgt_base
=~ /[nN]/ ?
$grey
:
$color
);
$drew_sequence
++;
}
if
(
defined
$tgt_last_end
) {
my
$delta
=
$seg
->[TGT_START] -
$tgt_last_end
;
my
$src_delta
=
$seg
->[SRC_START] -
$src_last_end
;
if
(
$delta
> 1 and
$src_delta
> 0) {
my
$gap_left
=
$fontwidth
+
$base2pixel
->(
$src_last_end
,0);
my
$gap_right
=
$base2pixel
->(
$seg
->[SRC_START],0);
(
$gap_left
,
$gap_right
) = (
$gap_right
+
$fontwidth
,
$gap_left
-
$fontwidth
)
if
$self
->flip;
warn
"delta=$delta, gap_left=$gap_left, gap_right=$gap_right"
if
DEBUG;
if
(
$delta
==
$src_delta
) {
$gap_left
+=
$pixels_per_base
/2-2;
$gap_right
-=
$pixels_per_base
/2-2;
}
next
if
$gap_left
<=
$panel_left
||
$gap_right
>=
$panel_right
;
$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
;
my
$gap_distance
=
$gap_right
-
$gap_left
+ 1;
my
$pixels_per_inserted_base
=
$gap_distance
/(
$delta
-1);
if
(
$pixels_per_inserted_base
>=
$fontwidth
) {
for
(
my
$i
= 0;
$i
<
$delta
-1;
$i
++) {
my
$x
=
$gap_left
+ (
$pixels_per_inserted_base
-
$fontwidth
)/2 +
$pixels_per_inserted_base
*
$i
;
my
$bp
=
$self
->_subsequence(
$tgt_dna
,
$tgt_last_end
+
$i
+1,
$tgt_last_end
+
$i
+1);
next
if
$x
<
$panel_left
;
$gd
->char(
$font
,
$x
,
$y
,
$bp
,
$color
);
}
}
$self
->_draw_insertion_point(
$gd
,
$gap_left
,
$gap_right
,
$y
,
$y
+
$lineheight
,
$mismatch
)
if
$delta
> 2;
}
elsif
( (
my
$delta
=
$seg
->[SRC_START] -
$src_last_end
) > 1) {
for
(
my
$i
=0;
$i
<
$delta
-1;
$i
++) {
my
$x
=
$base2pixel
->(
$src_last_end
,
$i
+1);
next
if
$x
>
$panel_right
;
$self
->filled_box(
$gd
,
$x
-
$pixels_per_base
/2+2,
$y
,
$x
+
$pixels_per_base
/2+1,
$y
+
$lineheight
,
$mismatch
,
$mismatch
)
if
$show_mismatch
;
$gd
->char(
$font
,
$x
,
$y
,
'-'
,
$color
);
}
}
}
$tgt_last_end
=
$seg
->[TGT_END];
$src_last_end
=
$seg
->[SRC_END];
}
if
(
defined
$leftmost
&&
$leftmost
-
$bl
>
$pixels_per_base
) {
$gd
->char(
$font
,
$_
,
$top
-1,
'-'
,
$color
)
for
map
{
$bl
+
$_
*$pixels_per_base
} 0..(
$leftmost
-
$bl
)/
$pixels_per_base
-1;
}
if
(
defined
$rightmost
&&
$br
-
$rightmost
>
$pixels_per_base
) {
$gd
->char(
$font
,
$_
,
$top
-1,
'-'
,
$color
)
for
map
{
$rightmost
+
$_
*$pixels_per_base
} (0..(
$br
-
$rightmost
)/
$pixels_per_base
);
}
return
$drew_sequence
;
}
sub
_subsequence {
my
$self
=
shift
;
my
(
$seq
,
$start
,
$end
,
$strand
) =
@_
;
my
$sub
;
if
((
defined
$strand
&&
$strand
< 0)) {
my
$piece
=
substr
(
$seq
,
length
(
$seq
)-
$end
,
$end
-
$start
+1);
$sub
=
$self
->reversec(
$piece
);
}
else
{
$sub
=
substr
(
$seq
,
$start
-1,
$end
-
$start
+1);
}
return
$self
->flip ?
$complement
{
$sub
} :
$sub
;
}
sub
realign {
my
$self
=
shift
;
my
(
$src
,
$tgt
) =
@_
;
return
Bio::Graphics::Browser::Realign::align_segs(
$src
,
$tgt
);
}
sub
_subfeat {
my
$self
=
shift
;
my
$feature
=
shift
;
my
@subfeat
=
$self
->SUPER::_subfeat(
$feature
);
return
@subfeat
if
@subfeat
;
if
(
$self
->level == 0 && !
@subfeat
&& !
$self
->feature_has_subparts) {
return
$self
->feature;
}
else
{
return
;
}
}
sub
_draw_insertion_point {
my
$self
=
shift
;
my
(
$gd
,
$left
,
$right
,
$top
,
$bottom
,
$color
) =
@_
;
my
$poly
= GD::Polygon->new();
$poly
->addPt(
$left
-3,
$top
+1);
$poly
->addPt(
$right
+2,
$top
+1);
$poly
->addPt((
$left
+
$right
)/2-1,
$top
+3);
$gd
->filledPolygon(
$poly
,
$color
);
$poly
= GD::Polygon->new();
$poly
->addPt(
$left
-3,
$bottom
);
$poly
->addPt(
$right
+2,
$bottom
);
$poly
->addPt((
$left
+
$right
)/2-1,
$bottom
-2);
$gd
->filledPolygon(
$poly
,
$color
);
}
1;