Skip to content

Commit 3138783

Browse files
shawnlaffanshawnlaffan
authored
Merge pull request #1045 from shawnlaffan/gui_phylo_highlight
GUI: phylogeny highlighting supports range circumcircles and convex hulls
2 parents 9fcafcd + ec5e1f3 commit 3138783

File tree

6 files changed

+245
-82
lines changed

6 files changed

+245
-82
lines changed

‎lib/Biodiverse/BaseData.pm‎

Lines changed: 4 additions & 27 deletions
Original file line numberDiff line numberDiff line change
@@ -2194,36 +2194,13 @@ sub get_groups_with_label { # get a list of the groups that contain $label
21942194
element => $args{label} );
21952195
}
21962196

2197-
sub get_groups_with_label_as_hash
2198-
{ # get a hash of the groups that contain $label
2199-
my $self = shift;
2200-
my %args = @_;
2197+
# get a hash of the groups that contain $label
2198+
sub get_groups_with_label_as_hash {
2199+
my ($self, %args) = @_;
22012200

22022201
croak "Label not specified\n" if !defined $args{label};
22032202

2204-
if ( !defined $args{use_elements} ) {
2205-
2206-
# takes care of the wantarray stuff this way
2207-
return $self->get_labels_ref->get_sub_element_hash_aa( $args{label} );
2208-
}
2209-
2210-
# Not sure why the rest is here - is it used anywhere?
2211-
# violates the guideline that subs should do one thing only
2212-
2213-
# make a copy - don't want to delete the original
2214-
my %results =
2215-
$self->get_labels_ref->get_sub_element_hash( element => $args{label} );
2216-
2217-
# get a list of keys we don't want
2218-
no warnings
2219-
'uninitialized'; # in case a list containing nulls is sent through
2220-
my %sub_results = %results;
2221-
delete @sub_results{ @{ $args{use_elements} } };
2222-
2223-
# now we delete those keys we don't want. Twisted, but should work.
2224-
delete @results{ keys %sub_results };
2225-
2226-
return wantarray ? %results : \%results;
2203+
return $self->get_labels_ref->get_sub_element_hash_aa( $args{label} );
22272204
}
22282205

22292206
sub get_groups_with_label_as_hash_aa {

‎lib/Biodiverse/GUI/Canvas/Grid.pm‎

Lines changed: 52 additions & 13 deletions
Original file line numberDiff line numberDiff line change
@@ -42,14 +42,24 @@ sub new {
4242
$self->init_legend(%args, parent => $self);
4343

4444
$self->{callbacks} = {
45-
map => sub {shift->draw_cells_cb(@_)},
46-
highlights => sub {shift->plot_highlights(@_)},
47-
overlays => sub {shift->_bounding_box_page_units(@_)},
48-
underlays => sub {},
49-
legend => sub {shift->get_legend->draw(@_)},
50-
sel_rect => sub {shift->draw_selection_rect (@_)}
45+
map => sub {shift->draw_cells_cb(@_)},
46+
highlights => sub {shift->plot_highlights(@_)},
47+
overlays => sub {shift->_bounding_box_page_units(@_)},
48+
underlays => sub {},
49+
legend => sub {shift->get_legend->draw(@_)},
50+
sel_rect => sub {shift->draw_selection_rect(@_)},
51+
range_convex_hulls => undef,
52+
range_circumcircles => undef,
5153
};
52-
$self->{callback_order} = [qw /underlays map overlays legend highlights sel_rect/];
54+
$self->{callback_order} = [qw /
55+
underlays
56+
map
57+
overlays
58+
legend
59+
range_convex_hulls
60+
range_circumcircles
61+
highlights sel_rect
62+
/];
5363

5464
return $self;
5565
}
@@ -628,21 +638,39 @@ sub plot_highlights {
628638
return FALSE;
629639
}
630640

641+
sub clear_range_convex_hulls {
642+
my $self = shift;
643+
$self->set_overlay(
644+
cb_target => 'range_convex_hulls',
645+
plot_on_top => 1,
646+
data => undef,
647+
);
648+
}
649+
650+
sub clear_range_circumcircles {
651+
my $self = shift;
652+
$self->set_overlay(
653+
cb_target => 'range_circumcircles',
654+
plot_on_top => 1,
655+
data => undef,
656+
);
657+
}
658+
631659
sub set_overlay {
632660
my ($self, %args) = @_;
633661
my ($shapefile, $colour, $plot_on_top, $alpha, $type, $linewidth)
634662
= @args{qw /shapefile colour plot_on_top alpha type linewidth/};
635663

636-
my $cb_target_name = $plot_on_top ? 'overlays' : 'underlays';
664+
my $cb_target_name = $args{cb_target} // ($plot_on_top ? 'overlays' : 'underlays');
637665

638-
if (!defined $shapefile) {
666+
if (!defined $shapefile && ! defined $args{data}) {
639667
# clear it
640668
$self->{callbacks}{$cb_target_name} = undef;
641669
$self->drawable->queue_draw;
642670
return;
643671
}
644672

645-
my $data = $self->load_shapefile($shapefile);
673+
my $data = $args{data} // $self->load_shapefile($shapefile);
646674

647675
my @rgba = (
648676
$self->rgb_to_array($colour),
@@ -653,10 +681,21 @@ sub set_overlay {
653681
$linewidth ||= 1;
654682

655683
my $cb;
656-
if (is_blessed_ref ($data->[0])) {
684+
if (is_blessed_ref ($data) && $data->isa('Biodiverse::Geometry::Circle')) {
685+
$cb = sub {
686+
my ($self, $cx) = @_;
687+
$cx->set_matrix($self->{matrix});
688+
$cx->set_source_rgba(@rgba);
689+
# line width should be an option in the GUI
690+
$cx->set_line_width(max($cx->device_to_user_distance($linewidth, $linewidth)));
691+
$cx->arc(@{$data->centre}, $data->radius, 0, 2.0 * PI);
692+
$cx->close_path;
693+
$cx->$stroke_or_fill;
694+
}
695+
}
696+
elsif (is_blessed_ref ($data->[0])) {
657697
$cb = sub {
658698
my ($self, $cx) = @_;
659-
660699
$cx->set_matrix($self->{matrix});
661700
$cx->set_source_rgba(@rgba);
662701
# line width should be an option in the GUI
@@ -674,7 +713,7 @@ sub set_overlay {
674713
$cx->$stroke_or_fill;
675714
};
676715
}
677-
else { # shapefiles, old style
716+
else { # label range convex hulls etc
678717
$cb = sub {
679718
my ($self, $cx) = @_;
680719

‎lib/Biodiverse/GUI/Tabs/Labels.pm‎

Lines changed: 136 additions & 20 deletions
Original file line numberDiff line numberDiff line change
@@ -398,6 +398,8 @@ sub get_tree_menu_items {
398398
( map {$self->get_tree_menu_item($_)}
399399
qw /plot_branches_by
400400
highlight_groups_on_map
401+
highlight_groups_on_map_convex_hull
402+
highlight_groups_on_map_circumcircle
401403
highlight_paths_on_tree
402404
separator
403405
background_colour
@@ -892,6 +894,133 @@ sub on_highlight_groups_on_map_changed {
892894
return;
893895
}
894896

897+
sub set_highlight_label_range_convex_hulls {
898+
my ($self, $value) = @_;
899+
900+
$self->{highlight_label_range_convex_hulls} = !!$value;
901+
902+
return;
903+
}
904+
905+
sub toggle_highlight_label_range_convex_hulls {
906+
my ($self, $value) = @_;
907+
908+
$self->{highlight_label_range_convex_hulls}
909+
= !$self->{highlight_label_range_convex_hulls};
910+
}
911+
912+
sub get_highlight_label_range_convex_hulls {
913+
$_[0]->{highlight_label_range_convex_hulls};
914+
}
915+
916+
sub set_highlight_label_range_circumcircles {
917+
my ($self, $value) = @_;
918+
919+
$self->{highlight_label_range_circumcircles} = !!$value;
920+
921+
return;
922+
}
923+
924+
sub toggle_highlight_label_range_circumcircles {
925+
my ($self, $value) = @_;
926+
927+
$self->{highlight_label_range_circumcircles}
928+
= !$self->{highlight_label_range_circumcircles};
929+
}
930+
931+
sub get_highlight_label_range_circumcircles {
932+
$_[0]->{highlight_label_range_circumcircles};
933+
}
934+
935+
sub highlight_label_range_convex_hulls {
936+
my ($self, $node) = @_;
937+
938+
return if !$self->get_highlight_label_range_convex_hulls;
939+
940+
my $terminal_elements = $node->get_terminal_elements;
941+
942+
my $bd = $self->get_base_ref;
943+
my $label_hash = $bd->get_labels_ref->get_element_hash;
944+
945+
# clear existing
946+
$self->{grid}->clear_range_convex_hulls;
947+
948+
my $cache = $bd->get_cached_value_dor_set_default_href('LABEL_RANGE_CONVEX_HULL_VERTICES');
949+
950+
foreach my $label (keys %$terminal_elements) {
951+
next LABEL if !exists $label_hash->{$label};
952+
my $data
953+
= $cache->{$label}
954+
//= $bd->get_label_range_convex_hull(label => $label)->GetPoints(0, 0);
955+
$self->{grid}->set_overlay(
956+
type => 'polyline',
957+
cb_target => 'range_convex_hulls',
958+
plot_on_top => 1,
959+
data => $data,
960+
colour => COLOUR_BLACK,
961+
alpha => 0.5,
962+
);
963+
}
964+
}
965+
966+
sub highlight_label_range_circumcircles {
967+
my ($self, $node) = @_;
968+
969+
return if !$self->get_highlight_label_range_circumcircles;
970+
971+
my $terminal_elements = $node->get_terminal_elements;
972+
973+
my $bd = $self->get_base_ref;
974+
my $label_hash = $bd->get_labels_ref->get_element_hash;
975+
976+
# clear existing
977+
$self->{grid}->clear_range_circumcircles;
978+
979+
foreach my $label (keys %$terminal_elements) {
980+
next LABEL if !exists $label_hash->{$label};
981+
my $data = $bd->get_label_range_circumcircle(label => $label);
982+
$self->{grid}->set_overlay(
983+
type => 'polyline',
984+
cb_target => 'range_circumcircles',
985+
plot_on_top => 1,
986+
data => $data,
987+
colour => COLOUR_BLACK,
988+
alpha => 0.5,
989+
);
990+
}
991+
}
992+
993+
sub highlight_label_range_marks {
994+
my ($self, $node) = @_;
995+
996+
my $terminal_elements = (defined $node) ? $node->get_terminal_elements : {};
997+
998+
# Hash of groups that have the selected labels
999+
my %groups;
1000+
1001+
my $bd = $self->get_base_ref;
1002+
my $label_hash = $bd->get_labels_ref->get_element_hash;
1003+
my $max_groups = $bd->get_group_count;
1004+
1005+
LABEL:
1006+
foreach my $label (keys %$terminal_elements) {
1007+
next LABEL if !exists $label_hash->{$label};
1008+
1009+
my $containing = eval {$bd->get_groups_with_label_as_hash_aa($label)};
1010+
next LABEL if !$containing;
1011+
1012+
@groups{keys %$containing} = ();
1013+
1014+
last LABEL if $max_groups == scalar keys %groups;
1015+
}
1016+
1017+
$self->{grid}->mark_with_circles ( [keys %groups] );
1018+
$self->{grid}->mark_with_dashes ( [] ); # clear any nbr_set2 highlights
1019+
1020+
return;
1021+
}
1022+
1023+
8951024
sub on_selected_matrix_changed {
8961025
my ($self, %args) = @_;
8971026
@@ -1438,6 +1567,8 @@ sub on_end_phylogeny_hover {
14381567

14391568
return if !$self->do_canvas_hover_flag;
14401569

1570+
$self->{grid}->clear_range_convex_hulls;
1571+
$self->{grid}->clear_range_circumcircles;
14411572
$self->{grid}->mark_with_circles;
14421573
}
14431574

@@ -1446,28 +1577,13 @@ sub on_end_phylogeny_hover {
14461577
sub on_phylogeny_highlight {
14471578
my ($self, $node) = @_;
14481579

1449-
return if !$self->do_canvas_hover_flag;
1450-
1451-
my $terminal_elements = (defined $node) ? $node->get_terminal_elements : {};
1452-
1453-
# Hash of groups that have the selected labels
1454-
my %groups;
1455-
my ($iter, $label, $hash);
1580+
return if !$node;
14561581

1457-
my $bd = $self->{base_ref};
1458-
my $label_hash = $bd->get_labels_ref->get_element_hash;
1459-
1460-
LABEL:
1461-
foreach my $label (keys %$terminal_elements) {
1462-
next LABEL if !exists $label_hash->{$label};
1463-
1464-
my $containing = eval {$bd->get_groups_with_label_as_hash(label => $label)};
1465-
next LABEL if !$containing;
1466-
1467-
@groups{keys %$containing} = ();
1468-
}
1582+
return if !$self->do_canvas_hover_flag;
14691583

1470-
$self->{grid}->mark_with_circles ( [keys %groups] );
1584+
$self->highlight_label_range_marks($node);
1585+
$self->highlight_label_range_convex_hulls($node);
1586+
$self->highlight_label_range_circumcircles($node);
14711587

14721588
if (defined $node) {
14731589
my $text = 'Node: ' . $node->get_name;

0 commit comments

Comments
 (0)