diff --git a/ChangeLog.md b/ChangeLog.md --- a/ChangeLog.md +++ b/ChangeLog.md @@ -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 diff --git a/examples/ExampleEvents.hs b/examples/ExampleEvents.hs --- a/examples/ExampleEvents.hs +++ b/examples/ExampleEvents.hs @@ -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 diff --git a/examples/ExampleFeatures1.hs b/examples/ExampleFeatures1.hs --- a/examples/ExampleFeatures1.hs +++ b/examples/ExampleFeatures1.hs @@ -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)] + diff --git a/examples/ExampleFeatures2.hs b/examples/ExampleFeatures2.hs --- a/examples/ExampleFeatures2.hs +++ b/examples/ExampleFeatures2.hs @@ -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] diff --git a/examples/ExampleFeatures3.hs b/examples/ExampleFeatures3.hs --- a/examples/ExampleFeatures3.hs +++ b/examples/ExampleFeatures3.hs @@ -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) diff --git a/hasklepias.cabal b/hasklepias.cabal --- a/hasklepias.cabal +++ b/hasklepias.cabal @@ -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 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 diff --git a/src/EventData.hs b/src/EventData.hs new file mode 100644 --- /dev/null +++ b/src/EventData.hs @@ -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] diff --git a/src/EventData/Aeson.hs b/src/EventData/Aeson.hs new file mode 100644 --- /dev/null +++ b/src/EventData/Aeson.hs @@ -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 diff --git a/src/EventData/Arbitrary.hs b/src/EventData/Arbitrary.hs new file mode 100644 --- /dev/null +++ b/src/EventData/Arbitrary.hs @@ -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) diff --git a/src/EventData/Context.hs b/src/EventData/Context.hs new file mode 100644 --- /dev/null +++ b/src/EventData/Context.hs @@ -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 diff --git a/src/EventData/Context/Arbitrary.hs b/src/EventData/Context/Arbitrary.hs new file mode 100644 --- /dev/null +++ b/src/EventData/Context/Arbitrary.hs @@ -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) + diff --git a/src/EventData/Context/Domain.hs b/src/EventData/Context/Domain.hs new file mode 100644 --- /dev/null +++ b/src/EventData/Context/Domain.hs @@ -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 diff --git a/src/EventData/Context/Domain/Demographics.hs b/src/EventData/Context/Domain/Demographics.hs new file mode 100644 --- /dev/null +++ b/src/EventData/Context/Domain/Demographics.hs @@ -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 diff --git a/src/FeatureCompose.hs b/src/FeatureCompose.hs new file mode 100644 --- /dev/null +++ b/src/FeatureCompose.hs @@ -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) diff --git a/src/FeatureCompose/Aeson.hs b/src/FeatureCompose/Aeson.hs new file mode 100644 --- /dev/null +++ b/src/FeatureCompose/Aeson.hs @@ -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) ] diff --git a/src/FeatureCompose/Criteria.hs b/src/FeatureCompose/Criteria.hs new file mode 100644 --- /dev/null +++ b/src/FeatureCompose/Criteria.hs @@ -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 diff --git a/src/FeatureEvents.hs b/src/FeatureEvents.hs new file mode 100644 --- /dev/null +++ b/src/FeatureEvents.hs @@ -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) diff --git a/src/Hasklepias.hs b/src/Hasklepias.hs --- a/src/Hasklepias.hs +++ b/src/Hasklepias.hs @@ -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 diff --git a/src/Hasklepias/Aeson.hs b/src/Hasklepias/Aeson.hs new file mode 100644 --- /dev/null +++ b/src/Hasklepias/Aeson.hs @@ -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 diff --git a/src/Hasklepias/Cohort.hs b/src/Hasklepias/Cohort.hs new file mode 100644 --- /dev/null +++ b/src/Hasklepias/Cohort.hs @@ -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) diff --git a/src/Hasklepias/Functions.hs b/src/Hasklepias/Functions.hs deleted file mode 100644 --- a/src/Hasklepias/Functions.hs +++ /dev/null @@ -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) diff --git a/src/Hasklepias/Reexports.hs b/src/Hasklepias/Reexports.hs --- a/src/Hasklepias/Reexports.hs +++ b/src/Hasklepias/Reexports.hs @@ -54,6 +54,7 @@ , length , null , zipWith + , sort , (++) ) import safe Data.Maybe ( Maybe(..), maybe, diff --git a/src/Hasklepias/Types.hs b/src/Hasklepias/Types.hs deleted file mode 100644 --- a/src/Hasklepias/Types.hs +++ /dev/null @@ -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 diff --git a/src/Hasklepias/Types/Context.hs b/src/Hasklepias/Types/Context.hs deleted file mode 100644 --- a/src/Hasklepias/Types/Context.hs +++ /dev/null @@ -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 diff --git a/src/Hasklepias/Types/Context/Arbitrary.hs b/src/Hasklepias/Types/Context/Arbitrary.hs deleted file mode 100644 --- a/src/Hasklepias/Types/Context/Arbitrary.hs +++ /dev/null @@ -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) - diff --git a/src/Hasklepias/Types/Event.hs b/src/Hasklepias/Types/Event.hs deleted file mode 100644 --- a/src/Hasklepias/Types/Event.hs +++ /dev/null @@ -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] diff --git a/src/Hasklepias/Types/Event/Aeson.hs b/src/Hasklepias/Types/Event/Aeson.hs deleted file mode 100644 --- a/src/Hasklepias/Types/Event/Aeson.hs +++ /dev/null @@ -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) diff --git a/src/Hasklepias/Types/Event/Arbitrary.hs b/src/Hasklepias/Types/Event/Arbitrary.hs deleted file mode 100644 --- a/src/Hasklepias/Types/Event/Arbitrary.hs +++ /dev/null @@ -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) diff --git a/src/Hasklepias/Types/Feature.hs b/src/Hasklepias/Types/Feature.hs deleted file mode 100644 --- a/src/Hasklepias/Types/Feature.hs +++ /dev/null @@ -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)) diff --git a/src/Hasklepias/Types/Feature/Aeson.hs b/src/Hasklepias/Types/Feature/Aeson.hs deleted file mode 100644 --- a/src/Hasklepias/Types/Feature/Aeson.hs +++ /dev/null @@ -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) ] diff --git a/test/EventData/AesonSpec.hs b/test/EventData/AesonSpec.hs new file mode 100644 --- /dev/null +++ b/test/EventData/AesonSpec.hs @@ -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 ()) diff --git a/test/EventData/Context/Domain/DemographicsSpec.hs b/test/EventData/Context/Domain/DemographicsSpec.hs new file mode 100644 --- /dev/null +++ b/test/EventData/Context/Domain/DemographicsSpec.hs @@ -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" diff --git a/test/EventData/Context/DomainSpec.hs b/test/EventData/Context/DomainSpec.hs new file mode 100644 --- /dev/null +++ b/test/EventData/Context/DomainSpec.hs @@ -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 diff --git a/test/EventData/ContextSpec.hs b/test/EventData/ContextSpec.hs new file mode 100644 --- /dev/null +++ b/test/EventData/ContextSpec.hs @@ -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"]) diff --git a/test/EventDataSpec.hs b/test/EventDataSpec.hs new file mode 100644 --- /dev/null +++ b/test/EventDataSpec.hs @@ -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` [] + diff --git a/test/FeatureCompose/AesonSpec.hs b/test/FeatureCompose/AesonSpec.hs new file mode 100644 --- /dev/null +++ b/test/FeatureCompose/AesonSpec.hs @@ -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}]" + + diff --git a/test/FeatureCompose/CriteriaSpec.hs b/test/FeatureCompose/CriteriaSpec.hs new file mode 100644 --- /dev/null +++ b/test/FeatureCompose/CriteriaSpec.hs @@ -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 diff --git a/test/FeatureComposeSpec.hs b/test/FeatureComposeSpec.hs new file mode 100644 --- /dev/null +++ b/test/FeatureComposeSpec.hs @@ -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)) diff --git a/test/FeatureEventsSpec.hs b/test/FeatureEventsSpec.hs new file mode 100644 --- /dev/null +++ b/test/FeatureEventsSpec.hs @@ -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 diff --git a/test/Hasklepias/AesonSpec.hs b/test/Hasklepias/AesonSpec.hs new file mode 100644 --- /dev/null +++ b/test/Hasklepias/AesonSpec.hs @@ -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) + diff --git a/test/Hasklepias/FunctionsSpec.hs b/test/Hasklepias/FunctionsSpec.hs deleted file mode 100644 --- a/test/Hasklepias/FunctionsSpec.hs +++ /dev/null @@ -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 diff --git a/test/Hasklepias/Types/ContextSpec.hs b/test/Hasklepias/Types/ContextSpec.hs deleted file mode 100644 --- a/test/Hasklepias/Types/ContextSpec.hs +++ /dev/null @@ -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"]) diff --git a/test/Hasklepias/Types/Event/AesonSpec.hs b/test/Hasklepias/Types/Event/AesonSpec.hs deleted file mode 100644 --- a/test/Hasklepias/Types/Event/AesonSpec.hs +++ /dev/null @@ -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] diff --git a/test/Hasklepias/Types/EventSpec.hs b/test/Hasklepias/Types/EventSpec.hs deleted file mode 100644 --- a/test/Hasklepias/Types/EventSpec.hs +++ /dev/null @@ -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` [] - diff --git a/test/Hasklepias/Types/Feature/AesonSpec.hs b/test/Hasklepias/Types/Feature/AesonSpec.hs deleted file mode 100644 --- a/test/Hasklepias/Types/Feature/AesonSpec.hs +++ /dev/null @@ -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}" - -