haskell-fsrs-7.1.0: test/Test/FSRS/Properties.hs
-- | Properties of the FSRS-7 model.
--
-- Most of these hold for every parameter vector inside the valid box, and are
-- generated that way. The ones about how retrievability and intervals respond
-- to /stability/ or /difficulty/ are narrower, for two reasons, and each such
-- property says which apply to it:
--
-- * The FSRS-7 forgetting curve re-weights its two components by stability, so
-- for adversarial-but-in-bounds weights the slow component can pull
-- retrievability /down/ as stability grows. Those properties are stated for
-- 'defaultParameters'.
-- * Difficulty pulls the curve two ways — it speeds the slow component up, but
-- also shifts mixture weight onto the fast one. At the trace ratio the model
-- itself maintains the first effect wins; for an arbitrarily lopsided pair of
-- traces neither does. Those properties are stated over
-- 'genNaturalMemoryState' / 'genGrowableState'.
module Test.FSRS.Properties (tests) where
import Test.Tasty (TestTree, testGroup)
import Test.Tasty.QuickCheck
( counterexample
, forAll
, testProperty
, vectorOf
, (===)
, (==>)
)
import qualified Test.Tasty.QuickCheck as QC
import FSRS
import Test.FSRS.Gen
tests :: TestTree
tests =
testGroup
"properties"
[ parameterProperties
, curveProperties
, fastTraceProperties
, intervalProperties
, difficultyProperties
, stabilityProperties
, stateProperties
]
-- | Grow both memory traces by the same factor, keeping their ratio — the
-- meaningful way to ask what "more stable" does now that a card has two
-- stabilities. The factor comes from 'genGrowableState', which guarantees
-- neither trace saturates.
scaleTraces :: Double -> MemoryState -> MemoryState
scaleTraces k st =
st
{ memoryStability = memoryStability st * k
, memoryStabilityFast = memoryStabilityFast st * k
}
-- | The largest value 'retrievability' can take.
retrievabilityCeiling :: Retrievability
retrievabilityCeiling = 1 - retrievabilityFloor
-- ---------------------------------------------------------------------------
parameterProperties :: TestTree
parameterProperties =
testGroup
"parameters"
[ testProperty "the defaults are valid" $
validateParameters (parametersToList defaultParameters) === []
, testProperty "there are exactly parameterCount defaults" $
length (parametersToList defaultParameters) === parameterCount
, testProperty "there is a bound for every weight" $
length parameterBounds === parameterCount
, testProperty "mkParameters . parametersToList is the identity" $
forAll genParameters $ \p ->
mkParameters (parametersToList p) === Right p
, testProperty "parameterAt agrees with parametersToList" $
forAll genParameters $ \p ->
map (parameterAt p) [0 .. parameterCount - 1] === parametersToList p
, testProperty "a wrong number of weights is rejected" $
forAll (QC.choose (0, 60)) $ \n ->
n /= parameterCount ==>
mkParameters (replicate n 0.5) === Left [WrongParameterCount n]
, testProperty "clampParameters always produces something valid" $
forAll (vectorOf parameterCount (QC.choose (-1000, 1000))) $ \ws ->
case clampParameters ws of
Left errs -> counterexample (show errs) False
Right p -> counterexample (show p) (validateParameters (parametersToList p) == [])
, testProperty "clampParameters is idempotent" $
forAll (vectorOf parameterCount (QC.choose (-1000, 1000))) $ \ws ->
let once = clampParameters ws
twice = once >>= clampParameters . parametersToList
in once === twice
, testProperty "clampParameters keeps valid weights untouched" $
forAll genParameters $ \p ->
clampParameters (parametersToList p) === Right p
, testProperty "clampParameters settles the ordering constraints" $
forAll (vectorOf parameterCount (QC.choose (-1000, 1000))) $ \ws ->
case clampParameters ws of
Left errs -> counterexample (show errs) False
Right p ->
let at = parameterAt p
in counterexample (show p) $
and [at i <= at j | (i, j) <- orderingConstraints]
]
-- ---------------------------------------------------------------------------
curveProperties :: TestTree
curveProperties =
testGroup
"forgetting curve"
[ testProperty "a card just reviewed is as recallable as it gets" $
-- FSRS-7 rescales retrievability away from 1, so "certain" is the
-- ceiling rather than exactly 1.
forAll genParameters $ \p ->
forAll genMemoryState $ \st ->
counterexample (show (retrievability p 0 st)) $
approxEqual 1.0e-15 1.0e-15 (retrievability p 0 st) retrievabilityCeiling
, testProperty "retrievability stays inside the rescaled range" $
forAll genParameters $ \p ->
forAll genElapsedDays $ \t ->
forAll genMemoryState $ \st ->
let r = retrievability p t st
in counterexample (show r) $
r >= retrievabilityFloor && r <= retrievabilityCeiling
, testProperty "retrievability decreases as time passes" $
forAll genParameters $ \p ->
forAll genElapsedDays $ \t1 ->
forAll (QC.choose (1.0e-6, 5)) $ \gap ->
forAll genMemoryState $ \st ->
let r1 = retrievability p t1 st
r2 = retrievability p (t1 + gap) st
in counterexample (show (t1, r1, r2)) (r2 <= r1 + 1.0e-15)
, testProperty "a negative elapsed time reads as no time at all" $
forAll genParameters $ \p ->
forAll genMemoryState $ \st ->
forAll (QC.choose (-1000, -1.0e-9)) $ \t ->
retrievability p t st === retrievability p 0 st
, testProperty "the derivative is never positive" $
forAll genParameters $ \p ->
forAll genElapsedDays $ \t ->
forAll genMemoryState $ \st ->
let d = retrievabilityDerivative p t st
in counterexample (show d) (d <= 0)
, testProperty "the derivative matches a finite difference" $
forAll genParameters $ \p ->
forAll (QC.choose (0.5, 50)) $ \t ->
forAll genMemoryState $ \st ->
let h = 1.0e-6 * t
numeric =
(retrievability p (t + h) st - retrievability p (t - h) st) / (2 * h)
exact = retrievabilityDerivative p t st
in counterexample (show (numeric, exact)) $
approxEqual 1.0e-7 1.0e-5 numeric exact
, testProperty "with the default weights, difficulty never helps recall" $
-- Difficulty pulls two ways: it speeds the slow component up (good for
-- this property) but also shifts mixture weight onto the fast one
-- (bad). At the trace ratio the model maintains the first wins; for an
-- arbitrarily lopsided pair of traces neither does, which is why this
-- is stated over 'genNaturalMemoryState'.
forAll genElapsedDays $ \t ->
forAll genNaturalMemoryState $ \st ->
forAll (QC.choose (difficultyMin, difficultyMax)) $ \d1 ->
forAll (QC.choose (difficultyMin, difficultyMax)) $ \d2 ->
let r1 = retrievability defaultParameters t st {memoryDifficulty = min d1 d2}
r2 = retrievability defaultParameters t st {memoryDifficulty = max d1 d2}
in counterexample (show (d1, d2, r1, r2)) (r2 <= r1 + 1.0e-15)
, testProperty "with the default weights, more stability means more recall" $
forAll genElapsedDays $ \t ->
forAll genGrowableState $ \(st, growth) ->
let st' = scaleTraces growth st
r1 = retrievability defaultParameters t st
r2 = retrievability defaultParameters t st'
in counterexample (show (st, st', r1, r2)) (r2 >= r1 - 1.0e-15)
]
-- ---------------------------------------------------------------------------
fastTraceProperties :: TestTree
fastTraceProperties =
testGroup
"fast trace"
[ testProperty "the fast trace's own recall is a probability" $
forAll genParameters $ \p ->
forAll genElapsedDays $ \t ->
forAll genStability $ \s ->
let r = fastTraceRetrievability p t s
in counterexample (show r) (r > 0 && r <= 1)
, testProperty "it is exactly 1 at no elapsed time" $
-- Unlike the mixture, this component is not rescaled.
forAll genParameters $ \p ->
forAll genStability $ \s ->
fastTraceRetrievability p 0 s === 1
, testProperty "it decreases as time passes" $
forAll genParameters $ \p ->
forAll genElapsedDays $ \t1 ->
forAll (QC.choose (1.0e-6, 5)) $ \gap ->
forAll genStability $ \s ->
let r1 = fastTraceRetrievability p t1 s
r2 = fastTraceRetrievability p (t1 + gap) s
in counterexample (show (r1, r2)) (r2 <= r1 + 1.0e-15)
, testProperty "a lapse leaves the fast trace below the slow one" $
-- The post-lapse cap is what stops a forgotten card from keeping a
-- large short-term boost. It is applied before the final clamp, so at
-- the very bottom of the range the floor wins — as it does upstream.
forAll genParameters $ \p ->
forAll genMemoryState $ \st ->
forAll genElapsedDays $ \t ->
let after = nextMemoryState p (Just st) t Again
cap = max stabilityMin (fastTraceRatio * memoryStability after)
in counterexample (show (after, cap)) $
memoryStabilityFast after <= cap + 1.0e-12
, testProperty "the slow trace is the slow block applied to itself" $
forAll genParameters $ \p ->
forAll genMemoryState $ \st ->
forAll genElapsedDays $ \t ->
forAll genRating $ \rating ->
let r = retrievability p t st
expected =
stabilityAfterReview
(slowTraceWeights p)
(memoryStability st)
(memoryDifficulty st)
r
rating
(slow, _) = nextStability p st t rating
in counterexample (show (expected, slow)) $
approxEqual 1.0e-12 1.0e-12 slow expected
, testProperty "the fast trace reads its own recall, not the mixture" $
forAll genParameters $ \p ->
forAll genMemoryState $ \st ->
forAll genElapsedDays $ \t ->
forAll (QC.elements [Hard, Good, Easy]) $ \rating ->
let rFast = fastTraceRetrievability p t (memoryStabilityFast st)
expected =
stabilityAfterReview
(fastTraceWeights p)
(memoryStabilityFast st)
(memoryDifficulty st)
rFast
rating
(_, fast) = nextStability p st t rating
in counterexample (show (expected, fast)) $
approxEqual 1.0e-12 1.0e-12 fast expected
]
-- ---------------------------------------------------------------------------
intervalProperties :: TestTree
intervalProperties =
testGroup
"interval inversion"
[ testProperty "the answer is always a legal interval" $
forAll genParameters $ \p ->
forAll genDesiredRetention $ \dr ->
forAll genMemoryState $ \st ->
let t = nextIntervalDays p dr st
in counterexample (show t) (t >= minimumIntervalDays && t <= maximumIntervalDays)
, testProperty "waiting that long really does land on the desired retention" $
forAll genParameters $ \p ->
forAll genDesiredRetention $ \dr ->
forAll genMemoryState $ \st ->
let t = nextIntervalDays p dr st
r = retrievability p t st
in -- Saturated answers cannot hit the target and do not claim to.
t > minimumIntervalDays && t < maximumIntervalDays ==>
counterexample (show (t, r, dr)) (approxEqual 1.0e-9 1.0e-9 r dr)
, testProperty "asking for more retention never buys a longer interval" $
forAll genParameters $ \p ->
forAll genMemoryState $ \st ->
forAll genDesiredRetention $ \dr1 ->
forAll (QC.choose (1.0e-6, 0.2)) $ \bump ->
let dr2 = min 0.999 (dr1 + bump)
t1 = nextIntervalDays p dr1 st
t2 = nextIntervalDays p dr2 st
in counterexample (show (dr1, dr2, t1, t2)) (t2 <= t1 * (1 + 1.0e-9))
, testProperty "with the default weights, more stability means a longer interval" $
-- Stated over 'genGrowableState' for the same reason as the curve's
-- monotonicity above.
forAll genDesiredRetention $ \dr ->
forAll genGrowableState $ \(st, growth) ->
let st' = scaleTraces growth st
t1 = nextIntervalDays defaultParameters dr st
t2 = nextIntervalDays defaultParameters dr st'
in counterexample (show (st, st', t1, t2)) (t2 >= t1 * (1 - 1.0e-9))
, testProperty "an impossible retention saturates instead of diverging" $
forAll genParameters $ \p ->
forAll genMemoryState $ \st ->
counterexample "retention 1" (nextIntervalDays p 1 st == minimumIntervalDays)
QC..&&. counterexample "retention 0" (nextIntervalDays p 0 st == maximumIntervalDays)
]
-- ---------------------------------------------------------------------------
difficultyProperties :: TestTree
difficultyProperties =
testGroup
"difficulty"
[ testProperty "initial difficulty is in range" $
forAll genParameters $ \p ->
forAll genRating $ \rating ->
let d = initialDifficulty p rating
in counterexample (show d) (d >= difficultyMin && d <= difficultyMax)
, testProperty "difficulty stays in range" $
forAll genParameters $ \p ->
forAll genDifficulty $ \d ->
forAll genRetrievability $ \r ->
forAll genRating $ \rating ->
let d' = nextDifficulty p d r rating
in counterexample (show d') (d' >= difficultyMin && d' <= difficultyMax)
, testProperty "among the passing grades, a better rating never makes a card harder" $
forAll genParameters $ \p ->
forAll genDifficulty $ \d ->
forAll genRetrievability $ \r ->
let ds = map (nextDifficulty p d r) [Hard, Good, Easy]
in counterexample (show ds) (nonIncreasing ds)
, testProperty "a surprising lapse is the harshest answer of all" $
-- FSRS-7 weights a lapse's step by `r + 0.1`, so a lapse only
-- outweighs a Hard once the model expected the card to be recalled.
-- Below that the weighting deliberately softens it.
forAll genParameters $ \p ->
forAll genDifficulty $ \d ->
forAll (QC.choose (0.4, 1.0)) $ \r ->
let ds = map (nextDifficulty p d r) allRatings
in counterexample (show ds) (nonIncreasing ds)
, testProperty "a less surprising lapse is a gentler lapse" $
forAll genParameters $ \p ->
forAll genDifficulty $ \d ->
forAll genRetrievability $ \r1 ->
forAll genRetrievability $ \r2 ->
let lo = nextDifficulty p d (min r1 r2) Again
hi = nextDifficulty p d (max r1 r2) Again
in counterexample (show (r1, r2, lo, hi)) (hi >= lo - 1.0e-12)
, testProperty "an easier first answer means an easier card" $
forAll genParameters $ \p ->
counterexample
(show (map (initialDifficulty p) allRatings))
(nonIncreasing (map (initialDifficulty p) allRatings))
, testProperty "difficulty stays in range over a long history" $
forAll genParameters $ \p ->
forAll (vectorOf 200 ((,) <$> genRetrievability <*> genRating)) $ \steps ->
let ds = scanl (\d (r, rating) -> nextDifficulty p d r rating) 5 steps
in counterexample (show (minimum ds, maximum ds)) $
all (\d -> d >= difficultyMin && d <= difficultyMax) ds
]
-- ---------------------------------------------------------------------------
stabilityProperties :: TestTree
stabilityProperties =
testGroup
"stability"
[ testProperty "both traces stay in range" $
forAll genParameters $ \p ->
forAll genMemoryState $ \st ->
forAll genElapsedDays $ \t ->
forAll genRating $ \rating ->
let after = nextMemoryState p (Just st) t rating
in counterexample (show after) $
inStabilityRange (memoryStability after)
&& inStabilityRange (memoryStabilityFast after)
, testProperty "a better rating never means less stability" $
forAll genParameters $ \p ->
forAll genMemoryState $ \st ->
forAll genElapsedDays $ \t ->
let ss = [memoryStability (nextMemoryState p (Just st) t r) | r <- allRatings]
in counterexample (show ss) (nonDecreasing ss)
, testProperty "remembering a card cannot weaken it" $
forAll genParameters $ \p ->
forAll genMemoryState $ \st ->
forAll genElapsedDays $ \t ->
forAll (QC.elements [Hard, Good, Easy]) $ \rating ->
let before = memoryStability st
after = memoryStability (nextMemoryState p (Just st) t rating)
in counterexample (show (before, after)) (after >= before * (1 - 1.0e-12))
, testProperty "forgetting a card cannot strengthen it" $
forAll genParameters $ \p ->
forAll genMemoryState $ \st ->
forAll genElapsedDays $ \t ->
let before = memoryStability st
after = memoryStability (nextMemoryState p (Just st) t Again)
in counterexample (show (before, after)) (after <= before * (1 + 1.0e-12))
, testProperty "post-lapse stability does not depend on difficulty" $
-- The finished model ablated the d ** -fail_d_exp factor, so a lapse's
-- stability is difficulty-free. Only the sinc branch reads difficulty,
-- and Again never takes it.
forAll genParameters $ \p ->
forAll genStability $ \s ->
forAll genRetrievability $ \r ->
forAll genDifficulty $ \d1 ->
forAll genDifficulty $ \d2 ->
let f d = stabilityAfterReview (slowTraceWeights p) s d r Again
in counterexample (show (f d1, f d2)) (f d1 === f d2)
, testProperty "the initial stability is the matching weight" $
forAll genParameters $ \p ->
forAll genRating $ \rating ->
initialStability p rating === parameterAt p (ratingToInt rating - 1)
]
where
inStabilityRange s = s >= stabilityMin && s <= stabilityMax
-- ---------------------------------------------------------------------------
stateProperties :: TestTree
stateProperties =
testGroup
"state transitions"
[ testProperty "a first review reads the state off the weights" $
forAll genParameters $ \p ->
forAll genElapsedDays $ \t ->
forAll genRating $ \rating ->
nextMemoryState p Nothing t rating === initialMemoryState p rating
, testProperty "a new card's fast trace is a fraction of its slow one" $
forAll genParameters $ \p ->
forAll genRating $ \rating ->
let st = initialMemoryState p rating
in counterexample (show st) $
approxEqual 1.0e-12 1.0e-12
(memoryStabilityFast st)
(fastTraceRatio * memoryStability st)
, testProperty "the elapsed time of a first review is ignored" $
forAll genParameters $ \p ->
forAll genElapsedDays $ \t1 ->
forAll genElapsedDays $ \t2 ->
forAll genRating $ \rating ->
nextMemoryState p Nothing t1 rating === nextMemoryState p Nothing t2 rating
, testProperty "an empty history has no memory state" $
forAll genParameters $ \p ->
replayReviews p [] === Nothing
, testProperty "replaying is a left fold" $
forAll genParameters $ \p ->
forAll genReviewHistory $ \xs ->
forAll genReviewHistory $ \ys ->
let viaConcat = replayReviews p (xs <> ys)
viaFold = foldl (\st (t, r) -> Just (nextMemoryState p st t r)) (replayReviews p xs) ys
in viaConcat === viaFold
, testProperty "any history leaves the card in a legal state" $
forAll genParameters $ \p ->
forAll genReviewHistory $ \history ->
case replayReviews p history of
Nothing -> QC.property (null history)
Just (MemoryState s d sFast) ->
counterexample (show (s, d, sFast)) $
s >= stabilityMin
&& s <= stabilityMax
&& sFast >= stabilityMin
&& sFast <= stabilityMax
&& d >= difficultyMin
&& d <= difficultyMax
, testProperty "the state is finite, however long the history" $
forAll genParameters $ \p ->
forAll (vectorOf 100 ((,) <$> genElapsedDays <*> genRating)) $ \history ->
case replayReviews p history of
Nothing -> counterexample "unexpected Nothing" False
Just (MemoryState s d sFast) ->
counterexample (show (s, d, sFast)) (all finite [s, d, sFast])
]
where
finite x = not (isNaN x) && not (isInfinite x)
-- ---------------------------------------------------------------------------
nonDecreasing :: [Double] -> Bool
nonDecreasing xs = and (zipWith (<=) xs (drop 1 xs))
nonIncreasing :: [Double] -> Bool
nonIncreasing xs = and (zipWith (>=) xs (drop 1 xs))