hasklepias-0.20.0: src/Hasklepias/Templates/Features/Enrollment.hs
{-|
Module : Enrollment Features Templates
Description : Templates for Features pertaining to enrollment
Copyright : (c) NoviSci, Inc 2020
License : BSD3
Maintainer : bsaul@novisci.com
-}
{-# OPTIONS_HADDOCK hide #-}
{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE MultiParamTypeClasses #-}
module Hasklepias.Templates.Features.Enrollment
( buildIsEnrolled
, buildContinuousEnrollment
, buildEnrollmentTests
) where
import Cohort
import EventData
import Features
import Hasklepias.FeatureEvents
import Hasklepias.Templates.TestUtilities
import Hasklepias.Reexports
import Hasklepias.ReexportsUnsafe
{-| Is Enrolled
TODO: describe this
-}
buildIsEnrolled
:: ( Intervallic i0 a
, Monoid (container (Interval a))
, Applicative container
, Witherable container
)
=>
Predicate (Event a) -- ^ The predicate to filter to Enrollment events (e.g. 'FeatureEvents.isEnrollment')
-> Definition
( Feature indexName (Index i0 a)
-> Feature eventsName (container (Event a))
-> Feature varName Status
)
buildIsEnrolled predicate = define
(\index ->
filter (getPredicate predicate)
.> combineIntervals
.> any (concur index)
.> includeIf
)
makeIsEnrolledTestInputs
:: (Integral b, IntervalSizeable a b)
=> TestName
-> Predicate (Event a)
-> (a, a)
-> [Event a]
-> Status
-> TestCase
(F "index" (Index Interval a), F "events" [Event a])
Status
(Predicate (Event a))
makeIsEnrolledTestInputs name buildArgs intrvl e s = MkTestCase
buildArgs
name
(pure (makeIndex $ readIntervalSafe intrvl), pure e)
(pure s)
buildIsEnrolledTestCases
:: [ TestCase
(F "index" (Index Interval Int), F "events" [Event Int])
Status
(Predicate (Event Int))
]
buildIsEnrolledTestCases =
[ f "Exclude if no events" isEnrollmentEvent (0, 1) [] Exclude
, f "Exclude if only interval meets"
isEnrollmentEvent
(0, 1)
[g (1, 6)]
Exclude
, f "Include if concurring interval"
isEnrollmentEvent
(0, 1)
[g (-1, 4)]
Include
, f "Include if concurring interval"
isEnrollmentEvent
(0, 1)
[g (-1, 1), g (1, 4)]
Include
] where
f = makeIsEnrolledTestInputs
g = makeEnrollmentEvent
buildIsEnrolledTests :: TestTree
buildIsEnrolledTests = testGroup
"Tests of isEnrolled template"
(fmap
(\x -> testCase (getTestName x)
(makeAssertion x (uncurryN $ eval (buildIsEnrolled (getBuilderArgs x))))
)
buildIsEnrolledTestCases
)
{-| Continuous Enrollment
TODO: describe this
-}
buildContinuousEnrollment
:: ( Monoid (container (Interval a))
, Monoid (container (Maybe (Interval a)))
, Applicative container
, Witherable container
, IntervalSizeable a b
)
=> (Index i0 a -> AssessmentInterval a) -- ^ function which maps index interval to interval in which to assess enrollment
-> Predicate (Event a) -- ^ The predicate to filter to Enrollment events (e.g. 'FeatureEvents.isEnrollment')
-> b -- ^ duration of allowable gap between enrollment intervals
-> Definition
( Feature indexName (Index i0 a)
-> Feature eventsName (container (Event a))
-> Feature prevName Status
-> Feature varName Status
)
buildContinuousEnrollment makeAssessmentInterval predicate allowableGap = define
(\index events prevStatus -> case prevStatus of
Exclude -> Exclude
Include -> includeIf
(allGapsWithinLessThanDuration
allowableGap
(makeAssessmentInterval index)
(combineIntervals $ filter (getPredicate predicate) events)
)
)
type ContEnrollArgs
= (Index Interval Int -> AssessmentInterval Int, Predicate (Event Int), Int)
makeContinuousEnrollmentTestInputs
:: (Integral b, IntervalSizeable a b)
=> TestName
-> ContEnrollArgs
-> (a, a)
-> [Event a]
-> Status
-> Status
-> TestCase
( F "index" (Index Interval a)
, F "events" [Event a]
, F "prev" Status
)
Status
ContEnrollArgs
makeContinuousEnrollmentTestInputs name buildArgs intrvl e prev s = MkTestCase
buildArgs
name
(pure (makeIndex (readIntervalSafe intrvl)), pure e, pure prev)
(pure s)
commonArgs
:: (Index Interval Int -> AssessmentInterval Int, Predicate (Event a), Int)
commonArgs = (makeBaselineFromIndex 10, isEnrollmentEvent, 3)
buildContinuousEnrollmentTestCases
:: [ TestCase
( F "index" (Index Interval Int)
, F "events" [Event Int]
, F "prev" Status
)
Status
ContEnrollArgs
]
buildContinuousEnrollmentTestCases =
[ f "Exclude if previously excluded" commonArgs (0, 1) [] Exclude Exclude
, f "Exclude if no events" commonArgs (0, 1) [] Include Exclude
, f "Exclude if gap >= 3"
commonArgs
(10, 11)
[g (1, 4), g (9, 12)]
Include
Exclude
{-
- <- Index
---------- <- Baseline
--- --- <- Enrollment
|--------------|
-}
, f "Exclude if gap >= 3" commonArgs (10, 11) [g (1, 7)] Include Exclude
{-
- <- Index
---------- <- Baseline
------ <- Enrollment
|--------------|
-}
, f "Exclude if gap >= 3" commonArgs (10, 11) [g (6, 13)] Include Exclude
{-
- <- Index
---------- <- Baseline
------- <- Enrollment
|--------------|
-}
, f "Include if gaps less than 3"
commonArgs
(10, 11)
[g (1, 3), g (5, 12)]
Include
Include
{-
- <- Index
---------- <- Baseline
-- ------- <- Enrollment
|--------------|
-}
, f "Include if gaps less than 3"
commonArgs
(10, 11)
[g (2, 9)]
Include
Include
{-
- <- Index
---------- <- Baseline
------- <- Enrollment
|--------------|
-}
, f "Include if gaps less than 3"
commonArgs
(10, 11)
[g (1, 6), g (4, 8)]
Include
Include
{-
- <- Index
---------- <- Baseline
----- <- Enrollment
----
|--------------|
-}
] where
f = makeContinuousEnrollmentTestInputs
g = makeEnrollmentEvent
buildContinuousEnrollmentTests :: TestTree
buildContinuousEnrollmentTests = testGroup
"Tests of continuous enrollment template"
(fmap
(\x -> testCase
(getTestName x)
(makeAssertion
x
(uncurryN $ eval (buildContinuousEnrollment (makeBaselineFromIndex 10) isEnrollmentEvent 3))
)
)
buildContinuousEnrollmentTestCases
)
buildEnrollmentTests :: TestTree
buildEnrollmentTests =
testGroup "" [buildIsEnrolledTests, buildContinuousEnrollmentTests]