You can not select more than 25 topics
Topics must start with a letter or number, can include dashes ('-') and can be up to 35 characters long.
119 lines
4.4 KiB
119 lines
4.4 KiB
11 months ago
|
From 7e5deed1cb3fafdd6eb035b3713ae2f46b67014a Mon Sep 17 00:00:00 2001
|
||
|
From: Alexey Khudyakov <alexey.skladnoy@gmail.com>
|
||
|
Date: Thu, 8 Jun 2023 13:26:11 +0300
|
||
|
Bug: https://github.com/haskell/math-functions/pull/75
|
||
|
Signed-off-by: hololeap <hololeap@protonmail.com>
|
||
|
Subject: [PATCH] Fix test suite
|
||
|
|
||
|
QC as of 2.14.3. became much better at generating test cases and started
|
||
|
reliably failing Kahan summation
|
||
|
|
||
|
This was fixed by tweaking badvec to be just very bad. Not outrageously
|
||
|
bad.
|
||
|
---
|
||
|
tests/Tests/Sum.hs | 72 +++++++++++++++++++++++++++-------------------
|
||
|
1 file changed, 43 insertions(+), 29 deletions(-)
|
||
|
|
||
|
diff --git a/tests/Tests/Sum.hs b/tests/Tests/Sum.hs
|
||
|
index 08eaf1e..1fcb2e9 100644
|
||
|
--- a/tests/Tests/Sum.hs
|
||
|
+++ b/tests/Tests/Sum.hs
|
||
|
@@ -4,54 +4,68 @@ module Tests.Sum (tests) where
|
||
|
|
||
|
import Control.Applicative ((<$>))
|
||
|
import Numeric.Sum as Sum
|
||
|
+import Numeric.MathFunctions.Comparison
|
||
|
import Prelude hiding (sum)
|
||
|
import Test.Tasty (TestTree, testGroup)
|
||
|
-import Test.Tasty.QuickCheck (testProperty)
|
||
|
+import Test.Tasty.QuickCheck
|
||
|
import Test.QuickCheck (Arbitrary(..))
|
||
|
import qualified Prelude
|
||
|
|
||
|
-t_sum :: ([Double] -> Double) -> [Double] -> Bool
|
||
|
-t_sum f xs = f xs == trueSum xs
|
||
|
-
|
||
|
-t_sum_error :: ([Double] -> Double) -> [Double] -> Bool
|
||
|
-t_sum_error f xs = abs (ts - f xs) <= abs (ts - Prelude.sum xs)
|
||
|
- where ts = trueSum xs
|
||
|
-
|
||
|
-t_sum_shifted :: ([Double] -> Double) -> [Double] -> Bool
|
||
|
+-- Test that summation result is same as exact sum. That should pass
|
||
|
+-- if we're effectively working with quad precision
|
||
|
+t_sum :: ([Double] -> Double) -> [Double] -> Property
|
||
|
+t_sum f xs
|
||
|
+ = counterexample ("APPROX = " ++ show approx)
|
||
|
+ $ counterexample ("EXACT = " ++ show exact)
|
||
|
+ $ counterexample ("DELTA = " ++ show (approx - exact))
|
||
|
+ $ counterexample ("ULPS = " ++ show (ulpDistance approx exact))
|
||
|
+ $ approx == exact
|
||
|
+ where
|
||
|
+ approx = f xs
|
||
|
+ exact = trueSum xs
|
||
|
+
|
||
|
+-- Test that summation has smaller error than naive summation or no
|
||
|
+-- worse than given number of ulps. If we're close enough to exact
|
||
|
+-- answer naive may get ahead
|
||
|
+t_sum_error :: ([Double] -> Double) -> [Double] -> Property
|
||
|
+t_sum_error f xs
|
||
|
+ = counterexample ("APPROX = " ++ show approx)
|
||
|
+ $ counterexample ("NAIVE = " ++ show naive)
|
||
|
+ $ counterexample ("EXACT = " ++ show exact)
|
||
|
+ $ counterexample ("A-EXACT = " ++ show (approx - exact))
|
||
|
+ $ counterexample ("N-EXACT = " ++ show (naive - exact))
|
||
|
+ $ counterexample ("ULPS[A] = " ++ show (ulpDistance approx exact))
|
||
|
+ $ counterexample ("ULPS[N] = " ++ show (ulpDistance naive exact))
|
||
|
+ $ abs (exact - approx) <= abs (exact - naive)
|
||
|
+ where
|
||
|
+ naive = Prelude.sum xs
|
||
|
+ approx = f xs
|
||
|
+ exact = trueSum xs
|
||
|
+
|
||
|
+t_sum_shifted :: ([Double] -> Double) -> [Double] -> Property
|
||
|
t_sum_shifted f = t_sum_error f . zipWith (+) badvec
|
||
|
|
||
|
trueSum :: (Fractional b, Real a) => [a] -> b
|
||
|
trueSum xs = fromRational . Prelude.sum . map toRational $ xs
|
||
|
|
||
|
badvec :: [Double]
|
||
|
-badvec = cycle [1,1e16,-1e16]
|
||
|
+badvec = cycle [1, 1e14, -1e14]
|
||
|
|
||
|
tests :: TestTree
|
||
|
-tests = testGroup "Summation" [
|
||
|
- testGroup "ID" [
|
||
|
- -- plain summation loses precision quickly
|
||
|
- -- testProperty "t_sum" $ t_sum (sum id)
|
||
|
-
|
||
|
- -- tautological tests:
|
||
|
- -- testProperty "t_sum_error" $ t_sum_error (sum id)
|
||
|
- -- testProperty "t_sum_shifted" $ t_sum_shifted (sum id)
|
||
|
- ]
|
||
|
- , testGroup "Kahan" [
|
||
|
- -- tests that cannot pass:
|
||
|
- -- testProprty "t_sum" $ t_sum (sum kahan)
|
||
|
- -- testProperty "t_sum_error" $ t_sum_error (sum kahan)
|
||
|
-
|
||
|
- -- kahan summation only beats normal summation with large values
|
||
|
+tests = testGroup "Summation"
|
||
|
+ [ testGroup "Kahan" [
|
||
|
+ -- Kahan summation only beats naive summation when truly
|
||
|
+ -- catastrophic cancellation occurs
|
||
|
testProperty "t_sum_shifted" $ t_sum_shifted (sum kahan)
|
||
|
]
|
||
|
, testGroup "KBN" [
|
||
|
- testProperty "t_sum" $ t_sum (sum kbn)
|
||
|
- , testProperty "t_sum_error" $ t_sum_error (sum kbn)
|
||
|
+ testProperty "t_sum" $ t_sum (sum kbn)
|
||
|
+ , testProperty "t_sum_error" $ t_sum_error (sum kbn)
|
||
|
, testProperty "t_sum_shifted" $ t_sum_shifted (sum kbn)
|
||
|
]
|
||
|
, testGroup "KB2" [
|
||
|
- testProperty "t_sum" $ t_sum (sum kb2)
|
||
|
- , testProperty "t_sum_error" $ t_sum_error (sum kb2)
|
||
|
+ testProperty "t_sum" $ t_sum (sum kb2)
|
||
|
+ , testProperty "t_sum_error" $ t_sum_error (sum kb2)
|
||
|
, testProperty "t_sum_shifted" $ t_sum_shifted (sum kb2)
|
||
|
]
|
||
|
]
|