Merge pull request #1046 from shawnlaffan/gui_range_convex_hull_union

This plots fewer lines and thus generates a less busy plot for large data sets.

Author: shawnlaffan

lib/Biodiverse/GUI/Tabs/Labels.pm

@@ -399,6 +399,7 @@ sub get_tree_menu_items {
                qw /plot_branches_by
                    highlight_groups_on_map
                    highlight_groups_on_map_convex_hull
+                   highlight_groups_on_map_convex_hull_union
                    highlight_groups_on_map_circumcircle
                    highlight_paths_on_tree
                    separator
@@ -913,6 +914,25 @@ sub get_highlight_label_range_convex_hulls {
     $_[0]->{highlight_label_range_convex_hulls};
 }
 
+sub set_highlight_label_range_convex_hull_union {
+    my ($self, $value) = @_;
+
+    $self->{highlight_label_range_convex_hull_union} = !!$value;
+
+    return;
+}
+
+sub toggle_highlight_label_range_convex_hull_union {
+    my ($self, $value) = @_;
+
+    $self->{highlight_label_range_convex_hull_union}
+        = !$self->{highlight_label_range_convex_hull_union};
+}
+
+sub get_highlight_label_range_convex_hull_union {
+    $_[0]->{highlight_label_range_convex_hull_union};
+}
+
 sub set_highlight_label_range_circumcircles {
     my ($self, $value) = @_;
 
@@ -963,6 +983,49 @@ sub highlight_label_range_convex_hulls {
     }
 }
 
+sub highlight_label_range_convex_hull_union {
+    my ($self, $node) = @_;
+
+    return if !$self->get_highlight_label_range_convex_hull_union;
+
+    my $terminal_elements = $node->get_terminal_elements;
+
+    my $bd = $self->get_base_ref;
+    my $label_hash = $bd->get_labels_ref->get_element_hash;
+
+    #  clear existing
+    $self->{grid}->clear_range_convex_hulls;
+
+    my $cache = $bd->get_cached_value_dor_set_default_href('LABEL_RANGE_CONVEX_HULL_VERTICES');
+
+    #  Cache on list of terminal names to avoid issues with trees
+    #  that have similarly named nodes with different terminals.
+    my $cache_key = $node->is_terminal_node ? $node->get_name : $node->get_terminal_element_names_sha256;
+
+    my $hull_union = $cache->{$cache_key};
+    if (!$hull_union) {
+        #  could climb up the tree if this takes too long
+        foreach my $label (keys %$terminal_elements) {
+            next LABEL if !exists $label_hash->{$label};
+            my $hull = $bd->get_label_range_convex_hull(label => $label);
+            $hull_union = $hull_union ? $hull_union->Union ($hull) : $hull;
+        }
+        $cache->{$cache_key} = $hull_union;
+    }
+
+    # avoid plotting empties
+    if (defined $hull_union) {
+        $self->{grid}->set_overlay(
+            type        => 'polyline',
+            cb_target   => 'range_convex_hulls',
+            plot_on_top => 1,
+            data        => scalar $hull_union->GetPoints(0, 0),
+            colour      => COLOUR_BLACK,
+            alpha       => 0.5,
+        );
+    }
+}
+
 sub highlight_label_range_circumcircles {
     my ($self, $node) = @_;
 
@@ -1583,11 +1646,11 @@ sub on_phylogeny_highlight {
 
     $self->highlight_label_range_marks($node);
     $self->highlight_label_range_convex_hulls($node);
+    $self->highlight_label_range_convex_hull_union($node);
     $self->highlight_label_range_circumcircles($node);
 
-    if (defined $node) {
-        my $text = 'Node: ' . $node->get_name;
-        $self->get_xmlpage_object('label_VL_tree')->set_markup($text);
+    if (my $widget = $self->get_xmlpage_object('label_VL_tree')) {
+        $widget->set_markup('Node: ' . $node->get_name);
     }
 
     return;

lib/Biodiverse/GUI/Tabs/Spatial.pm

@@ -418,6 +418,7 @@ sub get_tree_menu_items {
                    separator
                    highlight_groups_on_map
                    highlight_groups_on_map_convex_hull
+                   highlight_groups_on_map_convex_hull_union
                    highlight_groups_on_map_circumcircle
                    highlight_paths_on_tree
                    separator
@@ -1198,22 +1199,6 @@ sub on_phylogeny_hover {
     return;
 }
 
-# many other phylogeny methods are given in Labels.pm
-# Called by dendrogram when user hovers over a node
-sub on_phylogeny_highlight {
-    my ($self, $node) = @_;
-
-    return if !$node;
-
-    return if !$self->do_canvas_hover_flag;
-
-    $self->highlight_label_range_marks($node);
-    $self->highlight_label_range_convex_hulls($node);
-    $self->highlight_label_range_circumcircles($node);
-
-    return;
-}
-
 sub on_phylogeny_click {
     my ($self, $node) = @_;
 

lib/Biodiverse/GUI/Tabs/Tab.pm

@@ -1332,6 +1332,21 @@ EOT
                 $self->get_highlight_label_range_convex_hulls;
             },
         },
+        highlight_groups_on_map_convex_hull_union => {
+            type     => 'Gtk3::CheckMenuItem',
+            label    => 'Highlight groups on map with range convex hull union',
+            tooltip  => 'When hovering the mouse over a tree branch, '
+                . 'plot the union of the convex hulls of the range of each subtending label.',
+            event    => 'toggled',
+            callback => sub {
+                my ($self, $widget) = @_;
+                $self->set_highlight_label_range_convex_hull_union($widget->get_active);
+            },
+            active   => sub {
+                my ($self) = @_;
+                $self->get_highlight_label_range_convex_hull_union;
+            },
+        },
         highlight_groups_on_map_circumcircle => {
             type     => 'Gtk3::CheckMenuItem',
             label    => 'Highlight groups on map with range circumcircles',

lib/Biodiverse/TreeNode.pm

@@ -1017,6 +1017,26 @@ sub get_terminal_element_count {
     return scalar keys %$hash;
 }
 
+sub get_terminal_element_names_sha256 {
+    my $self = shift;
+    state $cache_key = 'terminal_element_names_sha256';
+
+    if (my $cached = $self->get_cached_value ($cache_key)) {
+        return $cached;
+    }
+
+    my $terminals = $self->get_terminal_elements;
+    my @names = sort keys %$terminals;
+
+    use Digest::SHA qw/sha256_hex/;
+    #  Join using ascii file separator control character,
+    #  which is also the default value for $;
+    my $sha = sha256_hex join "\034", @names;
+    $self->set_cached_value ($cache_key => $sha);
+
+    return $sha;
+}
+
 sub get_all_named_descendants {
     my $self = shift;
     my %args = (cache => 1, @_);  #  cache unless told otherwise