hasklepias 0.17.1 → 0.18.0
raw patch · 16 files changed
+738/−315 lines, 16 files
Files
- ChangeLog.md +6/−0
- examples/ExampleCohort1.hs +10/−9
- examples/ExampleFeatures1.hs +138/−83
- examples/ExampleFeatures2.hs +2/−2
- examples/ExampleFeatures4.hs +6/−6
- hasklepias.cabal +1/−1
- src/Cohort/Criteria.hs +1/−1
- src/EventData.hs +4/−1
- src/Features/Compose.hs +65/−104
- src/Hasklepias.hs +231/−5
- src/Hasklepias/Reexports.hs +5/−6
- src/Hasklepias/Templates/Features.hs +4/−1
- src/Hasklepias/Templates/Features/Enrollment.hs +2/−2
- src/Hasklepias/Templates/Features/NsatisfyP.hs +236/−10
- src/Hasklepias/Templates/TestUtilities.hs +21/−6
- test/FeaturesSpec.hs +6/−78
ChangeLog.md view
@@ -1,5 +1,11 @@ # Changelog for hasklepias +## 0.18.0++* Refactors the `Features.Compose` module a bit. Adds constructors for composing `Definition`. For example, `D1C :: (a2 -> a1 -> a) -> Definition (F n1 b -> F n02 a2) -> Definition (F n1 b -> F n01 a1) -> Definition (F n1 b -> F n0 a )`. Such constructors allow one to build definitions from other definitions, provided the input types are the same. Note: there is *not* a single interface to these constructors like is provided by the `define` and `defineA` functions. The poorly designed `Eval` typeclass is now replaced with a single `eval` function which simply pattern matches on the various shapes of `Definition`s. I fully expect this module to get another refactor in the future, but it is shaping up OK.+* Examples are updated according to the changes `define`/`eval`.+* Adds the `buildNofXOrNofYWithGapBool` template, which can be used for the common feature or 2-outpatient events with at least some gap between them or 1 inpatient event.+ ## 0.17.1 * Fixes silly mistake with git.
examples/ExampleCohort1.hs view
@@ -202,7 +202,8 @@ -> Feature "isEnrolled" Status -> Feature "isContinuousEnrolled" Status )-critEnrolled455 = buildContinuousEnrollment baselineInterval isEnrollmentEvent 30+critEnrolled455 =+ buildContinuousEnrollment baselineInterval isEnrollmentEvent 30 -- | Exclude if the subject is dead before the time of index. critDead@@ -278,10 +279,10 @@ where crit1 = eval critFemale featEvs crit2 = eval critOver50 agefeat- crit3 = eval critEnrolled (featInd, featEvs)- crit4 = eval critEnrolled455 (featInd, featEvs, crit3)- crit5 = eval critDead (featInd, dead)- agefeat = eval age (featInd, featEvs)+ crit3 = eval critEnrolled featInd featEvs+ crit4 = eval critEnrolled455 featInd featEvs crit3+ crit5 = eval critDead featInd dead+ agefeat = eval age featInd featEvs dead = eval deathDay featEvs featInd = featureIndex index featEvs = featureEvents events@@ -290,10 +291,10 @@ makeFeatureRunner :: Index Interval Day -> Events Day -> Featureset makeFeatureRunner index events = featureset ( packFeature idx- :| [ packFeature $ eval diabetes (idx, ef)- , packFeature $ eval ckd (idx, ef)- , packFeature $ eval ppi (idx, ef)- , packFeature $ eval glucocorticoids (idx, ef)+ :| [ packFeature $ eval diabetes idx ef+ , packFeature $ eval ckd idx ef+ , packFeature $ eval ppi idx ef+ , packFeature $ eval glucocorticoids idx ef ] ) where
examples/ExampleFeatures1.hs view
@@ -10,24 +10,32 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE DataKinds #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-} module ExampleFeatures1 ( exampleFeatures1Spec ) where +import Cohort ( AssessmentInterval ) import Control.Monad import ExampleEvents+import Features ( HasAttributes ) import Hasklepias+import Hasklepias ( IntervalSizeable )+import Hasklepias.ReexportsUnsafe ( ToJSON ) import Test.Hspec {- Index is defined as the first occurrence of an Orca bite. -} indexDef- :: (Ord a) => Definition (FeatureData (Events a) -> FeatureData (Interval a))+ :: (Ord a)+ => Definition+ (Feature "events" (Events a) -> Feature "index" (Index Interval a)) indexDef = defineA (\events -> case firstConceptOccurrence ["wasBitByOrca"] events of- Nothing -> featureDataL (Other "No occurrence of Orca bite")- Just x -> pure (getInterval x)+ Nothing -> makeFeature $ featureDataL (Other "No occurrence of Orca bite")+ Just x -> pure (makeIndex $ getInterval x) ) {- @@ -36,70 +44,76 @@ as an argument, so that the baseline FeatureData can be used to filter events based on different predicate functions. -}-bline- :: (IntervalSizeable a b)- => FeatureData (Events a)- -> FeatureData (Interval a)-bline x = fmap (enderval 60 . begin) (eval indexDef x)+bline :: (IntervalSizeable a b) => Index Interval a -> AssessmentInterval a+bline = makeBaselineFromIndex 60 -flwup- :: (IntervalSizeable a b)- => FeatureData (Events a)- -> FeatureData (Interval a)-flwup x = fmap (beginerval 30 . begin) (eval indexDef x)+flwup :: (IntervalSizeable a b) => Index Interval a -> AssessmentInterval a+flwup = makeFollowupFromIndex 30 {--Define enrolled as the indicator of whether all of the gaps between the union of -all enrollment intervals (+ allowableGap) --}-enrolled :: (IntervalSizeable a b) => b -> Interval a -> Events a -> Bool-enrolled allowableGap i events =- events- |> makeConceptsFilter ["enrollment"]- |> combineIntervals- |> gapsWithin i- |> maybe False (all (< allowableGap) . durations)--enrolledDef- :: IntervalSizeable a b- => b- -> Definition- ( FeatureData (Interval a)- -> FeatureData (Events a)- -> FeatureData Bool- )-enrolledDef allowableGap = define (enrolled allowableGap)-{- Define features that identify whether a subject as bit/struck by a duck and bit/struck by a macaw. -}-makeHxDef- :: (Ord a) => [Text] -> Interval a -> Events a -> (Bool, Maybe (Interval a))-makeHxDef cnpts i events =+makeHx+ :: (Ord a)+ => [Text]+ -> AssessmentInterval a+ -> Events a+ -> (Bool, Maybe (Interval a))+makeHx cnpts i events = (isNotEmpty (f i events), lastMay $ intervals (f i events)) where f i x = makePairedFilter enclose i (`hasConcepts` cnpts) x -duckHxDef :: (Ord a) => Interval a -> Events a -> (Bool, Maybe (Interval a))-duckHxDef = makeHxDef ["wasBitByDuck", "wasStruckByDuck"]+duckHx+ :: (Ord a) => AssessmentInterval a -> Events a -> (Bool, Maybe (Interval a))+duckHx = makeHx ["wasBitByDuck", "wasStruckByDuck"] -macawHxDef :: (Ord a) => Interval a -> Events a -> (Bool, Maybe (Interval a))-macawHxDef = makeHxDef ["wasBitByMacaw", "wasStruckByMacaw"]+duckHxDef+ :: (Ord a)+ => Definition+ ( Feature "index" (AssessmentInterval a)+ -> Feature "events" (Events a)+ -> Feature "duck history" (Bool, Maybe (Interval a))+ )+duckHxDef = define duckHx +macawHx+ :: (Ord a) => AssessmentInterval a -> Events a -> (Bool, Maybe (Interval a))+macawHx = makeHx ["wasBitByMacaw", "wasStruckByMacaw"]++macawHxDef+ :: (Ord a)+ => Definition+ ( Feature "index" (AssessmentInterval a)+ -> Feature "events" (Events a)+ -> Feature "macaw history" (Bool, Maybe (Interval a))+ )+macawHxDef = define macawHx+ -- | a helper function for 'twoMinorOrOneMajorDef' twoXOrOneY :: [Text] -> [Text] -> Events a -> Bool twoXOrOneY x y es = atleastNofX 2 x es || atleastNofX 1 y es -- | Define an event that identifies whether the subject has two minor or one major -- surgery.-twoMinorOrOneMajorDef :: (Ord a) => Interval a -> Events a -> Bool-twoMinorOrOneMajorDef i events =+twoMinorOrOneMajor :: (Ord a) => AssessmentInterval a -> Events a -> Bool+twoMinorOrOneMajor i events = twoXOrOneY ["hadMinorSurgery"] ["hadMajorSurgery"] (filterEnclose i events) +twoMinorOrOneMajorDef+ :: (Ord a)+ => Definition+ ( Feature "index" (AssessmentInterval a)+ -> Feature "events" (Events a)+ -> Feature "two major or one minor" Bool+ )+twoMinorOrOneMajorDef = define twoMinorOrOneMajor+ -- | Time from end of baseline to end of most recent Antibiotics -- with 5 day grace period-timeSinceLastAntibioticsDef- :: (IntervalSizeable a b) => Interval a -> Events a -> Maybe b-timeSinceLastAntibioticsDef i =+timeSinceLastAntibiotics+ :: (IntervalSizeable a b) => AssessmentInterval a -> Events a -> Maybe b+timeSinceLastAntibiotics i = lastMay -- want the last one . map (max 0 . diff (end i) . end) -- distances between end of baseline and antibiotic intervals . filterNotDisjoint i -- filter to intervals not disjoint from baseline interval@@ -107,25 +121,47 @@ . map (expandr 5) -- allow grace period . makeConceptsFilter ["tookAntibiotics"] -- filter to only antibiotics events +timeSinceLastAntibioticsDef+ :: (IntervalSizeable a b)+ => Definition+ ( Feature "index" (AssessmentInterval a)+ -> Feature "events" (Events a)+ -> Feature "time since antibiotics" (Maybe b)+ )+timeSinceLastAntibioticsDef = define timeSinceLastAntibiotics++ -- | Count of hospital events in a interval and duration of the last one-countOfHospitalEventsDef- :: (IntervalSizeable a b) => Interval a -> Events a -> (Int, Maybe b)-countOfHospitalEventsDef i =+countOfHospitalEvents+ :: (IntervalSizeable a b)+ => AssessmentInterval a+ -> Events a+ -> (Int, Maybe b)+countOfHospitalEvents i = (\x -> (length x, duration <$> lastMay x)) . filterNotDisjoint i -- filter to intervals not disjoint from interval . combineIntervals -- combine overlapping intervals . makeConceptsFilter ["wasHospitalized"] -- filter to only antibiotics events +countOfHospitalEventsDef+ :: (IntervalSizeable a b)+ => Definition+ ( Feature "index" (AssessmentInterval a)+ -> Feature "events" (Events a)+ -> Feature "count of hospitalizations" (Int, Maybe b)+ )+countOfHospitalEventsDef = define countOfHospitalEvents+ -- | time of distcontinuation of antibiotics -- and time from start of follow up -- This needs to be generalized as Nothing could either indicate they didn't -- discontinue or that they simply got no antibiotics records.-so :: Ord a => ComparativePredicateOf1 (Interval a)+so :: Intervallic i a => ComparativePredicateOf1 (i a) so = unionPredicates [startedBy, overlappedBy] -discontinuationDef- :: (IntervalSizeable a b) => Interval a -> Events a -> Maybe (a, b)-discontinuationDef i events =+discontinuation+ :: (IntervalSizeable a b) => AssessmentInterval a -> Events a -> Maybe (a, b)+discontinuation i events = (\x -> Just ( begin x -- we want the begin of this interval , diff (begin x) (begin i)@@ -133,7 +169,7 @@ ) =<< headMay -- if there are any gaps the first one is the first discontinuation =<< gapsWithin i -- find gaps to intervals clipped to i- =<< ( nothingIfNone (so i) -- if none of the intervals start or overlap + =<< ( nothingIfNone (so (getInterval i)) -- if none of the intervals start or overlap -- the followup, then never started antibiotics . combineIntervals -- combine overlapping intervals . map (expandr 5) -- allow grace period@@ -142,31 +178,50 @@ ) events +discontinuationDef+ :: (IntervalSizeable a b)+ => Definition+ ( Feature "index" (AssessmentInterval a)+ -> Feature "events" (Events a)+ -> Feature "discontinuation" (Maybe (a, b))+ )+discontinuationDef = define discontinuation++{-+ Tests+-}+ type MyData- = ( FeatureData (Interval Int)- , FeatureData Bool- , FeatureData (Bool, Maybe (Interval Int))- , FeatureData (Bool, Maybe (Interval Int))- , FeatureData Bool- , FeatureData (Maybe Int)- , FeatureData (Int, Maybe Int)- , FeatureData (Maybe (Int, Int))+ = ( Feature "index" (Index Interval Int)+ , Feature "enrolled" Status+ , Feature "duck history" (Bool, Maybe (Interval Int))+ , Feature "macaw history" (Bool, Maybe (Interval Int))+ , Feature "two major or one minor" Bool+ , Feature "time since antibiotics" (Maybe Int)+ , Feature "count of hospitalizations" (Int, Maybe Int)+ , Feature "discontinuation" (Maybe (Int, Int)) ) getUnitFeatures :: Events Int -> MyData getUnitFeatures x =- ( eval indexDef evs- , eval (enrolledDef 8) (bline evs, evs)- -- TODO: feature functions below need to be put into a FeatureDefintion- -- in order to run eval- , liftA2 duckHxDef (bline evs) evs- , liftA2 macawHxDef (bline evs) evs- , liftA2 twoMinorOrOneMajorDef (bline evs) evs- , liftA2 timeSinceLastAntibioticsDef (bline evs) evs- , liftA2 countOfHospitalEventsDef (bline evs) evs- , liftA2 discontinuationDef (flwup evs) evs+ ( idx+ , eval+ (buildContinuousEnrollment bline (containsConcepts ["enrollment"]) 60)+ idx+ evs+ (pure Include)+ , eval duckHxDef bl evs+ , eval macawHxDef bl evs+ , eval twoMinorOrOneMajorDef bl evs+ , eval timeSinceLastAntibioticsDef bl evs+ , eval countOfHospitalEventsDef bl evs+ , eval discontinuationDef fl evs )- where evs = pure x+ where+ evs = pure x+ idx = eval indexDef evs+ bl = fmap bline idx+ fl = fmap flwup idx includeAll :: Events Int -> Criteria@@ -179,8 +234,8 @@ example1results :: MyData example1results =- ( pure (beginerval 1 (60 :: Int))- , pure True+ ( pure $ makeIndex (beginerval 1 (60 :: Int))+ , pure Include , pure (True, Just $ beginerval 1 (51 :: Int)) , pure (False, Nothing) , pure True@@ -191,14 +246,14 @@ example2results :: MyData example2results =- ( featureDataL (Other "No occurrence of Orca bite")- , featureDataL (Other "No occurrence of Orca bite")- , featureDataL (Other "No occurrence of Orca bite")- , featureDataL (Other "No occurrence of Orca bite")- , featureDataL (Other "No occurrence of Orca bite")- , featureDataL (Other "No occurrence of Orca bite")- , featureDataL (Other "No occurrence of Orca bite")- , featureDataL (Other "No occurrence of Orca bite")+ ( makeFeature $ featureDataL (Other "No occurrence of Orca bite")+ , makeFeature $ featureDataL (Other "No occurrence of Orca bite")+ , makeFeature $ featureDataL (Other "No occurrence of Orca bite")+ , makeFeature $ featureDataL (Other "No occurrence of Orca bite")+ , makeFeature $ featureDataL (Other "No occurrence of Orca bite")+ , makeFeature $ featureDataL (Other "No occurrence of Orca bite")+ , makeFeature $ featureDataL (Other "No occurrence of Orca bite")+ , makeFeature $ featureDataL (Other "No occurrence of Orca bite") ) exampleFeatures1Spec :: Spec
examples/ExampleFeatures2.hs view
@@ -17,8 +17,8 @@ import Hasklepias import Test.Hspec -durationOfHospitalizedAntibiotics ::- (Show a, IntervalSizeable a b) => Events a -> FeatureData [b]+durationOfHospitalizedAntibiotics+ :: (Show a, IntervalSizeable a b) => Events a -> FeatureData [b] durationOfHospitalizedAntibiotics es | null y = featureDataL $ Other "no cases" | otherwise = pure $ durations y where
examples/ExampleFeatures4.hs view
@@ -460,7 +460,7 @@ :: (Integral b, IntervalSizeable a b) => [Event a] -> Feature "pcskProtocols" (Protocols b)-testProtocols input = eval pcskProtocols (idx, pcev)+testProtocols input = eval pcskProtocols idx pcev where evs = pure input idx = eval index evs@@ -512,16 +512,16 @@ , Feature "accident" (NegOutcomes b) ) testOutcomes input =- (eval o1 (idx, flevs, prot, ctime), eval o2 (idx, flevs, prot, ctime))+ (eval o1 idx flevs prot ctime, eval o2 idx flevs prot ctime) where evs = pure input idx = eval index evs- flevs = eval flupEvents (idx, evs)+ flevs = eval flupEvents idx evs pcev = eval pcskEvents evs dth = eval death flevs- disen = eval disenrollment (idx, evs)- prot = eval pcskProtocols (idx, pcev)- ctime = eval censorTime (dth, disen)+ disen = eval disenrollment idx evs+ prot = eval pcskProtocols idx pcev+ ctime = eval censorTime dth disen p1Outcomes :: (Integral b)
hasklepias.cabal view
@@ -1,6 +1,6 @@ cabal-version: 2.2 name: hasklepias-version: 0.17.1+version: 0.18.0 description: Please see the README on GitHub at <https://github.com/novisci/asclepias#readme> homepage: https://github.com/novisci/asclepias/#readme bug-reports: https://github.com/novisci/asclepias/issues
src/Cohort/Criteria.hs view
@@ -50,7 +50,7 @@ -- | Defines the return type for @'Criterion'@ indicating whether to include or -- exclude a subject.-data Status = Include | Exclude deriving (Eq, Show)+data Status = Include | Exclude deriving (Eq, Show, Generic) -- | Defines subject's diposition in a cohort either included or which criterion -- they were excluded by. See @'checkCohortStatus'@ for evaluating a @'Criteria'@
src/EventData.hs view
@@ -10,7 +10,7 @@ {-# LANGUAGE NoImplicitPrelude #-} module EventData- ( -- * Events+ ( -- ** Event Core module EventData.Core -- ** Event Contexts , module EventData.Context@@ -24,6 +24,8 @@ , module EventData.Aeson -- ** Generating arbitrary events , module EventData.Arbitrary++ ) where import EventData.Aeson@@ -33,4 +35,5 @@ import EventData.Core import EventData.Predicates import EventData.Accessors+
src/Features/Compose.hs view
@@ -12,18 +12,11 @@ {-# LANGUAGE Safe #-} {-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE DeriveGeneric #-}-{-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE DataKinds #-} {-# LANGUAGE TypeApplications #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE FunctionalDependencies #-}-{-# LANGUAGE AllowAmbiguousTypes #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE ExistentialQuantification #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE InstanceSigs #-} module Features.Compose (@@ -49,7 +42,7 @@ , DefineA(..) --- *** Evalution of Definitions- , Eval(..)+ , eval ) where @@ -277,16 +270,37 @@ See @'eval'@ for evaluating @Defintions@. -}-data Definition d where- D1 ::(b -> a) -> Definition (f1 b -> f0 a)- D1A ::(b -> f0 a) -> Definition (f1 b -> f0 a)- D2 ::(c -> b -> a) -> Definition (f2 c -> f1 b -> f0 a)- D2A ::(c -> b -> f0 a) -> Definition (f2 c -> f1 b -> f0 a)- D3 ::(d -> c -> b -> a) -> Definition (f3 d -> f2 c -> f1 b -> f0 a)- D3A ::(d -> c -> b -> f0 a) -> Definition (f3 d -> f2 c -> f1 b -> f0 a)- D4 ::(e -> d -> c -> b -> a) -> Definition (f4 e -> f3 d -> f2 c -> f1 b -> f0 a)- D4A ::(e -> d -> c -> b -> f0 a) -> Definition (f4 e -> f3 d -> f2 c -> f1 b -> f0 a) +type F n d = Feature n d+data Definition d where+ Pure :: a -> Definition (F n0 a )+ D1 :: (b -> a) -> Definition (F n1 b -> F n0 a)+ D1A :: (b -> F n0 a) -> Definition (F n1 b -> F n0 a)+ D1C :: (a2 -> a1 -> a) + -> Definition (F n1 b -> F n02 a2)+ -> Definition (F n1 b -> F n01 a1)+ -> Definition (F n1 b -> F n0 a )+ D2 :: (c -> b -> a) -> Definition (F n2 c -> F n1 b -> F n0 a)+ D2A :: (c -> b -> F n0 a) -> Definition (F n2 c -> F n1 b -> F n0 a)+ D2C :: (a2 -> a1 -> a) + -> Definition (F n2 c -> F n1 b -> F n02 a2)+ -> Definition (F n2 c -> F n1 b -> F n01 a1)+ -> Definition (F n2 c -> F n1 b -> F n0 a ) + D3 :: (d -> c -> b -> a) -> Definition (F n3 d -> F n2 c -> F n1 b -> F n0 a)+ D3A :: (d -> c -> b -> F n0 a) -> Definition (F n3 d -> F n2 c -> F n1 b -> F n0 a) + D3C :: (a2 -> a1 -> a) + -> Definition (F n3 d -> F n2 c -> F n1 b -> F n02 a2)+ -> Definition (F n3 d -> F n2 c -> F n1 b -> F n01 a1)+ -> Definition (F n3 d -> F n2 c -> F n1 b -> F n0 a ) + D4 :: (e -> d -> c -> b -> a) + -> Definition (F n4 e -> F n3 d -> F n2 c -> F n1 b -> F n0 a)+ D4A :: (e -> d -> c -> b -> F n0 a) + -> Definition (F n4 e -> F n3 d -> F n2 c -> F n1 b -> F n0 a)+ D4C :: (a2 -> a1 -> a) + -> Definition (F n4 e -> F n3 d -> F n2 c -> F n1 b -> F n02 a2)+ -> Definition (F n4 e -> F n3 d -> F n2 c -> F n1 b -> F n01 a1)+ -> Definition (F n4 e -> F n3 d -> F n2 c -> F n1 b -> F n0 a ) + {- | Define (and @'DefineA@) provide a means to create new @'Definition'@s via @'define'@ (@'defineA'@). The @'define'@ function takes a single function input and returns a lifted function. For example,@@ -320,28 +334,8 @@ class Define inputs def | def -> inputs where define :: inputs -> Definition def --- | See @'Define'@.-class DefineA inputs def | def -> inputs where- defineA :: inputs -> Definition def--instance Define (b -> a) (FeatureData b -> FeatureData a) where- define = D1-instance Define (c -> b -> a) (FeatureData c -> FeatureData b -> FeatureData a) where- define = D2-instance Define (d -> c -> b -> a) (FeatureData d -> FeatureData c -> FeatureData b -> FeatureData a) where- define = D3-instance Define (e -> d -> c -> b -> a) (FeatureData e -> FeatureData d -> FeatureData c -> FeatureData b -> FeatureData a) where- define = D4--instance DefineA (b -> FeatureData a) (FeatureData b -> FeatureData a) where- defineA = D1A-instance DefineA (c -> b -> FeatureData a) (FeatureData c -> FeatureData b -> FeatureData a) where- defineA = D2A-instance DefineA (d -> c -> b -> FeatureData a) (FeatureData d -> FeatureData c -> FeatureData b -> FeatureData a) where- defineA = D3A-instance DefineA (e -> d -> c -> b -> FeatureData a) (FeatureData e -> FeatureData d -> FeatureData c -> FeatureData b -> FeatureData a) where- defineA = D4A-+instance Define a (Feature n0 a) where+ define = Pure instance Define (b -> a) (Feature n1 b -> Feature n0 a) where define = D1 instance Define (c -> b -> a) (Feature n2 c -> Feature n1 b -> Feature n0 a) where@@ -351,6 +345,10 @@ instance Define (e -> d -> c -> b -> a) (Feature n4 e -> Feature n3 d -> Feature n2 c -> Feature n1 b -> Feature n0 a) where define = D4 +-- | See @'Define'@.+class DefineA inputs def | def -> inputs where+ defineA :: inputs -> Definition def+ instance DefineA (b -> Feature n0 a) (Feature n1 b -> Feature n0 a) where defineA = D1A instance DefineA (c -> b -> Feature n0 a) (Feature n2 c -> Feature n1 b -> Feature n0 a) where@@ -360,7 +358,6 @@ instance DefineA (e -> d -> c -> b -> Feature n0 a) (Feature n4 e -> Feature n3 d -> Feature n2 c -> Feature n1 b -> Feature n0 a) where defineA = D4A - {- | Evaluate a @Definition@. Note that (currently), the second argument of 'eval' is a *tuple* of inputs. For example, @@ -379,73 +376,37 @@ b :: Feature "B" String b = pure "yes" -c = eval myFeature (a, b)+c = eval myFeature a b @ -}-class Eval def args return | def -> args return where- eval :: Definition def -- ^ a @'Definition'@- -> args -- ^ a tuple of arguments to the @'Definition'@- -> return -instance Eval (FeatureData b -> FeatureData a)- (FeatureData b) (FeatureData a) where- eval (D1 f) x = fmap f x- eval (D1A f) x = x >>= f--instance Eval (Feature n1 b -> Feature n0 a)- (Feature n1 b) (Feature n0 a) where- eval (D1 f) (MkFeature x) = MkFeature $ fmap f x- eval (D1A f) (MkFeature x) = case fmap f x of- MkFeatureData (Left l) -> MkFeature $ MkFeatureData (Left l)- MkFeatureData (Right r) -> r---instance Eval (FeatureData c -> FeatureData b -> FeatureData a)- (FeatureData c, FeatureData b) (FeatureData a) where- eval (D2 f) (x, y) = liftA2 f x y- eval (D2A f) (x, y) = join (liftA2 f x y)--instance Eval (Feature n2 c -> Feature n1 b -> Feature n0 a)- (Feature n2 c, Feature n1 b) (Feature n0 a)- where- eval (D2 f) (MkFeature x, MkFeature y) = MkFeature $ liftA2 f x y- eval (D2A f) (MkFeature x, MkFeature y) = case liftA2 f x y of- MkFeatureData (Left l) -> MkFeature $ MkFeatureData (Left l)- MkFeatureData (Right r) -> r--instance Eval (FeatureData d -> FeatureData c -> FeatureData b -> FeatureData a)- (FeatureData d, FeatureData c, FeatureData b) (FeatureData a)- where- eval (D3 f) (x, y, z) = liftA3 f x y z- eval (D3A f) (x, y, z) = join (liftA3 f x y z)--instance Eval (Feature n3 d -> Feature n2 c -> Feature n1 b -> Feature n0 a)- (Feature n3 d, Feature n2 c, Feature n1 b) (Feature n0 a)- where- eval (D3 f) (MkFeature x, MkFeature y, MkFeature z) =+eval :: Definition d -> d+eval d = case d of+ Pure x -> pure x+ D1 f -> \(MkFeature x) -> MkFeature $ fmap f x+ D1A f -> \(MkFeature x) -> + case fmap f x of+ MkFeatureData (Left l) -> MkFeature $ MkFeatureData (Left l)+ MkFeatureData (Right r) -> r+ D1C f d1 d2 -> \x -> MkFeature $ liftA2 f (getFData (eval d1 x)) (getFData (eval d2 x))+ D2 f -> \(MkFeature x) (MkFeature y) -> MkFeature $ liftA2 f x y+ D2A f -> \(MkFeature x) (MkFeature y) -> + case liftA2 f x y of+ MkFeatureData (Left l) -> MkFeature $ MkFeatureData (Left l)+ MkFeatureData (Right r) -> r+ D2C f d1 d2 -> \x y -> MkFeature $ liftA2 f (getFData (eval d1 x y)) (getFData (eval d2 x y))+ D3 f -> \(MkFeature x) (MkFeature y) (MkFeature z) -> MkFeature $ liftA3 f x y z- eval (D3A f) (MkFeature x, MkFeature y, MkFeature z) = case liftA3 f x y z of- MkFeatureData (Left l) -> MkFeature $ MkFeatureData (Left l)- MkFeatureData (Right r) -> r--instance Eval (Feature n4 e -> Feature n3 d -> Feature n2 c -> Feature n1 b -> Feature n0 a)- (Feature n4 e, Feature n3 d, Feature n2 c, Feature n1 b) (Feature n0 a)- where- eval (D4 f) (MkFeature v, MkFeature x, MkFeature y, MkFeature z) =+ D3A f -> \(MkFeature x) (MkFeature y) (MkFeature z) -> + case liftA3 f x y z of+ MkFeatureData (Left l) -> MkFeature $ MkFeatureData (Left l)+ MkFeatureData (Right r) -> r+ D3C f d1 d2 -> \x y z -> MkFeature $ liftA2 f (getFData $ eval d1 x y z) (getFData $ eval d2 x y z)+ D4 f -> \(MkFeature v) (MkFeature x) (MkFeature y) (MkFeature z) -> MkFeature $ liftM4 f v x y z- eval (D4A f) (MkFeature v, MkFeature x, MkFeature y, MkFeature z) =- case liftM4 f v x y z of- MkFeatureData (Left l) -> MkFeature $ MkFeatureData (Left l)- MkFeatureData (Right r) -> r--{- | Initializes @Feature@ @Attributes@ to empty strings -}---- class HasAttributes n a where--- getAttributes :: Feature n a -> Attributes--- getAttributes _ = MkAttributes "" "" ""---- instance (KnownSymbol n) => HasAttributes n a where- -- getAttributes :: Feature n a -> Attributes- -- getAttributes _ = MkAttributes "" "" ""-+ D4A f -> \(MkFeature v) (MkFeature x) (MkFeature y) (MkFeature z) ->+ case liftM4 f v x y z of+ MkFeatureData (Left l) -> MkFeature $ MkFeatureData (Left l)+ MkFeatureData (Right r) -> r+ D4C f d1 d2 -> \v x y z -> MkFeature $ liftA2 f (getFData $ eval d1 v x y z) (getFData $ eval d2 v x y z)
src/Hasklepias.hs view
@@ -6,13 +6,21 @@ License : BSD3 Maintainer : bsaul@novisci.com -See the examples folder and manual for further documentation. -} module Hasklepias- ( module EventData+ ( -- $about + -- * Event Data+ {-|+ Events depend heavily on the [interval-algebra library](https://hackage.haskell.org/package/interval-algebra). + See that pacakge's documentation for information about the types and functions + for working with intervals.+ -}+ module EventData+ -- * Working with Features+ -- $features , module Features -- * Feature definition builders @@ -47,11 +55,10 @@ , module Hasklepias.ReexportsUnsafe ) where ++ import EventData -import IntervalAlgebra-import IntervalAlgebra.IntervalUtilities-import IntervalAlgebra.PairedInterval import Features @@ -65,3 +72,222 @@ import Hasklepias.Templates import Stype++{- $about++@Hasklepias@ is an embedded domain specific language (eDSL) written in [Haskell](https://www.haskell.org/).+To get started, then, you'll need to install the Haskell toolchain, especially +the [Glasgow Haskell Compiler](https://www.haskell.org/ghc/) (GHC) and the building+and packaging system [cabal](https://www.haskell.org/cabal), for which you can+use the [@ghcup@ utility](https://www.haskell.org/ghcup).++You can use any development environment you choose, but for maximum coding pleasure,+you should install the [Haskell language server](https://github.com/haskell/haskell-language-server)+(@hsl@). This can be installed using @ghcup@. Some integrated development+environments, such as [Visual Studio Code](https://code.visualstudio.com/, have +[excellent @hsl@ integration](https://marketplace.visualstudio.com/items?itemName=haskell.haskell).++In summary,++* Install [@ghcup@](https://www.haskell.org/ghcup).++@ + curl --proto '=https' --tlsv1.2 -sSf https://get-ghcup.haskell.org | sh+@+* Inspect your toolchain installation using @ghcup list@. You will need @ghc@ +(>= 8.10.4) , @hls@ (>= 1.2), and @cabal@ (>= 3.4) installed.+* Upgrade toolchain components as necesarry. For example:++@+ ghcup install ghc {ghcVersion}+ ghcup set ghc {ghcVersion}+ ghcup install cabal {cabalVersion}+ ghcup set cabal {cabalVersion} +@++* Setup your IDE. (e.g. in Visual Studio, you'll want to install the [Haskell](https://marketplace.visualstudio.com/items?itemName=haskell.haskell) extension.++=== Getting started in Haskell++Since @Hasklepias@ is written in [Haskell](https://www.haskell.org/), you'll need +to understand the syntax of Haskell function and a few concepts. The Haskell +language is over 30 years old and has many, many features. Here are a few resources:++* [Learn You a Haskell for Great Good!](http://learnyouahaskell.com/chapters): good intro text+* [Programming in Haskell](https://www.cs.nott.ac.uk/~pszgmh/pih.html): excellent intro text+* [What I wish I knew when learning Haskell](http://dev.stephendiehl.com/hask/): excellent resource+* [Haskeller competency matrix](https://gist.github.com/graninas/833a9ff306338aefec7e543100c16ea1)+* [Hoogle](https://hoogle.haskell.org/): search engine for Haskell functions+* [5 years of Haskell in production](https://www.youtube.com/watch?v=hZgW4mT1PkE[): video on using Haskell in production environment+* [Things software engineers trip up on when learning Haskell](https://williamyaoh.com/posts/2020-04-12-software-engineer-hangups.html): a software engineer's list of tips on using Haskell++=== Interacting with the examples (using GHCi)++To run the examples interactively, open a @ghci@ session with:++@+cabal repl hasklepias:examples +@++In @ghci@ you have access to all exposed functions in @hasklepias@, @interval-algebra@, +and those in the [examples](https://github.com/novisci/asclepias/tree/master/examples) folder.++-}++{- $features++A 'Feature' is a type parametrized by two types: @name@ and @d@. The type @d@ here+stands for "data", which then parametrizes the 'FeatureData' type which is the +singular value which a 'Feature' contains. The @d@ here can be almost anything+and need not be a scalar, for example, all the following are valid types for @d@:++* 'Int'+* 'Text'+* @(Int, Maybe Text)@ +* @[Double]@++The @name@ type a bit special: it does not appear on the right-hand side of the `=`. +In type-theory parlance, @name@ is a [phantom type](https://wiki.haskell.org/Phantom_type). +We'll see in a bit how this can be useful. For now, think of the @name@ as the+name of a variable as you would in most programming languages. To summarize, +a `Feature` 's type constructor takes two arguments (@name@ and @d@), but its+*value* constructor (@MkFeature@) takes a single value of type @FeatureData d@.++Values of the 'FeatureData' type contain the data we're ultimately interested +in analyzing or passing along to downstream applications. However, a 'FeatureData'+value does not simply contain data of type @d@. The type allows for the possibility+of missingness, failures, or errors by using the 'Data.Either.Either' type. A value+of a 'FeatureData', then, is either a @'Data.Either.Left' 'MissingReason'@ or a+@'Data.Either.Right' d@.++The use of @Either@ has important implications when defining Features, as we will see. +Now that we know the internals of a 'Feature', how do we create 'Feature' s? There+are two ways to create features: (1) 'pure'ly lifting data into a 'Feature' or+(2) writing a 'Definition': a function that 'define's a 'Feature' based on other +'Feature's. ++The first method is a way to get data directly into a 'Feature'. Fhe following+function takes a list of 'Events' and makes a 'Feature' of them:++@+allEvents :: [Event Day] -> Feature "allEvents" [Event Day]+allEvents = pure+@++The 'pure' lifting is generally used to lift a subject's input data into a 'Feature',+so that other features can be defined from a subject's data. 'Feature' s are+derived from other 'Feature's by the 'Definition' type. Specifically, +'Definition' is a type which contains a function which maps 'Feature' inputs+to a 'Feature' output, for example:++@+myDef :: Definition (Feature "a" Int -> Feature "b" Bool)+myDef = define (\x -> if x > 0 then True else False)+@++A 'Definition' is created by the 'define' (or 'defineA') function. One may ask+why 'define' is necessary, and we don't directly define the function +(@Feature "a" Int -> Feature "b" Bool@) directly. What may not be obvious in +the above, is that @x@ is type @Int@ not @Feature "a" Int@ and the return type +is @Bool@ not @Feature "b" Bool@. The 'define' function and 'Definition' type+do the magic of lifting these types to the 'Feature' level. To see this, +in the following, @myDef2@ is equivalent to @myDef@: ++@+intToBool :: Int -> Bool+intToBool x = if x > 0 then True else False)++myDef2 :: Definition (Feature "a" Int -> Feature "b" Bool)+myDef2 = define intToBoo+@++The 'define' function, then, let's us focus on the *logic* of our 'Feature's +without needing to worry handling the error cases. If we were to write a function+with signature @Feature "a" Int -> Feature "b" Bool@ directly, it would look+something like:++@+myFeat :: Feature "a" Int -> Feature "b" Bool+myFeat (MkFeature (MkFeatureData (Left r))) = MkFeature (MkFeatureData (Left r))+myFeat (MkFeature (MkFeatureData (Right x))) = MkFeature (MkFeatureData (Right $ intToBool x))+@++One would need to pattern match all the possible types of inputs, which gets+more complicated as the number of inputs increases. As an aside, since @Feature@s are+[Functors]( https://hackage.haskell.org/package/base-4.15.0.0/docs/Data-Functor.html),+one could instead write:++@+myFeat :: Feature "a" Int -> Feature "b" Bool+myFeat = fmap intToBool+@++This would require understanding how Functors and similar structures are used.+The 'define' and 'defineA' functions provide a common interface to these structures+without needing to understand the details.++== Evaluating Definitions++To evaluate a 'Definition', we use the 'eval' function. Consider the following example.+The input data is a list of 'Int's if the list is empty ('null'), this is considered+an error in @feat1@. If the list has more than 3 elements, then in @feat2@, +the sum is computed; otherwise @0@ is returned.++@+featInts :: [Int] -> Feature "someInts" [Int]+featInts = pure++feat1 :: Definition (Feature "someInts" [Int] -> Feature "hasMoreThan3" Bool)+feat1 = defineA+ (\ints -> if null ints then makeFeature (missingBecause $ Other "no data")+ else makeFeature $ featureDataR (length ints > 3))++feat2 :: Definition (+ Feature "hasMoreThan3" Bool+ -> Feature "someInts" [Int]+ -> Feature "sum" Int)+feat2 = define (\b ints -> if b then sum ints else 0)++ex0 = featInts []+ex0a = eval feat1 ex0 -- MkFeature (MkFeatureData (Left (Other "no data")))+ex0b = eval feat2 (ex0a, ex0) -- MkFeature (MkFeatureData (Left (Other "no data")))++ex1 = featInts [3, 8]+ex1a = eval feat1 ex1 -- MkFeature (MkFeatureData (Right False))+ex1b = eval feat2 (ex1a, ex1) -- MkFeature (MkFeatureData (Right 0))++ex2 = featInts [1..4]+ex2a = eval feat1 ex2 -- MkFeature (MkFeatureData (Right True))+ex2b = eval feat2 (ex2a, ex2) -- MkFeature (MkFeatureData (Right 10))+@++Note the value of @ex0b@. It is a 'Left' because the value of @ex0a@ is a 'Left';+in other words, errors propogate along 'Feature's. If a given @Feature@'s dependency +is a 'Left' then that 'Feature' will also be 'Left'. A @Feature@'s internal+'Either' structure has important implications for designing 'Feature's and+performance. Capturing an error in a 'Left' is a way to prevent downstream+dependencies from needing to be computed.++== Type Safety of Features++In describing the 'Feature' type, the utility of having the name as a type may+not have been clear. To clarify, consider the following example:++@+x :: Feature "someInt" Natural+x = pure 39++y :: Feature "age" Natural+y = pure 43++f :: Definition (Feature "age" Natural -> Feature "isOld" Bool)+f = define (>= 39)++fail = eval f x +pass = eval f y+@ ++In the example, @fail@ does not compile because @"someInt"@ is not @"age"@, +even though both the data type are @Natural@.++-}
src/Hasklepias/Reexports.hs view
@@ -137,16 +137,15 @@ import safe Data.Text ( pack, Text ) import safe Data.Tuple ( fst, snd, uncurry, curry ) import safe Data.Tuple.Curry ( curryN, uncurryN )-import safe IntervalAlgebra-import safe IntervalAlgebra.IntervalUtilities-import safe IntervalAlgebra.PairedInterval import safe Witherable ( Filterable(filter), Witherable(..) ) import safe Flow ( (!>), (.>), (<!), (<.), (<|), (|>) ) import Safe ( headMay, lastMay )--- import Data.Vector.Fusion.Bundle (scanl1)--- import Data.Map (fromList)--- import qualified Data.Map as Set+++import safe IntervalAlgebra+import safe IntervalAlgebra.IntervalUtilities+import safe IntervalAlgebra.PairedInterval setFromList :: (Ord a) => [a] -> Set.Set a setFromList = Set.fromList
src/Hasklepias/Templates/Features.hs view
@@ -26,4 +26,7 @@ , buildNofXWithGap , buildNofXWithGapBool , buildNofXWithGapBinary- , buildNofUniqueBegins)+ , buildNofUniqueBegins+ , buildNofXOrNofYWithGap+ , buildNofXOrNofYWithGapBool+ , buildNofXOrNofYWithGapBinary )
src/Hasklepias/Templates/Features/Enrollment.hs view
@@ -104,7 +104,7 @@ "Tests of isEnrolled template" (fmap (\x -> testCase (getTestName x)- (makeAssertion x (buildIsEnrolled (getBuilderArgs x)))+ (makeAssertion x (uncurryN $ eval (buildIsEnrolled (getBuilderArgs x)))) ) buildIsEnrolledTestCases )@@ -258,7 +258,7 @@ (getTestName x) (makeAssertion x- (buildContinuousEnrollment (makeBaselineFromIndex 10) isEnrollmentEvent 3)+ (uncurryN $ eval (buildContinuousEnrollment (makeBaselineFromIndex 10) isEnrollmentEvent 3)) ) ) buildContinuousEnrollmentTestCases
src/Hasklepias/Templates/Features/NsatisfyP.hs view
@@ -23,6 +23,9 @@ , buildNofXWithGapBool , buildNofXWithGapBinary , buildNofUniqueBegins+ , buildNofXOrNofYWithGap+ , buildNofXOrNofYWithGapBool+ , buildNofXOrNofYWithGapBinary ) where import Cohort@@ -39,7 +42,11 @@ -- | All the buildNSatisfyP tests. buildNsatisfyPTests :: TestTree buildNsatisfyPTests =- testGroup "NsatisfyP" [buildNofXTests, buildNofXWithGapTests, buildNofUniqueBeginsTests]+ testGroup "NsatisfyP" + [ buildNofXTests+ , buildNofXWithGapTests+ , buildNofXOrNofYWithGapTests+ , buildNofUniqueBeginsTests] {-| -}@@ -60,7 +67,7 @@ -> Feature eventsName (container0 (Event a)) -> Feature varName outputType )-buildNofXBase runProcess runPostProcess runCast makeAssessmentInterval relation predicate+buildNofXBase runPreProcess runProcess runPostProcess makeAssessmentInterval relation predicate = define (\index -> -- filter events to those satisfying both@@ -68,12 +75,12 @@ -- AND the given predicate filter (relation (makeAssessmentInterval index) &&& getPredicate predicate)+ -- run the preprocessing function+ .> runPreProcess -- run the processing function .> runProcess- -- run the post processing function- .> runPostProcess- -- run the casting function- .> runCast (makeAssessmentInterval index)+ -- run the postprocessing function+ .> runPostProcess (makeAssessmentInterval index) ) {-| Do N events relating to the 'AssessmentInterval' in some way the satisfy @@ -248,7 +255,7 @@ (fmap (\x -> testCase (getTestName x)- (makeAssertion x (uncurryN buildNofXBool (getBuilderArgs x)))+ (makeAssertion x (uncurryN $ eval (uncurryN buildNofXBool (getBuilderArgs x)))) ) buildNofXTestCases )@@ -472,15 +479,234 @@ (fmap (\x -> testCase (getTestName x)- (makeAssertion x (uncurryN buildNofXWithGapBool (getBuilderArgs x)))+ (makeAssertion x (uncurryN $ eval $ uncurryN buildNofXWithGapBool (getBuilderArgs x))) ) buildNofXWithGapTestCases ) +{-|+Is either 'buildNofX' or 'buildNofXWithGap' satisfied -{- -}+buildNofXOrNofYWithGap+ :: ( Intervallic i a+ , IntervalSizeable a b+ , IntervalCombinable i a+ , Witherable container+ )+ => (outputType -> outputType -> outputType) + -> (Bool -> outputType)+ -> Natural -- ^ count passed to 'buildNofX'+ -> Predicate (Event a)+ -> Natural -- ^ the minimum number of gaps passed to 'buildNofXWithGap'+ -> b -- ^ the minimum duration of a gap passed to 'buildNofXWithGap'+ -> (Index i a -> AssessmentInterval a)+ -> ComparativePredicateOf2 (AssessmentInterval a) (Event a)+ -> Predicate (Event a)+ -> Definition+ ( Feature indexName (Index i a)+ -> Feature eventsName (container (Event a))+ -> Feature varName outputType+ )+buildNofXOrNofYWithGap f cast xCount xPred gapCount gapDuration assess intervalPred yPred = + D2C f+ (buildNofX cast xCount assess intervalPred xPred)+ (buildNofXWithGap cast gapCount gapDuration assess intervalPred yPred) +-- | 'buildNofXOrNofYWithGap' specialized to return @Bool@. +buildNofXOrNofYWithGapBool+ :: ( Intervallic i a+ , IntervalSizeable a b+ , IntervalCombinable i a+ , Witherable container+ )+ => Natural -- ^ count passed to 'buildNofX'+ -> Predicate (Event a)+ -> Natural -- ^ the minimum number of gaps passed to 'buildNofXWithGap'+ -> b -- ^ the minimum duration of a gap passed to 'buildNofXWithGap'+ -> (Index i a -> AssessmentInterval a)+ -> ComparativePredicateOf2 (AssessmentInterval a) (Event a)+ -> Predicate (Event a)+ -> Definition+ ( Feature indexName (Index i a)+ -> Feature eventsName (container (Event a))+ -> Feature varName Bool+ )+buildNofXOrNofYWithGapBool = buildNofXOrNofYWithGap (||) id++-- | 'buildNofXOrNofYWithGap' specialized to return @Binary@. +buildNofXOrNofYWithGapBinary+ :: ( Intervallic i a+ , IntervalSizeable a b+ , IntervalCombinable i a+ , Witherable container+ )+ => Natural -- ^ count passed to 'buildNofX'+ -> Predicate (Event a)+ -> Natural -- ^ the minimum number of gaps passed to 'buildNofXWithGap'+ -> b -- ^ the minimum duration of a gap passed to 'buildNofXWithGap'+ -> (Index i a -> AssessmentInterval a)+ -> ComparativePredicateOf2 (AssessmentInterval a) (Event a)+ -> Predicate (Event a)+ -> Definition+ ( Feature indexName (Index i a)+ -> Feature eventsName (container (Event a))+ -> Feature varName Binary+ )+buildNofXOrNofYWithGapBinary = + buildNofXOrNofYWithGap (\x y -> fromBool $ (||) (toBool x) (toBool y) ) fromBool++type NofXOrNofYWithGapArgs+ = ( Natural+ , Predicate (Event Int)+ , Natural+ , Int+ , Index Interval Int -> AssessmentInterval Int+ , ComparativePredicateOf2 (AssessmentInterval Int) (Event Int)+ , Predicate (Event Int)+ )++type NofXOrNofYWithGapTestCase+ = TestCase+ (F "index" (Index Interval Int), F "events" [Event Int])+ Bool+ NofXOrNofYWithGapArgs++buildNofXOrNofYWithGapTestCases :: [NofXOrNofYWithGapTestCase]+buildNofXOrNofYWithGapTestCases =+ [ f "True if looking for no events and there are no events"+ (0, containsConcepts ["A"], 0, 3, makeBaselineFromIndex 10, concur, isEnrollmentEvent)+ (10, 11)+ []+ True+ {-+ - <- Index+ ---------- <- Baseline+ + |--------------|+ -}+ , f+ "True if looking for (at least) no events and there are events satisfying gap condition"+ (0, containsConcepts ["A"], 0, 3, makeBaselineFromIndex 10, concur, isEnrollmentEvent)+ (10, 11)+ [g (1, 2), g (8, 9)]+ True+ {-+ - <- Index+ ---------- <- Baseline+ - - <- Enrollment+ |--------------|+ -}+ , f "False if no X or Y events and looking for 1 X or 1 Y gap"+ (1, containsConcepts ["A"], 1, 3, makeBaselineFromIndex 10, concur, isEnrollmentEvent)+ (10, 11)+ []+ False+ {-+ - <- Index+ ---------- <- Baseline+ <- Enrollment+ |--------------|+ -}+ , f "False if a no X and Y single event and looking for gap"+ (1, containsConcepts ["A"], 1, 3, makeBaselineFromIndex 10, concur, isEnrollmentEvent)+ (10, 11)+ [g (8, 9)]+ False+ {-+ - <- Index+ ---------- <- Baseline+ - <- Enrollment+ |--------------|+ -}+ , f "False if no X 1 gap but not satisfying gap condition"+ (1, containsConcepts ["A"], 1, 3, makeBaselineFromIndex 10, concur, isEnrollmentEvent)+ (10, 11)+ [g (6, 7), g (8, 9)]+ False+ {-+ - <- Index+ ---------- <- Baseline+ - - <- Enrollment+ |--------------|+ -}+ , f "True if 1 gap satisfy gap condition"+ (1, containsConcepts ["D"], 1, 3, makeBaselineFromIndex 10, concur, containsConcepts ["A"])+ (10, 11)+ [h ["C", "A"] (2, 3), h ["A", "B"] (8, 9)]+ True+ {-+ - <- Index+ ---------- <- Baseline+ - <- ["C", "A"]+ - <- ["A", "B"] + |--------------|+ -}+ , f "True if 1 X event"+ (1, containsConcepts ["C"], 1, 3, makeBaselineFromIndex 10, concur, containsConcepts ["A"])+ (10, 11)+ [h ["C", "A"] (2, 3)]+ True+ {-+ - <- Index+ ---------- <- Baseline+ - <- ["C", "A"]+ |--------------|+ -}+ , f "True if 1 gap satisfy gap condition "+ (2, containsConcepts ["D"], 1, 3, makeBaselineFromIndex 10, concur, containsConcepts ["A"])+ (10, 11)+ [h ["C", "A"] (2, 3), h ["D", "E"] (5, 6), h ["A", "B"] (8, 9)]+ True+ {-+ - <- Index+ ---------- <- Baseline+ - <- ["C", "A"]+ - <- ["D", "E"]+ - <- ["A", "B"] + |--------------|+ -}+ , f "False if only one X and if no gap satisfy gap condition "+ (2, containsConcepts ["D"], 1, 3, makeBaselineFromIndex 10, concur, containsConcepts ["A"])+ (10, 11)+ [h ["C", "A"] (2, 3), h ["D", "A"] (4, 5)]+ False+ {-+ - <- Index+ ---------- <- Baseline+ - <- ["C", "A"]+ - <- ["D", "A"]+ |--------------|+ -}+ , f "True if two X and if no gap satisfy gap condition "+ (2, containsConcepts ["D"], 1, 3, makeBaselineFromIndex 10, concur, containsConcepts ["A"])+ (10, 11)+ [h ["D", "A"] (2, 3), h ["D", "A"] (4, 5)]+ True+ {-+ - <- Index+ ---------- <- Baseline+ - <- ["D", "A"]+ - <- ["D", "A"]+ |--------------|+ -}++ ] where+ f = makeTestInputs+ g = makeEnrollmentEvent+ h = makeEventWithConcepts++buildNofXOrNofYWithGapTests :: TestTree+buildNofXOrNofYWithGapTests = testGroup+ "Tests of NofXOrNofYWithGap template"+ (fmap+ (\x -> testCase+ (getTestName x)+ (makeAssertion x (uncurryN $ eval $ uncurryN buildNofXOrNofYWithGapBool (getBuilderArgs x)))+ )+ buildNofXOrNofYWithGapTestCases+ )+ {-| Do N events relating to the 'AssessmentInterval' in some way the satisfy the given predicate? -}@@ -579,7 +805,7 @@ (fmap (\x -> testCase (getTestName x)- (makeAssertion x (uncurryN buildNofUniqueBegins (getBuilderArgs x)))+ (makeAssertion x (uncurryN $ eval $ uncurryN buildNofUniqueBegins (getBuilderArgs x))) ) buildNofUniqueBeginsTestCases )
src/Hasklepias/Templates/TestUtilities.hs view
@@ -38,7 +38,7 @@ import Features.Compose ( Feature , Definition(..) , Define(..)- , Eval(..) )+ , eval ) import Hasklepias.Misc import IntervalAlgebra@@ -54,14 +54,29 @@ } deriving (Eq, Show) -evalTestCase :: (Eval def defArgs return) =>+-- evalTestCase :: +-- TestCase defArgs b builderArgs+-- -> (def -> return)+-- -- -> Definition def+-- -> ( return, Feature "result" b )+-- evalTestCase (MkTestCase buildArgs _ inputs truth) def = ( eval def inputs, truth )++evalTestCase :: TestCase defArgs b builderArgs- -> Definition def+ -> (defArgs -> return)+ -- -> Definition def -> ( return, Feature "result" b )-evalTestCase (MkTestCase buildArgs _ inputs truth) def = ( eval def inputs, truth )+evalTestCase (MkTestCase buildArgs _ inputs truth) def = ( def inputs, truth ) -makeAssertion :: (Eq b, Show b, Eval def defArgs (Feature "result" b)) =>- TestCase defArgs b builderArgs -> Definition def -> Assertion+-- makeAssertion :: (Eq b, Show b) =>+-- TestCase defArgs b builderArgs -> Definition def -> Assertion+-- makeAssertion x def = uncurry (@?=) (evalTestCase x def)++-- z :: Definition d -> (b -> a)+-- z def = (eval def)++makeAssertion :: (Eq b, Show b) =>+ TestCase defArgs b builderArgs -> (defArgs -> Feature "result" b) -> Assertion makeAssertion x def = uncurry (@?=) (evalTestCase x def) readIntervalSafe :: (Integral b, IntervalSizeable a b) => (a, a) -> Interval a
test/FeaturesSpec.hs view
@@ -14,30 +14,10 @@ -------------------------------------- example :: Feature "test" ()--- example = MkFeature $ pure () --- d0 :: Definition (FeatureData Int)--- d0 = define 5--d1 :: Definition (FeatureData Int -> FeatureData Int)-d1 = defineA- (\x -> if x < 0 then missingBecause $ Other "at least 1 < 0" else pure (x + 1)- )--d2 :: Definition (FeatureData Int -> FeatureData Int)-d2 = define (* 2)---d3 :: Definition (FeatureData Int -> FeatureData Int -> FeatureData Int)-d3 = define (+)- f1 :: Int -> Int f1 = (+ 2) -f1D :: Definition (FeatureData Int -> FeatureData Int)-f1D = define f1- f1F :: Definition (Feature "someInt" Int -> Feature "anotherInt" Int) f1F = define f1 @@ -45,9 +25,6 @@ f2 True = pure 1 f2 False = missingBecause $ Other "test" -f2D :: Definition (FeatureData Bool -> FeatureData Int)-f2D = defineA f2- f2' :: Bool -> Feature "someInt" Int f2' True = pure 1 f2' False = makeFeature $ missingBecause $ Other "test"@@ -60,9 +37,6 @@ f3 False 9 = "that" f3 _ _ = "otherwise" -f3D :: Definition (FeatureData Bool -> FeatureData Int -> FeatureData String)-f3D = define f3- f3F :: Definition ( Feature "myBool" Bool@@ -73,7 +47,7 @@ featInts :: [Int] -> Feature "someInts" [Int]-featInts = pure+featInts = pure feat1 :: Definition (Feature "someInts" [Int] -> Feature "hasMoreThan3" Bool) feat1 = defineA@@ -92,81 +66,35 @@ ex0 = featInts [] ex0a = eval feat1 ex0 -- MkFeature (MkFeatureData (Left (Other "no data")))-ex0b = eval feat2 (ex0a, ex0) -- MkFeature (MkFeatureData (Left (Other "no data")))+ex0b = eval feat2 ex0a ex0 -- MkFeature (MkFeatureData (Left (Other "no data"))) ex1 = featInts [3, 8] ex1a = eval feat1 ex1 -- MkFeature (MkFeatureData (Right False))-ex1b = eval feat2 (ex1a, ex1) -- MkFeature (MkFeatureData (Right 0))+ex1b = eval feat2 ex1a ex1 -- MkFeature (MkFeatureData (Right 0)) ex2 = featInts [1 .. 4] ex2a = eval feat1 ex2 -- MkFeature (MkFeatureData (Right True))-ex2b = eval feat2 (ex2a, ex2) -- MkFeature (MkFeatureData (Right 10))+ex2b = eval feat2 ex2a ex2 -- MkFeature (MkFeatureData (Right 10)) spec :: Spec spec = do - describe "checking d1" $ do- it "eval of d1 on d0" $ eval d1 (pure 5) `shouldBe` featureDataR 6- it "eval of d1 returns correct value"- $ eval d1 (featureDataR 5)- `shouldBe` featureDataR 6- it "d1 returns correct error"- $ eval d1 (featureDataR (-1))- `shouldBe` missingBecause (Other "at least 1 < 0")-- describe "checking d2" $ do- it "eval of d2 returns correct value"- $ eval d2 (featureDataR 5)- `shouldBe` featureDataR 10- it "eval of d2 returns correct value"- $ eval d2 (featureDataR 5)- `shouldBe` featureDataR 10- it "d2 returns correct error"- $ eval d2 (featureDataL (Other "at least 1 < 0"))- `shouldBe` featureDataL (Other "at least 1 < 0")-- describe "checking d3" $ do- it "eval of d2 returns correct values"- $ eval d3 (featureDataR 5, featureDataR 6)- `shouldBe` featureDataR 11- it "eval of d3 returns correct values"- $ eval d3 (featureDataR 5, featureDataR 5)- `shouldBe` featureDataR 10- it "d3 returns correct error"- $ eval d3 (featureDataL (Other "at least 1 < 0"), featureDataR 6)- `shouldBe` featureDataL (Other "at least 1 < 0")- it "d3 returns correct error"- $ eval d3 (featureDataR 6, featureDataL (Other "at least 1 < 0"))- `shouldBe` featureDataL (Other "at least 1 < 0")- describe "checking f1" $ do it "eval of f1F on d0 returns correct value" $ eval f1F (pure 5) `shouldBe` pure 7 describe "checking f2" $ do- it "eval of f2D on d0 returns correct value"- $ eval f2D (pure True)- `shouldBe` pure 1 it "eval of f1F on d0 returns correct value"- $ eval f2D (pure False)- `shouldBe` missingBecause (Other "test")- it "eval of f1F on d0 returns correct value" $ eval f2F (pure False) `shouldBe` makeFeature (missingBecause (Other "test")) describe "checking f3" $ do- it "eval of f3D returns correct value"- $ eval f3D (pure True, pure 1)- `shouldBe` pure "this"- it "eval of f3D returns correct value"- $ eval f3D (pure True, pure 9)- `shouldBe` pure "otherwise" it "eval of f3F returns correct value"- $ eval f3F (pure True, eval f2F (pure False))+ $ eval f3F (pure True) (eval f2F (pure False)) `shouldBe` makeFeature (missingBecause (Other "test")) it "eval of f3F returns correct value"- $ eval f3F (pure True, eval f2F (pure True))+ $ eval f3F (pure True) (eval f2F (pure True)) `shouldBe` pure "this" describe "checking ex0-2" $ do