diff --git a/bin/ui/hboxClusteringPage.ui b/bin/ui/hboxClusteringPage.ui index 338811f99..318f1b892 100644 --- a/bin/ui/hboxClusteringPage.ui +++ b/bin/ui/hboxClusteringPage.ui @@ -182,7 +182,7 @@ True False - Display + Map True @@ -408,126 +408,6 @@ Colours are currently taken from the outer ring. True - - - True - False - - - - - True - False - Plot by - True - - - False - - - True - False - Length - True - True - - - - - - True - False - Depth - True - plot_length - - - - - - - - - - True - False - Should the grouping be done by length or depth? - -This allows decoupling of node selection from the tree display so trees with many reversals can be more easily plotted by depth, but selections still use the branch lengths. - -This setting has no effect on the slider bar. It always groups using the plot method, selecting whichever branches it crosses. - Group by - True - - - False - - - True - False - Length - True - True - - - - - - True - False - Depth - True - group_length - - - - - - - - - - True - False - Highlight groups under this node when hovering over the node - Highlight groups on map? - True - True - - - - - - True - False - Highlight paths on the tree associated with groups on the map when you hover the mouse over them - Highlight node paths for groups? - True - True - - - - - - True - False - When deselected, the slider bar will not change the display colours. - Use the slider bar to select nodes for colouring? - True - True - - - - - True - False - Set the width of the tree branches. -Does not affect the vertical connectors. - - Set tree branch line widths - True - - diff --git a/bin/ui/hboxLabelsPage.ui b/bin/ui/hboxLabelsPage.ui index 1b9624746..16ecf998f 100644 --- a/bin/ui/hboxLabelsPage.ui +++ b/bin/ui/hboxLabelsPage.ui @@ -150,6 +150,15 @@ False + + + True + False + + + False + + True @@ -163,7 +172,7 @@ True False - Display + Map True @@ -173,7 +182,7 @@ True False - Grid + Display options: True @@ -241,77 +250,6 @@ True - - - True - False - - - - - True - False - Tree - True - - - - - True - False - Plot branches using their lengths. - Length - True - True - True - - - - - True - False - Plot branches as a function of depth from the root node. - Depth - True - True - phylogeny_plot_length - - - - - True - False - When hovering on a branch, -highlight the groups on the grid -in which it is found. - - Highlight groups on map? - True - True - - - - - True - False - When hovering over a cell on the map, -highlight the paths from the tip to the root of the tree -for labels found in that group. - Highlight node paths for groups? - True - True - - - - - True - False - Set the width of the tree branches. -Does not affect the vertical connectors. - Set tree branch line widths - True - - diff --git a/bin/ui/hboxSpatialPage.ui b/bin/ui/hboxSpatialPage.ui index 0fecb64cc..180864bdc 100644 --- a/bin/ui/hboxSpatialPage.ui +++ b/bin/ui/hboxSpatialPage.ui @@ -176,7 +176,7 @@ True False - Display + Map True @@ -469,103 +469,6 @@ Colours are scaled using percentiles defined in the colour stretch menu. True - - - True - False - - - - - True - False - Tree plot controls - True - - - - - True - False - Show or hide the legend on the tree plot -(if one is relevant) - Show legend - True - True - - - - - True - False - Log scale - Log scale the colours. -Uses the min and max determined by the Colour stretch choice. - True - True - - - - - True - False - Invert colour stretch - Invert (flip) the colour range. Has no effect on categorical colouring. - True - False - - - - - True - False - Colour mode - True - - - True - False - - - True - False - Hue - True - True - - - - - True - False - Sat... - True - True - - - - - True - False - Grey - True - True - - - - - - - - - True - False - Set the width of the tree branches. -Does not affect the vertical connectors. - Set tree branch line widths - True - - diff --git a/lib/Biodiverse/GUI/Dendrogram.pm b/lib/Biodiverse/GUI/Dendrogram.pm index 0cd9c3087..930fb9854 100644 --- a/lib/Biodiverse/GUI/Dendrogram.pm +++ b/lib/Biodiverse/GUI/Dendrogram.pm @@ -118,6 +118,7 @@ sub new { foreach my $widget_name (qw /selector_toggle selector_colorbutton autoincrement_toggle/) { eval { + # use get_xmlpage_object from parent $self->{$widget_name} = $self->get_parent_tab->{xmlPage}->get_object($widget_name); }; @@ -263,6 +264,11 @@ sub destroy { return; } +# makes it available outside the class +sub get_default_line_colour { + DEFAULT_LINE_COLOUR(); +} + ########################################################## # The Slider ########################################################## @@ -678,6 +684,14 @@ sub toggle_use_slider_to_select_nodes { return; } +sub set_use_slider_to_select_nodes { + my ($self, $bool) = @_; + + $self->{use_slider_to_select_nodes} = !!$bool; + + return; +} + # Colours a certain number of nodes below sub do_colour_nodes_below { my $self = shift; @@ -850,6 +864,8 @@ sub set_branch_line_width { my ($self, $val) = @_; my $current = $self->get_branch_line_width; + $val ||= 0; + $self->{branch_line_width} = $val; if ($current != $val && $self->{tree_node}) { @@ -1145,14 +1161,17 @@ sub clear_node_colours { $self->{node_colours_cache} = {}; my $tree = $self->get_tree_object(); - if($tree) { - foreach my $node ($tree->get_node_refs()) { - $self->set_node_colour( - node_name => $node->get_name(), - colour_ref => DEFAULT_LINE_COLOUR, - ); - } + + return if !$tree; + + foreach my $node ($tree->get_node_refs()) { + $self->set_node_colour( + node_name => $node->get_name(), + colour_ref => DEFAULT_LINE_COLOUR, + ); } + + return; } sub set_node_colour { @@ -1238,13 +1257,16 @@ sub recolour_cluster_lines { my $analysis_max = $self->{analysis_max}; my $colour_mode = $self->get_cluster_colour_mode(); - my $legend = $map->get_legend; - $legend->set_colour_mode_from_list_and_index ( - list => $list_name, - index => $list_index, - ); - my @minmax_args = ($analysis_min, $analysis_max); - my $colour_method = $legend->get_colour_method; + my ($legend, @minmax_args, $colour_method); + if ($colour_mode ne 'palette' and not $self->in_multiselect_mode) { + $legend = $map->get_legend; + $legend->set_colour_mode_from_list_and_index( + list => $list_name, + index => $list_index, + ); + @minmax_args = ($analysis_min, $analysis_max); + $colour_method = $legend->get_colour_method; + } foreach my $node_ref (@$cluster_nodes) { @@ -1849,7 +1871,7 @@ sub replay_multiselect_store { # Remove any existing highlights sub clear_highlights { - my $self = shift; + my ($self, $new_colour) = @_; # set all nodes to recorded/default colour return if !$self->{highlighted_lines}; @@ -1859,8 +1881,9 @@ sub clear_highlights { my $line = $self->{node_lines}{$node_name}; next if !$line; my $colour_ref - = $self->get_node_colour_aa ( $node_name ) - || DEFAULT_LINE_COLOUR; + = $new_colour + || $self->get_node_colour_aa ( $node_name ) + || DEFAULT_LINE_COLOUR; $line->set(fill_color_gdk => $colour_ref); } $self->{highlighted_lines} = undef; diff --git a/lib/Biodiverse/GUI/Export.pm b/lib/Biodiverse/GUI/Export.pm index 1ff01f827..7f3d7e65e 100644 --- a/lib/Biodiverse/GUI/Export.pm +++ b/lib/Biodiverse/GUI/Export.pm @@ -36,6 +36,7 @@ sub Run { my $gui = Biodiverse::GUI::GUIManager->instance; # stop keyboard events being applied to any open tabs + my $snooper_status = $gui->keyboard_snooper_active; $gui->activate_keyboard_snooper (0); # Get the Parameters metadata @@ -77,6 +78,7 @@ sub Run { if ($format_response ne 'ok') { $format_dlg->destroy; + $gui->activate_keyboard_snooper ($snooper_status); return; } @@ -98,7 +100,10 @@ sub Run { selected_format => $selected_format, ); - return if !$results->{success}; + if (!$results->{success}) { + $gui->activate_keyboard_snooper($snooper_status); + return; + } my $chooser = $results->{chooser}; my $parameters_table = $results->{param_table}; @@ -139,7 +144,7 @@ sub Run { } $dlg->destroy; - $gui->activate_keyboard_snooper (1); + $gui->activate_keyboard_snooper ($snooper_status); return; } diff --git a/lib/Biodiverse/GUI/Legend.pm b/lib/Biodiverse/GUI/Legend.pm index d0081a1c6..730d97ccc 100644 --- a/lib/Biodiverse/GUI/Legend.pm +++ b/lib/Biodiverse/GUI/Legend.pm @@ -150,6 +150,21 @@ sub show { return; } +sub set_visible { + my ($self, $check) = @_; + + return if !$self->{legend_group}; + + if ($check) { + $self->{legend_group}->show; + } + else { + $self->{legend_group}->hide; + } + + return; +} + # Makes a rectangle and fills it # with colours for the chosen legend # mode. diff --git a/lib/Biodiverse/GUI/Tabs/Clustering.pm b/lib/Biodiverse/GUI/Tabs/Clustering.pm index b4a8d7b19..8534931a4 100644 --- a/lib/Biodiverse/GUI/Tabs/Clustering.pm +++ b/lib/Biodiverse/GUI/Tabs/Clustering.pm @@ -63,7 +63,7 @@ sub new { $self->{xmlPage} = $xml_page; $self->{xmlLabel} = $xml_label; - my $page = $xml_page->get_object('hboxClusteringPage'); + my $page = $self->get_xmlpage_object('hboxClusteringPage'); my $label = $xml_label->get_object('hboxClusteringLabel'); my $label_text = $self->{xmlLabel}->get_object('lblClusteringName')->get_text; @@ -127,8 +127,8 @@ sub new { $self->queue_set_pane(1, 'vpaneClustering'); $self->{existing} = 0; - $xml_page->get_object('toolbarClustering')->hide; - $xml_page->get_object('toolbar_clustering_bottom')->hide; + $self->get_xmlpage_object('toolbarClustering')->hide; + $self->get_xmlpage_object('toolbar_clustering_bottom')->hide; } else { # We're being called to show an EXISTING output @@ -169,7 +169,7 @@ sub new { $defq_object = $def_query_init1; } if (my $prng_seed = $cluster_ref->get_prng_seed_argument()) { - my $spin_widget = $xml_page->get_object('spinbutton_cluster_prng_seed'); + my $spin_widget = $self->get_xmlpage_object('spinbutton_cluster_prng_seed'); $spin_widget->set_value ($prng_seed); } } @@ -192,7 +192,7 @@ sub new { initial_text => $sp_initial1, condition_object => $spatial_conditions[0], ); - $xml_page->get_object('frameClusterSpatialParams1')->add( + $self->get_xmlpage_object('frameClusterSpatialParams1')->add( $self->{spatialParams1}->get_object, ); @@ -202,7 +202,7 @@ sub new { start_hidden => $start_hidden, condition_object => $spatial_conditions[1], ); - $xml_page->get_object('frameClusterSpatialParams2')->add( + $self->get_xmlpage_object('frameClusterSpatialParams2')->add( $self->{spatialParams2}->get_object ); @@ -213,12 +213,12 @@ sub new { is_def_query => 'is_def_query', condition_object => $defq_object, ); - $xml_page->get_object('frameClusterDefinitionQuery1')->add( + $self->get_xmlpage_object('frameClusterDefinitionQuery1')->add( $self->{definition_query1}->get_object ); - $xml_page->get_object('plot_length') ->set_active(1); - $xml_page->get_object('group_length')->set_active(1); + # $self->get_xmlpage_object('plot_length') ->set_active(1); + # $self->get_xmlpage_object('group_length')->set_active(1); $self->{plot_mode} = 'length'; $self->{group_mode} = 'length'; @@ -253,7 +253,7 @@ sub new { ); Biodiverse::GUI::Tabs::CalculationsTree::init_calculations_tree( - $xml_page->get_object('treeSpatialCalculations'), + $self->get_xmlpage_object('treeSpatialCalculations'), $self->{calculations_model} ); @@ -278,16 +278,6 @@ sub new { btnZoomOutToolCL => {clicked => \&on_zoom_out_tool}, btnZoomFitToolCL => {clicked => \&on_zoom_fit_tool}, - plot_length => {toggled => \&on_plot_mode_changed}, - group_length => {toggled => \&on_group_mode_changed}, - - highlight_groups_on_map => - {toggled => \&on_highlight_groups_on_map_changed}, - use_highlight_path_changed => - {toggled => \&on_use_highlight_path_changed}, - menu_use_slider_to_select_nodes => - {toggled => \&on_menu_use_slider_to_select_nodes}, - menuitem_cluster_colour_mode_hue => {toggled => \&on_colour_mode_changed}, menuitem_cluster_colour_mode_sat => {activate => \&on_colour_mode_changed}, menuitem_cluster_colour_mode_grey => {toggled => \&on_colour_mode_changed}, @@ -303,7 +293,6 @@ sub new { menu_cluster_cell_show_outline => {toggled => \&on_set_cell_show_outline}, menuitem_cluster_show_legend => {toggled => \&on_show_hide_legend}, #menuitem_cluster_data_tearoff => {activate => \&on_toolbar_data_menu_tearoff}, - menuitem_cluster_set_tree_line_widths => {activate => \&on_set_tree_line_widths}, menuitem_cluster_excluded_cell_colour => {activate => \&on_set_excluded_cell_colour}, menuitem_cluster_undef_cell_colour => {activate => \&on_set_undef_cell_colour}, ); @@ -317,7 +306,7 @@ sub new { foreach my $widget_name (sort keys %widgets_and_signals) { my $args = $widgets_and_signals{$widget_name}; #say $widget_name; - my $widget = $xml_page->get_object($widget_name); + my $widget = $self->get_xmlpage_object($widget_name); if (!defined $widget) { warn "$widget_name not found"; next; @@ -332,6 +321,7 @@ sub new { $self->{menubar} = $self->get_xmlpage_object('menubar_clustering'); $self->update_export_menu; + $self->update_tree_menu; $self->init_colour_clusters; say "[Clustering tab] - Loaded tab - Clustering Analysis"; @@ -339,6 +329,52 @@ sub new { return $self; } +sub get_cluster_ref { + my $self = shift; + $self->{output_ref}; +} + +sub get_current_tree { + my $self = shift; + $self->get_cluster_ref; +} + + +# has a lot in common with Labels::get_tree_menu_items +sub get_tree_menu_items { + my $self = shift; + + my @menu_items = ( + { + type => 'Gtk2::MenuItem', + label => 'Tree options:', + tooltip => "Options to work with the cluster tree", + }, + ( map {$self->get_tree_menu_item($_)} + qw /plot_branches_by group_branches_by + highlight_groups_on_map highlight_paths_on_tree/ + ), + { + type => 'Gtk2::CheckMenuItem', + label => 'Use the slider bar to select branches for colouring', + tooltip => "When deselected, the slider bar will not change the display colours.", + event => 'toggled', + callback => sub { + my ($self, $menuitem) = @_; + my $bool = $menuitem->get_active; + $self->{dendrogram}->set_use_slider_to_select_nodes ($bool); + }, + active => 1, + }, + ( map {$self->get_tree_menu_item($_)} + qw/separator set_tree_branch_line_widths + separator export_tree/ + ), + ); + + return wantarray ? @menu_items : \@menu_items; +} + sub init_colour_clusters { my $self = shift; my $cluster_ref = $self->{output_ref}; @@ -371,9 +407,8 @@ sub setup_tie_breaker_widgets { my $self = shift; my $existing = shift; - my $xml_page = $self->{xmlPage}; my $hbox_name = 'hbox_cluster_tie_breakers'; - my $breaker_hbox = $xml_page->get_object($hbox_name); + my $breaker_hbox = $self->get_xmlpage_object($hbox_name); my ($tie_breakers, $bd); if ($existing) { @@ -450,13 +485,12 @@ sub setup_tie_breaker_widgets { # thus avoiding the need to build the list. sub set_colour_stretch_widgets_and_signals { my $self = shift; - my $xml_page = $self->{xmlPage}; # lazy - should build from menu widget my $i = 0; foreach my $stretch (qw /min-max 5-95 2.5-97.5 min-95 min-97.5 5-max 2.5-max/) { my $widget_name = "radio_dendro_colour_stretch$i"; - my $widget = $xml_page->get_object($widget_name); + my $widget = $self->get_xmlpage_object($widget_name); my $sub = sub { my $self = shift; @@ -533,11 +567,9 @@ sub on_show_hide_parameters { sub init_map { my $self = shift; - my $xml_page = $self->{xmlPage}; - - my $frame = $xml_page->get_object('mapFrame'); - my $hscroll = $xml_page->get_object('mapHScroll'); - my $vscroll = $xml_page->get_object('mapVScroll'); + my $frame = $self->get_xmlpage_object('mapFrame'); + my $hscroll = $self->get_xmlpage_object('mapHScroll'); + my $vscroll = $self->get_xmlpage_object('mapVScroll'); my $click_closure = sub { $self->on_grid_popup(@_); }; my $hover_closure = sub { $self->on_grid_hover(@_); }; @@ -564,12 +596,12 @@ sub init_map { $grid->set_base_struct($self->{basedata_ref}->get_groups_ref); - my $menu_log_checkbox = $xml_page->get_object('menu_dendro_colour_stretch_log_mode'); + my $menu_log_checkbox = $self->get_xmlpage_object('menu_dendro_colour_stretch_log_mode'); $menu_log_checkbox->signal_connect_swapped( toggled => \&on_grid_colour_scaling_changed, $self, ); - my $checkbox = $xml_page->get_object('menu_dendro_colour_stretch_flip_mode'); + my $checkbox = $self->get_xmlpage_object('menu_dendro_colour_stretch_flip_mode'); $checkbox->signal_connect_swapped( toggled => \&on_grid_colour_flip_changed, $self, @@ -1335,6 +1367,7 @@ sub on_run_analysis { } $self->init_colour_clusters; + $self->update_tree_menu; # If just ran a new analysis, pull up the pane if ($isnew or not $new_analysis) { @@ -1720,8 +1753,7 @@ sub show_cluster_descendents { sub on_name_changed { my $self = shift; - my $xml_page = $self->{xmlPage}; - my $name = $xml_page->get_object('txtClusterName')->get_text(); + my $name = $self->get_xmlpage_object('txtClusterName')->get_text(); my $label_widget = $self->{xmlLabel}->get_object('lblClusteringName'); $label_widget->set_text($name); @@ -1731,7 +1763,7 @@ sub on_name_changed { my $param_widget - = $xml_page->get_object('lbl_parameter_clustering_name'); + = $self->get_xmlpage_object('lbl_parameter_clustering_name'); $param_widget->set_markup("Name"); my $bd = $self->{basedata_ref}; diff --git a/lib/Biodiverse/GUI/Tabs/Labels.pm b/lib/Biodiverse/GUI/Tabs/Labels.pm index 4dd02f25f..0500ad196 100644 --- a/lib/Biodiverse/GUI/Tabs/Labels.pm +++ b/lib/Biodiverse/GUI/Tabs/Labels.pm @@ -5,6 +5,8 @@ use warnings; use English ( -no_match_vars ); +use experimental qw(refaliasing); + #use Data::Dumper; use Sort::Key::Natural qw /natsort mkkey_natural/; @@ -162,7 +164,6 @@ sub new { $self->{active_pane} = ''; # Connect signals - my $xml = $self->{xmlPage}; $self->{xmlLabel}->get_object('btnLabelsClose')->signal_connect_swapped(clicked => \&on_close, $self); @@ -182,21 +183,18 @@ sub new { $sig_clicked->('btnZoomOutToolVL', \&on_zoom_out_tool); $sig_clicked->('btnZoomFitToolVL', \&on_zoom_fit_tool); - $xml->get_object('menuitem_labels_overlays')->signal_connect_swapped(activate => \&on_overlays, $self); + $self->get_xmlpage_object('menuitem_labels_overlays')->signal_connect_swapped(activate => \&on_overlays, $self); $self->get_xmlpage_object("btnSelectToolVL")->set_active(1); - # CONVERT THIS TO A HASH BASED LOOP, as per Clustering.pm - # plot length triggers depth and vice versa - $xml->get_object('phylogeny_plot_length')->signal_connect_swapped(toggled => \&on_phylogeny_plot_mode_changed, $self); - $xml->get_object('highlight_groups_on_map_labels_tab')->signal_connect_swapped(activate => \&on_highlight_groups_on_map_changed, $self); - $xml->get_object('use_highlight_path_changed1')->signal_connect_swapped(activate => \&on_use_highlight_path_changed, $self); - $xml->get_object('menuitem_labels_show_legend')->signal_connect_swapped(toggled => \&on_show_hide_legend, $self); - $xml->get_object('menuitem_labels_set_tree_line_widths')->signal_connect_swapped(activate => \&on_set_tree_line_widths, $self); - + $self->get_xmlpage_object('menuitem_labels_show_legend')->signal_connect_swapped( + toggled => \&on_show_hide_legend, + $self + ); + foreach my $type_option (qw /auto linear log/) { my $radio_item = 'radiomenuitem_grid_colouring_' . $type_option; - $xml->get_object($radio_item)->signal_connect_swapped( + $self->get_xmlpage_object($radio_item)->signal_connect_swapped( toggled => \&on_grid_colour_scaling_changed, $self, ); @@ -207,6 +205,7 @@ sub new { $self->{menubar} = $self->get_xmlpage_object('menubarLabelsOptions'); $self->update_selection_menu; $self->update_export_menu; + $self->update_tree_menu (output_ref => $self->get_base_ref->get_groups_ref); say "[GUI] - Loaded tab - Labels"; @@ -324,6 +323,33 @@ sub init_dendrogram { return 1; } +sub get_current_tree { + my $self = shift; + return $self->{project}->get_selected_phylogeny; +} + +sub get_tree_menu_items { + my $self = shift; + + my @menu_items = ( + { + type => 'Gtk2::MenuItem', + label => 'Tree options:', + tooltip => "Options to work with the displayed tree " + . "(this is the same as the one selected at " + . "the project level)", + }, + ( map {$self->get_tree_menu_item($_)} + qw /plot_branches_by + highlight_groups_on_map highlight_paths_on_tree + separator set_tree_branch_line_widths + separator export_tree / + ), + ); + + return wantarray ? @menu_items : \@menu_items; +} + ################################################## # Labels list ################################################## @@ -743,6 +769,10 @@ sub set_phylogeny_options_sensitive { my $self = shift; my $enabled = shift; + # These are handled differently now. + # Leaving code as a reminder, but returning early. + return; + my $page = $self->{xmlPage}; for my $widget ( @@ -764,7 +794,8 @@ sub on_selected_phylogeny_changed { $self->{dendrogram}->clear; if ($phylogeny) { - $self->{dendrogram}->set_cluster($phylogeny, 'length'); # now storing tree objects directly + # now storing tree objects directly + $self->{dendrogram}->set_cluster($phylogeny, $self->{plot_mode} //= 'length'); $self->set_phylogeny_options_sensitive(1); } else { @@ -792,12 +823,10 @@ sub on_selected_matrix_changed { $self->{matrix_ref} = $matrix_ref; - my $xml_page = $self->{xmlPage}; - # hide the second list if no matrix selected - my $list_window = $xml_page->get_object('scrolledwindow_labels2'); + my $list_window = $self->get_xmlpage_object('scrolledwindow_labels2'); - my $list = $xml_page->get_object('listLabels1'); + my $list = $self->get_xmlpage_object('listLabels1'); my $col = $list->get_column ($labels_model_list2_sel_col); my $labels_are_in_mx = $self->some_labels_are_in_matrix; @@ -828,8 +857,6 @@ sub on_grid_colour_scaling_changed { # avoid triggering twice - we only care about which one is active return if !$radio_widget->get_active; - - my $xml_page = $self->{xmlPage}; my %names_and_strings; foreach my $opt (qw /auto linear log/) { @@ -839,7 +866,7 @@ sub on_grid_colour_scaling_changed { my $mode_string; foreach my $name (keys %names_and_strings) { my $string = $names_and_strings{$name}; - my $widget = $xml_page->get_object($name); + my $widget = $self->get_xmlpage_object($name); if ($widget->get_active) { $mode_string = $string; last; @@ -960,12 +987,12 @@ sub on_selected_labels_changed { #FIXME: This copies the hash (???recheck???) - not very fast... #my %hash = $self->{base_ref}->get_groups_with_label_as_hash(label => $label); # SWL - just use a ref. Unless Eugene was thinking of what the sub does... - my $hash = $bd->get_groups_with_label_as_hash (label => $label); + \my %hash = $bd->get_groups_with_label_as_hash_aa ($label); # groups contains count of how many different labels occur in it - foreach my $group (keys %$hash) { - $group_richness{$group}++; - } + # postfix-if for speed + $group_richness{$_}++ + foreach keys %hash; } my $grid = $self->{grid}; @@ -994,6 +1021,7 @@ sub on_selected_labels_changed { else { $grid->set_legend_log_mode_off; } + my $legend = $grid->get_legend; my $colour_func = sub { my $elt = shift; @@ -1003,7 +1031,7 @@ sub on_selected_labels_changed { #if ($use_log) { # $val = log ($val + 1); #} - return $grid->get_colour($val, 0, $display_max_value); + return $legend->get_colour($val, 0, $display_max_value); }; $grid->colour($colour_func); @@ -1092,9 +1120,8 @@ sub on_sorted { my $redraw = $args{redraw}; - my $xml_page = $self->{xmlPage}; - my $hmodel = $xml_page->get_object('listLabels1')->get_model(); - my $vmodel = $xml_page->get_object('listLabels2')->get_model(); + my $hmodel = $self->get_xmlpage_object('listLabels1')->get_model(); + my $vmodel = $self->get_xmlpage_object('listLabels2')->get_model(); my $model = $self->{labels_model}; my $matrix_ref = $self->{matrix_ref}; @@ -1223,9 +1250,9 @@ sub on_grid_hover { # highlight in the tree foreach my $label (keys %$labels) { # Might not match some or all nodes - next if !$tree->exists_node (name => $label); + next if !$tree->exists_node_name_aa ($label); eval { - my $node_ref = $tree->get_node_ref (node => $label); + my $node_ref = $tree->get_node_ref_aa ($label); $self->{dendrogram}->highlight_path($node_ref); } } @@ -1254,10 +1281,9 @@ sub on_grid_select { } # Select all terminal labels - my $xml_page = $self->{xmlPage}; - my $model = $self->{labels_model}; - my $hmodel = $xml_page->get_object('listLabels1')->get_model(); - my $hselection = $xml_page ->get_object('listLabels1')->get_selection(); + my $model = $self->{labels_model}; + my $hmodel = $self->get_xmlpage_object('listLabels1')->get_model(); + my $hselection = $self->get_xmlpage_object('listLabels1')->get_selection(); my $sel_mode = $self->get_selection_mode; @@ -1301,8 +1327,6 @@ sub on_grid_select { sub on_phylogeny_plot_mode_changed { my ($self, $combo) = @_; - my $xml_page = $self->{xmlPage}; - my %names_and_strings = ( phylogeny_plot_depth => 'depth', phylogeny_plot_length => 'length', @@ -1311,7 +1335,7 @@ sub on_phylogeny_plot_mode_changed { my $mode_string; while (my ($name, $string) = each %names_and_strings) { - my $widget = $xml_page->get_object($name); + my $widget = $self->get_xmlpage_object($name); if ($widget->get_active) { $mode_string = $string; last; diff --git a/lib/Biodiverse/GUI/Tabs/Outputs.pm b/lib/Biodiverse/GUI/Tabs/Outputs.pm index 00f2f56cb..8bcca457d 100644 --- a/lib/Biodiverse/GUI/Tabs/Outputs.pm +++ b/lib/Biodiverse/GUI/Tabs/Outputs.pm @@ -30,7 +30,7 @@ sub new { $self->{xmlLabel} = Gtk2::Builder->new(); $self->{xmlLabel}->add_from_file($self->{gui}->get_gtk_ui_file('hboxOutputsLabel.ui')); - my $page = $self->{xmlPage} ->get_object('hboxOutputsPage'); + my $page = $self->get_xmlpage_object('hboxOutputsPage'); my $label = $self->{xmlLabel}->get_object('hboxOutputsLabel'); my $menu_label = Gtk2::Label->new ('Outputs tab'); @@ -78,13 +78,11 @@ sub new { $model->signal_connect('row-inserted' => \&on_row_inserted, $self); # Connect signals - #$self->{xmlLabel}->get_object("btnOutputsClose")->signal_connect_swapped(clicked => \&Tabs::Tab::on_close, $self); - my $xml_page = $self->{xmlPage}; - $xml_page->get_object('btnOutputsShow' )->signal_connect_swapped(clicked => \&on_show, $self); - $xml_page->get_object('btnOutputsExport')->signal_connect_swapped(clicked => \&on_export, $self); - $xml_page->get_object('btnOutputsDelete')->signal_connect_swapped(clicked => \&on_delete, $self); - $xml_page->get_object('btnOutputsRename')->signal_connect_swapped(clicked => \&on_rename, $self); - $xml_page->get_object('btnOutputsDescribe')->signal_connect_swapped(clicked => \&on_describe, $self); + $self->get_xmlpage_object('btnOutputsShow' )->signal_connect_swapped(clicked => \&on_show, $self); + $self->get_xmlpage_object('btnOutputsExport')->signal_connect_swapped(clicked => \&on_export, $self); + $self->get_xmlpage_object('btnOutputsDelete')->signal_connect_swapped(clicked => \&on_delete, $self); + $self->get_xmlpage_object('btnOutputsRename')->signal_connect_swapped(clicked => \&on_rename, $self); + $self->get_xmlpage_object('btnOutputsDescribe')->signal_connect_swapped(clicked => \&on_describe, $self); @@ -206,12 +204,11 @@ sub on_row_changed { my $sensitive = $type eq 'output' || $type eq 'basedata'; - my $xml_page = $self->{xmlPage}; my @widget_name_array = qw /btnOutputsExport btnOutputsDelete btnOutputsRename/; foreach my $widget_name (@widget_name_array) { - $xml_page->get_object($widget_name)->set_sensitive($sensitive); + $self->get_xmlpage_object($widget_name)->set_sensitive($sensitive); } # If clicked on basedata, select it diff --git a/lib/Biodiverse/GUI/Tabs/Randomise.pm b/lib/Biodiverse/GUI/Tabs/Randomise.pm index dd7cd0c63..b2c97711d 100644 --- a/lib/Biodiverse/GUI/Tabs/Randomise.pm +++ b/lib/Biodiverse/GUI/Tabs/Randomise.pm @@ -55,10 +55,9 @@ sub new { $self->{xmlLabel} = Gtk2::Builder->new(); $self->{xmlLabel}->add_from_file($self->{gui}->get_gtk_ui_file('hboxRandomiseLabel.ui')); - my $xml_page = $self->{xmlPage}; my $xml_label = $self->{xmlLabel}; - my $page = $xml_page ->get_object('vboxRandomisePage'); + my $page = $self->get_xmlpage_object('vboxRandomisePage'); my $label = $xml_label->get_object('hboxRandomiseLabel'); my $label_text = $xml_label->get_object('lblRandomiseName')->get_text; my $label_widget = Gtk2::Label->new ($label_text); @@ -105,7 +104,7 @@ sub new { $self->add_iteration_count_to_table ($output_ref); my $name; - my $seed_widget = $xml_page->get_object('randomise_seed_value'); + my $seed_widget = $self->get_xmlpage_object('randomise_seed_value'); if ($output_ref) { #$self->{project}->register_in_outputs_model ($output_ref, $self); $self->register_in_outputs_model ($output_ref, $self); @@ -119,7 +118,7 @@ sub new { } $xml_label->get_object('lblRandomiseName')->set_text($name); - $xml_page ->get_object('randomise_results_list_name')->set_text ($name); + $self->get_xmlpage_object('randomise_results_list_name')->set_text ($name); $self->{tab_menu_label}->set_text($name ); # Connect signals @@ -127,11 +126,11 @@ sub new { clicked => \&on_close, $self, ); - $xml_page->get_object('btnRandomise')->signal_connect_swapped( + $self->get_xmlpage_object('btnRandomise')->signal_connect_swapped( clicked => \&on_run, $self, ); - $xml_page->get_object('randomise_results_list_name')->signal_connect_swapped( + $self->get_xmlpage_object('randomise_results_list_name')->signal_connect_swapped( changed => \&on_name_changed, $self, ); @@ -145,9 +144,7 @@ sub new { sub get_table_widget { my $self = shift; - my $xml_page = $self->{xmlPage}; - - my $table = $xml_page->get_object('table_randomise_setup'); + my $table = $self->get_xmlpage_object('table_randomise_setup'); return $table; } @@ -167,9 +164,7 @@ sub add_iteration_count_to_table { my $self = shift; my $output_ref = shift; - my $xml_page = $self->{xmlPage}; - - my $table = $xml_page->get_object('table_randomise_setup'); + my $table = $self->get_xmlpage_object('table_randomise_setup'); my $count = defined $output_ref ? $output_ref->get_param ('TOTAL_ITERATIONS') @@ -218,9 +213,8 @@ sub set_button_sensitivity { comboFunction /; - my $xml_page = $self->{xmlPage}; foreach my $widget (@widgets) { - $xml_page->get_object($widget)->set_sensitive ($sens); + $self->get_xmlpage_object($widget)->set_sensitive ($sens); } my $table = $self->get_xmlpage_object('tableParams'); @@ -619,9 +613,8 @@ sub on_run { $args{iterations} = $self->get_xmlpage_object('spinIterations')->get_value_as_int; - my $xml_page = $self->{xmlPage}; - my $name = $xml_page->get_object('randomise_results_list_name')->get_text; - my $seed = $xml_page->get_object('randomise_seed_value')->get_text; + my $name = $self->get_xmlpage_object('randomise_results_list_name')->get_text; + my $seed = $self->get_xmlpage_object('randomise_seed_value')->get_text; $seed =~ s/\s//g; # strip any whitespace if (not defined $seed or length ($seed) == 0) { warn "[GUI Randomise] PRNG seed is not defined, using system default\n"; diff --git a/lib/Biodiverse/GUI/Tabs/RegionGrower.pm b/lib/Biodiverse/GUI/Tabs/RegionGrower.pm index 8326e8289..c1aaf68d3 100644 --- a/lib/Biodiverse/GUI/Tabs/RegionGrower.pm +++ b/lib/Biodiverse/GUI/Tabs/RegionGrower.pm @@ -20,8 +20,7 @@ sub new { bless $self, $class; # now add some additional stuff - my $xml_page = $self->{xmlPage}; - my $hbox = $xml_page->get_object('hbox_cluster_metric'); + my $hbox = $self->get_xmlpage_object('hbox_cluster_metric'); my $label_widget = Gtk2::Label->new('Objective function: '); my $combo_minmax = Gtk2::ComboBox->new_text(); diff --git a/lib/Biodiverse/GUI/Tabs/Spatial.pm b/lib/Biodiverse/GUI/Tabs/Spatial.pm index 7fe14d457..3879751dc 100644 --- a/lib/Biodiverse/GUI/Tabs/Spatial.pm +++ b/lib/Biodiverse/GUI/Tabs/Spatial.pm @@ -141,7 +141,7 @@ sub new { $self->{output_ref} = $output_ref; # Initialise widgets - $self->{title_widget} = $self->{xmlPage} ->get_object('txtSpatialName'); + $self->{title_widget} = $self->get_xmlpage_object('txtSpatialName'); $self->{label_widget} = $self->{xmlLabel}->get_object('lblSpatialName'); $self->{title_widget}->set_text($self->{output_name} ); @@ -282,15 +282,8 @@ sub new { menuitem_spatial_undef_cell_colour => {activate => \&on_set_undef_cell_colour}, menuitem_spatial_cell_show_outline => {toggled => \&on_set_cell_show_outline}, menuitem_spatial_show_legend => {toggled => \&on_show_hide_legend}, - menuitem_spatial_set_tree_line_widths => {activate => \&on_set_tree_line_widths}, button_spatial_options => {clicked => \&run_options_dialogue}, - - menuitem_spatial_tree_colour_mode_hue => {toggled => \&on_tree_colour_mode_changed}, - menuitem_spatial_tree_colour_mode_sat => {toggled => \&on_tree_colour_mode_changed}, - menuitem_spatial_tree_colour_mode_grey => {toggled => \&on_tree_colour_mode_changed}, - - menuitem_spatial_tree_show_legend => {toggled => \&on_show_tree_legend_changed}, ); # bodge - should set the radio group @@ -337,12 +330,87 @@ sub new { $self->{menubar} = $self->get_xmlpage_object('menubar_spatial'); $self->update_export_menu; + $self->update_tree_menu; say "[Spatial tab] - Loaded tab - Spatial Analysis"; return $self; } +sub get_tree_menu_items { + my $self = shift; + + my @menu_items = ( + { + type => 'Gtk2::MenuItem', + label => 'Branch colouring', + tooltip => "These options control the branch colouring (when relevant)\n" + . 'The menu to control what is displayed is below the tree.', + }, + { + type => 'Gtk2::CheckMenuItem', + label => 'Show legend', + tooltip => 'Show or hide the legend on the tree plot (if one is relevant)', + event => 'toggled', + callback => \&on_show_tree_legend_changed, + active => 1, + self_key => 'checkbox_show_tree_legend', + }, + { + type => 'Gtk2::CheckMenuItem', + label => 'Log scale', + tooltip => "Log scale the colours.\n" + . "Uses the min and max determined by the Colour stretch choice.", + event => 'toggled', + callback => sub { + my ($self, $menuitem) = @_; + $self->{use_tree_log_scale} = $menuitem->get_active; + }, + active => 1, + }, + { + type => 'Gtk2::CheckMenuItem', + label => 'Invert colour stretch', + tooltip => "Invert (flip) the colour range. Has no effect on categorical colouring.", + event => 'toggled', + callback => sub { + my ($self, $menuitem) = @_; + $self->{tree_invert_colours} = $menuitem->get_active; + }, + active => 0, + }, + { + type => 'submenu_radio_group', + label => 'Colour mode', + items => [ # could be refactored + { + type => 'Gtk2::RadioMenuItem', + label => 'Hue', + event => 'activate', + callback => \&on_tree_colour_mode_changed, + }, + { + type => 'Gtk2::RadioMenuItem', + label => 'Sat...', + event => 'activate', + callback => \&on_tree_colour_mode_changed, + }, + { + type => 'Gtk2::RadioMenuItem', + label => 'Grey', + event => 'activate', + callback => \&on_tree_colour_mode_changed, + } + ], + }, + ( map {$self->get_tree_menu_item($_)} + qw /separator plot_branches_by set_tree_branch_line_widths + separator export_tree / + ), + ); + + return wantarray ? @menu_items : \@menu_items; +} # doesn't work yet sub screenshot { @@ -409,8 +477,7 @@ sub setup_dendrogram { sub update_dendrogram_combo { my $self = shift; - my $xmlpage = $self->{xmlPage}; - my $combobox = $xmlpage->get_object('comboTreeSelect'); + my $combobox = $self->get_xmlpage_object('comboTreeSelect'); # Clear the curent entries. # We need to load a new ListStore to avoid crashes due @@ -504,8 +571,7 @@ sub init_branch_colouring_menu { return if !defined $self->{output_ref}; return if blessed ($self) =~ /Matrix/; - my $xml_page = $self->{xmlPage}; - my $bottom_hbox = $xml_page->get_object('hbox_spatial_tab_bottom'); + my $bottom_hbox = $self->get_xmlpage_object('hbox_spatial_tab_bottom'); my $menubar = $self->{branch_colouring_menu}; my $have_menu = !!$menubar; @@ -521,8 +587,6 @@ sub init_branch_colouring_menu { my $label = Gtk2::Label->new('Branch colouring: '); - my $checkbox_show_legend - = $self->get_xmlpage_object('menuitem_spatial_tree_show_legend'); $menubar = Gtk2::MenuBar->new; my $menu = Gtk2::Menu->new; my $menuitem = Gtk2::MenuItem->new_with_label('Branch colouring: '); @@ -531,7 +595,9 @@ sub init_branch_colouring_menu { my $menu_action = sub { my $args = shift; my ($self, $listname, $output_ref) = @$args; - if ($checkbox_show_legend->get_active) { + my $chk_show_legend = $self->{checkbox_show_tree_legend}; + my $show_legend = $chk_show_legend ? $chk_show_legend->get_active : 1; + if ($show_legend) { $self->{dendrogram}->update_legend; # need dendrogram to pass on coords $self->{dendrogram}->get_legend->show; } @@ -1496,6 +1562,7 @@ sub on_run { $self->{initialising_grid} = 0; $self->update_export_menu; + $self->update_tree_menu; $self->{project}->set_dirty; @@ -1657,6 +1724,10 @@ sub highlight_paths_on_dendrogram { : $colour; $dendrogram->highlight_node ($node_ref, $colour_ref); + $dendrogram->set_node_colour( + colour_ref => $colour_ref, + node_name => $node_name, + ); $done{$node_name}[$idx]++; @@ -1688,11 +1759,8 @@ sub colour_branches_on_dendrogram { index => '', ); - my $log_check_box = $self->get_xmlpage_object('menuitem_spatial_tree_log_scale'); - $legend->set_log_mode($log_check_box->get_active); - - my $flip_check_box = $self->get_xmlpage_object('menuitem_spatial_tree_colour_stretch_flip_mode'); - $legend->set_invert_colours ($flip_check_box->get_active); + $legend->set_log_mode($self->{use_tree_log_scale}); + $legend->set_invert_colours ($self->{tree_invert_colours}); my $listref = $output_ref->get_list_ref ( list => $list_name, @@ -1708,8 +1776,8 @@ sub colour_branches_on_dendrogram { my @minmax_args = ($min, $max); my $colour_method = $legend->get_colour_method; - my $checkbox_show_legend = $self->get_xmlpage_object('menuitem_spatial_tree_show_legend'); - if ($checkbox_show_legend->get_active) { + my $checkbox_show_tree_legend = $self->{checkbox_show_tree_legend}; + if ($checkbox_show_tree_legend->get_active) { $dendrogram->update_legend; # need dendrogram to pass on coords $legend->show; } @@ -1742,13 +1810,17 @@ sub colour_branches_on_dendrogram { : COLOUR_BLACK; $dendrogram->highlight_node ($node_ref, $colour_ref); + $dendrogram->set_node_colour( + colour_ref => $colour_ref, + node_name => $node_name, + ); $done{$node_name}++; $node_ref = $node_ref->get_parent; } } - + } sub on_end_grid_hover { @@ -1756,7 +1828,7 @@ sub on_end_grid_hover { my $dendrogram = $self->{dendrogram} // return; - $dendrogram->clear_highlights; + $dendrogram->clear_highlights ($dendrogram->get_default_line_colour); } sub get_trees_are_available_to_plot { @@ -1810,8 +1882,7 @@ sub get_current_tree { sub on_name_changed { my $self = shift; - my $xml_page = $self->{xmlPage}; - my $name = $xml_page->get_object('txtSpatialName')->get_text(); + my $name = $self->get_xmlpage_object('txtSpatialName')->get_text(); my $label_widget = $self->{xmlLabel}->get_object('lblSpatialName'); $label_widget->set_text($name); @@ -1820,7 +1891,7 @@ sub on_name_changed { $tab_menu_label->set_text($name); my $param_widget - = $xml_page->get_object('lbl_parameter_spatial_name'); + = $self->get_xmlpage_object('lbl_parameter_spatial_name'); $param_widget->set_markup("Name"); my $bd = $self->{basedata_ref}; diff --git a/lib/Biodiverse/GUI/Tabs/SpatialMatrix.pm b/lib/Biodiverse/GUI/Tabs/SpatialMatrix.pm index 9b3707399..4a1210f14 100644 --- a/lib/Biodiverse/GUI/Tabs/SpatialMatrix.pm +++ b/lib/Biodiverse/GUI/Tabs/SpatialMatrix.pm @@ -106,7 +106,7 @@ sub new { # Initialise widgets - $self->{title_widget} = $self->{xmlPage} ->get_object('txtSpatialName'); + $self->{title_widget} = $self->get_xmlpage_object('txtSpatialName'); $self->{label_widget} = $self->{xmlLabel}->get_object('lblSpatialName'); $self->{title_widget}->set_text($self->{output_name} ); @@ -153,7 +153,6 @@ sub new { menuitem_spatial_undef_cell_colour => {activate => \&on_set_undef_cell_colour}, menuitem_spatial_cell_show_outline => {toggled => \&on_set_cell_show_outline}, menuitem_spatial_show_legend => {toggled => \&on_show_hide_legend}, - menuitem_spatial_set_tree_line_widths => {activate => \&on_set_tree_line_widths}, ); for my $n (0..6) { @@ -218,6 +217,7 @@ sub new { $self->{menubar} = $self->get_xmlpage_object('menubar_spatial'); $self->update_export_menu; + $self->update_tree_menu; # debug stuff $self->{selected_list} = 'SUBELEMENTS'; @@ -231,6 +231,14 @@ sub on_show_hide_parameters { } +sub get_tree_menu_items { + my $self = shift; + my @items = $self->SUPER::get_tree_menu_items; + my $re_wanted = qr/Set tree branch line widths|Plot branches by|Export/; + @items = grep {$_->{type} =~ /Separator/ or $_->{label} =~ /$re_wanted/} @items; + return wantarray ? @items : \@items; +} + sub init_grid { my $self = shift; diff --git a/lib/Biodiverse/GUI/Tabs/Tab.pm b/lib/Biodiverse/GUI/Tabs/Tab.pm index 0c3dc45ab..4c3ff19ff 100644 --- a/lib/Biodiverse/GUI/Tabs/Tab.pm +++ b/lib/Biodiverse/GUI/Tabs/Tab.pm @@ -445,8 +445,6 @@ sub on_grid_colour_flip_changed { return if !$grid; - my $xml_page = $self->{xmlPage}; - my $active = !!$checkbox->get_active; my $prev_mode = !!$grid->get_legend->get_invert_colours; @@ -465,8 +463,6 @@ sub on_grid_colour_flip_changed { sub on_grid_colour_scaling_changed { my ($self, $checkbox) = @_; - my $xml_page = $self->{xmlPage}; - my $active = $checkbox->get_active; if ($active) { @@ -980,6 +976,34 @@ sub get_colour_from_chooser { return $colour; } +sub set_dendrogram_plot_mode { + my ($self, $mode_string) = @_; + $mode_string ||= 'length'; + return if ($self->{plot_mode} // '') eq $mode_string; + my $tab_type = (blessed $self) =~ s/.+:://r; + say "[$tab_type tab] Changing tree plot mode to $mode_string"; + $self->{plot_mode} = $mode_string; + return if !$self->get_current_tree; + if (my $dendrogram = $self->{dendrogram}) { + $dendrogram->set_plot_mode($mode_string) + }; +}; + +# only used by Clustering at the moment +sub set_dendrogram_group_by_mode { + my ($self, $mode_string) = @_; + $mode_string ||= 'length'; + return if $self->{group_mode} eq $mode_string; + my $tab_type = (blessed $self) =~ s/.+:://r; + say "[$tab_type tab] Changing selection grouping mode to $mode_string"; + $self->{group_mode} = $mode_string; + return if !$self->get_current_tree; + if (my $dendrogram = $self->{dendrogram}) { + $dendrogram->set_group_mode($mode_string) + }; +}; + + sub on_set_tree_line_widths { my $self = shift; @@ -1158,4 +1182,231 @@ sub update_display_list_combos { return; } +sub update_tree_menu { + my ($self, %args) = @_; + + my $menubar = $self->{menubar}; + my $output_ref = $args{output_ref} || $self->{output_ref}; + return if !$output_ref; + + my $menu_items = $args{menu_items} || $self->get_tree_menu_items; + + my $tree_menu = $self->{tree_menu}; + + if (!$tree_menu) { + my $sep = Gtk2::SeparatorMenuItem->new; + $menubar->append($sep); + $tree_menu = Gtk2::MenuItem->new_with_label('Tree'); + $menubar->append($tree_menu); + $self->{tree_menu} = $tree_menu; + } + + if (($output_ref->get_param('COMPLETED') // 1) != 1) { + # completed == 2 for clusters analyses with matrices only + $tree_menu->set_sensitive(0); + } + else { + my $submenu = Gtk2::Menu->new; + + $self->_add_items_to_menu ( + menu => $submenu, + items => $menu_items, + ); + + $tree_menu->set_submenu($submenu); + $tree_menu->set_sensitive(1); + } + + $menubar->show_all(); +} + +sub _add_items_to_menu { + my ($self, %args) = @_; + my @menu_items = @{$args{items}}; + my $menu = $args{menu}; + my $radio_group = $args{radio_group}; + + ITEM: + foreach my $item (@menu_items) { + my $type = $item->{type} // 'Gtk2::MenuItem'; + + if ($type eq 'submenu_radio_group') { + # a bit messy + my $menu_item = Gtk2::MenuItem->new($item->{label} // ()); + if (my $tooltip = $item->{tooltip}) { + $menu_item->set_has_tooltip(1); + $menu_item->set_tooltip_text($tooltip); + } + $menu->append($menu_item); + my $radio_submenu = Gtk2::Menu->new; + $self->_add_items_to_menu( + items => $item->{items}, + menu => $radio_submenu, # temp + radio_group => [], + ); + $menu_item->set_submenu($radio_submenu); + next ITEM; + } + + my $menu_item; + if ($type =~ /Radio/) { + $menu_item = $type->new($radio_group, $item->{label} // ()); + push @$radio_group, $menu_item; + } + else { + $menu_item = $type->new($item->{label} // ()); + } + $menu->append($menu_item); + + next ITEM if $type =~ /Separator/; + + if (my $key = $item->{self_key}) { + $self->{$key} = $menu_item, + } + if (my $tooltip = $item->{tooltip}) { + $menu_item->set_has_tooltip(1); + $menu_item->set_tooltip_text($tooltip); + } + if (($type =~ 'Check') && exists $item->{active}) { + $menu_item->set_active($item->{active}); + } + if (my $callback = $item->{callback}) { + my $args = $item->{callback_args}; + $menu_item->signal_connect_swapped( + $item->{event} => $callback, + $args // $self + ); + } + } + +} + +sub get_tree_menu_item { + my ($self, $wanted) = @_; + + state $tooltip_select_by = < { + type => 'submenu_radio_group', + label => 'Plot branches by', + items => [ + { + type => 'Gtk2::RadioMenuItem', + label => 'Length', + event => 'activate', + callback => sub { + my $self = shift; + $self->set_dendrogram_plot_mode('length'), + }, + }, + { + type => 'Gtk2::RadioMenuItem', + label => 'Depth', + event => 'activate', + callback => sub { + my $self = shift; + $self->set_dendrogram_plot_mode('depth'); + }, + }, + ], + }, + group_branches_by => { + type => 'submenu_radio_group', + label => 'Select branches by', + tooltip => $tooltip_select_by, + items => [ + { + type => 'Gtk2::RadioMenuItem', + label => 'Length', + event => 'activate', + callback => sub { + my $self = shift; + $self->set_dendrogram_group_by_mode('length'); + }, + }, + { + type => 'Gtk2::RadioMenuItem', + label => 'Depth', + event => 'activate', + callback => sub { + my $self = shift; + $self->set_dendrogram_group_by_mode('depth'); + }, + }, + ], + }, + set_tree_branch_line_widths => { + type => 'Gtk2::MenuItem', + label => 'Set tree branch line widths', + tooltip => "Set the width of the tree branches.\n" + . "Does not affect the vertical connectors.", + event => 'activate', + callback => \&on_set_tree_line_widths, + }, + highlight_groups_on_map => { + type => 'Gtk2::CheckMenuItem', + label => 'Highlight groups on map', + tooltip => 'When hovering the mouse over a tree branch, ' + . 'highlight the groups on the map in which it is found.', + event => 'toggled', + callback => sub { + my $self = shift; + $self->on_highlight_groups_on_map_changed; + }, + active => 1, + self_key => 'checkbox_show_tree_legend', + }, + highlight_paths_on_tree => { + type => 'Gtk2::CheckMenuItem', + label => 'Highlight paths on tree', + tooltip => "When hovering over a group on the map, highlight the paths " + . "connecting the tips of the tree (that match labels in the group) " + . "to the root.", + event => 'toggled', + callback => sub { + my $self = shift; + $self->on_use_highlight_path_changed; + }, + active => 1, + }, + export_tree => { + type => 'Gtk2::MenuItem', + label => 'Export tree', + tooltip => 'Export the currently displayed tree', + event => 'activate', + callback => sub { + my $self = shift; + my $tree_ref = $self->get_current_tree; + return if !$tree_ref; + return Biodiverse::GUI::Export::Run($tree_ref); + }, + }, + separator => { + type => 'Gtk2::SeparatorMenuItem', + }, + }; + + my $item = $items->{$wanted}; + croak "Cannot find tree menu item item $wanted" + if !$item; + + return $item; +} + + 1;