haskell-fsrs-7.0.0: test/Test/FSRS/Unit.hs
-- | Hand-written checks of specific values and edge cases.
--
-- The numbers here were derived independently of the Haskell implementation:
-- the default weights come from the upstream model file, and the worked
-- examples were computed from the published formulas.
module Test.FSRS.Unit (tests) where
import Test.Tasty (TestTree, testGroup)
import Test.Tasty.HUnit (Assertion, assertBool, assertFailure, testCase, (@?=))
import FSRS
import Test.FSRS.Gen (approxEqual, relativeError)
tests :: TestTree
tests =
testGroup
"units"
[ parameterTests
, curveTests
, stateTests
, intervalTests
]
close :: String -> Double -> Double -> Assertion
close label expected actual =
assertBool
( label
<> ": expected "
<> show expected
<> ", got "
<> show actual
<> " (relative error "
<> show (relativeError actual expected)
<> ")"
)
(approxEqual 1.0e-12 1.0e-12 actual expected)
-- ---------------------------------------------------------------------------
parameterTests :: TestTree
parameterTests =
testGroup
"parameters"
[ testCase "FSRS-7 has 35 weights" $
parameterCount @?= 35
, testCase "the default weights are the published ones" $
parametersToList defaultParameters
@?= [ 0.041
, 2.4175
, 4.1283
, 11.9709
, 5.6385
, 0.4468
, 3.262
, 2.3054
, 0.1688
, 1.3325
, 0.3524
, 0.0049
, 0.7503
, 0.0896
, 0.6625
, 1.3
, 0.882
, 0.3072
, 3.5875
, 0.303
, 0.0107
, 0.2279
, 2.6413
, 0.5594
, 1.3
, 2.5
, 1.0
, 0.0723
, 0.1634
, 0.5
, 0.9555
, 0.2245
, 0.6232
, 0.1362
, 0.3862
]
, testCase "there is a bound for every weight" $
length parameterBounds @?= parameterCount
, testCase "too few weights are rejected" $
mkParameters [1, 2, 3] @?= Left [WrongParameterCount 3]
, testCase "an out-of-bounds weight is reported with its index" $
case mkParameters (setAt 5 99 (parametersToList defaultParameters)) of
Left errs -> errs @?= [ParameterOutOfBounds 5 99 0.001 4.0]
Right _ -> assertFailure "expected a rejection"
, testCase "several bad weights are all reported" $
case mkParameters (setAt 4 0 (setAt 26 7 (parametersToList defaultParameters))) of
Left errs -> length errs @?= 2
Right _ -> assertFailure "expected a rejection"
, testCase "the initial-stability weights must be ordered" $
case mkParameters (setAt 0 5 (parametersToList defaultParameters)) of
Left errs -> errs @?= [ParameterOutOfOrder 0 1 5 2.4175]
Right _ -> assertFailure "expected a rejection"
, testCase "a NaN weight is rejected" $
case mkParameters (setAt 6 (0 / 0) (parametersToList defaultParameters)) of
Left [ParameterNotFinite 6 _] -> pure ()
other -> assertFailure ("unexpected: " <> show other)
, testCase "clamping repairs junk" $
case clampParameters (replicate parameterCount 1000) of
Right p -> validateParameters (parametersToList p) @?= []
Left errs -> assertFailure (show errs)
, testCase "clamping fixes the ordering constraints too" $
case clampParameters (setAt 1 0.0001 (parametersToList defaultParameters)) of
Right p -> do
parameterAt p 0 @?= 0.041
-- w1 is pulled up to w0, not left below it.
parameterAt p 1 @?= 0.041
validateParameters (parametersToList p) @?= []
Left errs -> assertFailure (show errs)
, testCase "the weight blocks read the right indices" $ do
let p = defaultParameters
swIncreaseBase (longTermWeights p) @?= parameterAt p 7
swEasyBonus (longTermWeights p) @?= parameterAt p 15
swIncreaseBase (shortTermWeights p) @?= parameterAt p 16
swEasyBonus (shortTermWeights p) @?= parameterAt p 24
cwDecay1 (curveWeights p) @?= negate (parameterAt p 27)
cwDecay2 (curveWeights p) @?= negate (parameterAt p 28)
cwStabilityPower2 (curveWeights p) @?= parameterAt p 34
, testCase "ratings number from one" $
map ratingToInt allRatings @?= [1, 2, 3, 4]
, testCase "rating numbers round-trip" $ do
map ratingFromInt [1, 2, 3, 4] @?= map Just allRatings
ratingFromInt 0 @?= Nothing
ratingFromInt 5 @?= Nothing
]
setAt :: Int -> a -> [a] -> [a]
setAt i x xs = take i xs <> [x] <> drop (i + 1) xs
-- ---------------------------------------------------------------------------
curveTests :: TestTree
curveTests =
testGroup
"forgetting curve"
[ testCase "no time has passed, nothing is forgotten" $
retrievability defaultParameters 0 10 @?= 1
, testCase "w29 and w30 are the recall probability at t == s" $ do
-- Both components carry the same base, so their mixture is that base
-- at t == s whatever the stability-dependent weighting does.
mapM_
( \(base, s) ->
close
("R(s, s) with both bases at " <> show base)
base
(retrievability (tweak [(29, base), (30, base)]) s s)
)
[(b, s) | b <- [0.5, 0.85], s <- [0.5, 1, 37, 1000]]
, testCase "a worked value of the default curve" $
-- R(1, 1) with the default weights, computed from the published
-- formulas: weights 0.2245 and 0.6232, components 0.5 and 0.9555.
close
"R(1, 1)"
((0.2245 * 0.5 + 0.6232 * 0.9555) / (0.2245 + 0.6232))
(retrievability defaultParameters 1 1)
, testCase "retrievability at a century is still positive" $
assertBool "positive" (retrievability defaultParameters 36500 0.5 > 0)
]
where
tweak overrides =
case mkParameters (foldr apply (parametersToList defaultParameters) overrides) of
Right p -> p
Left errs -> error (show errs)
where
apply (i, v) ws = setAt i v ws
-- ---------------------------------------------------------------------------
stateTests :: TestTree
stateTests =
testGroup
"state transitions"
[ testCase "a first review reads stability straight off the weights" $
map (memoryStability . firstReview) allRatings
@?= [0.041, 2.4175, 4.1283, 11.9709]
, testCase "a first review's difficulty follows the published formula" $
mapM_
( \rating ->
close
("initial difficulty for " <> show rating)
( min 10 . max 1 $
5.6385 - exp (0.4468 * fromIntegral (ratingToInt rating - 1)) + 1
)
(memoryDifficulty (firstReview rating))
)
allRatings
, testCase "Again on a brand-new card gives the smallest stability" $
memoryStability (firstReview Again) @?= 0.041
, testCase "a same-instant review is handled by the short-term block" $ do
-- w26 is 1 by default, so the transition coefficient is 0 at dt == 0.
let before = MemoryState 10 5
r = retrievability defaultParameters 0 10
expected = stabilityAfterReview (shortTermWeights defaultParameters) before r Good
close
"same-instant stability"
expected
(memoryStability (nextMemoryState defaultParameters (Just before) 0 Good))
, testCase "a review after ten years is handled by the long-term block" $ do
let before = MemoryState 10 5
r = retrievability defaultParameters 3650 10
expected = stabilityAfterReview (longTermWeights defaultParameters) before r Good
close
"long-term stability"
expected
(memoryStability (nextMemoryState defaultParameters (Just before) 3650 Good))
, testCase "stability is clamped at the century mark" $
memoryStability (nextMemoryState defaultParameters (Just (MemoryState 36500 1)) 36500 Easy)
@?= stabilityMax
, testCase "repeated Good reviews converge on the Easy anchor" $
-- A Good review zeroes the rating delta, leaving only the 1% pull
-- towards the difficulty an Easy first review would have produced.
-- Iterating it therefore pins down which rating that anchor comes from.
mapM_
( \start ->
close
("limit from " <> show start)
(initialDifficulty defaultParameters Easy)
(iterate (\d -> nextDifficulty defaultParameters d Good) start !! 3000)
)
[difficultyMin, 5, difficultyMax]
, testCase "an empty history has no state" $
replayReviews defaultParameters [] @?= Nothing
, testCase "a one-review history is a first review" $
replayReviews defaultParameters [(99, Good)]
@?= Just (nextMemoryState defaultParameters Nothing 0 Good)
]
where
firstReview = nextMemoryState defaultParameters Nothing 0
-- ---------------------------------------------------------------------------
intervalTests :: TestTree
intervalTests =
testGroup
"interval inversion"
[ testCase "the interval really does land on the target" $
mapM_
( \(dr, s) ->
close
("R after the scheduled interval for " <> show (dr, s))
dr
(retrievability defaultParameters (nextIntervalDays defaultParameters dr s) s)
)
[(0.9, 10), (0.8, 1), (0.95, 100), (0.7, 0.5), (0.99, 1000)]
, testCase "an unreachable target saturates at the shortest interval" $
nextIntervalDays defaultParameters 1 10 @?= minimumIntervalDays
, testCase "a target of zero saturates at the longest interval" $
nextIntervalDays defaultParameters 0 10 @?= maximumIntervalDays
, testCase "a nonsensical target does not diverge" $ do
nextIntervalDays defaultParameters (0 / 0) 10 @?= maximumIntervalDays
nextIntervalDays defaultParameters (-1) 10 @?= maximumIntervalDays
nextIntervalDays defaultParameters 2 10 @?= minimumIntervalDays
, testCase "a fresh Good card comes back in about three days" $
close
"interval after one Good"
2.9669271623721456
( nextIntervalDays defaultParameters 0.9 $
memoryStability (nextMemoryState defaultParameters Nothing 0 Good)
)
, testCase "a fresh Easy card comes back in about seventeen days" $
close
"interval after one Easy"
16.9366155257869
( nextIntervalDays defaultParameters 0.9 $
memoryStability (nextMemoryState defaultParameters Nothing 0 Easy)
)
]