hasklepias-0.16.1: 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 #-}
module Hasklepias.Templates.Features.Enrollment (
defIsEnrolled
, defContinuousEnrollment
, defEnrollmentTests
) where
import Control.Applicative ( Applicative(..) )
import GHC.Int ( Int )
import GHC.TypeLits ( KnownSymbol )
import GHC.Show ( Show )
import Flow ( (|>), (.>) )
import IntervalAlgebra
import IntervalAlgebra.IntervalUtilities ( combineIntervals )
import IntervalAlgebra.PairedInterval ( intervals )
import Witherable ( Witherable )
import Data.Eq ( Eq )
import Data.Foldable (Foldable(..), any)
import Data.Function ( ($), (.) )
import Data.Functor ( Functor(.. ) )
import Data.Maybe ( Maybe )
import Data.Monoid ( Monoid(..) )
import Data.Text ( Text )
import Data.Tuple ( uncurry )
import Test.Tasty ( testGroup, TestName, TestTree )
import Test.Tasty.HUnit ( testCase )
import EventData ( Event
, Domain(..)
, EnrollmentFacts(..)
, event
, context
)
import Features.Compose ( Feature
, Definition(..)
, Define(..)
, Eval(..)
, makeFeature )
import Hasklepias.FeatureEvents ( allGapsWithinLessThanDuration
, makeConceptsFilter
, filterByDomain
, isEnrollment, lookback )
import Hasklepias.Templates.TestUtilities
( makeAssertion
, TemplateTestCase(..) )
import Hasklepias.Misc ( F )
import Cohort.Index ( Index(..) )
import Cohort.Criteria ( Status(..), includeIf )
{-| Is Enrolled
TODO: describe this
-}
defIsEnrolled ::
( Intervallic i0 a
, Monoid (container (Interval a))
, Applicative container
, Witherable container) =>
Definition
( Feature indexName (Index i0 a)
-> Feature eventsName (container (Event a))
-> Feature varName Status )
defIsEnrolled =
define
(\index ->
filterByDomain isEnrollment
.> combineIntervals
.> any (concur index)
.> includeIf
)
makeIsEnrolledTestInputs :: (IntervalSizeable a b) =>
TestName
-> b
-> a
-> [Event a]
-> Status
-> TemplateTestCase (F "index" (Index Interval a), F "events" [Event a]) Status
makeIsEnrolledTestInputs name dur bgn e s =
MkTemplateTestCase name (pure (MkIndex $ beginerval dur bgn), pure e) (pure s)
makeEnrollmentEvent :: (IntervalSizeable a b) => b -> a -> Event a
makeEnrollmentEvent dur bgn =
event (beginerval dur bgn) (context ( Enrollment (EnrollmentFacts ())) mempty)
defIsEnrolledTestCases :: [TemplateTestCase
(F "index" (Index Interval Int), F "events" [Event Int]) Status]
defIsEnrolledTestCases = [
f "Exclude if no events" 1 (0::Int) [] Exclude
, f "Exclude if only interval meets" 1 (0::Int) [g 5 1] Exclude
, f "Include if concurring interval" 1 (0::Int) [g 5 (-1)] Include
, f "Include if concurring interval" 1 (0::Int) [g 2 (-1), g 5 1] Include
] where f = makeIsEnrolledTestInputs
g = makeEnrollmentEvent
defIsEnrolledTests :: TestTree
defIsEnrolledTests = testGroup "Tests of isEnrolled template"
( fmap (\x -> testCase (getTestName x) (makeAssertion x defIsEnrolled) )
defIsEnrolledTestCases )
{-| Continuous Enrollment
TODO: describe this
-}
defContinuousEnrollment ::
( Monoid (container (Interval a))
, Monoid (container (Maybe (Interval a)))
, Applicative container
, Witherable container
, IntervalCombinable i1 a
, IntervalSizeable a b) =>
(Index i0 a -> i1 a) -- ^ function which maps index interval to interval in which to assess enrollment
-> 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 )
defContinuousEnrollment formInterval allowableGap =
define
(\index events prevStatus ->
case prevStatus of
Exclude -> Exclude
Include -> includeIf
( allGapsWithinLessThanDuration
allowableGap
(formInterval index)
(combineIntervals $ filterByDomain isEnrollment events))
)
makeContinuousEnrollmentTestInputs :: (IntervalSizeable a b) =>
TestName
-> b
-> a
-> [Event a]
-> Status
-> Status
-> TemplateTestCase (F "index" (Index Interval a), F "events" [Event a], F "prev" Status) Status
makeContinuousEnrollmentTestInputs name dur bgn e prev s =
MkTemplateTestCase name (pure (MkIndex $ beginerval dur bgn), pure e, pure prev) (pure s)
defContinuousEnrollmentTestCases :: [TemplateTestCase
(F "index" (Index Interval Int), F "events" [Event Int], F "prev" Status) Status]
defContinuousEnrollmentTestCases = [
f "Exclude if previously excluded" 1 (0::Int) [] Exclude Exclude
, f "Exclude if no events" 1 (0::Int) [] Include Exclude
{-
- <- Index
---------- <- Baseline
--- --- <- Enrollment
|--------------|
-}
, f "Exclude if gap >= 3" 1 (10::Int) [g 3 1, g 3 9] Include Exclude
{-
- <- Index
---------- <- Baseline
------ <- Enrollment
|--------------|
-}
, f "Exclude if gap >= 3" 1 (10::Int) [g 6 1] Include Exclude
{-
- <- Index
---------- <- Baseline
------- <- Enrollment
|--------------|
-}
, f "Exclude if gap >= 3" 1 (10::Int) [g 7 6] Include Exclude
{-
- <- Index
---------- <- Baseline
-- ------- <- Enrollment
|--------------|
-}
, f "Include if gaps less than 3" 1 (10::Int) [g 2 1, g 7 5] Include Include
{-
- <- Index
---------- <- Baseline
------- <- Enrollment
|--------------|
-}
, f "Include if gaps less than 3" 1 (10::Int) [g 7 2] Include Include
{-
- <- Index
---------- <- Baseline
----- <- Enrollment
----
|--------------|
-}
, f "Include if gaps less than 3" 1 (10::Int) [g 5 1, g 4 4] Include Include
] where f = makeContinuousEnrollmentTestInputs
g = makeEnrollmentEvent
defContinuousEnrollmentTests :: TestTree
defContinuousEnrollmentTests = testGroup "Tests of continuous enrollment template"
( fmap (\x -> testCase (getTestName x)
(makeAssertion x (defContinuousEnrollment (lookback 10) 3)) )
defContinuousEnrollmentTestCases )
defEnrollmentTests :: TestTree
defEnrollmentTests = testGroup "" [defIsEnrolledTests, defContinuousEnrollmentTests]