hasklepias 0.7.1 → 0.8.3

raw patch · 45 files changed

+1678/−1061 lines, 45 filesdep +lensdep +lens-aesonPVP ok

version bump matches the API change (PVP)

Dependencies added: lens, lens-aeson

API changes (from Hackage documentation)

Files

• ChangeLog.md +31/−1
• examples/ExampleEvents.hs +11/−7
• examples/ExampleFeatures1.hs +60/−47
• examples/ExampleFeatures2.hs +2/−2
• examples/ExampleFeatures3.hs +2/−2
• hasklepias.cabal +31/−19
• src/EventData.hs +96/−0
• src/EventData/Aeson.hs +99/−0
• src/EventData/Arbitrary.hs +48/−0
• src/EventData/Context.hs +139/−0
• src/EventData/Context/Arbitrary.hs +40/−0
• src/EventData/Context/Domain.hs +36/−0
• src/EventData/Context/Domain/Demographics.hs +74/−0
• src/FeatureCompose.hs +150/−0
• src/FeatureCompose/Aeson.hs +33/−0
• src/FeatureCompose/Criteria.hs +78/−0
• src/FeatureEvents.hs +140/−0
• src/Hasklepias.hs +20/−4
• src/Hasklepias/Aeson.hs +65/−0
• src/Hasklepias/Cohort.hs +57/−0
• src/Hasklepias/Functions.hs +0/−140
• src/Hasklepias/Reexports.hs +1/−0
• src/Hasklepias/Types.hs +0/−20
• src/Hasklepias/Types/Context.hs +0/−132
• src/Hasklepias/Types/Context/Arbitrary.hs +0/−39
• src/Hasklepias/Types/Event.hs +0/−95
• src/Hasklepias/Types/Event/Aeson.hs +0/−80
• src/Hasklepias/Types/Event/Arbitrary.hs +0/−48
• src/Hasklepias/Types/Feature.hs +0/−179
• src/Hasklepias/Types/Feature/Aeson.hs +0/−33
• test/EventData/AesonSpec.hs +98/−0
• test/EventData/Context/Domain/DemographicsSpec.hs +18/−0
• test/EventData/Context/DomainSpec.hs +28/−0
• test/EventData/ContextSpec.hs +29/−0
• test/EventDataSpec.hs +59/−0
• test/FeatureCompose/AesonSpec.hs +35/−0
• test/FeatureCompose/CriteriaSpec.hs +46/−0
• test/FeatureComposeSpec.hs +63/−0
• test/FeatureEventsSpec.hs +31/−0
• test/Hasklepias/AesonSpec.hs +58/−0
• test/Hasklepias/FunctionsSpec.hs +0/−30
• test/Hasklepias/Types/ContextSpec.hs +0/−28
• test/Hasklepias/Types/Event/AesonSpec.hs +0/−64
• test/Hasklepias/Types/EventSpec.hs +0/−58
• test/Hasklepias/Types/Feature/AesonSpec.hs +0/−33

@@ -1,5 +1,35 @@ # Changelog for hasklepias +## 0.8.3++* Modifies `FromJSON` instance for events to use `parseEvent` as well as create a moment from the provided `begin` in the case that `end` is missing.+* Updates `FromJSON` instance for events to parse the facts object. Currently the only implemented domain is demographics.+* Adds `FromJSON` instances for `Population`, so now data from multiple subjects can be marshaled into Hasklepias programs.++## 0.8.2++* Adds preliminary `Subject`, `Population`, `ObsUnit`, and `Cohort` types to the `Hasklepias` module, along with the `makeObsUnitFeatures` which takes a function that maps a `Subject` into a `ObsUnit`. Currently, this function only supports 1-1 mapping between subjects and observational units. There is also the `makeCohort` function which maps a `Population` to a `Cohort`. The types get preliminary `FromJSON` (for `Subject` and `Population`) and `ToJSON` (for `ObsUnit` and `Cohort`) instances as well. Example 1 demonstrates use of these two functions.++## 0.8.1++* Adds an initial pass at the `Domain` type; simply including the `Demographics` type for now.++## 0.8.0++* Reorganizes modules into a more "vertical" structure that reflects the decoupling of the various components that make up hasklepias:+  * `EventData`: types and functions related to the event data model+  * `FeatureCompose`: types and functions for composing new features+  * `FeatureEvents`: various utilities for composing features from events specifically+  * `Hasklepias`: at this point, just reexporting the above modules and other Haskell functions++## 0.7.3++* Refactors the `eval*` function for Features so that there is a single `eval` not two.++## 0.7.2++* Adds `Criteria` module which provides specialized functions and types for working with boolean `Feature`s which are meant to be used to determine whether a subject is included or excluded from cohorts.+ ## 0.7.1  * Fixes bug in `FeatureData` `Monad` instance, so you don't get infinite recursion.@@ -15,7 +45,7 @@  ## 0.6.0 -* Adds `PolyKinds` extension to `Feature` module to enable poly-kind inputs to `FeatureDefinition`s. Adds a related `Defineable` typeclass with `define` and `eval` functions as a common interface for defining new definitions and evaluating them. +* Adds `PolyKinds` extension to `Feature` module to enable poly-kind inputs to `FeatureDefinition`s. Adds a related `Defineable` typeclass with `define` and `eval` functions as a common interface for defining new definitions and evaluating them. * Removes `defineEF` and `applyEF` function (and other similar functions). The functionality is now handled by the `Defineable` class.  ## 0.5.1

@@ -12,14 +12,12 @@     , exampleEvents2     , exampleEvents3     , exampleEvents4+    , exampleSubject1+    , exampleSubject2 ) where-  -import IntervalAlgebra ( beginerval, IntervalSizeable )-import Hasklepias.Types.Event ( event, Event, Events )-import Hasklepias.Types.Context ( context, packConcepts )-import Data.List ( sort )-import Data.Text(Text) +import Hasklepias+ exampleEvents1 :: Events Int exampleEvents1 = toEvents exampleEvents1Data @@ -32,10 +30,16 @@ exampleEvents4 :: Events Int  exampleEvents4 = toEvents exampleEvents4Data +exampleSubject1 :: Subject (Events Int)+exampleSubject1 = MkSubject ("a", exampleEvents1)++exampleSubject2 :: Subject (Events Int)+exampleSubject2 = MkSubject ("b", exampleEvents2)+ type EventData a = (a, a, Text)  toEvent :: (IntervalSizeable a a, Show a) => EventData a -> Event a-toEvent x = event (beginerval (t1 x) (t2 x)) (context $ packConcepts [t3 x])+toEvent x = event (beginerval (t1 x) (t2 x)) (context Nothing (packConcepts [t3 x]))  toEvents :: (Ord a, Show a, IntervalSizeable a a) => [EventData a] -> Events a toEvents = sort.map toEvent

@@ -17,21 +17,21 @@ import Hasklepias import ExampleEvents import Test.Hspec-import Data.Bifunctor-import Control.Applicative import Control.Monad  {- Index is defined as the first occurrence of an Orca bite. -}-indexDef :: (Ord a) => Events a -> FeatureData (Interval a)-indexDef events =-  case firstConceptOccurrence ["wasBitByOrca"] events of+indexDef :: (Ord a) => FeatureDefinition+  (FeatureData (Events a))+  (Interval a)+indexDef = defineM (\events ->+  case firstConceptOccurrence ["wasBitByOrca"]  events of         Nothing -> featureDataL (Other "No occurrence of Orca bite")-        Just x  -> featureDataR (getInterval x)+        Just x  -> pure (getInterval x)) -indexSpec :: (Ord a) => FeatureSpec Text (*) (Events a) (Interval a)-indexSpec = makeFeatureSpec "index" "" (define0 indexDef)+-- indexSpec :: (Ord a) => FeatureSpec Text (*) (Events a) (Interval a)+-- indexSpec = makeFeatureSpec "index" "" (define indexDef)  {-   The baseline interval is the interval (b - 60, b), where b is the begin of @@ -39,35 +39,35 @@ as an argument, so that the baseline FeatureData can be used to filter events based on different predicate functions. -}-baseline :: (IntervalSizeable a b) =>-     FeatureData (Interval a) -- ^ pass the result of index to get a baseline filter-  -> FeatureData (Interval a)-baseline = fmap (enderval 60 . begin)- bline :: (IntervalSizeable a b) =>-     Events a+     FeatureData (Events a)   -> FeatureData (Interval a)-bline = baseline . indexDef+bline x = fmap (enderval 60 . begin) (eval indexDef x)  flwup :: (IntervalSizeable a b) =>-     Events a+     FeatureData (Events a)   -> FeatureData (Interval a)-flwup = fmap (beginerval 30 . begin) . indexDef+flwup x = fmap (beginerval 30 . begin) (eval indexDef x)  {- Define enrolled as the indicator of whether all of the gaps between the union of  all enrollment intervals (+ allowableGap)  -}-enrolledDef :: (IntervalSizeable a b) =>+enrolled :: (IntervalSizeable a b) =>       b       -> Interval a -> Events a -> Bool-enrolledDef allowableGap i events =+enrolled allowableGap i events =     events       |> makeConceptsFilter ["enrollment"]       |> combineIntervals       |> gapsWithin i       |> maybe False (all (< allowableGap) . durations) +enrolledDef :: IntervalSizeable a b =>+      b+      -> FeatureDefinition+         (FeatureData (Interval a), FeatureData (Events a)) Bool+enrolledDef allowableGap = define2 (enrolled allowableGap) {- Define features that identify whether a subject as bit/struck by a duck and bit/struck by a macaw.@@ -149,9 +149,9 @@           ["tookAntibiotics"])     events -getUnitFeatures ::-      Events Int-  -> ( FeatureData (Interval Int)++type MyData = +     ( FeatureData (Interval Int)      , FeatureData Bool      , FeatureData (Bool, Maybe (Interval Int))      , FeatureData (Bool, Maybe (Interval Int))@@ -160,36 +160,35 @@      , FeatureData (Int, Maybe Int)      , FeatureData (Maybe (Int, Int))      )++getUnitFeatures ::+      Events Int+  -> MyData getUnitFeatures x = (-    -- indexDef x-    evs >>= indexDef-  , liftA2 (enrolledDef 8) (bline x) evs-  , liftA2 duckHxDef  (bline x) evs-  , liftA2 macawHxDef (bline x) evs-  , liftA2 twoMinorOrOneMajorDef (bline x) evs-  , liftA2 timeSinceLastAntibioticsDef (bline x) evs-  , liftA2 countOfHospitalEventsDef (bline x) evs-  , liftA2 discontinuationDef (flwup x) evs+    eval indexDef evs+  , eval (enrolledDef 8) (bline evs, evs)  +  , 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   ) where evs = pure x --exampleFeatures1Spec :: Spec-exampleFeatures1Spec = do--    it "getUnitFeatures from exampleEvents1" $-      getUnitFeatures exampleEvents1 `shouldBe`-      ( featureDataR (beginerval 1 (60 :: Int))-      , featureDataR True-      , featureDataR (True, Just $ beginerval 1 (51 :: Int))-      , featureDataR (False, Nothing)-      , featureDataR True-      , featureDataR $ Just 4-      , featureDataR (1, Just 8)-      , featureDataR $ Just (78, 18)+example1results :: MyData+example1results =+      ( pure (beginerval 1 (60 :: Int))+      , pure True+      , pure (True, Just $ beginerval 1 (51 :: Int))+      , pure (False, Nothing)+      , pure True+      , pure $ Just 4+      , pure (1, Just 8)+      , pure $ Just (78, 18)       ) -    it "getUnitFeatures from exampleEvents2" $-      getUnitFeatures exampleEvents2 `shouldBe`+example2results :: MyData+example2results =        ( featureDataL (Other "No occurrence of Orca bite")       , featureDataL (Other "No occurrence of Orca bite")       , featureDataL (Other "No occurrence of Orca bite")@@ -199,3 +198,17 @@       , featureDataL (Other "No occurrence of Orca bite")       , featureDataL (Other "No occurrence of Orca bite")       )++exampleFeatures1Spec :: Spec+exampleFeatures1Spec = do++    it "getUnitFeatures from exampleEvents1" $+      getUnitFeatures exampleEvents1 `shouldBe` example1results++    it "getUnitFeatures from exampleEvents2" $+      getUnitFeatures exampleEvents2 `shouldBe` example2results++    it "mapping a population to cohort" $+      makeCohort getUnitFeatures (MkPopulation [exampleSubject1, exampleSubject2 ]) `shouldBe`+            MkCohort [MkObsUnit ("a", example1results), MkObsUnit ("b", example2results)]+

@@ -23,7 +23,7 @@   -> FeatureData [b] durationOfHospitalizedAntibiotics es     | null y    = featureDataL $ Other "no cases"-    | otherwise = featureDataR $ durations y+    | otherwise = pure $ durations y     where conceptsText = ["wasHospitalized", "tookAntibiotics"]            concepts = map packConcept conceptsText           x = formMeetingSequence (map (toConceptEventOf concepts) es)@@ -39,4 +39,4 @@      it "durationOfHospitalizedAntibiotics from exampleEvents3" $         durationOfHospitalizedAntibiotics exampleEvents3 `shouldBe` -            featureDataR [3, 2]+            pure [3, 2]

@@ -38,7 +38,7 @@         , fmap begin (lastMay x)))      -- if exists, keep the begin of the last "c1" interval  flwup :: FeatureData (Interval Int)-flwup = featureDataR $ beginerval 50 0+flwup = pure $ beginerval 50 0  exampleFeatures3Spec :: Spec exampleFeatures3Spec = do@@ -46,4 +46,4 @@     it "examplePairComparison"  $         liftA2 examplePairComparison flwup (pure exampleEvents4)              `shouldBe`-        featureDataR (True, Just 16)+        pure (True, Just 16)

@@ -1,6 +1,6 @@ cabal-version:  2.2 name:           hasklepias-version:        0.7.1+version:        0.8.3 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@@ -22,17 +22,21 @@  library   exposed-modules:+      EventData+      EventData.Arbitrary+      EventData.Aeson+      EventData.Context+      EventData.Context.Arbitrary+      EventData.Context.Domain+      EventData.Context.Domain.Demographics+      FeatureCompose+      FeatureCompose.Aeson+      FeatureCompose.Criteria+      FeatureEvents       Hasklepias-      Hasklepias.Functions+      Hasklepias.Aeson       Hasklepias.Reexports-      Hasklepias.Types-      Hasklepias.Types.Feature-      Hasklepias.Types.Feature.Aeson-      Hasklepias.Types.Context-      Hasklepias.Types.Context.Arbitrary-      Hasklepias.Types.Event-      Hasklepias.Types.Event.Aeson-      Hasklepias.Types.Event.Arbitrary+      Hasklepias.Cohort   other-modules:       Paths_hasklepias   autogen-modules:@@ -45,13 +49,15 @@     , bytestring >=0.10     , containers >=0.6.0     , flow == 1.0.22-    , interval-algebra == 0.8.2 +    , interval-algebra == 0.8.2+    , lens == 5.0.1+    , lens-aeson == 1.1.1+    , safe >= 0.3     , text >=1.2.3     , time >=1.11+    , QuickCheck     , unordered-containers >=0.2.10-    , safe >= 0.3     , vector >=0.12-    , QuickCheck     , witherable >= 0.4   default-language: Haskell2010 @@ -59,11 +65,16 @@   type: exitcode-stdio-1.0   main-is: Spec.hs   other-modules:-      Hasklepias.FunctionsSpec-      Hasklepias.Types.ContextSpec-      Hasklepias.Types.Event.AesonSpec-      Hasklepias.Types.EventSpec-      Hasklepias.Types.Feature.AesonSpec+      EventDataSpec+      EventData.AesonSpec+      EventData.ContextSpec+      EventData.Context.DomainSpec+      EventData.Context.Domain.DemographicsSpec+      FeatureComposeSpec+      FeatureCompose.CriteriaSpec+      FeatureCompose.AesonSpec+      Hasklepias.AesonSpec+      FeatureEventsSpec       Paths_hasklepias   autogen-modules:       Paths_hasklepias @@ -78,7 +89,8 @@     , flow == 1.0.22     , hasklepias     , hspec-    , interval-algebra == 0.8.2 +    , interval-algebra == 0.8.2+    , lens == 5.0.1     , text >=1.2.3     , time >=1.11     , unordered-containers >=0.2.10

@@ -0,0 +1,96 @@+{-|+Module      : Hasklepias Event Type+Description : Defines the Event type and its component types, constructors, +              and class instance+Copyright   : (c) NoviSci, Inc 2020+License     : BSD3+Maintainer  : bsaul@novisci.com+-}+{-# LANGUAGE NoImplicitPrelude #-}+{-# LANGUAGE TypeSynonymInstances #-}+{-# LANGUAGE FlexibleInstances #-}+-- {-# LANGUAGE Safe #-}++module EventData(+   Event+ , Events+ , ConceptEvent+ , event+ , ctxt+ , toConceptEvent+ , toConceptEventOf+ , mkConceptEvent+ , module EventData.Context+) where++import GHC.Show                         ( Show(show) )+import Data.Function                    ( ($) )+import Data.Set                         ( member, fromList, intersection )+import Data.Ord                         ( Ord )+import IntervalAlgebra                  ( Interval+                                        , Intervallic+                                        , Intervallic (getInterval) )+import IntervalAlgebra.PairedInterval   ( PairedInterval+                                        , makePairedInterval+                                        , getPairData )+import EventData.Context                ( HasConcept(..)+                                        , Concepts+                                        , Concept+                                        , packConcept+                                        , Context(..)+                                        , fromConcepts+                                        , toConcepts )+++-- | An Event @a@ is simply a pair @(Interval a, Context)@.+type Event a = PairedInterval Context a++-- instance (Ord a, Show a) => Show (Event a) where+--   show x = "{" ++ show (getInterval x) ++ ", " ++ show (ctxt x) ++ "}"++instance HasConcept (Event a) where+    hasConcept x y = ctxt x `hasConcept` y++-- | A smart constructor for 'Event a's.+event :: Interval a -> Context -> Event a+event i c = makePairedInterval c i++-- | Access the 'Context' of an 'Event a'.+ctxt :: Event a -> Context+ctxt = getPairData++-- | An event containing only concepts and an interval+type ConceptEvent a = PairedInterval Concepts a++-- instance (Ord a, Show a) => Show (ConceptEvent a) where+--   show x = "{" ++ show (getInterval x) ++ ", " ++ show (getPairData x) ++ "}"++instance HasConcept (ConceptEvent a) where+    hasConcept e concept = member (packConcept concept) (fromConcepts $ getPairData e)++-- | Drops an @Event@ to a @ConceptEvent@ by moving the concepts in the data+--   position in the paired interval and throwing out the facts and source.+toConceptEvent :: (Show a, Ord a) => Event a -> ConceptEvent a+toConceptEvent e = makePairedInterval (_concepts $ ctxt e) (getInterval e)++toConceptEventOf :: (Show a, Ord a) => [Concept] -> Event a -> ConceptEvent a+toConceptEventOf cpts e =+    makePairedInterval+        (toConcepts $ intersection (fromList cpts) (fromConcepts $ _concepts $ ctxt e))+        (getInterval e)++-- |+mkConceptEvent :: (Show a, Ord a) => Interval a -> Concepts -> ConceptEvent a+mkConceptEvent i c = makePairedInterval c i++-- | A @List@ of @Event a@+-- +-- NOTE (20190911): I (B. Saul) am starting out the Events type as a +-- list of the Event type. This may be not be the optimal approach,+-- especially with regards to lookup/filtering the list. Ideally,+-- we could do one pass through the ordered container (whatever it is)+-- to identify events by concept; rather than repeated evaluations of+-- the lookup predicates. This could be handled by, for example, +-- representing Events has a Map with a list of concept indices. +-- But this gets us off the ground.+type Events a = [Event a]

@@ -0,0 +1,99 @@+{-|+Module      : Functions for Parsing Event data model+Description : Defines FromJSON instances for Events.+Copyright   : (c) NoviSci, Inc 2020+License     : BSD3+Maintainer  : bsaul@novisci.com+-}+{-# LANGUAGE NoImplicitPrelude #-}+{-# LANGUAGE FlexibleInstances, OverloadedStrings #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE UndecidableInstances #-}+{-# LANGUAGE ScopedTypeVariables #-}++module EventData.Aeson(+      parseEventIntLines+    , parseEventDayLines+) where++import IntervalAlgebra                      ( beginerval+                                            , parseInterval+                                            , Interval+                                            , IntervalSizeable(add, diff, moment) )+import EventData.Context                    ( Concepts+                                            , Concept+                                            , Context+                                            , context+                                            , packConcept+                                            , toConcepts )+import EventData                            ( Event, event )+import EventData.Context.Domain+import Prelude                              ( (<$>), (<*>), ($)+                                            , fmap, pure, id+                                            , Int, String, Ord, Show)+import Data.Aeson                           ( eitherDecode+                                            , (.:), (.:?)+                                            , withObject+                                            , FromJSON(parseJSON)+                                            , Value(Array) )+import Data.Either                          ( Either(..) )+import Data.Maybe                           ( maybe )+import Data.Text                            ( Text )+import Data.Time                            ( Day )+import Data.Vector                          ((!))+import qualified Data.ByteString.Lazy as B+import qualified Data.ByteString.Char8 as C+import Data.Either                          (rights, either)+import Control.Monad ++instance (FromJSON a, Show a, IntervalSizeable a b) => FromJSON (Interval a) where+    parseJSON = withObject "Time" $ \o -> do+        t <- o .: "time"+        b <- t .: "begin"+        e <- t .:? "end" +        -- In the case that the end is missing, create a moment+        let e2 = maybe (add (moment @a) b) (id) e +        let ei = parseInterval b e2+        case ei of+            Left e  -> fail e+            Right i -> return i++instance FromJSON Domain where+    parseJSON = withObject "Domain" $ \o -> do+        domain :: Text <- o .: "domain"+        case domain of+            "Demographics" -> Demographics <$> o .: "facts"+            _              -> pure (UnimplementedDomain ())++instance FromJSON Concept where+    parseJSON c = packConcept <$> parseJSON  c++instance FromJSON Concepts where+    parseJSON c = toConcepts <$> parseJSON c++instance FromJSON Context where+    parseJSON (Array v) = context <$>+        parseJSON (v ! 5) <*>+        parseJSON (v ! 4)+    -- parseJSON v = context <$> parseJSON v++instance  (FromJSON a, Show a, IntervalSizeable a b) => FromJSON (Event a) where+    parseJSON (Array v) = event <$> parseJSON (v ! 5) <*> parseJSON (Array v)+    -- parseJSON (Array v) = event <$>+    --         parseJSON (v ! 5) <*>+    --         parseJSON (v ! 4)++-- |  Parse @Event Int@ from json lines.+parseEventLines :: (FromJSON a, Show a, IntervalSizeable a b) => B.ByteString -> [Event a]+parseEventLines l =+    rights $ fmap +    (\x -> eitherDecode $ B.fromStrict x :: (FromJSON a, Show a, IntervalSizeable a b) =>  Either String (Event a))+        (C.lines $ B.toStrict l)+++parseEventIntLines :: B.ByteString -> [Event Int]+parseEventIntLines = parseEventLines++-- |  Parse @Event Day@ from json lines.+parseEventDayLines :: B.ByteString -> [Event Day]+parseEventDayLines = parseEventLines

@@ -0,0 +1,48 @@+{-|+Module      : Generate arbitrary events +Description : Functions for generating arbitrary events+Copyright   : (c) NoviSci, Inc 2020+License     : BSD3+Maintainer  : bsaul@novisci.com+Stability   : experimental+-}+{-# LANGUAGE NoImplicitPrelude #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE FlexibleContexts #-}+module EventData.Arbitrary(+     generateEventsInt+) where++import Test.QuickCheck (+    Arbitrary(arbitrary, shrink)+    , Gen+    , sample'+    , sample+    , generate+    , resize+    , suchThat +    , orderedList  )+import GHC.Show ( Show )+import GHC.IO ( IO )+import Control.Monad ( Functor(fmap), liftM2 )+import Data.Eq ( Eq((==)) )+import Data.Function (($))+import Data.Int ( Int )+import Data.Ord ( Ord )+import Data.List(length)+import IntervalAlgebra ( Interval )+import IntervalAlgebra.Arbitrary ()+import EventData+    ( event, Event, ConceptEvent, toConceptEvent )+import EventData.Context.Arbitrary ()++instance (Arbitrary (Interval a)) => Arbitrary (Event a) where+    arbitrary = liftM2 event arbitrary arbitrary++instance (Ord a, Show a, Arbitrary (Interval a)) => Arbitrary (ConceptEvent a) where+    arbitrary = fmap toConceptEvent arbitrary++-- | Generate @n@ @Event Int@+generateEventsInt :: Int -> IO [Event Int]+generateEventsInt i = +    generate $ suchThat (orderedList :: Gen [Event Int]) (\x -> length x == i)

@@ -0,0 +1,139 @@+{-|+Module      : Event Data Model Contexts+Description : Defines the Context type and its component types, constructors, +              and class instances+Copyright   : (c) NoviSci, Inc 2020+License     : BSD3+Maintainer  : bsaul@novisci.com+-}++{-# LANGUAGE NoImplicitPrelude #-}+-- {-# LANGUAGE Safe #-}+{-# LANGUAGE TemplateHaskell #-}++module EventData.Context(+    Context(..)+  , concepts+  , facts+  , source+  , context+  , emptyContext++  , Concept+  , Concepts+  , toConcepts+  , fromConcepts+  , packConcept+  , unpackConcept+  , packConcepts+  , unpackConcepts+  , HasConcept(..)+) where++import Control.Lens             ( makeLenses )+import GHC.Show                 ( Show(show) )+import Data.Bool                ( Bool )+import Data.Eq                  ( Eq )+import Data.Function            ( (.), ($) )+import Data.List                ( all, any, map )+import Data.Maybe               ( Maybe(Nothing) )+import Data.Monoid              ( (<>), Monoid(mempty) )+import Data.Ord                 ( Ord )+import Data.Semigroup           ( Semigroup((<>)) )+import Data.Text                ( Text )+import Data.Set                 ( Set+                                , fromList, union, empty, map, toList, member)+import EventData.Context.Domain ( Domain )++-- | A @Context@ consists of three parts: @concepts@, @facts@, and @source@. +-- +-- At this time, @facts@ and @source@ are simply stubs to be fleshed out in +-- later versions of hasklepias. +data Context = Context {+      _concepts :: Concepts+    , _facts    :: Maybe Domain+    , _source   :: Maybe Source+} deriving (Eq, Show)++data Source = Source deriving (Eq, Show)++instance Semigroup Context where+    x <> y = Context (_concepts x <> _concepts y) Nothing Nothing++instance Monoid Context where+    mempty = emptyContext++instance HasConcept Context where+    hasConcept ctxt concept = +        member (packConcept concept) (fromConcepts $ _concepts ctxt)++-- | Smart contructor for Context type+--+-- Creates 'Context' from a list of 'Concept's. At this time, the @facts@ and+-- @source@ are both set to 'Nothing'.+context :: Maybe Domain -> Concepts -> Context+context d x = Context x d Nothing++-- | Just an empty Context+emptyContext :: Context+emptyContext = Context mempty Nothing Nothing++-- | A @Concept@ is textual "tag" for a context.+newtype Concept = Concept Text deriving (Eq, Ord)++instance Show Concept where+    show (Concept x) = show x++-- | Pack text into a concept+packConcept :: Text -> Concept+packConcept = Concept++-- | Unpack text from a concept+unpackConcept :: Concept -> Text +unpackConcept (Concept x) =  x++-- | @Concepts@ is a 'Set' of 'Concepts's.+newtype Concepts = Concepts ( Set Concept )+    deriving (Eq, Show)++instance Semigroup Concepts where+    Concepts x <> Concepts y = Concepts (x <> y)++instance Monoid Concepts where+    mempty = Concepts mempty++-- | Constructor for 'Concepts'.+toConcepts :: Set Concept -> Concepts+toConcepts = Concepts++fromConcepts :: Concepts -> Set Concept+fromConcepts (Concepts x) = x++-- | Put a list of text into a set concepts.+packConcepts :: [Text] -> Concepts+packConcepts x = Concepts $ fromList $ Data.List.map packConcept x++-- | Take a set of concepts to a list of text.+unpackConcepts :: Concepts -> [Text]+unpackConcepts (Concepts x) = toList $ Data.Set.map unpackConcept x ++{- |+The 'HasConcept' typeclass provides predicate functions for determining whether+an @a@ has a concept.+-}+class HasConcept a where+    -- | Does an @a@ have a particular 'Concept'?+    hasConcept  :: a -> Text -> Bool++    -- | Does an @a@ have *any* of a list of 'Concept's?+    hasConcepts :: a -> [Text] -> Bool+    hasConcepts x = any (\c -> x `hasConcept` c)++    -- | Does an @a@ have *all* of a list of `Concept's?+    hasAllConcepts :: a -> [Text] -> Bool+    hasAllConcepts x = all (\c -> x `hasConcept` c) ++instance HasConcept Concepts where+    hasConcept (Concepts e) concept = member (packConcept concept) e++makeLenses ''Context

@@ -0,0 +1,40 @@+{-|+Module      : Generate arbitrary contexts+Description : Functions for generating arbitrary context +Copyright   : (c) NoviSci, Inc 2020+License     : BSD3+Maintainer  : bsaul@novisci.com+-}++{-# LANGUAGE NoImplicitPrelude #-}+{-# LANGUAGE OverloadedStrings #-}+-- {-# LANGUAGE Safe #-}++module EventData.Context.Arbitrary() where++import Test.QuickCheck              ( Arbitrary(arbitrary), elements, sublistOf ) +import Data.Function                ( (.) )+import Data.Functor                 ( Functor(fmap) )+import Data.List                    ( map )+import Data.Maybe                   ( Maybe(Nothing) )+import Data.Set                     ( fromList )+import EventData.Context            ( Concept+                                    , Concepts+                                    , Context+                                    , context+                                    , toConcepts+                                    , packConcepts+                                    , packConcept)++conceptChoices :: [Concept]+conceptChoices = map packConcept ["A", "B", "C", "D", "E", "F", "G", "H", "I", "J"]++instance Arbitrary Concept where+    arbitrary = elements conceptChoices++instance Arbitrary Context where+    arbitrary = fmap (\x -> context Nothing ((toConcepts . fromList) x)) (sublistOf conceptChoices)++-- instance Arbitrary Concepts where+--     arbitrary = fmap fromList (sublistOf conceptChoices)+

@@ -0,0 +1,36 @@+{-|+Module      : Event Data Model facts +Description : Defines the Context type and its component types, constructors, +              and class instances+Copyright   : (c) NoviSci, Inc 2020+License     : BSD3+Maintainer  : bsaul@novisci.com+-}++{-# LANGUAGE NoImplicitPrelude #-}+{-# LANGUAGE Trustworthy #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE ScopedTypeVariables #-}+module EventData.Context.Domain(+    Domain(..)+    , _Demographics+    , module EventData.Context.Domain.Demographics+) where++import Prelude                                  ( Show, Eq+                                                , ($), (<$>), (<*>), fail, drop+                                                , pure )+import Control.Lens                             ( makePrisms )+import GHC.Generics                             ( Generic )+import Data.Foldable+import Data.Text                                ( Text, empty )+import EventData.Context.Domain.Demographics++data Domain =+      Demographics DemographicsFacts+    | UnimplementedDomain ()+    deriving ( Eq, Show, Generic )++makePrisms ''Domain

@@ -0,0 +1,74 @@+{-|+Module      : Event Data Model facts +Description : Defines the Context type and its component types, constructors, +              and class instances+Copyright   : (c) NoviSci, Inc 2020+License     : BSD3+Maintainer  : bsaul@novisci.com+-}++{-# LANGUAGE NoImplicitPrelude #-}+{-# LANGUAGE Trustworthy #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE TemplateHaskell #-}++module EventData.Context.Domain.Demographics(+      DemographicsFacts(..)+    , DemographicsInfo(..)+    , DemographicsField(..)+    , demo+    , field +    , info+) where++import Prelude                  ( drop, Show, Eq, Maybe )+import Control.Lens             ( makeLenses )+import GHC.Generics             ( Generic )+import Data.Text                ( Text )+import Data.Aeson               ( FromJSON(..)+                                , genericParseJSON+                                , defaultOptions+                                , fieldLabelModifier )  ++newtype DemographicsFacts = +    DemographicsFacts { _demo :: DemographicsInfo+                      } deriving( Eq, Show, Generic )++data DemographicsInfo = +    DemographicsInfo { _field :: DemographicsField+                     , _info :: Maybe Text+                     } deriving ( Eq, Show, Generic )++data DemographicsField =+      BirthYear+    | BirthDate+    | Race+    | RaceCodes+    | Gender+    | Zipcode+    | County+    | CountyFIPS+    | State+    | Ethnicity+    | Region+    | UrbanRural+    | GeoPctAmIndian+    | GeoPctAsian+    | GeoPctBlack+    | GeoPctHispanic+    | GeoPctMutli+    | GeoPctOther+    | GeoPctWhite+    | GeoType+    | GeoAdiStateRank+    | GeoAdiNatRank+    deriving ( Eq, Show, Generic )++makeLenses ''DemographicsFacts+makeLenses ''DemographicsInfo++instance FromJSON DemographicsFacts where+  parseJSON = genericParseJSON defaultOptions{fieldLabelModifier = drop 1}+instance FromJSON DemographicsInfo where+  parseJSON = genericParseJSON defaultOptions{fieldLabelModifier = drop 1}+instance FromJSON DemographicsField where

@@ -0,0 +1,150 @@+{-|+Module      : Define and evaluate Features +Description : Defines the Feature type and its component types, constructors, +              and class instances+Copyright   : (c) NoviSci, Inc 2020+License     : BSD3+Maintainer  : bsaul@novisci.com+-}++{-# LANGUAGE NoImplicitPrelude #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE Safe #-}+{-# LANGUAGE OverloadedStrings #-}++{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE FlexibleInstances #-}++module FeatureCompose(+    -- * Types+      FeatureSpec(..)+    , Feature(..)+    , FeatureData(..)+    , MissingReason(..)+    -- , FeatureDefinition(..)+    , FeatureDefinition(..)+    , makeFeatureSpec+    , featureDataR+    , featureDataL+    , define+    , defineM+    , define2+    , defineM2+    , eval+) where++import safe GHC.Read                   ( Read )+import safe GHC.Show                   ( Show(show) )+import safe GHC.Generics               ( Generic )+import safe Control.Applicative        ( Applicative(..) )+import safe Control.Monad              ( Functor(..), Monad(..), join, liftM, liftM2)+import safe Data.Either                ( Either(..) )+import safe Data.Eq                    ( Eq )+import safe Data.Function              ( ($), (.) )+import safe Data.List                  ( (++), zipWith )+import safe Data.Maybe                 ( Maybe(..), maybe )+import safe Data.Ord                   ( Ord )+import safe Data.Traversable           ( Traversable(..) )+import safe Data.Text                  ( Text )+import safe Data.Tuple                 ( uncurry, curry )++-- import safe Test.QuickCheck       ( Property )++{- | A 'FeatureSpec' contains all the information needed to derive a 'Feature':+      * its name+      * its attributes+      * the function needed to derive a feature (i.e. the 'FeatureDefinition')+-}+data (Show b) => FeatureSpec b di d0 = MkFeatureSpec {+        getSpecName :: Text+      , getSpecAttr :: b+      , getDefn :: FeatureDefinition di d0+      -- To add in future: an optional list of properties to check+      -- , getProp :: Maybe [Feature d -> Events a -> Property] +    }++-- | TODO+makeFeatureSpec :: Show b =>+     Text+  -> b+  -> FeatureDefinition di d0+  -> FeatureSpec b di d0+makeFeatureSpec = MkFeatureSpec++{- | A 'Feature' contains the following:+      * a name+      * its attributes+      * 'FeatureData'+-}+data (Show b) => Feature b d = MkFeature {+        getName :: Text+      , getAttr :: b+      , getData :: FeatureData d+      } deriving (Eq)++instance (Show b, Show d) => Show (Feature b d) where+    show x = "(" ++ show (getName x) ++ ": (" ++ show (getAttr x) ++ ") "  ++ show (getData x) ++ " )\n"++instance (Show b) => Functor (Feature b) where+  fmap f (MkFeature n a d) = MkFeature n a (fmap f d)++{- | 'FeatureData' is @'Either' 'MissingReason' d@, where @d@ can be any type +     of data derivable from 'Hasklepias.Event.Events'.+-}+newtype FeatureData d = MkFeatureData { getFeatureData :: Either MissingReason [d] }+  deriving (Generic, Show, Eq)++instance Functor FeatureData where+  fmap f (MkFeatureData x) = MkFeatureData (fmap (fmap f) x)++instance Applicative FeatureData where+  pure = featureDataR . pure+  liftA2 f (MkFeatureData x) (MkFeatureData y) =+    MkFeatureData ( liftA2 (zipWith f) x y )++instance Monad FeatureData where+  (MkFeatureData x) >>= f = -- TODO: surely there's a cleaner way+    case fmap (fmap f) x of+         Left l  -> featureDataL l+         Right v -> case getFeatureData (sequenceA v) of+                      Left l  -> featureDataL l+                      Right v -> MkFeatureData $ Right (join v)++-- | Create the 'Right' side of 'FeatureData'.+featureDataR :: [d] -> FeatureData d+featureDataR = MkFeatureData . Right++-- | Create the 'Left' side of 'FeatureData'.+featureDataL :: MissingReason -> FeatureData d+featureDataL = MkFeatureData . Left++-- | 'FeatureData' may be missing for any number of reasons. +data MissingReason =+    InsufficientData+  | Excluded+  | Other Text+  | Unknown+  deriving (Eq, Read, Show, Generic)++-- TODO: the code below should be generalized so that there is a single define/eval+--       interface and the recursive structure is realizing and not hacked together.+newtype FeatureDefinition di d0 = MkFeatureDefinition (di -> FeatureData d0)++class Eval di d0 where+  eval :: FeatureDefinition di d0 -> di -> FeatureData d0+  eval (MkFeatureDefinition f) = f++instance Eval (FeatureData d1) d0 where+instance Eval (FeatureData d2, FeatureData d1) d0 where++defineM :: (d1 -> FeatureData d0) -> FeatureDefinition (FeatureData d1) d0+defineM f = MkFeatureDefinition (>>= f)++defineM2 :: (d2 -> d1 -> FeatureData d0) -> FeatureDefinition (FeatureData d2, FeatureData d1) d0+defineM2 f = MkFeatureDefinition (\ (x, y) -> join (liftA2 f x y))++define :: (d1 -> d0) -> FeatureDefinition (FeatureData d1) d0+define f = MkFeatureDefinition (fmap f)++define2 :: (d2 -> d1 -> d0) -> FeatureDefinition (FeatureData d2, FeatureData d1) d0+define2 f = MkFeatureDefinition $ uncurry (liftA2 f)

@@ -0,0 +1,33 @@+{-|+Module      : Functions for encoding Feature data+Description : Defines ToJSON instances for Features.+Copyright   : (c) NoviSci, Inc 2020+License     : BSD3+Maintainer  : bsaul@novisci.com+-}++{-# LANGUAGE OverloadedStrings #-}++module FeatureCompose.Aeson(+) where++import IntervalAlgebra              ( Interval, Intervallic(end, begin) )+import FeatureCompose               ( Feature(..)+                                    , MissingReason+                                    , FeatureData(..) )+import Data.Aeson                   ( object, KeyValue((.=)), ToJSON(toJSON) )++instance (ToJSON a, Ord a, Show a)=> ToJSON (Interval a) where+    toJSON x = object ["begin" .= begin x, "end" .= end x]++instance ToJSON MissingReason ++instance (ToJSON d)=> ToJSON (FeatureData d) where+    toJSON  x = case getFeatureData x of +      (Left l)  -> toJSON l+      (Right r) -> toJSON r++instance (Show b, ToJSON b, ToJSON d) => ToJSON (Feature b d) where+    toJSON x = object [ "name"   .= getName x+                       , "attrs" .= toJSON (getAttr x)+                       , "data"  .= toJSON (getData x) ]

@@ -0,0 +1,78 @@+{-|+Module      : Feature Building Criteria+Description : Defines the Feature type and its component types, constructors, +              and class instances+Copyright   : (c) NoviSci, Inc 2020+License     : BSD3+Maintainer  : bsaul@novisci.com+-}++{-# LANGUAGE NoImplicitPrelude #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE Safe #-}++module FeatureCompose.Criteria(+      Criterion(..)+    , Criteria(..)+    , Status(..)+    , getBools+    , include+    , exclude+    , collectBools+    , evalBools+    , runCriteria+) where++import safe GHC.Int                    ( Int )+import safe GHC.Num                    ( Num((+)) )+import safe GHC.Show                   ( Show(show) )+import safe Control.Monad              ( Functor(..) )+import safe Data.Bool                  ( Bool(..), otherwise, not, (&&) )+import safe Data.Either                ( Either(..), partitionEithers )+import safe Data.Eq                    ( Eq(..) )+import safe Data.Function              ( ($), (.) )+import safe Data.List                  ( all, transpose, null, elemIndex )+import safe Data.Maybe                 ( Maybe(..), maybe )+import safe Data.Tuple                 ( fst, snd )+import safe Data.Text                  ( Text )+import safe FeatureCompose++data Criterion b =+      Inclusion (Feature b Bool)+    | Exclusion (Feature b Bool)+    deriving (Show, Eq)++newtype Criteria b = MkCriteria [Criterion b] deriving (Show)++data Status = Included | ExcludedBy Int deriving (Show, Eq)++statusMay :: Maybe Int -> Status+statusMay (Just i) = ExcludedBy i+statusMay Nothing  = Included++getBools :: (Show b) => Criterion b -> FeatureData Bool+getBools (Inclusion x) = getData x+getBools (Exclusion x) = fmap not (getData x)++include :: (Show b) => Feature b Bool -> Criterion b+include = Inclusion++exclude :: (Show b) => Feature b Bool -> Criterion b+exclude = Exclusion++collectBools :: (Show b) => Criteria b -> [FeatureData Bool]+collectBools (MkCriteria x) = fmap getBools x++runBools :: [[Bool]] -> [Status]+runBools l = fmap (statusMay . fmap (+1) . elemIndex False) (transpose l)++-- | TODO: what happens if the feature data lists are not the same length or empty(?)+--         this should get handled in a safer way.+evalBools :: [FeatureData Bool] -> FeatureData Status+evalBools fs+    | null (fst bools) = featureDataR $ runBools (snd bools)+    | otherwise        = featureDataL Excluded+    where bools = partitionEithers $ fmap getFeatureData fs++runCriteria :: (Show b) => Criteria b -> FeatureData Status+runCriteria  = evalBools . collectBools

@@ -0,0 +1,140 @@+{-|+Module      : Functions for composing features from events  +Description : Functions for composing features. +Copyright   : (c) NoviSci, Inc 2020+License     : BSD3+Maintainer  : bsaul@novisci.com++Provides functions used in defining 'Feature's.+-}++{-# LANGUAGE NoImplicitPrelude #-}+{-# LANGUAGE FlexibleContexts #-}+-- {-# LANGUAGE Safe #-}++module FeatureEvents(++    -- * Container predicates+      isNotEmpty+    , atleastNofX+    , twoXOrOneY++    -- * Finding occurrences of concepts+    , nthConceptOccurrence+    , firstConceptOccurrence++    -- * Reshaping containers+    , allPairs+    , splitByConcepts++    -- * Create filters+    , makeConceptsFilter+    , makePairedFilter+) where++import Data.Text                            ( Text )+import Control.Applicative                  ( Applicative(liftA2) )+import IntervalAlgebra                      ( Intervallic(..)+                                            , ComparativePredicateOf1+                                            , ComparativePredicateOf2+                                            , Interval )+import IntervalAlgebra.PairedInterval       ( PairedInterval, getPairData )+-- import IntervalAlgebra.IntervalUtilities    ( compareIntervals )+import EventData                            ( Events+                                            , Event+                                            , ConceptEvent+                                            , ctxt )+import EventData.Context                    ( Concept+                                            , Concepts+                                            , Context+                                            , HasConcept( hasConcepts ) )+import Safe                                 ( headMay, lastMay ) +import Data.Bool                       ( Bool, (&&), not, (||) )+import Data.Function                   ( (.), ($) )+import Data.Int                        ( Int )+import Data.List                       ( filter, length, null )+import Data.Maybe                      ( Maybe(..) )+import Data.Ord                        ( Ord((>=)) )+++-- | Is the input list empty? +isNotEmpty :: [a] -> Bool+isNotEmpty = not.null++-- | Filter 'Events' to those that have any of the provided concepts.+makeConceptsFilter ::+       [Text]    -- ^ the list of concepts by which to filter +    -> Events a+    -> Events a+makeConceptsFilter cpts = filter (`hasConcepts` cpts)++-- | Filter 'Events' to a single @'Maybe' 'Event'@, based on a provided function,+--   with the provided concepts. For example, see 'firstConceptOccurrence' and+--  'lastConceptOccurrence'.+nthConceptOccurrence ::+       (Events a -> Maybe (Event a)) -- ^ function used to select a single event+    -> [Text]+    -> Events a+    -> Maybe (Event a)+nthConceptOccurrence f c = f.makeConceptsFilter c++-- | Finds the *first* occurrence of an 'Event' with at least one of the concepts.+--   Assumes the input 'Events' list is appropriately sorted.+firstConceptOccurrence ::+      [Text]+    -> Events a+    -> Maybe (Event a)+firstConceptOccurrence = nthConceptOccurrence headMay++-- | Finds the *last* occurrence of an 'Event' with at least one of the concepts.+--   Assumes the input 'Events' list is appropriately sorted.+lastConceptOccurrence ::+      [Text]+    -> Events a+    -> Maybe (Event a)+lastConceptOccurrence = nthConceptOccurrence lastMay++-- | Does 'Events' have at least @n@ events with any of the Concept in @x@.+atleastNofX ::+      Int -- ^ n+   -> [Text] -- ^ x+   -> Events a -> Bool+atleastNofX n x es = length (makeConceptsFilter x es) >= n++-- | TODO+twoXOrOneY :: [Text] -> [Text] -> Events a -> Bool+twoXOrOneY x y es = atleastNofX 2 x es ||+                    atleastNofX 1 y es++-- | Takes a predicate of intervals and a predicate on the data part of a +--   paired interval to create a single predicate such that both input+--   predicates should hold.+makePairPredicate ::  Ord a =>+       ComparativePredicateOf2 (i0 a) ((PairedInterval b) a)+    -> i0 a+    -> (b -> Bool)+    -> (PairedInterval b a -> Bool)+makePairPredicate pi i pd x =  pi i x && pd (getPairData x)++-- | +makePairedFilter :: Ord a => +       ComparativePredicateOf2 (i0 a) ((PairedInterval b) a)+    -> i0 a+    -> (b -> Bool)+    -> [PairedInterval b a]+    -> [PairedInterval b a]+makePairedFilter fi i fc = filter (makePairPredicate fi i fc)++-- | Generate all pair-wise combinations from two lists.+allPairs :: [a] -> [b] -> [(a, b)]+allPairs = liftA2 (,)++-- | Split an @Events a@ into a pair of @Events a@. The first element contains+--   events have any of the concepts in the first argument, similarly for the+--   second element.+splitByConcepts :: [Text] +        -> [Text]+        -> Events a+        -> (Events a, Events a)+splitByConcepts c1 c2 es = ( filter (`hasConcepts` c1) es+                           , filter (`hasConcepts` c2) es)

@@ -8,17 +8,33 @@ -}  module Hasklepias (-      module Hasklepias.Types-    , module Hasklepias.Functions+      module EventData+    , module EventData.Aeson+    , module EventData.Context+    , module EventData.Context.Domain+    , module FeatureCompose+    , module FeatureCompose.Criteria+    , module FeatureCompose.Aeson+    , module FeatureEvents     , module Hasklepias.Reexports     , module IntervalAlgebra     , module IntervalAlgebra.IntervalUtilities     , module IntervalAlgebra.PairedInterval+    , module Hasklepias.Cohort+    , module Hasklepias.Aeson ) where  import IntervalAlgebra import IntervalAlgebra.IntervalUtilities import IntervalAlgebra.PairedInterval-import Hasklepias.Types-import Hasklepias.Functions+import EventData+import EventData.Aeson+import EventData.Context+import EventData.Context.Domain+import FeatureCompose+import FeatureCompose.Aeson+import FeatureCompose.Criteria+import FeatureEvents import Hasklepias.Reexports+import Hasklepias.Cohort+import Hasklepias.Aeson

@@ -0,0 +1,65 @@+{-|+Module      : Functions for Parsing Hasklepias populations +Description : Defines FromJSON instances for Hasklepias populations .+Copyright   : (c) NoviSci, Inc 2020+License     : BSD3+Maintainer  : bsaul@novisci.com+-}+{-# LANGUAGE NoImplicitPrelude #-}+{-# LANGUAGE FlexibleInstances, OverloadedStrings #-}+{-# LANGUAGE UndecidableInstances #-}++module Hasklepias.Aeson(+      parsePopulationIntLines+    , parsePopulationDayLines+) where++import IntervalAlgebra+import EventData+import EventData.Aeson +import Hasklepias.Cohort+import Data.Aeson                           ( FromJSON(..)+                                            , eitherDecode+                                            , Value(Array))+import qualified Data.ByteString.Lazy as B  ( fromStrict+                                            , toStrict+                                            , ByteString)+import qualified Data.ByteString.Char8 as C ( lines )+import Prelude                              ( (<$>), (<*>), ($), fmap+                                            , Int, String, Ord, Show)+import Data.Either                          ( Either, rights )+import Data.List                            ( sort, (++) )+import qualified Data.Map.Strict as M       ( toList, fromListWith)+import Data.Vector                          ( (!) )+import Data.Time.Calendar                   ( Day )++newtype SubjectEvent a = MkSubjectEvent (ID, Event a)++subjectEvent :: ID -> Event a -> SubjectEvent a+subjectEvent x y = MkSubjectEvent (x, y)++instance (FromJSON a, Show a, IntervalSizeable a b) => FromJSON (SubjectEvent a) where+    parseJSON (Array v) = subjectEvent <$> +        parseJSON (v ! 0) <*> (event <$> parseJSON (v ! 5) <*> parseJSON (Array v))++mapIntoPop :: (Ord a) => [SubjectEvent a] -> Population (Events a)+mapIntoPop l = MkPopulation $ +    fmap (\(id, es) -> MkSubject (id, sort es)) -- TODO: is there a way to avoid the sort+        (M.toList $ M.fromListWith (++) (fmap (\(MkSubjectEvent (id, e)) -> (id, [e])) l ))++-- |  Parse @Event Int@ from json lines.+parsePopulationLines :: +    (FromJSON a, Show a, IntervalSizeable a b) => +        B.ByteString -> Population (Events a)+parsePopulationLines l =+    mapIntoPop $ rights $ fmap +    (\x -> eitherDecode $ B.fromStrict x :: (FromJSON a, Show a, IntervalSizeable a b) => Either String (SubjectEvent a))+        (C.lines $ B.toStrict l)+++parsePopulationIntLines :: B.ByteString -> Population (Events Int)+parsePopulationIntLines = parsePopulationLines++-- |  Parse @Event Day@ from json lines.+parsePopulationDayLines :: B.ByteString -> Population (Events Day)+parsePopulationDayLines = parsePopulationLines

@@ -0,0 +1,57 @@+{-|+Module      : Hasklepias Subject Type+Description : Defines the Subject type+Copyright   : (c) NoviSci, Inc 2020+License     : BSD3+Maintainer  : bsaul@novisci.com+-}+{-# LANGUAGE NoImplicitPrelude #-}+{-# LANGUAGE DeriveGeneric #-}++module Hasklepias.Cohort(+      Subject(..)+    , ID+    , Population(..)+    , ObsUnit(..)+    , Cohort(..)+    , makeObsUnitFeatures+    , makeCohort+) where++import Prelude                  ( Eq, Show, Functor(..) )     +import Data.Aeson               ( FromJSON, ToJSON )        +import Data.Text                ( Text )+import GHC.Generics             ( Generic)++type ID = Text+newtype Subject d = MkSubject (ID, d)+    deriving (Eq, Show, Generic)++instance Functor Subject where+    fmap f (MkSubject (id, x)) = MkSubject (id, f x)++instance (FromJSON d) => FromJSON (Subject d) where++newtype Population d = MkPopulation [Subject d]+    deriving (Eq, Show, Generic)++instance (FromJSON d) => FromJSON (Population d) where++instance Functor Population where+    fmap f (MkPopulation x) = MkPopulation (fmap (fmap f) x)++newtype ObsUnit d = MkObsUnit (ID, d)+    deriving (Eq, Show, Generic)++instance (ToJSON d) => ToJSON (ObsUnit d) where++newtype Cohort d = MkCohort [ObsUnit d]+    deriving (Eq, Show, Generic)++instance (ToJSON d) => ToJSON (Cohort d) where++makeObsUnitFeatures :: (d1 -> d0) -> Subject d1 -> ObsUnit d0 +makeObsUnitFeatures f (MkSubject (id, dat)) = MkObsUnit (id, f dat)++makeCohort :: (d1 -> d0) -> Population d1 -> Cohort d0+makeCohort f (MkPopulation x) = MkCohort (fmap (makeObsUnitFeatures f) x)

@@ -1,140 +0,0 @@-{-|-Module      : Hasklepias Feature building functions -Description : Functions for composing features. -Copyright   : (c) NoviSci, Inc 2020-License     : BSD3-Maintainer  : bsaul@novisci.com--Provides functions used in defining 'Feature's.--}--{-# LANGUAGE NoImplicitPrelude #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE Safe #-}--module Hasklepias.Functions(--    -- * Container predicates-      isNotEmpty-    , atleastNofX-    , twoXOrOneY--    -- * Finding occurrences of concepts-    , nthConceptOccurrence-    , firstConceptOccurrence--    -- * Reshaping containers-    , allPairs-    , splitByConcepts--    -- * Create filters-    , makeConceptsFilter-    , makePairedFilter-) where--import Data.Text                            ( Text )-import Control.Applicative                  ( Applicative(liftA2) )-import IntervalAlgebra                      ( Intervallic(..)-                                            , ComparativePredicateOf1-                                            , ComparativePredicateOf2-                                            , Interval )-import IntervalAlgebra.PairedInterval       ( PairedInterval, getPairData )--- import IntervalAlgebra.IntervalUtilities    ( compareIntervals )-import Hasklepias.Types.Event               ( Events-                                            , Event-                                            , ConceptEvent-                                            , ctxt )-import Hasklepias.Types.Context             ( Concept-                                            , Concepts-                                            , Context-                                            , HasConcept( hasConcepts ) )-import Safe                                 ( headMay, lastMay ) -import safe Data.Bool                       ( Bool, (&&), not, (||) )-import safe Data.Function                   ( (.), ($) )-import safe Data.Int                        ( Int )-import safe Data.List                       ( filter, length, null )-import safe Data.Maybe                      ( Maybe(..) )-import safe Data.Ord                        ( Ord((>=)) )----- | Is the input list empty? -isNotEmpty :: [a] -> Bool-isNotEmpty = not.null---- | Filter 'Events' to those that have any of the provided concepts.-makeConceptsFilter ::-       [Text]    -- ^ the list of concepts by which to filter -    -> Events a-    -> Events a-makeConceptsFilter cpts = filter (`hasConcepts` cpts)---- | Filter 'Events' to a single @'Maybe' 'Event'@, based on a provided function,---   with the provided concepts. For example, see 'firstConceptOccurrence' and---  'lastConceptOccurrence'.-nthConceptOccurrence ::-       (Events a -> Maybe (Event a)) -- ^ function used to select a single event-    -> [Text]-    -> Events a-    -> Maybe (Event a)-nthConceptOccurrence f c = f.makeConceptsFilter c---- | Finds the *first* occurrence of an 'Event' with at least one of the concepts.---   Assumes the input 'Events' list is appropriately sorted.-firstConceptOccurrence ::-      [Text]-    -> Events a-    -> Maybe (Event a)-firstConceptOccurrence = nthConceptOccurrence headMay---- | Finds the *last* occurrence of an 'Event' with at least one of the concepts.---   Assumes the input 'Events' list is appropriately sorted.-lastConceptOccurrence ::-      [Text]-    -> Events a-    -> Maybe (Event a)-lastConceptOccurrence = nthConceptOccurrence lastMay---- | Does 'Events' have at least @n@ events with any of the Concept in @x@.-atleastNofX ::-      Int -- ^ n-   -> [Text] -- ^ x-   -> Events a -> Bool-atleastNofX n x es = length (makeConceptsFilter x es) >= n---- | TODO-twoXOrOneY :: [Text] -> [Text] -> Events a -> Bool-twoXOrOneY x y es = atleastNofX 2 x es ||-                    atleastNofX 1 y es---- | Takes a predicate of intervals and a predicate on the data part of a ---   paired interval to create a single predicate such that both input---   predicates should hold.-makePairPredicate ::  Ord a =>-       ComparativePredicateOf2 (i0 a) ((PairedInterval b) a)-    -> i0 a-    -> (b -> Bool)-    -> (PairedInterval b a -> Bool)-makePairPredicate pi i pd x =  pi i x && pd (getPairData x)---- | -makePairedFilter :: Ord a => -       ComparativePredicateOf2 (i0 a) ((PairedInterval b) a)-    -> i0 a-    -> (b -> Bool)-    -> [PairedInterval b a]-    -> [PairedInterval b a]-makePairedFilter fi i fc = filter (makePairPredicate fi i fc)---- | Generate all pair-wise combinations from two lists.-allPairs :: [a] -> [b] -> [(a, b)]-allPairs = liftA2 (,)---- | Split an @Events a@ into a pair of @Events a@. The first element contains---   events have any of the concepts in the first argument, similarly for the---   second element.-splitByConcepts :: [Text] -        -> [Text]-        -> Events a-        -> (Events a, Events a)-splitByConcepts c1 c2 es = ( filter (`hasConcepts` c1) es-                           , filter (`hasConcepts` c2) es)

@@ -54,6 +54,7 @@                                             , length                                             , null                                             , zipWith+                                            , sort                                             , (++) ) import safe Data.Maybe                      ( Maybe(..),                                               maybe,

@@ -1,20 +0,0 @@-{-|-Module      : Hasklepias Types-Description : Re-exports all the Hasklepias type modules-Copyright   : (c) NoviSci, Inc 2020-License     : BSD3-Maintainer  : bsaul@novisci.com--}--module Hasklepias.Types (-      module Hasklepias.Types.Context-    , module Hasklepias.Types.Event-    , module Hasklepias.Types.Feature-    , module Hasklepias.Types.Event.Arbitrary- -) where--import Hasklepias.Types.Event-import Hasklepias.Types.Event.Arbitrary-import Hasklepias.Types.Context-import Hasklepias.Types.Feature

@@ -1,132 +0,0 @@-{-|-Module      : Hasklepias Contexts-Description : Defines the Context type and its component types, constructors, -              and class instances-Copyright   : (c) NoviSci, Inc 2020-License     : BSD3-Maintainer  : bsaul@novisci.com--}--{-# LANGUAGE NoImplicitPrelude #-}-{-# LANGUAGE Safe #-}--module Hasklepias.Types.Context(-    Context(getConcepts)-  , context-  , emptyContext--  , Concept-  , Concepts-  , toConcepts-  , fromConcepts-  , packConcept-  , unpackConcept-  , packConcepts-  , unpackConcepts-  , HasConcept(..)-) where--import GHC.Show                 ( Show(show) )-import Data.Bool                ( Bool )-import Data.Eq                  ( Eq )-import Data.Function            ( (.), ($) )-import Data.List                ( all, any, map )-import Data.Maybe               ( Maybe(Nothing) )-import Data.Monoid              ( (<>), Monoid(mempty) )-import Data.Ord                 ( Ord )-import Data.Semigroup           ( Semigroup((<>)) )-import Data.Text                ( Text )-import Data.Set                 ( Set-                                , fromList, union, empty, map, toList, member)---- | A @Context@ consists of three parts: @concepts@, @facts@, and @source@. --- --- At this time, @facts@ and @source@ are simply stubs to be fleshed out in --- later versions of hasklepias. -data Context = Context {-      getConcepts :: Concepts-    , getFacts    :: Maybe Facts-    , getSource   :: Maybe Source-} deriving (Eq, Show)--data Facts  = Facts  deriving (Eq, Show)-data Source = Source deriving (Eq, Show)--instance Semigroup Context where-    x <> y = Context (getConcepts x <> getConcepts y) Nothing Nothing--instance Monoid Context where-    mempty = emptyContext--instance HasConcept Context where-    hasConcept ctxt concept = -        member (packConcept concept) (fromConcepts $ getConcepts ctxt)---- | Smart contructor for Context type------ Creates 'Context' from a list of 'Concept's. At this time, the @facts@ and--- @source@ are both set to 'Nothing'.-context :: Concepts -> Context-context x = Context x Nothing Nothing---- | Just an empty Context-emptyContext :: Context-emptyContext = Context mempty Nothing Nothing---- | A @Concept@ is textual "tag" for a context.-newtype Concept = Concept Text deriving (Eq, Ord)--instance Show Concept where-    show (Concept x) = show x---- | Pack text into a concept-packConcept :: Text -> Concept-packConcept = Concept---- | Unpack text from a concept-unpackConcept :: Concept -> Text -unpackConcept (Concept x) =  x---- | @Concepts@ is a 'Set' of 'Concepts's.-newtype Concepts = Concepts ( Set Concept )-    deriving (Eq, Show)--instance Semigroup Concepts where-    Concepts x <> Concepts y = Concepts (x <> y)--instance Monoid Concepts where-    mempty = Concepts mempty---- | Constructor for 'Concepts'.-toConcepts :: Set Concept -> Concepts-toConcepts = Concepts--fromConcepts :: Concepts -> Set Concept-fromConcepts (Concepts x) = x---- | Put a list of text into a set concepts.-packConcepts :: [Text] -> Concepts-packConcepts x = Concepts $ fromList $ Data.List.map packConcept x---- | Take a set of concepts to a list of text.-unpackConcepts :: Concepts -> [Text]-unpackConcepts (Concepts x) = toList $ Data.Set.map unpackConcept x --{- |-The 'HasConcept' typeclass provides predicate functions for determining whether-an @a@ has a concept.--}-class HasConcept a where-    -- | Does an @a@ have a particular 'Concept'?-    hasConcept  :: a -> Text -> Bool--    -- | Does an @a@ have *any* of a list of 'Concept's?-    hasConcepts :: a -> [Text] -> Bool-    hasConcepts x = any (\c -> x `hasConcept` c)--    -- | Does an @a@ have *all* of a list of `Concept's?-    hasAllConcepts :: a -> [Text] -> Bool-    hasAllConcepts x = all (\c -> x `hasConcept` c) --instance HasConcept Concepts where-    hasConcept (Concepts e) concept = member (packConcept concept) e

@@ -1,39 +0,0 @@-{-|-Module      : Generate arbitrary events-Description : Functions for generating arbitrary events-Copyright   : (c) NoviSci, Inc 2020-License     : BSD3-Maintainer  : bsaul@novisci.com--}--{-# LANGUAGE NoImplicitPrelude #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE Safe #-}--module Hasklepias.Types.Context.Arbitrary() where--import Test.QuickCheck              ( Arbitrary(arbitrary), elements, sublistOf ) -import Data.Function                ( (.) )-import Data.Functor                 ( Functor(fmap) )-import Data.List                    ( map )-import Data.Set                     ( fromList )-import Hasklepias.Types.Context     ( Concept-                                    , Concepts-                                    , Context-                                    , context-                                    , toConcepts-                                    , packConcepts-                                    , packConcept)--conceptChoices :: [Concept]-conceptChoices = map packConcept ["A", "B", "C", "D", "E", "F", "G", "H", "I", "J"]--instance Arbitrary Concept where-    arbitrary = elements conceptChoices--instance Arbitrary Context where-    arbitrary = fmap (context . toConcepts . fromList) (sublistOf conceptChoices)---- instance Arbitrary Concepts where---     arbitrary = fmap fromList (sublistOf conceptChoices)-

@@ -1,95 +0,0 @@-{-|-Module      : Hasklepias Event Type-Description : Defines the Event type and its component types, constructors, -              and class instance-Copyright   : (c) NoviSci, Inc 2020-License     : BSD3-Maintainer  : bsaul@novisci.com--}-{-# LANGUAGE NoImplicitPrelude #-}-{-# LANGUAGE TypeSynonymInstances #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE Safe #-}--module Hasklepias.Types.Event(-   Event- , Events- , ConceptEvent- , event- , ctxt- , toConceptEvent- , toConceptEventOf- , mkConceptEvent-) where--import GHC.Show                         ( Show(show) )-import Data.Function                    ( ($) )-import Data.Set                         ( member, fromList, intersection )-import Data.Ord                         ( Ord )-import IntervalAlgebra                  ( Interval-                                        , Intervallic-                                        , Intervallic (getInterval) )-import IntervalAlgebra.PairedInterval   ( PairedInterval-                                        , makePairedInterval-                                        , getPairData )-import Hasklepias.Types.Context         ( HasConcept(..)-                                        , Concepts-                                        , Concept-                                        , packConcept-                                        , Context (getConcepts)-                                        , fromConcepts-                                        , toConcepts )----- | An Event @a@ is simply a pair @(Interval a, Context)@.-type Event a = PairedInterval Context a---- instance (Ord a, Show a) => Show (Event a) where---   show x = "{" ++ show (getInterval x) ++ ", " ++ show (ctxt x) ++ "}"--instance HasConcept (Event a) where-    hasConcept x y = ctxt x `hasConcept` y---- | A smart constructor for 'Event a's.-event :: Interval a -> Context -> Event a-event i c = makePairedInterval c i---- | Access the 'Context' of an 'Event a'.-ctxt :: Event a -> Context-ctxt = getPairData---- | An event containing only concepts and an interval-type ConceptEvent a = PairedInterval Concepts a---- instance (Ord a, Show a) => Show (ConceptEvent a) where---   show x = "{" ++ show (getInterval x) ++ ", " ++ show (getPairData x) ++ "}"--instance HasConcept (ConceptEvent a) where-    hasConcept e concept = member (packConcept concept) (fromConcepts $ getPairData e)---- | Drops an @Event@ to a @ConceptEvent@ by moving the concepts in the data---   position in the paired interval and throwing out the facts and source.-toConceptEvent :: (Show a, Ord a) => Event a -> ConceptEvent a-toConceptEvent e = makePairedInterval (getConcepts $ ctxt e) (getInterval e)--toConceptEventOf :: (Show a, Ord a) => [Concept] -> Event a -> ConceptEvent a-toConceptEventOf cpts e =-    makePairedInterval-        (toConcepts $ intersection (fromList cpts) (fromConcepts $ getConcepts $ ctxt e))-        (getInterval e)---- |-mkConceptEvent :: (Show a, Ord a) => Interval a -> Concepts -> ConceptEvent a-mkConceptEvent i c = makePairedInterval c i---- | A @List@ of @Event a@--- --- NOTE (20190911): I (B. Saul) am starting out the Events type as a --- list of the Event type. This may be not be the optimal approach,--- especially with regards to lookup/filtering the list. Ideally,--- we could do one pass through the ordered container (whatever it is)--- to identify events by concept; rather than repeated evaluations of--- the lookup predicates. This could be handled by, for example, --- representing Events has a Map with a list of concept indices. --- But this gets us off the ground.-type Events a = [Event a]

@@ -1,80 +0,0 @@-{-|-Module      : Functions for Parsing Hasklepias Event data-Description : Defines FromJSON instances for Events.-Copyright   : (c) NoviSci, Inc 2020-License     : BSD3-Maintainer  : bsaul@novisci.com--}-{-# LANGUAGE FlexibleInstances, OverloadedStrings #-}--module Hasklepias.Types.Event.Aeson(-      parseEventIntLines-    , parseEventDayLines-) where--import IntervalAlgebra-    ( beginerval, Interval, IntervalSizeable(diff) )-import Hasklepias.Types.Context-    ( Concepts, Concept, Context, context, packConcept, toConcepts )-import Hasklepias.Types.Event ( Event, event )-import Data.Aeson-    ( eitherDecode,-      (.:),-      withObject,-      FromJSON(parseJSON),-      Value(Array) )-import Data.Time ( Day )-import Data.Vector ((!))-import qualified Data.ByteString.Lazy as B-import qualified Data.ByteString.Char8 as C-import Data.Either (rights, fromRight)--instance FromJSON (Interval Int) where-    parseJSON = withObject "Time" $ \o -> do-        t <- o .: "time"-        b <- t .: "begin"-        e <- t .: "end"-        return $ beginerval (diff e b) b-        --(parseInterval (b :: Day) (e :: Day))--instance FromJSON (Interval Day) where-    parseJSON = withObject "Time" $ \o -> do-        t <- o .: "time"-        b <- t .: "begin"-        e <- t .: "end"-        return  $ beginerval (diff e b) b -        --(parseInterval (b :: Day) (e :: Day))--instance FromJSON Concept where-    parseJSON c = packConcept <$> parseJSON  c--instance FromJSON Concepts where-    parseJSON c = toConcepts <$> parseJSON c--instance FromJSON Context where-    parseJSON v = context <$> parseJSON v--instance FromJSON (Event Int) where-    parseJSON (Array v) = event <$>-            parseJSON (v ! 5) <*>-            parseJSON (v ! 4)--instance FromJSON (Event Day) where-    parseJSON (Array v) = event <$>-            parseJSON (v ! 5) <*>-            parseJSON (v ! 4)---- |  Parse @Event Int@ from json lines.--- --- This function and the event parsing in general needs a lot of work to be --- production-ready. But this is good enough for prototyping.-parseEventIntLines :: B.ByteString -> [Event Int]-parseEventIntLines l =-    rights $ map (\x -> eitherDecode $ B.fromStrict x :: Either String (Event Int))-        (C.lines $ B.toStrict l)---- |  Parse @Event Day@ from json lines.-parseEventDayLines :: B.ByteString -> [Event Day]-parseEventDayLines l =-    rights $ map (\x -> eitherDecode $ B.fromStrict x :: Either String (Event Day))-        (C.lines $ B.toStrict l)

@@ -1,48 +0,0 @@-{-|-Module      : Generate arbitrary events-Description : Functions for generating arbitrary events-Copyright   : (c) NoviSci, Inc 2020-License     : BSD3-Maintainer  : bsaul@novisci.com-Stability   : experimental--}-{-# LANGUAGE NoImplicitPrelude #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE FlexibleContexts #-}-module Hasklepias.Types.Event.Arbitrary(-     generateEventsInt-) where--import Test.QuickCheck (-    Arbitrary(arbitrary, shrink)-    , Gen-    , sample'-    , sample-    , generate-    , resize-    , suchThat -    , orderedList  )-import GHC.Show ( Show )-import GHC.IO ( IO )-import Control.Monad ( Functor(fmap), liftM2 )-import Data.Eq ( Eq((==)) )-import Data.Function (($))-import Data.Int ( Int )-import Data.Ord ( Ord )-import Data.List(length)-import IntervalAlgebra ( Interval )-import IntervalAlgebra.Arbitrary ()-import Hasklepias.Types.Event-    ( event, Event, ConceptEvent, toConceptEvent )-import Hasklepias.Types.Context.Arbitrary ()--instance (Arbitrary (Interval a)) => Arbitrary (Event a) where-    arbitrary = liftM2 event arbitrary arbitrary--instance (Ord a, Show a, Arbitrary (Interval a)) => Arbitrary (ConceptEvent a) where-    arbitrary = fmap toConceptEvent arbitrary---- | Generate @n@ @Event Int@-generateEventsInt :: Int -> IO [Event Int]-generateEventsInt i = -    generate $ suchThat (orderedList :: Gen [Event Int]) (\x -> length x == i)

@@ -1,179 +0,0 @@-{-|-Module      : Hasklepias Feature Type-Description : Defines the Feature type and its component types, constructors, -              and class instances-Copyright   : (c) NoviSci, Inc 2020-License     : BSD3-Maintainer  : bsaul@novisci.com--}--{-# LANGUAGE NoImplicitPrelude #-}-{-# LANGUAGE DeriveGeneric #-}-{-# LANGUAGE Safe #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE OverloadedStrings #-}--module Hasklepias.Types.Feature(-    -- * Types-      FeatureSpec(..)-    , Feature(..)-    , FeatureData(..)-    , MissingReason(..)-    , FeatureDefinition(..)-    , makeFeatureSpec-    , featureDataR-    , featureDataL-    , define0-    , define1-    , define1d-    , define2-    , define2d-    , eval0-    , eval1-    , eval2-    , evalSpec0-    , evalSpec1-    , evalSpec2-) where--import safe GHC.Read                   ( Read )-import safe GHC.Show                   ( Show(show) )-import safe GHC.Generics               ( Generic, D )-import safe Control.Applicative        ( Applicative(..) )-import safe Control.Monad              ( Functor(..), Monad(..), join, liftM, liftM2)-import safe Data.Either                ( Either(..) )-import safe Data.Eq                    ( Eq )-import safe Data.Function              ( ($), (.) )-import safe Data.List             ( (++) )-import safe Data.Maybe                 ( Maybe(..), maybe )-import safe Data.Ord                   ( Ord )-import safe Data.Text                  ( Text )--- import safe Test.QuickCheck       ( Property )--{- | A 'FeatureSpec' contains all the information needed to derive a 'Feature':-      * its name-      * its attributes-      * the function needed to derive a feature (i.e. the 'FeatureDefinition')--}-data (Show b) => FeatureSpec b f e d = MkFeatureSpec {-        getSpecName :: Text-      , getSpecAttr :: b-      , getDefn :: FeatureDefinition f e d-      -- To add in future: an optional list of properties to check-      -- , getProp :: Maybe [Feature d -> Events a -> Property] -    }---- | TODO-makeFeatureSpec :: Show b =>-     Text-  -> b-  -> FeatureDefinition f e d-  -> FeatureSpec b f e d-makeFeatureSpec = MkFeatureSpec--{- | A 'Feature' contains the following:-      * a name-      * its attributes-      * 'FeatureData'--}-data (Show b) => Feature b d = MkFeature {-        getName :: Text-      , getAttr :: b-      , getData :: FeatureData d-      } deriving (Eq)--instance (Show b, Show d) => Show (Feature b d) where-    show x = "(" ++ show (getName x) ++ ": (" ++ show (getAttr x) ++ ") "  ++ show (getData x) ++ " )\n"--instance (Show b) => Functor (Feature b) where-  fmap f (MkFeature n a d) = MkFeature n a (fmap f d)--{- | 'FeatureData' is @'Either' 'MissingReason' d@, where @d@ can be any type -     of data derivable from 'Hasklepias.Event.Events'.--}-newtype FeatureData d = MkFeatureData { getFeatureData :: Either MissingReason d }-  deriving (Generic, Show, Eq)--instance Functor FeatureData where-  fmap f (MkFeatureData x) = MkFeatureData (fmap f x)--instance Applicative FeatureData where-  pure = featureDataR-  liftA2 f (MkFeatureData x) (MkFeatureData y) = MkFeatureData ( liftA2 f x y )--instance Monad FeatureData where-  (MkFeatureData x) >>= f = -    case fmap f x of-         Left l  -> featureDataL l-         Right v -> v---- | Create the 'Right' side of 'FeatureData'.-featureDataR :: d -> FeatureData d-featureDataR = MkFeatureData . Right---- | Create the 'Left' side of 'FeatureData'.-featureDataL :: MissingReason -> FeatureData d-featureDataL = MkFeatureData . Left---- | 'FeatureData' may be missing for any number of reasons. -data MissingReason =-    InsufficientData-  | Excluded-  | Other Text-  | Unknown-  deriving (Eq, Read, Show, Generic)---- TODO: the code below should be generalized so that there is a single define/eval---       interface.--- | A type to hold FeatureData definitions; i.e. functions that return ---  features. -data FeatureDefinition f e d =-    FD0 (e -> FeatureData d)-  | FD1 (FeatureData e -> FeatureData d)-  | FD2 (FeatureData f -> FeatureData e -> FeatureData d)---- | TODO-define0 :: (e -> FeatureData d) -> FeatureDefinition * e d-define0 = FD0---- | TODO-eval0 :: FeatureDefinition * e d -> e -> FeatureData d-eval0 (FD0 f) = f---- | TODO-evalSpec0 :: (Show b) => FeatureSpec b * e d -> e -> Feature b d-evalSpec0 (MkFeatureSpec nm attr def) y = MkFeature nm attr (eval0 def y)---- | TODO-define1 :: (e -> d) -> FeatureDefinition * e d-define1 f = FD1 $ fmap f---- | TODO-define1d :: (e -> FeatureData d) -> FeatureDefinition * e d-define1d f = FD1 (>>= f)---- | TODO-eval1 :: FeatureDefinition * e d -> FeatureData e -> FeatureData d-eval1 (FD1 f) = f---- | TODO-evalSpec1 :: (Show b) => FeatureSpec b * e d -> Feature b e -> Feature b d-evalSpec1 (MkFeatureSpec nm attr def) y = MkFeature nm attr (eval1 def (getData y))---- | TODO-define2 :: (f -> e -> d) -> FeatureDefinition f e d-define2 f =  FD2 $ liftA2 f---- | TODO-define2d :: (f -> e -> FeatureData d) -> FeatureDefinition f e d-define2d f = FD2 (\x y -> join (liftM2 f x y))---- | TODO-eval2 :: FeatureDefinition f e d -> FeatureData f -> FeatureData e -> FeatureData d-eval2 (FD2 f) = f---- | TODO-evalSpec2 :: (Show b) => FeatureSpec b f e d -> Feature b f -> Feature b e -> Feature b d-evalSpec2 (MkFeatureSpec nm attr def) y z = MkFeature nm attr (eval2 def (getData y) (getData z))

@@ -1,33 +0,0 @@-{-|-Module      : Functions for encoding Hasklepias Feature data-Description : Defines ToJSON instances for Features.-Copyright   : (c) NoviSci, Inc 2020-License     : BSD3-Maintainer  : bsaul@novisci.com--}--{-# LANGUAGE OverloadedStrings #-}--module Hasklepias.Types.Feature.Aeson(-) where--import IntervalAlgebra              ( Interval, Intervallic(end, begin) )-import Hasklepias.Types.Feature     ( Feature(..)-                                    , MissingReason-                                    , FeatureData(..) )-import Data.Aeson                   ( object, KeyValue((.=)), ToJSON(toJSON) )--instance (ToJSON a, Ord a, Show a)=> ToJSON (Interval a) where-    toJSON x = object ["begin" .= begin x, "end" .= end x]--instance ToJSON MissingReason --instance (ToJSON d)=> ToJSON (FeatureData d) where-    toJSON  x = case getFeatureData x of -      (Left l)  -> toJSON l-      (Right r) -> toJSON r--instance (Show b, ToJSON b, ToJSON d) => ToJSON (Feature b d) where-    toJSON x = object [ "name"   .= getName x-                       , "attrs" .= toJSON (getAttr x)-                       , "data"  .= toJSON (getData x) ]

@@ -0,0 +1,98 @@+{-# LANGUAGE OverloadedStrings #-}+module EventData.AesonSpec (spec) where++import IntervalAlgebra+import EventData+import EventData.Aeson+import EventData.Context as HC+import EventData.Context.Domain+import Data.Aeson+import Data.Maybe+import Data.Time as DT+import Test.Hspec+import qualified Data.ByteString.Lazy as B++testInInt :: B.ByteString+testInInt = "[\"abc\", 0, 1, \"Diagnosis\",\+          \[\"someThing\"],\+          \{\"domain\":\"Diagnosis\",\"time\":{\"begin\":0,\"end\":1}}]"++testInputsInt :: B.ByteString+testInputsInt = +      "[\"abc\", 0, 1, \"Diagnosis\",\+      \[\"someThing\"],\+      \{\"domain\":\"Diagnosis\",\"time\":{\"begin\":0,\"end\":1}}]\n\+      \[\"abc\", 5, 6, \"Diagnosis\",\+      \[\"someThing\"],\+      \{\"domain\":\"Diagnosis\",\"time\":{\"begin\":5,\"end\":6}}]"++testInDay :: B.ByteString+testInDay = "[\"abc\", \"2020-01-01\", \"2020-01-02\", \"Diagnosis\",\+          \[\"someThing\"],\+          \{\"domain\":\"Diagnosis\",\+          \ \"time\":{\"begin\":\"2020-01-01\",\"end\":\"2020-01-02\"}}]"++testInDay2 :: B.ByteString+testInDay2 = "[\"abc\", \"2020-01-01\", null, \"Diagnosis\",\+          \[\"someThing\"],\+          \{\"domain\":\"Diagnosis\",\+          \ \"time\":{\"begin\":\"2020-01-01\",\"end\":null}}]"+++testInputsDay :: B.ByteString+testInputsDay = +      "[\"abc\", \"2020-01-01\", \"2020-01-02\", \"Diagnosis\",\+      \[\"someThing\"],\+      \{\"domain\":\"Diagnosis\",\+      \ \"time\":{\"begin\":\"2020-01-01\",\"end\":\"2020-01-02\"}}]\n\+      \[\"abc\", \"2020-01-05\", \"2020-01-06\", \"Diagnosis\",\+      \[\"someThing\"],\+      \{\"domain\":\"Diagnosis\",\+      \ \"time\":{\"begin\":\"2020-01-05\",\"end\":\"2020-01-06\"}}]"++testInputsDay2 :: B.ByteString+testInputsDay2 = +      "[\"abc\", \"2020-01-01\", null, \"Diagnosis\",\+      \[\"someThing\"],\+      \{\"domain\":\"Diagnosis\",\+      \ \"time\":{\"begin\":\"2020-01-01\",\"end\":\"2020-01-02\"}}]\n\+      \[\"abc\", \"2020-01-05\", null, \"Diagnosis\",\+      \[\"someThing\"],\+      \{\"domain\":\"Diagnosis\",\+      \ \"time\":{\"begin\":\"2020-01-05\",\"end\":\"2020-01-06\"}}]"++testOutInt1 = event (beginerval 1 (0 :: Int)) (HC.context ( Just $ UnimplementedDomain () ) (packConcepts ["someThing"]))+testOutInt2 = event (beginerval 1 (5 :: Int)) (HC.context ( Just $ UnimplementedDomain () ) (packConcepts ["someThing"]))++testOutDay1 = event (beginerval 1 (fromGregorian 2020 1 1))+                     (HC.context ( Just $ UnimplementedDomain () ) (packConcepts ["someThing"]))+testOutDay2 = event (beginerval 1 (fromGregorian 2020 1 5)) +               (HC.context ( Just $ UnimplementedDomain () ) (packConcepts [ "someThing"]))+++dmo :: Domain+dmo = Demographics $ DemographicsFacts (DemographicsInfo BirthYear (Just "1987"))++jsonDemoTest :: B.ByteString+jsonDemoTest = "{\"domain\":\"Demographics\",\"facts\":{\"demo\":{\"field\":\"BirthYear\",\"info\":\"1987\"}}}"++jsonOtherTest :: B.ByteString+jsonOtherTest = "{\"domain\":\"Labs\",\"facts\":{\"code\":{\"code\":\"XYZ\"}}}"++spec :: Spec +spec = do +    it "an Int event is parsed correctly" $ +       ( decode testInInt )  `shouldBe` (Just testOutInt1)+    it "lines of Int events are parsed correctly" $+       (parseEventIntLines testInputsInt) `shouldBe` [testOutInt1, testOutInt2]++    it "a Day event is parsed correctly" $ +       ( decode testInDay )  `shouldBe` (Just testOutDay1)+    it "a Day event with missing end day is parsed correctly" $ +       ( decode testInDay2 )  `shouldBe` (Just testOutDay1)+    it "lines of Int events are parsed correctly" $+       (parseEventDayLines testInputsDay) `shouldBe` [testOutDay1, testOutDay2]+    it "jsonDemoTest is parsed correctly" $+       decode jsonDemoTest  `shouldBe` Just dmo+    it "jsonOtherTest is parsed correctly" $+       decode jsonOtherTest  `shouldBe` Just (UnimplementedDomain ())

@@ -0,0 +1,18 @@+{-# LANGUAGE OverloadedStrings #-}+module EventData.Context.Domain.DemographicsSpec (spec) where++import EventData.Context.Domain.Demographics+import Test.Hspec                       ( it, shouldBe, Spec )+import Control.Lens                     ( (^.), view )++dmo :: DemographicsFacts+dmo = DemographicsFacts (DemographicsInfo BirthYear (Just "1987"))++spec :: Spec+spec = do+    it "" $+      view (demo.field) dmo `shouldBe` BirthYear+    it "" $ +       dmo^.demo.field `shouldBe` BirthYear+    it "" $+       dmo^.demo.info `shouldBe` Just "1987"

@@ -0,0 +1,28 @@+{-# LANGUAGE OverloadedStrings #-}+module EventData.Context.DomainSpec (spec) where++import EventData.Context.Domain+import Test.Hspec                       ( it, shouldBe, Spec )+import Control.Lens                     ( preview, (^.), (^?), (.~), over )+import Control.Monad                    ( join )+import Data.Aeson                       ( decode )+import Data.Text                        ( Text, unpack )+import Data.Text.Read                   ( rational )+import qualified Data.ByteString.Lazy as B++dmo :: Domain+dmo = Demographics $ DemographicsFacts (DemographicsInfo BirthYear (Just "1987"))++myIntMap :: Text -> Maybe Integer -- TODO: this is ridiculous+myIntMap x =  fmap floor (either (const Nothing) (Just . fst) (Data.Text.Read.rational x))++spec :: Spec+spec = do+    it "preview demographics facts" $+      dmo ^? _Demographics `shouldBe` Just (DemographicsFacts( DemographicsInfo BirthYear (Just "1987")))+    it "preview demographic field" $+      fmap (^.demo.field) (dmo ^? _Demographics)  `shouldBe` Just BirthYear+    it "preview birthyear" $+      ((^.demo.info) =<< preview _Demographics dmo)  `shouldBe` Just "1987"+    it "preview birthyear as Integer" $+      (myIntMap =<< ((^.demo.info) =<< preview _Demographics dmo))  `shouldBe` Just 1987

@@ -0,0 +1,29 @@+{-# LANGUAGE OverloadedStrings #-}+module EventData.ContextSpec (spec) where++import EventData.Context as HC+import Test.Hspec ( shouldBe, it, Spec )+import Data.Maybe (Maybe(Nothing))+import Data.Set(fromList)++ctxt1 :: Context+ctxt1 = HC.context Nothing (packConcepts  ["c1", "c2"])++ctxt2 :: Context+ctxt2 = HC.context Nothing (packConcepts ["c2", "c3"])++spec :: Spec+spec = do+    it "getConcepts returns correct values" $+       _concepts ctxt1 `shouldBe` packConcepts ["c1", "c2"]+    it "hasConcept returns True when concept is in context" $+      (ctxt1 `hasConcept` "c1") `shouldBe` True+    it "hasConcept returns False when concept is not in context" $+      (ctxt1 `hasConcept` "c3") `shouldBe` False+    it "hasConcepts returns True when at at least one concept is in context" $+      (ctxt1 `hasConcepts` ["c3", "c1"]) `shouldBe` True+    it "hasConcepts returns False when no concept is in context" $+      (ctxt1 `hasConcepts` ["c3", "c4"]) `shouldBe` False++    it "<> combines contexts" $+      (ctxt1 <> ctxt2) `shouldBe` HC.context Nothing (packConcepts ["c1", "c2", "c3"])

@@ -0,0 +1,59 @@+{-# LANGUAGE OverloadedStrings #-}+module EventDataSpec (spec) where++import IntervalAlgebra+import IntervalAlgebra.IntervalUtilities+import FeatureEvents +import EventData+import EventData.Context as HC+import Data.Maybe+import Test.Hspec ( it, shouldBe, Spec )++evnt1 :: Event Int+evnt1 = event ( beginerval 4 (1 :: Int))+              (HC.context Nothing (packConcepts ["c1", "c2"] ))+evnt2 :: Event Int+evnt2 = event ( beginerval 4 (2 :: Int)  )+              (HC.context Nothing (packConcepts ["c3", "c4"] ))+evnts :: [Event Int]+evnts = [evnt1, evnt2]++containmentInt :: Interval Int+containmentInt = beginerval 10 (0 :: Int) ++noncontainmentInt :: Interval Int+noncontainmentInt = beginerval 6 (4 :: Int) ++anotherInt :: Interval Int+anotherInt = beginerval 5 (15 :: Int) ++spec :: Spec+spec = do+    it "hasConcept returns True when concept is in context" $+      (evnt1 `hasConcept` "c1") `shouldBe` True+    it "hasConcept returns False when concept is not in context" $+      (evnt1 `hasConcept` "c3") `shouldBe` False+    it "hasConcepts returns True when at at least one concept is in context" $+      (evnt1 `hasConcepts` ["c3", "c1"]) `shouldBe` True+    it "hasConcepts returns False when no concept is in context" $+      (evnt1 `hasConcepts` ["c3", "c4"]) `shouldBe` False++    it "filterEvents for evnt1" $+      filter (`hasConcept` "c1") evnts `shouldBe` [evnt1]+    it "filterEvents for evnt2" $+      filter (`hasConcept` "c3") evnts `shouldBe` [evnt2]+    it "filterEvents to no events" $+      filter (`hasConcept` "c5") evnts `shouldBe` []++    it "lift2IntervalPredicate meets" $+      meets evnt1 evnt2 `shouldBe` False+    it "lift2IntervalPredicate overlaps" $+      overlaps evnt1 evnt2 `shouldBe` True+    it "lift2IntervalPredicate overlaps" $+      overlappedBy evnt2 evnt1 `shouldBe` True++    it "filterEvents by interval containment" $+      filterContains containmentInt evnts `shouldBe` evnts+    it "filterEvents by interval containment" $+      filterContains noncontainmentInt evnts `shouldBe` []+

@@ -0,0 +1,35 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE FlexibleContexts #-}+module FeatureCompose.AesonSpec (spec) where++import IntervalAlgebra+import EventData+import EventData.Context+import FeatureEvents+import FeatureCompose+import FeatureCompose.Aeson+import Data.Aeson (encode)+import Data.Maybe+import Data.Time as DT+import Test.Hspec ( shouldBe, it, Spec )+import qualified Data.ByteString.Lazy as B+++ex1 :: Events Int+ex1 = [event (beginerval 10 0) (context Nothing (packConcepts ["enrollment"]))]++index:: (Ord a) =>+     Events a+  -> FeatureData (Interval a)+index es =+    case firstConceptOccurrence ["enrollment"] es of+        Nothing -> featureDataL (Other "No Enrollment")+        Just x  -> pure (getInterval x)+++spec :: Spec+spec = do+    it "an Int event is parsed correctly" $+       encode (index ex1)  `shouldBe` "[{\"end\":10,\"begin\":0}]"++

@@ -0,0 +1,46 @@+{-# LANGUAGE OverloadedStrings #-}++module FeatureCompose.CriteriaSpec (spec) where++import FeatureCompose+import FeatureCompose.Criteria+import Test.Hspec ( describe, pending, shouldBe, it, Spec )++f1 :: Feature String Bool+f1 = MkFeature "f1" "" (featureDataR [True, False, True])++f2 :: Feature String Bool+f2 = MkFeature "f2" "" (featureDataR [True, True, True])++f3 :: Feature String Bool+f3 = MkFeature "f3" "" (featureDataR [True, True, True])++spec :: Spec+spec = do++  describe "checking d1" $+    do++      it "include f2/include f3" $+        runCriteria (MkCriteria [include f2, include f3]) `shouldBe`+             featureDataR [Included, Included, Included ]++      it "exclude f2/include f3" $+        runCriteria (MkCriteria [exclude f2, include f3]) `shouldBe`+             featureDataR [ExcludedBy 1, ExcludedBy 1, ExcludedBy 1]++      it "include f2/exclude f3" $+        runCriteria (MkCriteria [include f2, exclude f3]) `shouldBe`+             featureDataR [ExcludedBy 2, ExcludedBy 2, ExcludedBy 2]++      it "exclude f3/exclude f3" $+        runCriteria (MkCriteria [exclude f2, exclude f3]) `shouldBe`+             featureDataR [ExcludedBy 1, ExcludedBy 1, ExcludedBy 1]++      it "include f1/exclude f3" $+        runCriteria (MkCriteria [include f1, exclude f2]) `shouldBe`+             featureDataR [ExcludedBy 2, ExcludedBy 1, ExcludedBy 2]++      -- it "" $+      --   runCriteria (MkCriteria [ include (MkFeature "f1" "" (featureDataR []))])+      --     `shouldBe` featureDataL Excluded

@@ -0,0 +1,63 @@+{-# LANGUAGE OverloadedStrings #-}++module FeatureComposeSpec (spec) where++import FeatureCompose+import Control.Applicative+import Test.Hspec ( describe, pending, shouldBe, it, Spec )+import Data.Foldable++d1 :: FeatureDefinition (FeatureData Int) Int+d1 = defineM+  (\x ->+    if x < 0 then+      featureDataL $ Other "at least 1 < 0"+    else+      pure (x + 1)+   )++d2 :: FeatureDefinition (FeatureData Int) Int+d2 = define (*2)++d3 ::  FeatureDefinition (FeatureData Int, FeatureData Int) Int+d3 = define2 (+)++spec :: Spec+spec = do++  describe "checking d1" $+    do++      it "eval of d1 returns correct values for List" $+        eval d1 (featureDataR [5, 6, 7]) `shouldBe`+          featureDataR [6, 7, 8]+      it "d1 returns correct error for List" $+        eval d1 (featureDataR [-1, 5, 6]) `shouldBe`+          (featureDataL (Other "at least 1 < 0") :: (FeatureData Int))++  describe "checking d2" $+    do+      it "eval of d2 returns correct values for List" $+        eval d2 (featureDataR [5]) `shouldBe`+          featureDataR [10]+      it "eval of d2 returns correct values for List" $+        eval d2 (featureDataR [5, 6, 7]) `shouldBe`+          featureDataR [10, 12, 14]+      it "d2 returns correct error for List" $+        eval d2 (featureDataL (Other "at least 1 < 0")) `shouldBe`+          (featureDataL (Other "at least 1 < 0") :: (FeatureData Int))++  describe "checking d3" $+    do+      it "eval of d2 returns correct values for List" $+        eval d3 (featureDataR [5], featureDataR [6])  `shouldBe`+          featureDataR [11]+      it "eval of d3 returns correct values for List" $+        eval d3 (featureDataR [5, 6, 7], featureDataR [5, 6, 7]) `shouldBe`+          featureDataR [10, 12, 14]+      it "d3 returns correct error for List" $+        eval d3 (featureDataL (Other "at least 1 < 0"), featureDataR [6])  `shouldBe`+          (featureDataL (Other "at least 1 < 0") :: (FeatureData Int))+      it "d3 returns correct error for List" $+        eval d3 (featureDataR [6], featureDataL (Other "at least 1 < 0")) `shouldBe`+          (featureDataL (Other "at least 1 < 0") :: (FeatureData Int))

@@ -0,0 +1,31 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE AllowAmbiguousTypes #-}+{-# LANGUAGE FlexibleContexts #-}+module FeatureEventsSpec (spec) where++import IntervalAlgebra+import FeatureEvents ( firstConceptOccurrence )+import EventData ( Event, event )+import EventData.Context as HC ( context, packConcepts )+import Data.Maybe+import Test.Hspec ( it, shouldBe, Spec )++-- | Toy events for unit tests+evnt1 :: Event Int+evnt1 = event ( beginerval (4 :: Int) (1 :: Int) ) +        ( HC.context Nothing (packConcepts ["c1", "c2"] ))+evnt2 :: Event Int+evnt2 = event ( beginerval (4 :: Int) (2 :: Int) )+         ( HC.context Nothing (packConcepts ["c3", "c4"] ))+evnts :: [Event Int]+evnts = [evnt1, evnt2]++spec :: Spec+spec = do+    it "find first occurrence of c1" $+      firstConceptOccurrence ["c1"] evnts `shouldBe` Just evnt1+    it "find first occurrence of c3" $+      firstConceptOccurrence ["c3"] evnts `shouldBe` Just evnt2+    it "find first occurrence of c5" $+      firstConceptOccurrence ["c5"] evnts `shouldBe` Nothing

@@ -0,0 +1,58 @@+{-# LANGUAGE OverloadedStrings #-}+module Hasklepias.AesonSpec (spec) where++import IntervalAlgebra+import EventData+import Hasklepias.Aeson+import Hasklepias.Cohort+import EventData.Context as HC+import EventData.Context.Domain+import Data.Aeson+import Data.Maybe+import Data.Time as DT+import Test.Hspec+import qualified Data.ByteString.Lazy as B++++testInputsDay1 :: B.ByteString+testInputsDay1 = +      "[\"abc\", \"2020-01-01\", \"2020-01-02\", \"Diagnosis\",\+      \[\"someThing\"],\+      \{\"domain\":\"Diagnosis\",\+      \ \"time\":{\"begin\":\"2020-01-01\",\"end\":\"2020-01-02\"}}]\n\+      \[\"abc\", \"2020-01-05\", \"2020-01-06\", \"Diagnosis\",\+      \[\"someThing\"],\+      \{\"domain\":\"Diagnosis\",\+      \ \"time\":{\"begin\":\"2020-01-05\",\"end\":\"2020-01-06\"}}]"+++testInputsDay2 :: B.ByteString+testInputsDay2 = +      "[\"def\", \"2020-01-01\", null, \"Diagnosis\",\+      \[\"someThing\"],\+      \{\"domain\":\"Diagnosis\",\+      \ \"time\":{\"begin\":\"2020-01-01\",\"end\":\"2020-01-02\"}}]\n\+      \[\"def\", \"2020-01-05\", null, \"Diagnosis\",\+      \[\"someThing\"],\+      \{\"domain\":\"Diagnosis\",\+      \ \"time\":{\"begin\":\"2020-01-05\",\"end\":\"2020-01-06\"}}]"++testInput = testInputsDay1 <> "\n" <> testInputsDay2++testOutDay1 = event (beginerval 1 (fromGregorian 2020 1 1))+               (HC.context ( Just $ UnimplementedDomain () ) (packConcepts ["someThing"]))+testOutDay2 = event (beginerval 1 (fromGregorian 2020 1 5)) +               (HC.context ( Just $ UnimplementedDomain () ) (packConcepts [ "someThing"]))+++testOutPop = MkPopulation [+          MkSubject ("abc", [testOutDay1, testOutDay2])+        , MkSubject ("def", [testOutDay1, testOutDay2])+      ]++spec :: Spec +spec = do +    it "a population is parsed" $ +       ( parsePopulationDayLines testInput ) `shouldBe` (testOutPop)+

@@ -1,30 +0,0 @@-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE AllowAmbiguousTypes #-}-{-# LANGUAGE FlexibleContexts #-}-module Hasklepias.FunctionsSpec (spec) where--import IntervalAlgebra-import Hasklepias.Functions ( firstConceptOccurrence )-import Hasklepias.Types.Event ( Event, event )-import Hasklepias.Types.Context as HC ( context, packConcepts )-import Test.Hspec ( it, shouldBe, Spec )---- | Toy events for unit tests-evnt1 :: Event Int-evnt1 = event ( beginerval (4 :: Int) (1 :: Int) ) -        ( HC.context $ packConcepts ["c1", "c2"] )-evnt2 :: Event Int-evnt2 = event ( beginerval (4 :: Int) (2 :: Int) )-         ( HC.context $ packConcepts ["c3", "c4"] )-evnts :: [Event Int]-evnts = [evnt1, evnt2]--spec :: Spec-spec = do-    it "find first occurrence of c1" $-      firstConceptOccurrence ["c1"] evnts `shouldBe` Just evnt1-    it "find first occurrence of c3" $-      firstConceptOccurrence ["c3"] evnts `shouldBe` Just evnt2-    it "find first occurrence of c5" $-      firstConceptOccurrence ["c5"] evnts `shouldBe` Nothing

@@ -1,28 +0,0 @@-{-# LANGUAGE OverloadedStrings #-}-module Hasklepias.Types.ContextSpec (spec) where--import Hasklepias.Types.Context as HC-import Test.Hspec ( shouldBe, it, Spec )-import Data.Set(fromList)--ctxt1 :: Context-ctxt1 = HC.context $ packConcepts  ["c1", "c2"]--ctxt2 :: Context-ctxt2 = HC.context $ packConcepts ["c2", "c3"]--spec :: Spec-spec = do-    it "getConcepts returns correct values" $-      getConcepts ctxt1 `shouldBe` packConcepts ["c1", "c2"]-    it "hasConcept returns True when concept is in context" $-      (ctxt1 `hasConcept` "c1") `shouldBe` True-    it "hasConcept returns False when concept is not in context" $-      (ctxt1 `hasConcept` "c3") `shouldBe` False-    it "hasConcepts returns True when at at least one concept is in context" $-      (ctxt1 `hasConcepts` ["c3", "c1"]) `shouldBe` True-    it "hasConcepts returns False when no concept is in context" $-      (ctxt1 `hasConcepts` ["c3", "c4"]) `shouldBe` False--    it "<> combines contexts" $-      (ctxt1 <> ctxt2) `shouldBe` HC.context (packConcepts ["c1", "c2", "c3"])

@@ -1,64 +0,0 @@-{-# LANGUAGE OverloadedStrings #-}-module Hasklepias.Types.Event.AesonSpec (spec) where--import IntervalAlgebra-import Hasklepias.Types.Event-import Hasklepias.Types.Event.Aeson-import Data.Aeson-import Data.Time as DT-import Hasklepias.Types.Context as HC-import Test.Hspec-import qualified Data.ByteString.Lazy as B--testInInt :: B.ByteString-testInInt = "[\"abc\", 0, 1, \"Diagnosis\",\-          \[\"someThing\"],\-          \{\"domain\":\"Diagnosis\",\"time\":{\"begin\":0,\"end\":1}}]"--testInputsInt :: B.ByteString-testInputsInt = -      "[\"abc\", 0, 1, \"Diagnosis\",\-      \[\"someThing\"],\-      \{\"domain\":\"Diagnosis\",\"time\":{\"begin\":0,\"end\":1}}]\n\-      \[\"abc\", 5, 6, \"Diagnosis\",\-      \[\"someThing\"],\-      \{\"domain\":\"Diagnosis\",\"time\":{\"begin\":5,\"end\":6}}]"--testInDay :: B.ByteString-testInDay = "[\"abc\", \"2020-01-01\", \"2020-01-02\", \"Diagnosis\",\-          \[\"someThing\"],\-          \{\"domain\":\"Diagnosis\",\-          \ \"time\":{\"begin\":\"2020-01-01\",\"end\":\"2020-01-02\"}}]"---testInputsDay :: B.ByteString-testInputsDay = -      "[\"abc\", \"2020-01-01\", \"2020-01-02\", \"Diagnosis\",\-      \[\"someThing\"],\-      \{\"domain\":\"Diagnosis\",\-      \ \"time\":{\"begin\":\"2020-01-01\",\"end\":\"2020-01-02\"}}]\n\-      \[\"abc\", \"2020-01-05\", \"2020-01-06\", \"Diagnosis\",\-      \[\"someThing\"],\-      \{\"domain\":\"Diagnosis\",\-      \ \"time\":{\"begin\":\"2020-01-05\",\"end\":\"2020-01-06\"}}]"--testOutInt1 = event (beginerval 1 (0 :: Int)) (HC.context $ packConcepts ["someThing"])-testOutInt2 = event (beginerval 1 (5 :: Int)) (HC.context $ packConcepts ["someThing"])--testOutDay1 = event (beginerval 1 (fromGregorian 2020 1 1))-                     (HC.context $ packConcepts ["someThing"])-testOutDay2 = event (beginerval 1 (fromGregorian 2020 1 5)) -               (HC.context $ packConcepts [ "someThing"])---spec :: Spec -spec = do -    it "an Int event is parsed correctly" $ -       ( decode testInInt )  `shouldBe` (Just testOutInt1)-    it "lines of Int events are parsed correctly" $-       (parseEventIntLines testInputsInt) `shouldBe` [testOutInt1, testOutInt2]--    it "a Day event is parsed correctly" $ -       ( decode testInDay )  `shouldBe` (Just testOutDay1)-    it "lines of Int events are parsed correctly" $-       (parseEventDayLines testInputsDay) `shouldBe` [testOutDay1, testOutDay2]

@@ -1,58 +0,0 @@-{-# LANGUAGE OverloadedStrings #-}-module Hasklepias.Types.EventSpec (spec) where--import IntervalAlgebra-import IntervalAlgebra.IntervalUtilities-import Hasklepias.Functions-import Hasklepias.Types.Event-import Hasklepias.Types.Context as HC-import Test.Hspec ( it, shouldBe, Spec )--evnt1 :: Event Int-evnt1 = event ( beginerval 4 (1 :: Int))-              ( HC.context $ packConcepts ["c1", "c2"] )-evnt2 :: Event Int-evnt2 = event ( beginerval 4 (2 :: Int)  )-              ( HC.context $ packConcepts ["c3", "c4"] )-evnts :: [Event Int]-evnts = [evnt1, evnt2]--containmentInt :: Interval Int-containmentInt = beginerval 10 (0 :: Int) --noncontainmentInt :: Interval Int-noncontainmentInt = beginerval 6 (4 :: Int) --anotherInt :: Interval Int-anotherInt = beginerval 5 (15 :: Int) --spec :: Spec-spec = do-    it "hasConcept returns True when concept is in context" $-      (evnt1 `hasConcept` "c1") `shouldBe` True-    it "hasConcept returns False when concept is not in context" $-      (evnt1 `hasConcept` "c3") `shouldBe` False-    it "hasConcepts returns True when at at least one concept is in context" $-      (evnt1 `hasConcepts` ["c3", "c1"]) `shouldBe` True-    it "hasConcepts returns False when no concept is in context" $-      (evnt1 `hasConcepts` ["c3", "c4"]) `shouldBe` False--    it "filterEvents for evnt1" $-      filter (`hasConcept` "c1") evnts `shouldBe` [evnt1]-    it "filterEvents for evnt2" $-      filter (`hasConcept` "c3") evnts `shouldBe` [evnt2]-    it "filterEvents to no events" $-      filter (`hasConcept` "c5") evnts `shouldBe` []--    it "lift2IntervalPredicate meets" $-      meets evnt1 evnt2 `shouldBe` False-    it "lift2IntervalPredicate overlaps" $-      overlaps evnt1 evnt2 `shouldBe` True-    it "lift2IntervalPredicate overlaps" $-      overlappedBy evnt2 evnt1 `shouldBe` True--    it "filterEvents by interval containment" $-      filterContains containmentInt evnts `shouldBe` evnts-    it "filterEvents by interval containment" $-      filterContains noncontainmentInt evnts `shouldBe` []-

@@ -1,33 +0,0 @@-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE FlexibleContexts #-}-module Hasklepias.Types.Feature.AesonSpec (spec) where--import IntervalAlgebra-import Hasklepias.Types-import Hasklepias.Functions-import Hasklepias.Types.Feature.Aeson-import Data.Aeson-import Data.Time as DT--- import Hasklepias.Types.Context as HC-import Test.Hspec ( shouldBe, it, Spec )-import qualified Data.ByteString.Lazy as B---ex1 :: Events Int-ex1 = [event (beginerval 10 0) (context $ packConcepts ["enrollment"])]--index:: (Ord a) =>-     Events a-  -> FeatureData (Interval a)-index es =-    case firstConceptOccurrence ["enrollment"] es of-        Nothing -> featureDataL (Other "No Enrollment")-        Just x  -> featureDataR (getInterval x)---spec :: Spec-spec = do-    it "an Int event is parsed correctly" $-       encode (index ex1)  `shouldBe` "{\"end\":10,\"begin\":0}"--