throw a warning when using comparison operator and badval is in {0, 1}

When using a comparison operator, inconsistent results can appear when a badvalue is either 0 or 1. This is because {0, 1} is the range of all operators that return a logical PDL. This means that if the input PDL contains badvalues, it can not both represent badvalues that are the result of computing the operator *and* logical values at the same time. This is a continuation of the work addressing the problem brought up in <http://sourceforge.net/p/pdl/bugs/390/>, <#124>.
PDLPorters · Jul 28, 2015 · 61955ef · 61955ef
1 parent ab1e97d
commit 61955ef
Show file tree

Hide file tree

Showing 2 changed files with 56 additions and 7 deletions.
diff --git a/Basic/Ops/ops.pd b/Basic/Ops/ops.pd
@@ -94,6 +94,17 @@ EOH
 	#      See also `ufunc()`.
 	delete $extra{Exception};
     }
+    if( exists $extra{Comparison} && $PDL::Config{WITH_BADVAL} ) {
+	# *append* to header
+	$extra{HdrCode} .= <<'EOH';
+           if(    PDL->get_pdl_badvalue(a) == 0 || PDL->get_pdl_badvalue(a) == 1
+	       || PDL->get_pdl_badvalue(b) == 0 || PDL->get_pdl_badvalue(b) == 1 ) {
+
+	          warn("Badvalue is set to 0 or 1. This will cause data loss when using badvalues for comparison operators.");
+
+	   }
+EOH
+    }
 
     pp_def($name,
 	   Pars => 'a(); b(); [o]c();',
@@ -309,13 +320,13 @@ biop('divide','/',1,'divide two piddles', Exception => '$b() == 0' );
 
 ## comparison ops
 # need swapping
-biop('gt','>',1,'the binary E<gt> (greater than) operation');
-biop('lt','<',1,'the binary E<lt> (less than) operation');
-biop('le','<=',1,'the binary E<lt>= (less equal) operation');
-biop('ge','>=',1,'the binary E<gt>= (greater equal) operation');
+biop('gt','>',1,'the binary E<gt> (greater than) operation', Comparison => 1 );
+biop('lt','<',1,'the binary E<lt> (less than) operation', Comparison => 1 );
+biop('le','<=',1,'the binary E<lt>= (less equal) operation', Comparison => 1 );
+biop('ge','>=',1,'the binary E<gt>= (greater equal) operation', Comparison => 1 );
 # no swap required
-biop('eq','==',0,'binary I<equal to> operation (C<==>)');
-biop('ne','!=',0,'binary I<not equal to> operation (C<!=>)');
+biop('eq','==',0,'binary I<equal to> operation (C<==>)', Comparison => 1 );
+biop('ne','!=',0,'binary I<not equal to> operation (C<!=>)', Comparison => 1 );
 
 ## bit ops
 # those need to be limited to the right types

diff --git a/t/badvalue_scalar_cmp.t b/t/badvalue_scalar_cmp.t
@@ -4,6 +4,7 @@ use strict;
 use warnings;
 
 use PDL::Config;
+use Test::Warn;
 
 plan skip_all => "Bad values disabled" unless $PDL::Config{WITH_BADVAL};
 plan skip_all => "Skip if badvalue support only supports NaN badvalues" if $PDL::Config{BADVAL_USENAN};
@@ -17,7 +18,7 @@ use PDL::LiteF;
 ## <http://sourceforge.net/p/pdl/bugs/390/>
 ## <https://github.com/PDLPorters/pdl/issues/124>
 
-plan tests => 4;
+plan tests => 5;
 
 subtest "Issue example code" => sub {
 	my $x = pdl(1, 2, 3, 0);
@@ -194,3 +195,40 @@ subtest "Comparison between a vector and scalar" => sub {
 	is( "" . ( $p > 3 ), '[0 BAD 0 1]', "compare PDL against (scalar = 3)");
 	is( "" . ( $p > 4 ), '[0 BAD 0 0]', "compare PDL against (scalar = 4)");
 };
+
+subtest "Throw a warning when badvalue is set to 0 or 1 and a comparison operator is used" => sub {
+	my $warn_msg_re = qr/Badvalue is set to 0 or 1/;
+
+	# We do not need to change the contents of this PDL.
+	# Only the value of badvalue changes.
+	my $p = pdl([0, 1, 2]);
+	$p->badflag(1);
+	subtest "Badvalue set to 0" => sub {
+		$p->badvalue(0);
+		warning_like { $p == 1 } $warn_msg_re, "A warning thrown for badval == 0 and == operator";
+	};
+
+	subtest "Badvalue set to 1" => sub {
+		$p->badvalue(1);
+		warning_like { $p == 1 } $warn_msg_re, "A warning thrown for badval == 1 and == operator";
+	};
+
+	subtest "Badvalue set to 2" => sub {
+		$p->badvalue(2);
+		warning_like { $p == 1 } undef, "No warning thrown for badval == 2 and == operator";
+	};
+
+	subtest "Badvalue set to 0 and other operators" => sub {
+		$p->badvalue(0);
+
+		warning_like { $p > 1 } $warn_msg_re, "A warning thrown for badval == 0 and > operator";
+		warning_like { $p >= 1 } $warn_msg_re, "A warning thrown for badval == 0 and >= operator";
+		warning_like { $p < 1 } $warn_msg_re, "A warning thrown for badval == 0 and < operator";
+		warning_like { $p <= 1 } $warn_msg_re, "A warning thrown for badval == 0 and <= operator";
+
+		warning_like { $p == 1 } $warn_msg_re, "A warning thrown for badval == 0 and == operator";
+		warning_like { $p != 1 } $warn_msg_re, "A warning thrown for badval == 0 and != operator";
+
+		warning_like { $p + 1 } undef, "No warning thrown for badval == 0 and + operator";
+	};
+}