diff --git a/.github/workflows/macos.yml b/.github/workflows/macos.yml index e39f155a3..3ca41ffdb 100644 --- a/.github/workflows/macos.yml +++ b/.github/workflows/macos.yml @@ -35,7 +35,7 @@ jobs: which cpanm - name: Install GDAL and its deps - run: brew install gdal + run: brew install --force --overwrite gdal - name: perl -V run: perl -V diff --git a/.gitignore b/.gitignore index 1e5b75984..2359847d9 100644 --- a/.gitignore +++ b/.gitignore @@ -20,3 +20,4 @@ biodiverse.iml /xx.bps /biodiverseb.iml /.idea +/AGS_bin diff --git a/bin/ui/hboxClusteringPage.ui b/bin/ui/hboxClusteringPage.ui index 14bd64213..338811f99 100644 --- a/bin/ui/hboxClusteringPage.ui +++ b/bin/ui/hboxClusteringPage.ui @@ -222,6 +222,15 @@ Uses the min and max determined by the Colour stretch choice. True + + + True + False + Invert (flip) the colour range. Has no effect on categorical colouring. + Invert colour stretch + True + + True diff --git a/bin/ui/hboxSpatialPage.ui b/bin/ui/hboxSpatialPage.ui index a8b36e05c..0fecb64cc 100644 --- a/bin/ui/hboxSpatialPage.ui +++ b/bin/ui/hboxSpatialPage.ui @@ -222,6 +222,15 @@ True + + + True + False + Invert (flip) the colour range. Has no effect on categorical colouring. + Invert colour stretch + True + + True @@ -490,10 +499,22 @@ Colours are scaled using percentiles defined in the colour stretch menu. 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 diff --git a/lib/Biodiverse/GUI/Dendrogram.pm b/lib/Biodiverse/GUI/Dendrogram.pm index c0b449f28..094f7961e 100644 --- a/lib/Biodiverse/GUI/Dendrogram.pm +++ b/lib/Biodiverse/GUI/Dendrogram.pm @@ -871,12 +871,19 @@ sub recolour_cluster_elements { my $cluster_colour_mode = $self->get_cluster_colour_mode(); my $colour_callback; - + + my %list_and_index = (list => $list_name, index => $list_index); my $is_canape = $list_name =~ />>CANAPE>>/ && $list_index =~ /CANAPE/; my $is_zscore = eval { - $parent_tab->index_is_zscore(list => $list_name, index => $list_index); + $parent_tab->index_is_zscore(%list_and_index); }; my $is_prank = $list_name =~ />>p_rank>>/; + my $is_ratio + = !$is_prank && !$is_zscore + && eval {$parent_tab->index_is_ratio(%list_and_index)}; + my $is_divergent + = !$is_prank && !$is_zscore && !$is_ratio + && eval {$parent_tab->index_is_divergent(%list_and_index)}; if ($cluster_colour_mode eq 'palette') { # sets colours according to palette @@ -917,6 +924,18 @@ sub recolour_cluster_elements { }; } elsif ($cluster_colour_mode eq 'list-values') { + my $abs_extreme; + if ($is_ratio) { + $abs_extreme = exp (max (abs log $analysis_min, log $analysis_max)); + $analysis_min = 1 / $abs_extreme; + $analysis_max = $abs_extreme; + } + elsif ($is_divergent) { # assumes zero - needs work + $abs_extreme = max(abs $analysis_min, abs $analysis_max); + $analysis_min = 0; + $analysis_max = $abs_extreme; + } + # sets colours according to (usually spatial) # list value for the element's cluster $colour_callback = sub { @@ -936,6 +955,8 @@ sub recolour_cluster_elements { return $is_canape ? $map->get_colour_canape ($val) : $is_zscore ? $map->get_colour_zscore ($val) : $is_prank ? $map->get_colour_prank ($val) + : $is_ratio ? $map->get_colour_ratio ($val, $abs_extreme) + : $is_divergent ? $map->get_colour_divergent ($val, 0, $abs_extreme) : $map->get_colour($val, $analysis_min, $analysis_max); } else { @@ -956,6 +977,8 @@ sub recolour_cluster_elements { $map->get_legend->set_canape_mode($is_canape); $map->get_legend->set_zscore_mode($is_zscore); $map->get_legend->set_prank_mode($is_prank); + $map->get_legend->set_ratio_mode($is_ratio); + $map->get_legend->set_divergent_mode($is_divergent); if ($cluster_colour_mode eq 'list-values') { $map->set_legend_min_max($analysis_min, $analysis_max); @@ -1235,12 +1258,32 @@ sub recolour_cluster_lines { my $analysis_min = $self->{analysis_min}; my $analysis_max = $self->{analysis_max}; my $colour_mode = $self->get_cluster_colour_mode(); - + + my %list_and_index = (list => $list_name, index => $list_index); my $is_canape = $list_name =~ />>CANAPE>>/ && $list_index =~ /^CANAPE/; my $is_zscore = eval { - $self->{parent_tab}->index_is_zscore (list => $list_name, index => $list_index); + $self->{parent_tab}->index_is_zscore (%list_and_index); }; my $is_prank = $list_name =~ />>p_rank>>/; + my $is_ratio + = !$is_prank && !$is_zscore + && eval {$self->{parent_tab}->index_is_ratio(%list_and_index)}; + my $is_divergent + = !$is_prank && !$is_zscore && !$is_ratio + && eval {$self->{parent_tab}->index_is_divergent(%list_and_index)}; + + my $abs_extreme; + if ($is_ratio) { + $abs_extreme = exp (max (abs log $analysis_min, log $analysis_max)); + $analysis_min = 1 / $abs_extreme; + $analysis_max = $abs_extreme; + } + elsif ($is_divergent) { # assumes zero - needs work + $abs_extreme = max(abs $analysis_min, abs $analysis_max); + $analysis_min = 0; + $analysis_max = $abs_extreme; + } + foreach my $node_ref (@$cluster_nodes) { @@ -1264,10 +1307,12 @@ sub recolour_cluster_lines { : undef; # allows for missing lists $colour_ref = defined $val - ? ( $is_canape ? $map->get_colour_canape($val) - : $is_zscore ? $map->get_colour_zscore($val) - : $is_prank ? $map->get_colour_prank($val) - : $map->get_colour ($val, $analysis_min, $analysis_max) + ? ( $is_canape ? $map->get_colour_canape($val) : + $is_zscore ? $map->get_colour_zscore($val) : + $is_prank ? $map->get_colour_prank($val) : + $is_ratio ? $map->get_colour_ratio ($val, $abs_extreme) : + $is_divergent ? $map->get_colour_divergent ($val, 0, $abs_extreme) : + $map->get_colour ($val, $analysis_min, $analysis_max) ) : undef; } @@ -3111,6 +3156,7 @@ sub update_legend { return if !$legend; if ($self->{width_px} && $self->{height_px}) { + $legend->make_rect; $legend->reposition($self->{width_px}, $self->{height_px}); } diff --git a/lib/Biodiverse/GUI/Grid.pm b/lib/Biodiverse/GUI/Grid.pm index 3e8cb1e69..e47d83d6d 100644 --- a/lib/Biodiverse/GUI/Grid.pm +++ b/lib/Biodiverse/GUI/Grid.pm @@ -221,6 +221,7 @@ sub update_legend { return if !($self->{width_px} && $self->{height_px}); + $self->get_legend->make_rect; $self->get_legend->reposition($self->{width_px}, $self->{height_px}); return; @@ -1134,6 +1135,7 @@ sub set_colour_for_undef { $self->{colour_none} = $colour; } +# need factory generation for the next few sub get_colour { my $self = shift; return $self->get_legend->get_colour (@_); @@ -1154,6 +1156,15 @@ sub get_colour_prank { return $self->get_legend->get_colour_prank (@_); } +sub get_colour_ratio { + my $self = shift; + return $self->get_legend->get_colour_ratio (@_); +} + +sub get_colour_divergent { + my $self = shift; + return $self->get_legend->get_colour_divergent (@_); +} ########################################################## diff --git a/lib/Biodiverse/GUI/Legend.pm b/lib/Biodiverse/GUI/Legend.pm index 8567dde03..2e4f7181c 100644 --- a/lib/Biodiverse/GUI/Legend.pm +++ b/lib/Biodiverse/GUI/Legend.pm @@ -114,7 +114,9 @@ sub new { # clunky that we need to do it here my @anchors = ('nw', ('w') x 3, 'sw'); foreach my $i (reverse 0..4) { - $self->{canape_marks}[$i] = $self->make_mark($anchors[$i]); + $self->{canape_marks}[$i] = $self->make_mark($anchors[$i]); + $self->{divergent_marks}[$i] = $self->make_mark($anchors[$i]); + $self->{ratio_marks}[$i] = $self->make_mark($anchors[$i]); } @anchors = ('nw', ('w') x 5, 'sw'); foreach my $i (reverse 0..6) { @@ -243,15 +245,44 @@ sub make_rect { $self->add_row($self->{legend_colours_group}, $row, $colour); } } + elsif ($self->get_ratio_mode) { + ($width, $height) = ($self->get_width, 180); + $self->{legend_height} = $height; + + local $self->{log_mode} = 0; # hacky override + + my $mid = ($height - 1) / 2; + foreach my $row (0..($height - 1)) { + my $val = $row < $mid ? 1 / ($mid - $row) : $row - $mid; + # invert again so colours match legend text + my $colour = $self->get_colour_ratio (1 / $val, $mid); + $self->add_row($self->{legend_colours_group}, $row, $colour); + } + } + elsif ($self->get_divergent_mode) { + ($width, $height) = ($self->get_width, 180); + $self->{legend_height} = $height; + + local $self->{log_mode} = 0; # hacky override + + my $centre = ($height - 1) / 2; + my $extreme = $height - $centre; + foreach my $row (0..($height - 1)) { + # ensure colours match plot since 0 is the top + my $colour = $self->get_colour_divergent ($height - $row, $centre, $extreme); + $self->add_row($self->{legend_colours_group}, $row, $colour); + } + } elsif ($self->{legend_mode} eq 'Hue') { ($width, $height) = ($self->get_width, 180); $self->{legend_height} = $height; + local $self->{log_mode} = 0; # hacky override + foreach my $row (0..($height - 1)) { - my @rgb = hsv_to_rgb($row, 1, 1); - my ($r,$g,$b) = ($rgb[0]*257, $rgb[1]*257, $rgb[2]*257); - $self->add_row($self->{legend_colours_group},$row,$r,$g,$b); + my $colour = $self->get_colour_hue ($height - $row, 0, $height-1); + $self->add_row($self->{legend_colours_group}, $row, $colour); } } @@ -260,27 +291,23 @@ sub make_rect { ($width, $height) = ($self->get_width, 100); $self->{legend_height} = $height; + local $self->{log_mode} = 0; # hacky override + foreach my $row (0..($height - 1)) { - my @rgb = hsv_to_rgb( - $self->{hue}, - 1 - $row / $height, - 1, - ); - my ($r,$g,$b) = ($rgb[0]*257, $rgb[1]*257, $rgb[2]*257); - $self->add_row($self->{legend_colours_group},$row,$r,$g,$b); + my $colour = $self->get_colour_saturation ($height - $row, 0, $height-1); + $self->add_row($self->{legend_colours_group}, $row, $colour); } - } elsif ($self->{legend_mode} eq 'Grey') { ($width, $height) = ($self->get_width, 255); $self->{legend_height} = $height; + local $self->{log_mode} = 0; # hacky override + foreach my $row (0..($height - 1)) { - my $intensity = $self->rescale_grey(255 - $row); - my @rgb = ($intensity * 257 ) x 3; - my ($r,$g,$b) = ($rgb[0], $rgb[1], $rgb[2]); - $self->add_row($self->{legend_colours_group},$row,$r,$g,$b); + my $colour = $self->get_colour_grey ($height - $row, 0, $height-1); + $self->add_row($self->{legend_colours_group}, $row, $colour); } } else { @@ -404,6 +431,8 @@ sub reposition { = $self->get_zscore_mode ? @{$self->{zscore_marks}} : $self->get_prank_mode ? @{$self->{prank_marks}} : $self->get_canape_mode ? @{$self->{canape_marks}} + : $self->get_divergent_mode ? @{$self->{divergent_marks}} + : $self->get_ratio_mode ? @{$self->{ratio_marks}} : @{$self->{marks}}; foreach my $i (0..$#mark_arr) { my $mark = $mark_arr[$#mark_arr - $i]; @@ -548,6 +577,11 @@ sub get_colour { return $self->get_colour_canape ($val) if $self->get_canape_mode; + my $method = $colour_methods{$self->{legend_mode}}; + + croak "Unknown colour system: $self->{legend_mode}\n" + if !$method; + if (defined $min and $val < $min) { $val = $min; } @@ -564,14 +598,8 @@ sub get_colour { $min = 0; $max = 1; } - my @args = ($val, $min, $max); - my $method = $colour_methods{$self->{legend_mode}}; - - croak "Unknown colour system: $self->{legend_mode}\n" - if !$method; - - return $self->$method(@args); + return $self->$method($val, $min, $max); } @@ -601,6 +629,10 @@ sub get_colour_zscore { = firstidx {$val < 0 ? $val < $_ : $val <= $_} (-2.58, -1.96, -1.65, 1.65, 1.96, 2.58); + if ($self->get_invert_colours) { + $idx = $idx < 0 ? 0 : ($#zscore_colours - $idx); + } + return $zscore_colours[$idx]; } @@ -618,9 +650,108 @@ sub get_colour_prank { = firstidx {$val < 0 ? $val < $_ : $val <= $_} (0.01, 0.025, 0.05, 0.95, 0.975, 0.99); + if ($self->get_invert_colours) { + $idx = $idx < 0 ? 0 : ($#zscore_colours - $idx); + } + return $zscore_colours[$idx]; } +sub get_colour_divergent { + my ($self, $val, $centre, $max_dist) = @_; + + state $default_colour = Gtk2::Gdk::Color->new(0, 0, 0); + + return $default_colour + if ! defined $max_dist; + + state $centre_colour = Gtk2::Gdk::Color->parse('#ffffbf'); + + $centre //= 0; + + return $centre_colour + if $val == $centre || $max_dist == 0; + + my $colour; + my @arr_cen = (0xff, 0xff, 0xbf); + my @arr_hi = (0x45, 0x75, 0xb4); # blue + my @arr_lo = (0xd7, 0x30, 0x27); # red + + if ($self->get_invert_colours) { + @arr_lo = (0x45, 0x75, 0xb4); # blue + @arr_hi = (0xd7, 0x30, 0x27); # red + } + + $max_dist = abs $max_dist; + my $pct = abs (($val - $centre) / $max_dist); + + if ($self->get_log_mode) { + $pct = log (1 + 100 * $pct) / log (101); + } + + # handle out of range vals + $pct = min (1, $pct); + + # interpolate between centre and extreme for each of R, G and B + my @rgb + = map { + ($arr_cen[$_] + + $pct + * (($val < $centre ? $arr_hi[$_] : $arr_lo[$_]) - $arr_cen[$_]) + ) * 256} (0..2); + + $colour = Gtk2::Gdk::Color->new(@rgb); + return $colour; +} + +sub get_colour_ratio { + my ($self, $val, $extreme) = @_; + + state $default_colour = Gtk2::Gdk::Color->new(0, 0, 0); + + return $default_colour + if ! defined $extreme; + + state $centre_colour = Gtk2::Gdk::Color->parse('#ffffbf'); + + return $centre_colour + if $val == 1 || $extreme == 1; + + # simplify logic below + if ($extreme < 1) { + $extreme = 1 / $extreme; + } + + my @arr_cen = (0xff, 0xff, 0xbf); + my @arr_hi = (0x45, 0x75, 0xb4); # blue + my @arr_lo = (0xd7, 0x30, 0x27); # red + + if ($self->get_invert_colours) { + @arr_lo = (0x45, 0x75, 0xb4); # blue + @arr_hi = (0xd7, 0x30, 0x27); # red + } + + # ensure fractions get correct scaling + my $scaled = $val < 1 ? 1 / $val : $val; + + my $pct = abs (($scaled - 1) / abs ($extreme - 1)); + $pct = min ($pct, 1); # account for bounded ranges + + if ($self->get_log_mode) { + $pct = log (1 + 100 * $pct) / log (101); + } + + # interpolate between centre and extreme for each of R, G and B + my @rgb + = map { + ($arr_cen[$_] + + $pct + * (($val < 1 ? $arr_hi[$_] : $arr_lo[$_]) - $arr_cen[$_]) + ) * 256} (0..2); +# say "$val, $extreme, $scaled"; + return Gtk2::Gdk::Color->new(@rgb); +} + sub get_colour_hue { my ($self, $val, $min, $max) = @_; # We use the following system: @@ -637,12 +768,18 @@ sub get_colour_hue { if ($max != $min) { return $default_colour if ! defined $val; - $hue = ($val - $min) / ($max - $min) * 180; + $hue = ($val - $min) / ($max - $min); } else { $hue = 0; } + if ($self->get_invert_colours) { + $hue = 1 - $hue; + } + + $hue = 180 * min (1, max ($hue, 0)); + $hue = int(180 - $hue); # reverse 0..180 to 180..0 (this makes high values red) my ($r, $g, $b) = hsv_to_rgb($hue, 1, 1); @@ -656,19 +793,22 @@ sub get_colour_saturation { # SATURATION goes from 0 to 1 as val goes from min to max # Hue is variable, Brightness 1 state $default_colour = Gtk2::Gdk::Color->new(0, 0, 0); - my $sat; return $default_colour - if ! defined $max || ! defined $min; + if ! defined $val || ! defined $max || ! defined $min; + my $sat; if ($max != $min) { - return $default_colour - if ! defined $val; $sat = ($val - $min) / ($max - $min); } else { $sat = 1; } + $sat = min (1, max ($sat, 0)); + + if ($self->get_invert_colours) { + $sat = 1 - $sat; + } my ($r, $g, $b) = hsv_to_rgb($self->{hue}, $sat, 1); @@ -679,20 +819,22 @@ sub get_colour_grey { my ($self, $val, $min, $max) = @_; state $default_colour = Gtk2::Gdk::Color->new(0, 0, 0); - my $sat; return $default_colour - if ! defined $max || ! defined $min; + if ! defined $val || ! defined $max || ! defined $min; + my $sat; if ($max != $min) { - return $default_colour - if ! defined $val; - $sat = ($val - $min) / ($max - $min); } else { $sat = 1; } + + if ($self->get_invert_colours) { + $sat = 1 - $sat; + } + $sat *= 255; $sat = $self->rescale_grey($sat); # don't use all the shades $sat *= 257; @@ -758,7 +900,8 @@ sub rgb_to_hsv { # Sets the values of the textboxes next to the legend */ sub set_min_max { - my ($self, $min, $max) = @_; + # val1 and val2 could be min/max or mid/extent + my ($self, $val1, $val2) = @_; return $self->set_text_marks_zscore if $self->get_zscore_mode; @@ -773,13 +916,19 @@ sub set_min_max { return $self->set_text_marks_canape if $self->get_canape_mode; + return $self->set_text_marks_divergent ($val1, $val2) + if $self->get_divergent_mode; + + return $self->set_text_marks_ratio ($val2) + if $self->get_ratio_mode; - $min //= $self->{last_min}; - $max //= $self->{last_max}; + my $min = $val1 //= $self->{last_min}; + my $max = $val2 //= $self->{last_max}; $self->{last_min} = $min; $self->{last_max} = $max; + return if ! ($self->{marks} && defined $min && defined $max @@ -888,6 +1037,75 @@ sub set_text_marks_zscore { return; } +# refactor needed +sub set_text_marks_divergent { + my ($self, $mid, $extent) = @_; + + my $mid2 = ($mid + $extent) / 2; + my @strings = ( + $mid - $extent, + $mid - $extent / 2, + $mid, + $mid + $extent / 2, + $mid + $extent + ); + + if ($self->get_log_mode) { + my $pct = abs (($strings[-2] - $mid) / abs ($extent)); + $pct = log (1 + 100 * $pct) / log (101); + # say "P2: $pct"; + $strings[-2] *= $pct; + $pct = abs (($strings[1] - $mid) / abs ($extent)); + $pct = log (1 + 100 * $pct) / log (101); + # say "P1: $pct"; + $strings[1] *= $pct; + } + + @strings = map {0 + sprintf "%.4g", $_} @strings; + + if ($self->{legend_lt_flag}) { + $strings[0] = "<=$strings[0]"; + } + if ($self->{legend_gt_flag}) { + $strings[-1] = ">=$strings[-1]"; + } + # say join ' ', @strings; + + $self->set_text_marks_for_labels (\@strings, $self->{divergent_marks}); +} + +sub set_text_marks_ratio { + my ($self, $max) = @_; + + $max //= 1; + my $mid = 1 + ($max - 1) / 2; + my @strings = ( + 1 / $max, + 1 / $mid, + 1, + $mid, + $max + ); + + if ($self->get_log_mode) { + my $pct = abs (($mid - 1) / abs ($max - 1)); + $pct = log (1 + 100 * $pct) / log (101); + $strings[1] = 1 / ($mid * $pct); + $strings[-2] = $mid * $pct; + } + + @strings = map {0 + sprintf "%.4g", $_} @strings; + + if ($self->{legend_lt_flag}) { + $strings[0] = "<=$strings[0]"; + } + if ($self->{legend_gt_flag}) { + $strings[-1] = ">=$strings[-1]"; + } + + $self->set_text_marks_for_labels (\@strings, $self->{ratio_marks}); +} + sub set_text_marks_prank { my $self = shift; my @strings = ('<0.01', '<0.025', '<0.05', '[0.05,0.95]', '>0.95', '>0.975', '>0.99'); @@ -958,6 +1176,9 @@ sub set_canape_mode_off { my ($self) = @_; my $prev_val = $self->{canape_mode}; $self->{canape_mode} = 0; + foreach my $mark (@{$self->{canape_marks}}) { + $mark->hide; + } if ($prev_val) { # give back our colours $self->make_rect; $self->reposition($self->{width_px}, $self->{height_px}) # trigger a redisplay of the legend @@ -1020,6 +1241,86 @@ sub set_zscore_mode { return $self->{zscore_mode}; } +sub set_divergent_mode_on { + my ($self) = @_; + my $prev_val = $self->{divergent_mode}; + $self->{divergent_mode} = 1; + if (!$prev_val) { # update legend colours + $self->make_rect; + $self->reposition($self->{width_px}, $self->{height_px}); # trigger a redisplay of the legend + } + return 1; +} + +sub set_divergent_mode_off { + my ($self) = @_; + my $prev_val = $self->{divergent_mode}; + $self->{divergent_mode} = 0; + foreach my $mark (@{$self->{divergent_marks}}) { + $mark->hide; + } + if ($prev_val) { # give back our colours + $self->make_rect; + $self->reposition($self->{width_px}, $self->{height_px}) # trigger a redisplay of the legend + } + return 0; +} + +sub get_divergent_mode { + $_[0]->{divergent_mode}; +} + +sub set_divergent_mode { + my ($self, $bool) = @_; + if ($bool) { + $self->set_divergent_mode_on; + } + else { + $self->set_divergent_mode_off; + } + return $self->{divergent_mode}; +} + +sub set_ratio_mode_on { + my ($self) = @_; + my $prev_val = $self->{ratio_mode}; + $self->{ratio_mode} = 1; + if (!$prev_val) { # update legend colours + $self->make_rect; + $self->reposition($self->{width_px}, $self->{height_px}); # trigger a redisplay of the legend + } + return 1; +} + +sub set_ratio_mode_off { + my ($self) = @_; + my $prev_val = $self->{ratio_mode}; + $self->{ratio_mode} = 0; + foreach my $mark (@{$self->{ratio_marks}}) { + $mark->hide; + } + if ($prev_val) { # give back our colours + $self->make_rect; + $self->reposition($self->{width_px}, $self->{height_px}) # trigger a redisplay of the legend + } + return 0; +} + +sub get_ratio_mode { + $_[0]->{ratio_mode}; +} + +sub set_ratio_mode { + my ($self, $bool) = @_; + if ($bool) { + $self->set_ratio_mode_on; + } + else { + $self->set_ratio_mode_off; + } + return $self->{ratio_mode}; +} + sub set_prank_mode_on { my ($self) = @_; my $prev_val = $self->{prank_mode}; @@ -1082,8 +1383,7 @@ sub format_number_for_display { sub rescale_grey { my $self = shift; my $value = shift; - my $max = shift; - defined $max or $max = 255; + my $max = shift // 255; $value /= $max; $value *= (LIGHTEST_GREY_FRAC - DARKEST_GREY_FRAC); @@ -1093,5 +1393,14 @@ sub rescale_grey { return $value; } +# flip the colour ranges if true +sub get_invert_colours { + $_[0]->{invert_colours}; +}; + +sub set_invert_colours { + my ($self, $bool) = @_; + $self->{invert_colours} = !!$bool; +} 1; diff --git a/lib/Biodiverse/GUI/Tabs/Clustering.pm b/lib/Biodiverse/GUI/Tabs/Clustering.pm index bad24a6f4..6a7c889b7 100644 --- a/lib/Biodiverse/GUI/Tabs/Clustering.pm +++ b/lib/Biodiverse/GUI/Tabs/Clustering.pm @@ -569,7 +569,12 @@ sub init_map { toggled => \&on_grid_colour_scaling_changed, $self, ); - + my $checkbox = $xml_page->get_object('menu_dendro_colour_stretch_flip_mode'); + $checkbox->signal_connect_swapped( + toggled => \&on_grid_colour_flip_changed, + $self, + ); + $self->warn_if_basedata_has_gt2_axes; return; diff --git a/lib/Biodiverse/GUI/Tabs/Labels.pm b/lib/Biodiverse/GUI/Tabs/Labels.pm index 29420304a..58c0283c7 100644 --- a/lib/Biodiverse/GUI/Tabs/Labels.pm +++ b/lib/Biodiverse/GUI/Tabs/Labels.pm @@ -2410,8 +2410,10 @@ sub do_set_selection_mode { sub numerically {$a <=> $b}; -# dummy sub +# dummy subs sub index_is_zscore {} +sub index_is_ratio {} +sub set_invert_colours {} # methods aren't inherited when called as GTK callbacks # so we have to manually inherit them using SUPER:: diff --git a/lib/Biodiverse/GUI/Tabs/Spatial.pm b/lib/Biodiverse/GUI/Tabs/Spatial.pm index 2a368fd55..e56a45f3b 100644 --- a/lib/Biodiverse/GUI/Tabs/Spatial.pm +++ b/lib/Biodiverse/GUI/Tabs/Spatial.pm @@ -10,6 +10,7 @@ our $VERSION = '4.99_001'; use Gtk2; use Carp; use Scalar::Util qw /blessed looks_like_number refaddr weaken/; +use List::Util qw /max/; use Time::HiRes; use Sort::Key::Natural qw /natsort/; use Ref::Util qw /is_ref is_hashref is_arrayref/; @@ -551,6 +552,7 @@ sub init_branch_colouring_combo { = $self->{output_ref}->get_hash_lists_across_elements; foreach my $list_name (natsort @$list_names) { next if $list_name =~ /SPATIAL_RESULTS$/; + next if $list_name =~ /CANAPE>>$/; next if $list_name eq 'RECYCLED_SET'; my $iter = $model->append(); @@ -652,12 +654,17 @@ sub init_grid { } $self->{initialising_grid} = 0; - + my $menu_log_checkbox = $self->{xmlPage}->get_object('menu_colour_stretch_log_mode'); $menu_log_checkbox->signal_connect_swapped( toggled => \&on_grid_colour_scaling_changed, $self, ); + my $menu_flip_checkbox = $self->{xmlPage}->get_object('menu_colour_stretch_flip_mode'); + $menu_flip_checkbox->signal_connect_swapped( + toggled => \&on_grid_colour_flip_changed, + $self, + ); $self->warn_if_basedata_has_gt2_axes; @@ -1580,12 +1587,9 @@ sub colour_branches_on_dendrogram { else { $legend->set_log_mode_off; } - - my $checkbox = $self->{xmlPage}->get_object('menuitem_spatial_tree_show_legend'); - if ($checkbox->get_active) { - $dendrogram->update_legend; # need dendrogram to pass on coords - $legend->show; - } + + my $flip_check_box = $self->{xmlPage}->get_object('menuitem_spatial_tree_colour_stretch_flip_mode'); + $legend->set_invert_colours ($flip_check_box->get_active); my $listref = $output_ref->get_list_ref ( list => $list_name, @@ -1598,12 +1602,19 @@ sub colour_branches_on_dendrogram { $legend->set_min_max (@$minmax); my ($min, $max) = @$minmax; # should not need to pass this + # currently does not handle divergent, ratio or CANAPE - these do not yet apply for tree branches my @minmax_args = ($is_zscore || $is_prank) ? () : ($min, $max); my $colour_method = $is_zscore ? 'get_colour_zscore' : $is_prank ? 'get_colour_prank' : 'get_colour'; + my $checkbox_show_legend = $self->{xmlPage}->get_object('menuitem_spatial_tree_show_legend'); + if ($checkbox_show_legend->get_active) { + $dendrogram->update_legend; # need dendrogram to pass on coords + $legend->show; + } + my %done; LABEL: @@ -1993,10 +2004,29 @@ sub recolour { #say 'WARNING - CLEARING CACHE FOR DEBUG'; #delete @{$colour_cache}{keys %$colour_cache}; # temp for debug my $ccache = $colour_cache->{$list}{$index} //= {}; - + + my %list_and_index = (list => $list, index => $index); my $is_canape = $list =~ />>CANAPE>>/ && $index =~ /^CANAPE/; - my $is_zscore = $self->index_is_zscore (list => $list, index => $index); + my $is_zscore = $self->index_is_zscore (%list_and_index); my $is_prank = $list =~ />>p_rank>>/; + my $is_ratio + = !$is_prank && !$is_zscore + && $self->index_is_ratio (%list_and_index); + my $is_divergent + = !$is_prank && !$is_zscore && !$is_ratio + && $self->index_is_divergent (%list_and_index); + + my $abs_extreme; + if ($is_ratio) { + $abs_extreme = exp (max (abs log $min, log $max)); + $min = 1 / $abs_extreme; + $max = $abs_extreme; + } + elsif ($is_divergent) { # assumes zero - needs work + $abs_extreme = max(abs $min, abs $max); + $min = 0; + $max = $abs_extreme; + } my $colour_func = sub { my $elt = shift // return; @@ -2013,7 +2043,9 @@ sub recolour { = defined $val ? ( $is_canape ? $grid->get_colour_canape ($val) : $is_zscore ? $grid->get_colour_zscore ($val) : - $is_prank ? $grid->get_colour_prank ($val) : + $is_prank ? $grid->get_colour_prank ($val) : + $is_ratio ? $grid->get_colour_ratio ($val, $abs_extreme) : + $is_divergent ? $grid->get_colour_divergent ($val, 0, $abs_extreme) : $grid->get_colour($val, $min, $max) ) : $colour_none; @@ -2029,9 +2061,14 @@ sub recolour { # !$output_ref->group_passed_def_query(group => $elt); #}; - $self->{grid}->get_legend->set_canape_mode($is_canape); - $self->{grid}->get_legend->set_zscore_mode($is_zscore); - $self->{grid}->get_legend->set_prank_mode($is_prank); + my $legend = $self->{grid}->get_legend; + # This is getting messy but ensures cleanup of old labels. + # Should register active labels. + $legend->set_canape_mode($is_canape); + $legend->set_zscore_mode($is_zscore); + $legend->set_prank_mode($is_prank); + $legend->set_ratio_mode($is_ratio); + $legend->set_divergent_mode($is_divergent); $self->show_legend; $grid->colour($colour_func); diff --git a/lib/Biodiverse/GUI/Tabs/SpatialMatrix.pm b/lib/Biodiverse/GUI/Tabs/SpatialMatrix.pm index 071be309b..95888d267 100644 --- a/lib/Biodiverse/GUI/Tabs/SpatialMatrix.pm +++ b/lib/Biodiverse/GUI/Tabs/SpatialMatrix.pm @@ -279,6 +279,11 @@ sub init_grid { toggled => \&on_grid_colour_scaling_changed, $self, ); + my $menu_flip_checkbox = $self->{xmlPage}->get_object('menu_colour_stretch_flip_mode'); + $menu_flip_checkbox->signal_connect_swapped( + toggled => \&on_grid_colour_flip_changed, + $self, + ); $self->warn_if_basedata_has_gt2_axes; diff --git a/lib/Biodiverse/GUI/Tabs/Tab.pm b/lib/Biodiverse/GUI/Tabs/Tab.pm index 4524c91b3..34b250743 100644 --- a/lib/Biodiverse/GUI/Tabs/Tab.pm +++ b/lib/Biodiverse/GUI/Tabs/Tab.pm @@ -433,6 +433,30 @@ sub on_show_hide_legend { } +sub on_grid_colour_flip_changed { + my ($self, $checkbox) = @_; + + my $grid = $self->{grid}; + + return if !$grid; + + my $xml_page = $self->{xmlPage}; + + my $active = !!$checkbox->get_active; + my $prev_mode = !!$grid->get_legend->get_invert_colours; + + $grid->get_legend->set_invert_colours ($active); + + # trigger a redisplay if needed + if ($prev_mode != $active) { + $self->recolour; + $grid->update_legend; + } + + return; +} + + sub on_grid_colour_scaling_changed { my ($self, $checkbox) = @_; @@ -484,7 +508,7 @@ sub index_is_zscore { my $list = $args{list} // ''; return 1 - if $list =~ />>z_scores>>/; + if $list =~ />>z_scores>>/; state $bd_obj = Biodiverse::BaseData->new ( NAME => 'zscorage', @@ -498,13 +522,59 @@ sub index_is_zscore { my $index = $args{index} // ''; return 1 - if $indices_object->index_is_list (index => $list) - && $indices_object->index_is_zscore (index => $list); + if $indices_object->index_is_list (index => $list) + && $indices_object->index_is_zscore (index => $list); return $indices_object->index_is_scalar (index => $index) && $indices_object->index_is_zscore (index => $index); } +sub index_is_ratio { + my $self = shift; + my %args = @_; + + # check list and then check index + my $list = $args{list} // ''; + + return if $args{list} ne 'SPATIAL_RESULTS'; + + state $bd_obj = Biodiverse::BaseData->new ( + NAME => 'rationing', + CELL_SIZES => [1], + CELL_ORIGINS => [0] + ); + state $indices_object = Biodiverse::Indices->new ( + BASEDATA_REF => $bd_obj, + ); + + my $index = $args{index} // ''; + + return $indices_object->index_is_ratio (index => $index); +} + +sub index_is_divergent { + my $self = shift; + my %args = @_; + + # check list and then check index + my $list = $args{list} // ''; + + return if $args{list} ne 'SPATIAL_RESULTS'; + + state $bd_obj = Biodiverse::BaseData->new ( + NAME => 'divergency', + CELL_SIZES => [1], + CELL_ORIGINS => [0] + ); + state $indices_object = Biodiverse::Indices->new ( + BASEDATA_REF => $bd_obj, + ); + + my $index = $args{index} // ''; + + return $indices_object->index_is_divergent (index => $index); +} + sub on_colour_mode_changed { my ($self, $menu_item) = @_; @@ -1080,7 +1150,4 @@ sub update_display_list_combos { return; } - - - 1; diff --git a/lib/Biodiverse/Indices.pm b/lib/Biodiverse/Indices.pm index 42c798bba..8de29f498 100644 --- a/lib/Biodiverse/Indices.pm +++ b/lib/Biodiverse/Indices.pm @@ -1294,6 +1294,60 @@ sub index_is_zscore { return !!$zscore_hash->{$args{index} // ''}; } +sub get_ratio_indices { + my $self = shift; + my %args = @_; + my $list = $args{calculations} || $self->get_calculations_as_flat_hash; + + my %indices; + foreach my $calculations ( keys %$list ) { + my $meta = $self->get_metadata( sub => $calculations ); + INDEX: + foreach my $index ( keys %{ $meta->get_indices } ) { + next INDEX if !$meta->get_index_is_ratio($index); + $indices{$index} = $meta->get_index_description($index); + } + } + + return wantarray ? %indices : \%indices; +} + +sub index_is_ratio { + my $self = shift; + my %args = @_; + + my $hash = $self->get_ratio_indices; + + return !!$hash->{$args{index} // ''}; +} + +sub get_divergent_indices { + my $self = shift; + my %args = @_; + my $list = $args{calculations} || $self->get_calculations_as_flat_hash; + + my %indices; + foreach my $calculations ( keys %$list ) { + my $meta = $self->get_metadata( sub => $calculations ); + INDEX: + foreach my $index ( keys %{ $meta->get_indices } ) { + next INDEX if !$meta->get_index_is_divergent($index); + $indices{$index} = $meta->get_index_description($index); + } + } + + return wantarray ? %indices : \%indices; +} + +sub index_is_divergent { + my $self = shift; + my %args = @_; + + my $hash = $self->get_divergent_indices; + + return !!$hash->{$args{index} // ''}; +} + sub get_valid_calculations_to_run { my $self = shift; diff --git a/lib/Biodiverse/Indices/PhylogeneticRelative.pm b/lib/Biodiverse/Indices/PhylogeneticRelative.pm index 15c8cf48e..767356f84 100644 --- a/lib/Biodiverse/Indices/PhylogeneticRelative.pm +++ b/lib/Biodiverse/Indices/PhylogeneticRelative.pm @@ -34,6 +34,7 @@ sub get_metadata_calc_phylo_rpd1 { indices => { PHYLO_RPD1 => { description => 'RPD1', + is_ratio => 1, }, PHYLO_RPD_NULL1 => { description => 'Null model score used as the denominator in the RPD1 calculations', @@ -41,6 +42,7 @@ sub get_metadata_calc_phylo_rpd1 { PHYLO_RPD_DIFF1 => { description => 'How much more or less PD is there than expected, in original tree units.', formula => ['= tree\_length \times (PD\_P - PHYLO\_RPD\_NULL1)'], + is_divergent => 1, } }, ); @@ -99,6 +101,7 @@ sub get_metadata_calc_phylo_rpe1 { indices => { PHYLO_RPE1 => { description => 'Relative Phylogenetic Endemism score', + is_ratio => 1, }, PHYLO_RPE_NULL1 => { description => 'Null score used as the denominator in the RPE calculations', @@ -106,6 +109,7 @@ sub get_metadata_calc_phylo_rpe1 { PHYLO_RPE_DIFF1 => { description => 'How much more or less PE is there than expected, in original tree units.', formula => ['= tree\_length \times (PE\_WE\_P - PHYLO\_RPE\_NULL1)'], + is_divergent => 1, } }, ); @@ -166,6 +170,7 @@ sub get_metadata_calc_phylo_rpd2 { indices => { PHYLO_RPD2 => { description => 'RPD2', + is_ratio => 1, }, PHYLO_RPD_NULL2 => { description => 'Null model score used as the denominator in the RPD2 calculations', @@ -173,6 +178,7 @@ sub get_metadata_calc_phylo_rpd2 { PHYLO_RPD_DIFF2 => { description => 'How much more or less PD is there than expected, in original tree units.', formula => ['= tree\_length \times (PD\_P - PHYLO\_RPD\_NULL2)'], + is_divergent => 1, } }, ); @@ -241,6 +247,7 @@ sub get_metadata_calc_phylo_rpe_central { indices => { PHYLO_RPEC => { description => 'Relative Phylogenetic Endemism score, central', + is_ratio => 1, }, PHYLO_RPE_NULLC => { description => 'Null score used as the denominator in the PHYLO_RPEC calculations', @@ -248,6 +255,7 @@ sub get_metadata_calc_phylo_rpe_central { PHYLO_RPE_DIFFC => { description => 'How much more or less PE is there than expected, in original tree units.', formula => ['= tree\_length \times (PE\_WEC\_P - PHYLO\_RPE\_NULLC)'], + is_divergent => 1, } }, ); @@ -299,6 +307,7 @@ sub get_metadata_calc_phylo_rpe2 { indices => { PHYLO_RPE2 => { description => 'Relative Phylogenetic Endemism score, type 2', + is_ratio => 1, }, PHYLO_RPE_NULL2 => { description => 'Null score used as the denominator in the RPE2 calculations', @@ -306,6 +315,7 @@ sub get_metadata_calc_phylo_rpe2 { PHYLO_RPE_DIFF2 => { description => 'How much more or less PE is there than expected, in original tree units.', formula => ['= tree\_length \times (PE\_WE\_P - PHYLO\_RPE\_NULL2)'], + is_divergent => 1, } }, ); diff --git a/lib/Biodiverse/Metadata/Indices.pm b/lib/Biodiverse/Metadata/Indices.pm index 8b31cb6ed..102f85a74 100644 --- a/lib/Biodiverse/Metadata/Indices.pm +++ b/lib/Biodiverse/Metadata/Indices.pm @@ -174,4 +174,22 @@ sub get_index_is_zscore { return $indices->{$index}{is_zscore}; } +sub get_index_is_ratio { + my ($self, $index) = @_; + + no autovivification; + + my $indices = $self->get_indices; + return $indices->{$index}{is_ratio}; +} + +sub get_index_is_divergent { + my ($self, $index) = @_; + + no autovivification; + + my $indices = $self->get_indices; + return $indices->{$index}{is_divergent}; +} + 1;