diff --git a/lib/Biodiverse/Cluster.pm b/lib/Biodiverse/Cluster.pm index 1c2b7698e..002a47c0c 100644 --- a/lib/Biodiverse/Cluster.pm +++ b/lib/Biodiverse/Cluster.pm @@ -1070,7 +1070,6 @@ sub build_matrix_elements { $n++; { - no autovivification; # save a bit of memory next ELEMENT2 if $already_calculated{$element2}; next ELEMENT2 if $element1 eq $element2; @@ -1087,24 +1086,22 @@ sub build_matrix_elements { # If we already have this value then get it and assign it. # Some of these contortions appear to be due to an old approach # where all matrices were built in one loop. - # Could probably drop out sooner now. - my $exists = 0; - my $iter = 0; - my %not_exists_iter; - my $value; - + # Could probably drop out sooner now. if (!$ofh) { + my $iter = 0; + my $exists = 0; + my %not_exists_iter; + my $value; + MX: foreach my $mx (@$matrices) { # second is shadow matrix, if given #last MX if $ofh; $value = $mx->get_defined_value_aa ($element1, $element2); - if (defined $value) { # don't redo them... - $exists ++; - } - else { - $not_exists_iter{$iter} = 1; - } + # don't redo them... + defined $value + ? ($exists++) + : ($not_exists_iter{$iter} = 1); $iter ++; } diff --git a/lib/Biodiverse/Indices.pm b/lib/Biodiverse/Indices.pm index faf3cbafa..b4650b51e 100644 --- a/lib/Biodiverse/Indices.pm +++ b/lib/Biodiverse/Indices.pm @@ -1547,23 +1547,19 @@ sub run_dependencies { } else { my %dep_results; - if ( exists $dep_list->{$calc} ) { - my $deps = $dep_list->{$calc} || []; + if (my $deps = $dep_list->{$calc} ) { + LOCAL_DEP: foreach my $dep (@$deps) { - my $dep_res = - exists $as_results_from{$dep} - ? $as_results_from{$dep} - : {}; + my $dep_res = $as_results_from{$dep} + || next LOCAL_DEP; @dep_results{ keys %$dep_res } = values %$dep_res; } } - if ( exists $dep_list_global->{$calc} ) { - my $deps = $dep_list_global->{$calc} || []; + if (my $deps = $dep_list_global->{$calc}) { + GLOBAL_DEP: foreach my $dep (@$deps) { - my $dep_res = - exists $as_results_from_global{$dep} - ? $as_results_from_global{$dep} - : {}; + my $dep_res = $as_results_from_global{$dep} + || next GLOBAL_DEP; @dep_results{ keys %$dep_res } = values %$dep_res; } } @@ -1589,12 +1585,13 @@ sub run_calculations { my $self = shift; my %args = @_; - $self - ->reset_results; # clear any previous local results - poss redundant now + # clear any previous local results - poss redundant now + $self->reset_results; my $pre_calc_local_results = $self->run_precalc_locals(%args); - my %calcs_to_run = $self->get_valid_calculations_to_run; + use experimental qw/refaliasing/; + \my %calcs_to_run = $self->get_valid_calculations_to_run; my %results; # stores the results foreach my $calc ( keys %calcs_to_run ) { @@ -1631,32 +1628,34 @@ sub get_results_from_pre_calc_global { sub run_precalc_globals { my $self = shift; - my %args = @_; - my $results = $self->run_dependencies( %args, type => 'pre_calc_global', ); + my $results = $self->run_dependencies( @_, type => 'pre_calc_global', ); return wantarray ? %$results : $results; } sub run_precalc_locals { my $self = shift; - my %args = @_; - return $self->run_dependencies( %args, type => 'pre_calc', ); + return $self->run_dependencies( @_, type => 'pre_calc', ); } sub run_postcalc_locals { my $self = shift; - my %args = @_; - return $self->run_dependencies( %args, type => 'post_calc', ); + # Most cases do not have local post calcs so we can save some time, + # especially when building pairwise matrices. + # Should perhaps be a method with caching - has_post_calc_locals + my $validated_calcs = $self->get_param('VALID_CALCULATIONS'); + return if !$validated_calcs->{calc_lists_by_type}{post_calc_local}; + + return $self->run_dependencies( @_, type => 'post_calc' ); } sub run_postcalc_globals { my $self = shift; - my %args = @_; - return $self->run_dependencies( %args, type => 'post_calc_global', ); + return $self->run_dependencies( @_, type => 'post_calc_global' ); } sub set_pairwise_mode { diff --git a/lib/Biodiverse/Indices/Indices.pm b/lib/Biodiverse/Indices/Indices.pm index 9b6fbf0e3..308be12a1 100644 --- a/lib/Biodiverse/Indices/Indices.pm +++ b/lib/Biodiverse/Indices/Indices.pm @@ -1627,18 +1627,7 @@ sub calc_abc { # wrapper for _calc_abc - use the other wrappers for actual GUI delete @args{qw/count_samples count_labels}/}; - return $self->_calc_abc(%args) - if is_hashref($args{element_list1}) - || @{$args{element_list1} // []} != 1 - || defined( - $args{element_list2} - // $args{label_hash1} - // $args{label_hash2} - // $args{label_list1} - // $args{label_list2} - ); - - return $self->_calc_abc_one_element(%args); + return $self->_calc_abc_dispatcher(%args); } sub get_metadata_calc_abc2 { @@ -1655,22 +1644,11 @@ sub get_metadata_calc_abc2 { return $metadata_class->new(\%metadata); } +# run calc_abc, but keep a track of the label counts across groups sub calc_abc2 { - # run calc_abc, but keep a track of the label counts across groups - my ($self, %args) = @_; - - return $self->_calc_abc(%args, count_labels => 1) - if is_hashref($args{element_list1}) - || @{$args{element_list1} // []} != 1 - || defined( - $args{element_list2} - // $args{label_hash1} - // $args{label_hash2} - // $args{label_list1} - // $args{label_list2} - ); + my $self = shift; - return $self->_calc_abc_one_element(%args, count_labels => 1); + return $self->_calc_abc_dispatcher(@_, count_labels => 1); } sub get_metadata_calc_abc3 { @@ -1690,20 +1668,35 @@ sub get_metadata_calc_abc3 { # run calc_abc, but keep a track of the label counts and samples across groups sub calc_abc3 { + my $self = shift; + + return $self->_calc_abc_dispatcher(@_, count_samples => 1); +} + +# keep a lot of logic in one place +sub _calc_abc_dispatcher { my ($self, %args) = @_; - return $self->_calc_abc(%args, count_samples => 1) + my $have_lb_lists = defined ( + $args{label_hash1} + // $args{label_hash2} + // $args{label_list1} + // $args{label_list2} + ); + + return $self->_calc_abc_pairwise_mode(%args) + if $self->get_pairwise_mode + && @{$args{element_list1} // []} == 1 + && @{$args{element_list2} // []} == 1 + && !$have_lb_lists; + + return $self->_calc_abc(%args) if is_hashref($args{element_list1}) || @{$args{element_list1} // []} != 1 - || defined( - $args{element_list2} - // $args{label_hash1} - // $args{label_hash2} - // $args{label_list1} - // $args{label_list2} - ); + || defined $args{element_list2} + || $have_lb_lists; - return $self->_calc_abc_one_element(%args, count_samples => 1); + return $self->_calc_abc_one_element(%args); } # A simplified version of _calc_abc for a single element. @@ -1746,6 +1739,92 @@ sub _calc_abc_one_element { return wantarray ? %results : \%results; } +# If we are in pairwise mode and only processing two elements +# then we can cache some of the results. +# Assumes only one of each of element1 and element2 passed. +sub _calc_abc_pairwise_mode { + my ($self, %args) = @_; + + my $element1 = $args{element_list1}[0]; + my $element2 = $args{element_list2}[0]; + + my $count_samples = $args{count_samples}; + my $count_labels = !$count_samples && $args{count_labels}; + + my (%label_hash1, %label_hash2); + my $cache = $self->get_cached_value_dor_set_default_href ( + '_calc_abc_pairwise_mode_' . ($count_labels ? 2 : $count_samples ? 3 : 1) + ); + + if (!$cache->{$element1}) { + \my %labels = $self->get_basedata_ref->get_labels_in_group_as_hash_aa($element1); + if ($count_samples) { + %label_hash1 = %labels; + } + else { + @label_hash1{keys %labels} = (1) x keys %labels; + } + $cache->{$element1} = \%label_hash1; + } + else { + \%label_hash1 = $cache->{$element1}; + } + + if (!$cache->{$element2}) { + \my %labels = $self->get_basedata_ref->get_labels_in_group_as_hash_aa($element2); + if ($count_samples) { + %label_hash2 = %labels; + } + else { + @label_hash2{keys %labels} = (1) x keys %labels; + } + $cache->{$element2} = \%label_hash2; + } + else { + \%label_hash2 = $cache->{$element2}; + } + + # now merge + my %label_list_master; + if ($count_samples || $count_labels) { + %label_list_master = %label_hash1; + pairmap {$label_list_master{$a} += $b} %label_hash2; + } + else { + %label_list_master = (%label_hash1, %label_hash2); + } + + my $abc = scalar keys %label_list_master; + + # a, b and c are simply differences of the lists + # doubled letters are to avoid clashes with globals $a and $b + my $aa + = (scalar keys %label_hash1) + + (scalar keys %label_hash2) + - $abc; + my $bb = $abc - (scalar keys %label_hash2); + my $cc = $abc - (scalar keys %label_hash1); + + my %results = ( + A => $aa, + B => $bb, + C => $cc, + ABC => $abc, + + label_hash_all => \%label_list_master, + label_hash1 => \%label_hash1, + label_hash2 => \%label_hash2, + element_list1 => {$element1 => 1}, + element_list2 => {$element2 => 1}, + element_list_all => [$element1, $element2], + element_count1 => 1, + element_count2 => 1, + element_count_all => 2, + ); + + return wantarray ? %results : \%results; +} + sub _calc_abc { # required by all the other indices, as it gets the labels in the elements my $self = shift; my %args = @_; @@ -1894,7 +1973,7 @@ sub _calc_abc { # required by all the other indices, as it gets the labels in } # set the counts to one if using plain old abc, as the elements section doesn't obey it properly - if (0 || !($count_labels || $count_samples)) { + if (0 && !($count_labels || $count_samples)) { @label_list_master{keys %label_list_master} = (1) x scalar keys %label_list_master; @{$label_list{1}}{keys %{$label_list{1}}} = (1) x scalar keys %{$label_list{1}}; @{$label_list{2}}{keys %{$label_list{2}}} = (1) x scalar keys %{$label_list{2}}; diff --git a/lib/Biodiverse/Indices/RWTurnover.pm b/lib/Biodiverse/Indices/RWTurnover.pm index c2241a29e..71c47752c 100644 --- a/lib/Biodiverse/Indices/RWTurnover.pm +++ b/lib/Biodiverse/Indices/RWTurnover.pm @@ -9,6 +9,7 @@ no warnings 'experimental::refaliasing'; use Carp; use List::Util qw /sum reduce/; +use Ref::Util qw /is_hashref/; our $VERSION = '4.99_002'; @@ -21,7 +22,7 @@ sub get_metadata_calc_rw_turnover { name => 'Range weighted Sorenson', reference => 'Laffan et al. (2016) https://doi.org/10.1111/2041-210X.12513', type => 'Taxonomic Dissimilarity and Comparison', - pre_calc => [qw /calc_endemism_whole_lists calc_abc/], + pre_calc => [qw /calc_endemism_whole_lists calc_abc2/], uses_nbr_lists => 2, # how many lists it must have distribution => 'nonnegative', # for A, B and C indices => { @@ -65,12 +66,20 @@ sub calc_rw_turnover { # or inverse of ranges my $cache = $self->get_cached_value_dor_set_default_href ('_calc_phylo_rwt_pairwise_branch_sum_cache'); + # use postfix idiom? + # ideally we would only be passed arrays, but see issue #919 + my $key1 = is_hashref ($args{element_list1}) + ? ((keys %{$args{element_list1}})[0]) + : (${$args{element_list1}}[0]); + my $key2 = is_hashref ($args{element_list2}) + ? ((keys %{$args{element_list2}})[0]) + : (${$args{element_list2} //[]}[0]); # Could use a reduce call to collapse the "sum map {} @list" idiom, # thus avoiding a list generation. These are only run once per group, # though, so it might not matter. - my $sum_i = $cache->{(keys %{$args{element_list1}})[0]} # use postfix deref? + my $sum_i = $cache->{$key1} //= (sum map {1 / $_} @ranges{keys %list1}) // 0; - my $sum_j = $cache->{(keys %{$args{element_list2}})[0]} + my $sum_j = $cache->{$key2} //= (sum map {1 / $_} @ranges{keys %list2}) // 0; # save some looping, mainly when there are large differences in key counts if (keys %list1 <= keys %list2) { @@ -121,7 +130,7 @@ sub get_metadata_calc_phylo_rw_turnover { name => 'Phylo Range weighted Turnover', reference => 'Laffan et al. (2016) https://doi.org/10.1111/2041-210X.12513', type => 'Phylogenetic Turnover', - pre_calc => [qw /calc_abc _calc_pe_lists_per_element_set/], + pre_calc => [qw /_calc_pe_lists_per_element_set/], # pre_calc_global => [qw / # get_node_range_hash_as_lists # get_trimmed_tree_parent_name_hash @@ -164,9 +173,20 @@ sub calc_phylo_rw_turnover { # simplify the calcs as we only need to find $aa my $cache = $self->get_cached_value_dor_set_default_href ('_calc_phylo_rwt_pairwise_branch_sum_cache'); - my $sum_i = $cache->{(keys %{$args{element_list1}})[0]} # use postfix deref? + # use postfix idiom? + # ideally we would only be passed arrays, but see issue #919 + my $key1 = is_hashref ($args{element_list1}) + ? ((keys %{$args{element_list1}})[0]) + : (${$args{element_list1}}[0]); + my $key2 = is_hashref ($args{element_list2}) + ? ((keys %{$args{element_list2}})[0]) + : (${$args{element_list2} //[]}[0]); + # Could use a reduce call to collapse the "sum map {} @list" idiom, + # thus avoiding a list generation. These are only run once per group, + # though, so it might not matter. + my $sum_i = $cache->{$key1} //= (sum values %list1) // 0; - my $sum_j = $cache->{(keys %{$args{element_list2}})[0]} + my $sum_j = $cache->{$key2} //= (sum values %list2) // 0; # save some looping, mainly when there are large differences in key counts if (keys %list1 <= keys %list2) { diff --git a/lib/Biodiverse/Matrix.pm b/lib/Biodiverse/Matrix.pm index 4e93fa030..585b29832 100644 --- a/lib/Biodiverse/Matrix.pm +++ b/lib/Biodiverse/Matrix.pm @@ -216,12 +216,11 @@ sub rebuild_value_index { # we want pairs in their stored order next EL2 - if 1 != - $self->element_pair_exists( element1 => $el1, element2 => $el2 ); + if 1 != $self->element_pair_exists_aa( $el1, $el2 ); my $val = $self->get_value( element1 => $el1, element2 => $el2 ); - my $index_val = $self->get_value_index_key( value => $val ); + my $index_val = $self->get_value_index_key_aa( $val ); $self->{BYVALUE}{$index_val}{$el1}{$el2}++; } @@ -247,6 +246,18 @@ sub get_value_index_key { return $val; } +sub get_value_index_key_aa { + my ($self, $val) = @_; + + $val // return 'undef'; + + my $prec = $self->get_param('VAL_INDEX_PRECISION'); + + return $prec + ? sprintf $prec, $val + : $val; +} + # need to flesh this out - total number of elements, symmetry, summary stats etc sub _describe { my $self = shift; @@ -448,7 +459,7 @@ sub add_element { return; } - my $index_val = $self->get_value_index_key( value => $val ); + my $index_val = $self->get_value_index_key_aa( $val ); $self->{BYELEMENT}{$element1}{$element2} = $val; $self->{BYVALUE}{$index_val}{$element1}{$element2}++; @@ -467,8 +478,9 @@ sub delete_element { my $exists = $self->element_pair_exists(@_) || return 0; - croak "element1 and/or element2 not defined\n" - if !( defined $args{element1} && defined $args{element2} ); + # handled in the exists check + # croak "element1 and/or element2 not defined\n" + # if !( defined $args{element1} && defined $args{element2} ); my ( $element1, $element2 ) = $exists == 1 @@ -496,7 +508,7 @@ sub delete_element { // warn "ISSUES BYELEMENT $element1 $element2\n"; } - my $index_val = $self->get_value_index_key( value => $value ); + my $index_val = $self->get_value_index_key_aa( $value ); if ( !$val_index->{$index_val} ) { # a bit underhanded, but this ensures we upgrade old matrices $self->rebuild_value_index; @@ -552,7 +564,7 @@ sub get_elements { sub get_elements_ref { my $self = shift; - return $self->{ELEMENTS} // do { $self->{ELEMENTS} = {} }; + return $self->{ELEMENTS} //= {}; } sub get_elements_as_array { @@ -574,7 +586,7 @@ sub get_element_pairs_with_value { my $val = $args{value}; - my $val_key = $self->get_value_index_key (value => $val); + my $val_key = $self->get_value_index_key_aa ($val); my %results; @@ -584,8 +596,8 @@ sub get_element_pairs_with_value { # could special case $val_key == 0 when index precision is %.2g # and we know we only have defined values - while ( my ( $el1, $hash_ref ) = each %$element_hash ) { - foreach my $el2 ( keys %$hash_ref ) { + foreach my $el1 (keys %$element_hash) { + foreach my $el2 ( keys %{$element_hash->{$el1}} ) { # Deliberately micro-optimised code # to reduce book-keeping overheads. # Note that stringification implicitly uses %.15f precision @@ -597,40 +609,9 @@ sub get_element_pairs_with_value { return wantarray ? %results : \%results; } -sub get_element_values { # get all values associated with one element - my $self = shift; - my %args = @_; - - croak "element not specified (matrix)\n" if !defined $args{element}; - croak "matrix element does not exist\n" - if !$self->element_is_in_matrix( element => $args{element} ); - - my @elements = $self->get_elements_as_array; - - my %values; - foreach my $el (@elements) { - if ( - $self->element_pair_exists( - element1 => $el, - element2 => $args{element} - ) - ) - { - $values{$el} = $self->get_value( - element1 => $el, - element2 => $args{element} - ); - } - } - - return wantarray ? %values : \%values; -} - sub delete_all_elements { my $self = shift; - no autovivification; - $self->{BYVALUE} = undef; $self->{BYELEMENT} = undef; $self->{ELEMENTS} = undef; diff --git a/lib/Biodiverse/Matrix/Base.pm b/lib/Biodiverse/Matrix/Base.pm index 81f4850b1..9d20f0770 100644 --- a/lib/Biodiverse/Matrix/Base.pm +++ b/lib/Biodiverse/Matrix/Base.pm @@ -36,6 +36,10 @@ sub element_is_in_matrix { return exists $self->{ELEMENTS}{$element}; } +sub element_is_in_matrix_aa { + exists $_[0]->{ELEMENTS}{$_[1]}; +} + # syntactic sugar sub set_value { my $self = shift; @@ -45,32 +49,24 @@ sub set_value { sub get_value { # return the value of a pair of elements. argument checking is done by element_pair_exists. my $self = shift; my %args = @_; - - my ($element1, $element2); - my $exists = $args{pair_exists} || $self->element_pair_exists (@_); - if ($exists == 1) { - $element1 = $args{element1}; - $element2 = $args{element2}; - return $self->{BYELEMENT}{$element1}{$element2}; - } - elsif ($exists == 2) { # elements exist, but in different order - switch them - $element1 = $args{element2}; - $element2 = $args{element1}; - return $self->{BYELEMENT}{$element1}{$element2}; - } - elsif (! $exists) { - if ($args{element1} eq $args{element2} - and $self->element_is_in_matrix (element => $args{element1}) - ) { - return $self->get_param ('SELF_SIMILARITY'); # defaults to undef - } + my $exists = $args{pair_exists} // $self->element_pair_exists (@_); - return; # if we get this far then the combination does not exist - cannot get the value - } + return $self->{BYELEMENT}{$args{element1}}{$args{element2}} + if $exists == 1; + # elements exist, but in different order - switch them + return $self->{BYELEMENT}{$args{element2}}{$args{element1}} + if $exists == 2; + + # defaults to undef + return $self->get_param ('SELF_SIMILARITY') + if !$exists + and $args{element1} eq $args{element2} + and $self->element_is_in_matrix_aa ($args{element1}); - croak "[MATRICES] You seem to have added an extra result (value $exists) to" . - " sub element_pair_exists. What were you thinking?\n"; + # if we get this far then the combination does not exist + # and we cannot get the value + return; } # Same as get_value except it does not check for existence or self-similarity @@ -96,7 +92,25 @@ sub get_defined_value_aa { $el_ref->{$_[1]}{$_[2]} // $el_ref->{$_[2]}{$_[1]}; } +sub get_element_values { # get all values associated with one element + my $self = shift; + my %args = @_; + + croak "element not specified (matrix)\n" if !defined $args{element}; + croak "matrix element does not exist\n" + if !$self->element_is_in_matrix_aa( $args{element} ); + my $elements = $self->get_elements_as_array; + + my %values; + foreach my $el (@$elements) { + my $v = $self->get_defined_value_aa($el, $args{element}) + // next; + $values{$el} = $v; + } + + return wantarray ? %values : \%values; +} # check an element pair exists, returning: # 1 if yes, @@ -120,6 +134,23 @@ sub element_pair_exists { : 0; } +sub element_pair_exists_aa { + my ($self, $element1, $element2) = @_; + + Biodiverse::MissingArgument->throw ('element1 and/or element2 not defined') + if ! (defined $element1 && defined $element2); + + # avoid some excess hash lookups + my $hash_ref = $self->{BYELEMENT}; + + # need to stop autovivification of element1 or 2 + no autovivification; + return exists $hash_ref->{$element1}{$element2} ? 1 + : exists $hash_ref->{$element2}{$element1} ? 2 + : 0; +} + + sub get_element_pair_count { my $self = shift; @@ -128,9 +159,9 @@ sub get_element_pair_count { my $elements = $self->{BYELEMENT}; my $count = 0; - foreach my $subhash (values %$elements) { - $count += scalar keys %$subhash; - } + # postfix for speed + $count += scalar keys %$_ + foreach values %$elements; return $count; } @@ -141,8 +172,10 @@ sub delete_all_pairs_with_element { my $self = shift; my %args = @_; - croak "element not specified\n" if ! defined $args{element}; - croak "element does not exist\n" if ! $self->element_is_in_matrix (element => $args{element}); + croak "element not specified\n" + if ! defined $args{element}; + croak "element does not exist\n" + if ! $self->element_is_in_matrix_aa ($args{element}); my $element = $args{element}; diff --git a/lib/Biodiverse/Matrix/LowMem.pm b/lib/Biodiverse/Matrix/LowMem.pm index 2087a4d8b..c81341a39 100644 --- a/lib/Biodiverse/Matrix/LowMem.pm +++ b/lib/Biodiverse/Matrix/LowMem.pm @@ -51,16 +51,32 @@ sub new { return $self; } -sub element_is_in_matrix { +sub element_is_in_matrix { my $self = shift; my %args = @_; - + croak "element not defined\n" if ! defined $args{element}; my $element = $args{element}; return 1 if exists $self->{BYELEMENT}{$element}; - + + my $el_hash = $self->{BYELEMENT}; + foreach my $hashref (values %$el_hash) { + return 1 if exists $hashref->{$element}; + } + + return; +} + +# no real speedup with array args but we need symmetry with Base.pm +sub element_is_in_matrix_aa { + my ($self, $element) = @_; + + croak "element not defined\n" if ! defined $element; + + return 1 if exists $self->{BYELEMENT}{$element}; + my $el_hash = $self->{BYELEMENT}; foreach my $hashref (values %$el_hash) { return 1 if exists $hashref->{$element}; @@ -113,34 +129,31 @@ sub add_element_aa { # add an element pair to the object sub delete_element { # should be called delete_element_pair, but need to find where it's used first my $self = shift; my %args = @_; - croak "element1 or element2 not defined\n" - if ! defined $args{element1} - || ! defined $args{element2}; + + # taken care of in the exists sub + # croak "element1 or element2 not defined\n" + # if ! defined $args{element1} + # || ! defined $args{element2}; my $element1 = $args{element1}; my $element2 = $args{element2}; - my $exists = $self->element_pair_exists (@_); + my $exists = $self->element_pair_exists_aa ($element1, $element2) + || return 0; - if (! $exists) { - #print "WARNING: element combination does not exist\n"; - return 0; # combination does not exist - cannot delete it - } - elsif ($exists == 2) { # elements exist, but in different order - switch them - #print "DELETE ELEMENTS SWITCHING $element1 $element2\n"; - $element1 = $args{element2}; - $element2 = $args{element1}; - } + # elements exist but in different order - switch them + ($element1, $element2) = ($element2, $element1) + if $exists == 2; # now we get to the cleanup, including the containing hashes if they are now empty # all the undef - delete pairs are to ensure they get deleted properly # the hash ref must be empty (undef) or it won't be deleted # autovivification of $self->{BYELEMENT}{$element1} is avoided by $exists above - delete $self->{BYELEMENT}{$element1}{$element2}; # if exists $self->{BYELEMENT}{$element1}{$element2}; - if (scalar keys %{$self->{BYELEMENT}{$element1}} == 0) { + my $href = $self->{BYELEMENT}; + delete $href->{$element1}{$element2}; # if exists $self->{BYELEMENT}{$element1}{$element2}; + if (!keys %{$href->{$element1}}) { #print "Deleting BYELEMENT{$element1}\n"; #undef $self->{BYELEMENT}{$element1}; - defined (delete $self->{BYELEMENT}{$element1}) - || warn "ISSUES BYELEMENT $element1 $element2\n"; + delete $href->{$element1} // warn "ISSUES BYELEMENT $element1 $element2\n"; } return 1; # return success if we get this far @@ -189,8 +202,8 @@ sub get_element_pairs_with_value { while (my ($el1, $hash_ref) = each %$element_hash) { foreach my $el2 (keys %$hash_ref) { my $value = $self->get_value (element1 => $el1, element2 => $el2); - next if $val ne $value; - $results{$el1}{$el2} ++; + $results{$el1}{$el2} ++ + if $val eq $value; } } diff --git a/t/25-Matrix.t b/t/25-Matrix.t index dc4a9ee51..e4d6a5166 100644 --- a/t/25-Matrix.t +++ b/t/25-Matrix.t @@ -484,6 +484,10 @@ sub run_main_tests { } }; + my $vals = $mx->get_element_values (element => 'a'); + my $exp_vals = {b => 101, d => 104, f => 101}; + is $vals, $exp_vals, 'get_element_values'; + }