haskell-fsrs-7.1.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 reference model file, the worked examples
-- were computed from the published formulas, and 'referenceFixtures' reproduces
-- the two numeric assertions the reference implementation makes about itself.
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
, referenceFixtures
]
close :: String -> Double -> Double -> Assertion
close = closeWith 1.0e-12
closeWith :: Double -> String -> Double -> Double -> Assertion
closeWith t label expected actual =
assertBool
( label
<> ": expected "
<> show expected
<> ", got "
<> show actual
<> " (relative error "
<> show (relativeError actual expected)
<> ")"
)
(approxEqual t t actual expected)
-- ---------------------------------------------------------------------------
parameterTests :: TestTree
parameterTests =
testGroup
"parameters"
[ testCase "FSRS-7 has 34 weights" $
parameterCount @?= 34
, testCase "the default weights are the published ones" $
parametersToList defaultParameters
@?= [ 0.1104
, 2.2395
, 3.9221
, 11.7841
, 6.1686
, 0.6457
, 3.6807
, 1.9795
, 0.0
, 1.3826
, 0.7024
, 0.5999
, 0.8146
, 0.6398
, 1.0
, 1.3207
, 0.6707
, 3.8668
, 0.4416
, 0.0934
, 1.8631
, 0.6162
, 1.0869
, 0.1567
, 0.0801
, 0.2421
, 0.9464
, 0.1433
, 0.7145
, 0.0
, 0.5667
, 0.3734
, 0.5333
, 0.3048
]
, 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 24 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.2395]
Right _ -> assertFailure "expected a rejection"
, testCase "the curve's two bases must be ordered" $
-- The bounds of w25 and w26 overlap, so only a base1 above base2 is a
-- violation.
case mkParameters (setAt 26 0.5 (setAt 25 0.85 (parametersToList defaultParameters))) of
Right _ -> assertFailure "expected a rejection"
Left errs -> errs @?= [ParameterOutOfOrder 25 26 0.85 0.5]
, 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.1104
-- w1 is pulled up to w0, not left below it.
parameterAt p 1 @?= 0.1104
validateParameters (parametersToList p) @?= []
Left errs -> assertFailure (show errs)
, testCase "the weight blocks read the right indices" $ do
let p = defaultParameters
swIncreaseBase (slowTraceWeights p) @?= parameterAt p 7
swEasyBonus (slowTraceWeights p) @?= parameterAt p 14
swIncreaseBase (fastTraceWeights p) @?= parameterAt p 15
swEasyBonus (fastTraceWeights p) @?= parameterAt p 22
cwDecayBase1 (curveWeights p) @?= parameterAt p 23
cwDecay2 (curveWeights p) @?= parameterAt p 24
cwStabilityPower2 (curveWeights p) @?= parameterAt p 30
cwStabilityDecay1 (curveWeights p) @?= parameterAt p 33
, 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, almost nothing is forgotten" $
-- FSRS-7 rescales retrievability into [1e-5, 1 - 1e-5], so a card
-- reviewed a moment ago stops just short of certainty.
close "R(0)" (1 - retrievabilityFloor) (retrievability defaultParameters 0 (MemoryState 10 5 8))
, testCase "w25 and w26 are the recall probability at t == s" $ do
-- Both components carry the same base, and at an average difficulty
-- with the two traces level the 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 * (1 - 2 * retrievabilityFloor) + retrievabilityFloor)
(retrievability (tweak [(25, base), (26, base)]) s (MemoryState s 5 s))
)
[(b, s) | b <- [0.5, 0.7, 0.85], s <- [0.5, 1, 37, 1000]]
, testCase "the fast component alone is not rescaled" $
-- fastTraceRetrievability is a bare power law, so it hits 1 exactly.
mapM_
(\s -> fastTraceRetrievability defaultParameters 0 s @?= 1)
[0.01, 1, 37, 1000]
, testCase "a harder card is forgotten faster" $ do
let r d = retrievability defaultParameters 7 (MemoryState 10 d 8)
assertBool "monotone in difficulty" (and (zipWith (>=) (map r [1, 3, 5, 7, 10]) (drop 1 (map r [1, 3, 5, 7, 10]))))
, testCase "retrievability at a century is still above the floor" $
assertBool
"above the floor"
(retrievability defaultParameters 36500 (MemoryState 0.5 5 0.4) > retrievabilityFloor)
]
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.1104, 2.2395, 3.9221, 11.7841]
, testCase "a new card's fast trace starts below its slow one" $
mapM_
( \rating ->
close
("initial fast stability for " <> show rating)
(fastTraceRatio * memoryStability (firstReview rating))
(memoryStabilityFast (firstReview rating))
)
allRatings
, testCase "a first review's difficulty follows the published formula" $
mapM_
( \rating ->
close
("initial difficulty for " <> show rating)
( min 10 . max 1 $
6.1686 - exp (0.6457 * fromIntegral (ratingToInt rating - 1)) + 1
)
(memoryDifficulty (firstReview rating))
)
allRatings
, testCase "Again on a brand-new card gives the smallest stability" $
memoryStability (firstReview Again) @?= 0.1104
, testCase "a Good review reverts difficulty 1% towards the Easy anchor" $ do
-- A Good review zeroes the rating delta, leaving only the mean
-- reversion. The anchor is the *unclamped* initial difficulty of an
-- Easy first review, which is what makes this pin down the anchor.
let anchor = 6.1686 - exp (0.6457 * 3) + 1
mapM_
( \d ->
close
("mean reversion from " <> show d)
(min 10 (max 1 (0.01 * anchor + 0.99 * d)))
(nextDifficulty defaultParameters d 0.9 Good)
)
[2, 5, 7.5]
, testCase "a lapse's difficulty step is weighted by how surprising it was" $ do
-- Forgetting a card you were expected to recall (high R) is harsher
-- than forgetting one that was long overdue.
let d = 5
harsh = nextDifficulty defaultParameters d 0.95 Again
gentle = nextDifficulty defaultParameters d 0.05 Again
assertBool
("expected " <> show harsh <> " > " <> show gentle)
(harsh > gentle)
, testCase "a lapse pulls the fast trace under the slow one" $ do
let after = nextMemoryState defaultParameters (Just (MemoryState 100 5 400)) 30 Again
assertBool
(show after)
(memoryStabilityFast after <= fastTraceRatio * memoryStability after + 1.0e-12)
, testCase "stability is clamped at the century mark" $
memoryStability
(nextMemoryState defaultParameters (Just (MemoryState 36500 1 36500)) 36500 Easy)
@?= stabilityMax
, 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, st) ->
close
("R after the scheduled interval for " <> show (dr, st))
dr
(retrievability defaultParameters (nextIntervalDays defaultParameters dr st) st)
)
[ (0.9, MemoryState 10 5 8)
, (0.8, MemoryState 1 5 0.8)
, (0.95, MemoryState 100 2 80)
, (0.7, MemoryState 0.5 8 0.4)
, (0.99, MemoryState 1000 5 800)
]
, testCase "an unreachable target saturates at the shortest interval" $
nextIntervalDays defaultParameters 1 (MemoryState 10 5 8) @?= minimumIntervalDays
, testCase "a target of zero saturates at the longest interval" $
nextIntervalDays defaultParameters 0 (MemoryState 10 5 8) @?= maximumIntervalDays
, testCase "a nonsensical target does not diverge" $ do
let st = MemoryState 10 5 8
nextIntervalDays defaultParameters (0 / 0) st @?= maximumIntervalDays
nextIntervalDays defaultParameters (-1) st @?= maximumIntervalDays
nextIntervalDays defaultParameters 2 st @?= minimumIntervalDays
, testCase "a fresh Good card comes back in about five days" $
close
"interval after one Good"
4.777721806896744
( nextIntervalDays defaultParameters 0.9 $
nextMemoryState defaultParameters Nothing 0 Good
)
, testCase "a fresh Easy card comes back in about two months" $
close
"interval after one Easy"
53.86951316227529
( nextIntervalDays defaultParameters 0.9 $
nextMemoryState defaultParameters Nothing 0 Easy
)
]
-- ---------------------------------------------------------------------------
-- | The two numeric assertions the reference implementation makes about
-- FSRS-7 in its own test suite, reproduced here. These are the only fixtures
-- in the package that were not produced by our own transcription of the model,
-- so they are what pins the port to upstream rather than to itself.
--
-- Both come from @src\/inference.rs@ of
-- <https://github.com/open-spaced-repetition/fsrs-rs/pull/426 fsrs-rs#426>:
-- @test_memory_state_fsrs7@ and @test_next_interval_fsrs7@. The tolerances are
-- loose because upstream computes in single precision.
referenceFixtures :: TestTree
referenceFixtures =
testGroup
"reference fixtures"
[ testCase "test_memory_state_fsrs7" $ do
let history =
[ (0, Again)
, (0, Good)
, (1, Good)
, (3, Good)
, (8, Good)
, (21, Good)
]
case replayReviews defaultParameters history of
Nothing -> assertFailure "replayReviews returned Nothing"
Just st -> do
closeWith 1.0e-6 "stability" 25.985723 (memoryStability st)
closeWith 1.0e-6 "difficulty" 5.877549 (memoryDifficulty st)
, testCase "test_next_interval_fsrs7" $
-- Upstream rounds to whole days and floors at one.
map (wholeDays . (/ 10) . fromIntegral) [1 .. 10 :: Int]
@?= [36500, 36500, 36500, 12813, 843, 92, 13, 2, 1, 1]
]
where
wholeDays :: Retrievability -> Integer
wholeDays dr =
max 1 . round $
nextIntervalDays defaultParameters dr (MemoryState 1 5 1)