diff --git a/ChangeLog.md b/ChangeLog.md --- a/ChangeLog.md +++ b/ChangeLog.md @@ -1,5 +1,14 @@ # Changelog for hasklepias +## 0.15.0 + +* Adds `Occurrence` type which is a simply a pair a reason and an `EventTime`. That is, an `Occurrence` captures what and when something occurred. Adds the `CensoredOccurrence` type which is similar to an `Occurrence`, except that the reason is of type `CensoringReason cr or`, where `data CensoringReason cr or = AdminCensor | C cr | O or`. The time of a `CensoredOccurrence` is a `MaybeCensored (EventTime a)` (not simply can `EventTime`). See the examples in `examples/ExampleFeatures4` for usage. +* A number of the utility functions in the `Hasklepias.FeatureEvents` module are generalized to operate on data structures other than lists of `Event`s. +* Exports type synonyms `F n a` and `Def d` for `Feature n a` and `Definiton d` to save a bit of typing. +* Adds `Hasklepias.Misc` module as a location to collect miscellaneous types and functions for the time-being, until better locations are found or created. +* Adds `examples/ExampleFeatures4.hs` which is an extensive example of assessing exposure protocols and censored outcomes. +* Moves the `Cohort` module to the top-level. Moves the `FeatureEvents` module within the `Hasklepias` module. + ## 0.14.0 * Adds the ability to modify the output shape of cohorts. The `makeCohortApp` now takes a "`shape`" function as an argument of type `Cohort d -> CohortShape shape`. Currently, two functions of this type are provided: `rowWise` and `colWise`. The `rowWise` functions presents the output feature data in a row-wise format where each subject's data is its own array; whereas `colWise` presents the feature data where all the data of a given feature are in a single array. diff --git a/examples/ExampleFeatures4.hs b/examples/ExampleFeatures4.hs new file mode 100644 --- /dev/null +++ b/examples/ExampleFeatures4.hs @@ -0,0 +1,571 @@ +{-| +Module : ExampleFeatures4 +Description : Demostrates how to define an outcome monitoring treatment regimes + over time. +Copyright : (c) NoviSci, Inc 2020 +License : BSD3 +Maintainer : bsaul@novisci.com +-} + +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE TypeApplications #-} + +module ExampleFeatures4( + exampleFeatures4Spec +) where + +import Hasklepias +import ExampleEvents ( exampleEvents4 ) +import Test.Hspec ( shouldBe, it, Spec, xcontext, describe, pending ) + +{- + Example Data and utilities to create such +-} + +type EventData a b = (b, a, Text) + +t1 :: (a, b, c) -> a +t1 (x , _ , _) = x +t2 :: (a, b, c) -> b +t2 (_ , x , _) = x +t3 :: (a, b, c) -> c +t3 (_ , _ , x) = x + +toEvent :: (IntervalSizeable a b, Show a, Integral b) => + EventData a b-> Event a +toEvent x = event (beginerval (t1 x) (t2 x)) + (context (UnimplementedDomain ()) (packConcepts [t3 x])) + +toEvents :: (Show a, IntervalSizeable a b, Integral b) => + [EventData a b] -> Events a +toEvents = sort.map toEvent + +sapExample1 :: Events Day +sapExample1 = toEvents [ + (1, fromGregorian 2017 1 1, "index") + , (1, fromGregorian 2017 3 1, "pcsk") + ] + +sapExample2 :: Events Day +sapExample2 = toEvents [ + (1, fromGregorian 2017 1 1, "index") + , (1, fromGregorian 2017 3 1, "wellness") + ] + +p1Events :: Events Int +p1Events = toEvents [ + (1, 1, "index") + , (1, 7 + 15, "pcsk") + ] + +p2Events :: Events Int +p2Events = toEvents [ + (1, 1, "index") + , (1, 7 + 60, "pcsk") + ] + +p3Events :: Events Int +p3Events = toEvents [ + (1, 1, "index") + , (1, 7 + 120, "pcsk") + ] + +p4Events :: Events Int +p4Events = toEvents [ + (1, 1, "index") + , (1, 7 + 240, "pcsk") + ] + +p5Events :: Events Int +p5Events = toEvents [ + (1, 1, "index") + ] + +{- + Types used for features +-} + +data CensorReason = + -- The order matters here in that if two censoring events occur on the same + -- day then the reason for censoring will be chosen based on the following + -- ordering. + Death + | Disenrollment + | Discontinuation + | Noncompliance + | EndOfData + deriving (Eq, Show, Ord) + +instance OccurrenceReason CensorReason + +data OutcomeReason = + Wellness + | Accident + -- etc + deriving (Eq, Show, Ord) + +instance OccurrenceReason OutcomeReason + +data NegOutcomes b = MkNegOutcome { + g1 :: CensoredOccurrence CensorReason OutcomeReason b + , g2 :: CensoredOccurrence CensorReason OutcomeReason b + , g3 :: CensoredOccurrence CensorReason OutcomeReason b + , g4 :: CensoredOccurrence CensorReason OutcomeReason b + , g5 :: CensoredOccurrence CensorReason OutcomeReason b + } deriving (Eq) + +instance (Show b) => Show ( NegOutcomes b ) where + show (MkNegOutcome x1 x2 x3 x4 x5) = + "\n g1: " ++ show x1 ++ + "\n g2: " ++ show x2 ++ + "\n g3: " ++ show x3 ++ + "\n g4: " ++ show x4 ++ + "\n g5: " ++ show x5 ++ + "\n" + +data ProtocolStatus a = + Compliant + | NonCompliant (EventTime a) + deriving (Eq, Show) + +data Protocols a = MkProtocols { + noInit :: ProtocolStatus a + , init30 :: ProtocolStatus a + , init90 :: ProtocolStatus a + , init180 :: ProtocolStatus a + , init365 :: ProtocolStatus a + } deriving (Eq) + +instance (Show a) => Show (Protocols a) where + show (MkProtocols x1 x2 x3 x4 x5) = + "\n " ++ show x1 ++ + "\n " ++ show x2 ++ + "\n " ++ show x3 ++ + "\n " ++ show x4 ++ + "\n " ++ show x5 ++ + "\n" + +{- + Helper functions +-} + +-- | Duration of follow up in days +followupDuration :: Integral b => b +followupDuration = 365 + +-- | Duration to not observe events after the begin of index. +washoutDuration :: Integral b => b +washoutDuration = 7 + +-- | Creates an interval *starting 7 days after the index* and +-- ending 'followupDuration' days later. +makeFollowupInterval :: ( Integral b + , Intervallic i a + , IntervalSizeable a b) => + b -> Index i a -> Interval a +makeFollowupInterval dur index = + beginerval dur (add washoutDuration (begin $ getIndex index)) + +-- | Creates an interval *starting 7 days after the index* and +-- ending 'followupDuration' days later. +followupInterval :: (Integral b, IntervalSizeable a b) => + Index Interval a -> Interval a +followupInterval = makeFollowupInterval 365 + +{- + Functions for defining the study's exposure protocol(s) +-} + +protocol :: ( Intervallic i0 a + , Intervallic i1 a + , Intervallic i2 a + , IntervalSizeable a b + , Filterable container) => + (Index i2 a -> i0 a) + -- ^ Function that maps an index interval to interval during which protocol is evaluated + -> (i0 a -> container (i1 a) -> ProtocolStatus b) + -- ^ Function that maps data to a @ProtocolStatus@. + -> Index i2 a + -> container (i1 a) + -> ProtocolStatus b +protocol g f i dat = f (g i) ( filterConcur (g i) dat ) + +compliantIfNone :: ( IntervalSizeable a b + , Intervallic i0 a + , Intervallic i1 a + , Witherable container ) => + i0 a + -> container (i1 a) + -> ProtocolStatus b +compliantIfNone i x + | null x = Compliant + | otherwise = NonCompliant (mkEventTime (fmap (`diff` begin i) (end <$> headMay (toList x)))) + +compliantIfSome :: ( IntervalSizeable a b + , Intervallic i0 a + , Intervallic i1 a + , Witherable container) => + i0 a + -> container (i1 a) + -> ProtocolStatus b +compliantIfSome i x + | null x = NonCompliant (mkEventTime (Just $ diff (end i) (begin i))) + | otherwise = Compliant + +protocolNoInit :: ( Integral b + , IntervalSizeable a b + , Intervallic i0 a + , Intervallic i1 a + , Witherable container) => + Index i0 a + -> container (i1 a) + -> ProtocolStatus b +protocolNoInit = protocol (makeFollowupInterval 365) compliantIfNone + +protocols :: ( Integral b + , IntervalSizeable a b + , Intervallic i0 a + , Intervallic i1 a + , Witherable container) => + Index i0 a + -> container (i1 a) + -> Protocols b +protocols i e = MkProtocols + ( protocol (makeFollowupInterval 365) compliantIfNone i e) + ( protocol (makeFollowupInterval 30 ) compliantIfSome i e) + ( protocol (makeFollowupInterval 90 ) compliantIfSome i e) + ( protocol (makeFollowupInterval 180) compliantIfSome i e) + ( protocol (makeFollowupInterval 365) compliantIfSome i e) + +-- adminCensor :: (Integral b) => EventTime b -> CensoredOccurrence c o b +-- adminCensor t = MkCensoredOccurrence AdminCensor ( RightCensored t ) + +compliantOutcome :: (Integral b) => + EventTime b + -> Occurrence OutcomeReason b + -> Occurrence CensorReason b + -> CensoredOccurrence CensorReason OutcomeReason b +compliantOutcome + adminTime + (MkOccurrence (oreason, otime)) + (MkOccurrence (creason, ctime)) + | all (adminTime <) [otime, ctime] = adminCensor adminTime + | all (otime <=) [ctime] = MkCensoredOccurrence (O oreason) (Uncensored otime) + | otherwise = MkCensoredOccurrence (C creason) (RightCensored ctime) + +nonCompliantOutcome :: (Integral b) => + EventTime b + -> EventTime b + -> Occurrence OutcomeReason b + -> Occurrence CensorReason b + -> CensoredOccurrence CensorReason OutcomeReason b +nonCompliantOutcome + etime + adminTime + (MkOccurrence (oreason, otime)) + (MkOccurrence (creason, ctime)) + | all (adminTime <) [otime, ctime, etime] = adminCensor adminTime + | all (otime <=) [ctime, etime] = MkCensoredOccurrence (O oreason) (Uncensored otime) + | etime <= ctime = MkCensoredOccurrence (C Noncompliance) (RightCensored etime) + | otherwise = MkCensoredOccurrence (C creason) (RightCensored ctime) + +decideOutcome :: (Integral b) => + EventTime b -- ^ admin censoring time + -> ProtocolStatus b -- ^ pcsk + -> Occurrence OutcomeReason b -- ^ time of outcome + -> Occurrence CensorReason b -- ^ time of censoring (other than noncompliance) + -> CensoredOccurrence CensorReason OutcomeReason b +decideOutcome adminTime exposure outcomeTime censorTime = + case exposure of + Compliant -> compliantOutcome adminTime outcomeTime censorTime + NonCompliant t -> nonCompliantOutcome t adminTime outcomeTime censorTime + +{- + Features needed to evaluate censoring and outcome events +-} +index :: (Ord a)=> + Def (F "events" (Events a) -> F "index" (Index Interval a)) +index = defineA ( + makeConceptsFilter ["index"] + .> intervals + .> headMay + .> \case + Nothing -> makeFeature $ featureDataL ( Other "no index" ) + Just x -> pure $ makeIndex x + ) + +flupEvents :: (Integral b, IntervalSizeable a b) => + Def ( + F "index" (Index Interval a) + -> F "events" (Events a) + -> F "allFollowupEvents" (Events b)) +flupEvents = define (\index es -> + es + |> filterConcur ( followupInterval index) + |> fmap ( diffFromBegin ( followupInterval index ) ) + ) + +{- + Censoring Events +-} + +death :: Integral b => Def ( + F "allFollowupEvents" (Events b) + -> F "death" (EventTime b)) +death = define (mkEventTime . fmap begin . firstConceptOccurrence ["death"]) + +disenrollment :: (Integral b, IntervalSizeable a b) => + Def ( + F "index" (Index Interval a) + -- using all events rather than just follow-up events because enrollment + -- intervals need to be combined first + -> F "events" (Events a) + -> F "disenrollment" (EventTime b)) +disenrollment = define (\i events -> + events + |> makeConceptsFilter ["enrollment"] + -- combine any concurring enrollment intervals + |> combineIntervals + -- find gaps between any enrollment intervals (as well as bounds of followup ) + |> gapsWithin (followupInterval i) + -- get the first gap longer than 30 days (if it exists) + |> \x -> (headMay . filter (\x -> duration x > 30)) =<< x + -- Shift endpoints of intervals so that end of follow up is reference point + |> fmap (diffFromBegin (followupInterval i)) + -- take the end of this gap as the time of disenrollment + |> fmap end + |> mkEventTime ) + +-- | A collector feature for all censors (except noncompliance) +censorTime :: (Integral b) => Def ( + F "death" (EventTime b) + -> F "disenrollment" (EventTime b) + -- etc + -> F "censortime" (Occurrence CensorReason b)) +censorTime = define ( + \dth disrl -> + minimum [ makeOccurrence Death dth + , makeOccurrence Disenrollment disrl + -- etc + ] + ) + +{- + Exposure Definitions +-} + +pcskEvents :: Def ( + F "events" (Events a) + -> F "pcskEvents" (Events a)) +pcskEvents = define ( makeConceptsFilter ["pcsk"] ) + +pcskProtocols :: (Integral b, IntervalSizeable a b) => + Def ( + F "index" (Index Interval a) + -> F "pcskEvents" (Events a) + -> F "pcskProtocols" (Protocols b) ) +pcskProtocols = define protocols + +{- + Outcome definitions +-} + +makeg :: (Integral b, IntervalSizeable a b) => + b + -> Index Interval a + -> ProtocolStatus b + -> Occurrence OutcomeReason b + -> Occurrence CensorReason b + -> CensoredOccurrence CensorReason OutcomeReason b +makeg dur i = decideOutcome + (mkEventTime $ Just $ duration (makeFollowupInterval dur i)) + +makeNegOutcomes :: (Integral b, IntervalSizeable a b) => + Index Interval a + -> Protocols b + -> Occurrence CensorReason b + -> Occurrence OutcomeReason b + -> NegOutcomes b +makeNegOutcomes i (MkProtocols p1 p2 p3 p4 p5) c o = MkNegOutcome + (makeg 365 i p1 o c) + (makeg 30 i p2 o c) + (makeg 90 i p3 o c) + (makeg 180 i p4 o c) + (makeg 365 i p5 o c) + +type OutcomeFeature name a b = + F "index" (Index Interval a) + -> F "allFollowupEvents" (Events b) + -> F "pcskProtocols" (Protocols b) + -> F "censortime" (Occurrence CensorReason b) + -> F name (NegOutcomes b) + +makeOutcomeDefinition :: + ( KnownSymbol name + , Integral b + , IntervalSizeable a b) => + [Text] + -> OutcomeReason + -> Def ( F "index" (Index Interval a) + -> F "allFollowupEvents" (Events b) + -> F "pcskProtocols" (Protocols b) + -> F "censortime" ( Occurrence CensorReason b) + -> F name ( NegOutcomes b)) +makeOutcomeDefinition cpt oreason = define ( + \index events protocols censor -> + events + |> firstConceptOccurrence cpt + |> \x -> makeOccurrence oreason (mkEventTime (fmap begin x)) + |> makeNegOutcomes index protocols censor + ) + +o1 :: (Integral b, IntervalSizeable a b ) => + Def ( OutcomeFeature "wellness" a b) +o1 = makeOutcomeDefinition ["wellness"] Wellness + +o2 :: (Integral b, IntervalSizeable a b ) => + Def ( OutcomeFeature "accident" a b) +o2 = makeOutcomeDefinition ["accident"] Accident + +{- + Tests of protocols +-} + +testProtocols :: (Integral b, IntervalSizeable a b ) => + [Event a] -> Feature "pcskProtocols" (Protocols b) +testProtocols input = eval pcskProtocols (idx, pcev) + where evs = pure input + idx = eval index evs + pcev = eval pcskEvents evs + +p1Protocols :: Feature "pcskProtocols" (Protocols Int) +p1Protocols = pure $ MkProtocols + ( NonCompliant (mkEventTime (Just 15)) ) + Compliant + Compliant + Compliant + Compliant + +p2Protocols :: Feature "pcskProtocols" (Protocols Int) +p2Protocols = pure $ MkProtocols + ( NonCompliant (mkEventTime (Just 60)) ) + ( NonCompliant (mkEventTime (Just 30)) ) + Compliant + Compliant + Compliant + +p3Protocols :: Feature "pcskProtocols" (Protocols Int) +p3Protocols = pure $ MkProtocols + ( NonCompliant (mkEventTime (Just 120)) ) + ( NonCompliant (mkEventTime (Just 30)) ) + ( NonCompliant (mkEventTime (Just 90)) ) + Compliant + Compliant + +p4Protocols :: Feature "pcskProtocols" (Protocols Int) +p4Protocols = pure $ MkProtocols + ( NonCompliant (mkEventTime (Just 240)) ) + ( NonCompliant (mkEventTime (Just 30)) ) + ( NonCompliant (mkEventTime (Just 90)) ) + ( NonCompliant (mkEventTime (Just 180)) ) + Compliant + +p5Protocols :: Feature "pcskProtocols" (Protocols Int) +p5Protocols = pure $ MkProtocols + Compliant + ( NonCompliant (mkEventTime (Just 30)) ) + ( NonCompliant (mkEventTime (Just 90)) ) + ( NonCompliant (mkEventTime (Just 180)) ) + ( NonCompliant (mkEventTime (Just 365)) ) + +{- + Tests of outcomes +-} + +testOutcomes :: ( Integral b, IntervalSizeable a b ) => + [Event a] + -> (Feature "wellness" ( NegOutcomes b ), Feature "accident" (NegOutcomes b) ) +testOutcomes input = ( + eval o1 (idx, flevs, prot, ctime) + , eval o2 (idx, flevs, prot, ctime) ) + where evs = pure input + idx = eval index evs + flevs = eval flupEvents (idx, evs) + pcev = eval pcskEvents evs + dth = eval death flevs + disen = eval disenrollment (idx, evs) + prot = eval pcskProtocols (idx, pcev) + ctime = eval censorTime (dth, disen) + +p1Outcomes :: (Integral b) => + ( Feature "wellness" ( NegOutcomes b) + , Feature "accident" ( NegOutcomes b)) +p1Outcomes = ( + pure $ MkNegOutcome + (MkCensoredOccurrence (C Noncompliance) (RightCensored (mkEventTime (Just 15)))) + (MkCensoredOccurrence AdminCensor (RightCensored (mkEventTime (Just 30)))) + (MkCensoredOccurrence AdminCensor (RightCensored (mkEventTime (Just 90)))) + (MkCensoredOccurrence AdminCensor (RightCensored (mkEventTime (Just 180)))) + (MkCensoredOccurrence AdminCensor (RightCensored (mkEventTime (Just 365)))) + , pure $ MkNegOutcome + (MkCensoredOccurrence (C Noncompliance) (RightCensored (mkEventTime (Just 15)))) + (MkCensoredOccurrence AdminCensor (RightCensored (mkEventTime (Just 30)))) + (MkCensoredOccurrence AdminCensor (RightCensored (mkEventTime (Just 90)))) + (MkCensoredOccurrence AdminCensor (RightCensored (mkEventTime (Just 180)))) + (MkCensoredOccurrence AdminCensor (RightCensored (mkEventTime (Just 365)))) + ) + + +p1Outcomes' :: (Integral b) => + ( Feature "wellness" (NegOutcomes b) + , Feature "accident" (NegOutcomes b)) +p1Outcomes' = ( + pure $ MkNegOutcome + (MkCensoredOccurrence (C Noncompliance) (RightCensored (mkEventTime (Just 15)))) + (MkCensoredOccurrence AdminCensor (RightCensored (mkEventTime (Just 30)))) + (MkCensoredOccurrence (O Wellness) (Uncensored (mkEventTime (Just 51)))) + (MkCensoredOccurrence (O Wellness) (Uncensored (mkEventTime (Just 51)))) + (MkCensoredOccurrence (O Wellness) (Uncensored (mkEventTime (Just 51)))) + , pure $ MkNegOutcome + (MkCensoredOccurrence (C Noncompliance) (RightCensored (mkEventTime (Just 15)))) + (MkCensoredOccurrence AdminCensor (RightCensored (mkEventTime (Just 30)))) + (MkCensoredOccurrence AdminCensor (RightCensored (mkEventTime (Just 90)))) + (MkCensoredOccurrence AdminCensor (RightCensored (mkEventTime (Just 180)))) + (MkCensoredOccurrence AdminCensor (RightCensored (mkEventTime (Just 365)))) + ) + +{- + Test specs +-} + +exampleFeatures4Spec :: Spec +exampleFeatures4Spec = do + describe "tests of exposure protocols" $ + do + it "p1" $ + testProtocols p1Events `shouldBe` p1Protocols + it "p2" $ + testProtocols p2Events `shouldBe` p2Protocols + it "p3" $ + testProtocols p3Events `shouldBe` p3Protocols + it "p4" $ + testProtocols p4Events `shouldBe` p4Protocols + it "p5" $ + testProtocols p5Events `shouldBe` p5Protocols + + describe "tests of outcomes" $ + do + it "p1" $ + testOutcomes p1Events `shouldBe` p1Outcomes + it "p1'" $ + testOutcomes (sort p1Events <> [toEvent (1, 59, "wellness")] ) + `shouldBe` p1Outcomes' + + -- describe "SAP examples" $ + -- do + -- it "sap example 1" pending + -- testOutcomes sapExample1 `shouldBe` ??? diff --git a/examples/Main.hs b/examples/Main.hs --- a/examples/Main.hs +++ b/examples/Main.hs @@ -6,6 +6,7 @@ import ExampleFeatures1 ( exampleFeatures1Spec ) import ExampleFeatures2 ( exampleFeatures2Spec ) import ExampleFeatures3 ( exampleFeatures3Spec ) +import ExampleFeatures4 ( exampleFeatures4Spec ) import ExampleCohort1 ( exampleCohort1tests ) import Test.Tasty import Test.Tasty.Hspec ( testSpec ) @@ -18,11 +19,13 @@ main = do spec1 <- testSpec "spec1" exampleFeatures1Spec spec2 <- testSpec "spec2" exampleFeatures2Spec - spec3 <- testSpec "spec3" exampleFeatures3Spec + spec3 <- testSpec "spec3" exampleFeatures3Spec + spec4 <- testSpec "spec4" exampleFeatures4Spec defaultMain (testGroup "tests" [ spec1 , spec2 - , spec3 + , spec3 + , spec4 , testGroup "Tests" [exampleCohort1tests] ]) 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.14.0 +version: 0.15.0 description: Please see the README on GitHub at homepage: https://github.com/novisci/asclepias/#readme bug-reports: https://github.com/novisci/asclepias/issues @@ -36,17 +36,18 @@ Features.Featureable Features.Output Features.Featureset - FeatureEvents + Cohort + Cohort.Core + Cohort.Input + Cohort.Output + Cohort.Criteria + Cohort.Index Hasklepias + Hasklepias.FeatureEvents Hasklepias.MakeApp + Hasklepias.Misc Hasklepias.Reexports Hasklepias.ReexportsUnsafe - Hasklepias.Cohort - Hasklepias.Cohort.Core - Hasklepias.Cohort.Input - Hasklepias.Cohort.Output - Hasklepias.Cohort.Criteria - Hasklepias.Cohort.Index Stype Stype.Aeson Stype.Numeric @@ -71,7 +72,7 @@ , co-log == 0.4.0.1 , flow == 1.0.22 , ghc-prim == 0.6.1 - , interval-algebra == 0.9.0 + , interval-algebra == 0.10.0 , lens == 5.0.1 , lens-aeson == 1.1.1 , mtl == 2.2.2 @@ -101,10 +102,10 @@ FeaturesSpec Features.OutputSpec Features.FeaturesetSpec - Hasklepias.Cohort.InputSpec - Hasklepias.Cohort.CoreSpec - Hasklepias.Cohort.CriteriaSpec - FeatureEventsSpec + Cohort.InputSpec + Cohort.CoreSpec + Cohort.CriteriaSpec + Hasklepias.FeatureEventsSpec Stype.AesonSpec Stype.Numeric.CensoredSpec Paths_hasklepias @@ -121,7 +122,7 @@ , flow == 1.0.22 , hasklepias , hspec - , interval-algebra == 0.9.0 + , interval-algebra == 0.10.0 , lens == 5.0.1 , text >=1.2.3 , time >=1.11 @@ -138,6 +139,7 @@ ExampleFeatures1 ExampleFeatures2 ExampleFeatures3 + ExampleFeatures4 ExampleCohort1 hs-source-dirs: examples diff --git a/src/Cohort.hs b/src/Cohort.hs new file mode 100644 --- /dev/null +++ b/src/Cohort.hs @@ -0,0 +1,35 @@ +{-| +Module : Hasklepias Cohorts +Description : Defines the Cohort type and associated methods +Copyright : (c) NoviSci, Inc 2020 +License : BSD3 +Maintainer : bsaul@novisci.com +-} +{-# OPTIONS_HADDOCK hide #-} +{-# LANGUAGE NoImplicitPrelude #-} + +module Cohort( + + -- * Defining Cohorts + module Cohort.Core + + -- ** Criteria + , module Cohort.Criteria + -- ** Index + , module Cohort.Index + + -- * Cohort I/O + -- ** Input + , module Cohort.Input + -- ** Output + , module Cohort.Output + + +) where + + +import Cohort.Core +import Cohort.Index +import Cohort.Criteria +import Cohort.Input +import Cohort.Output diff --git a/src/Cohort/Core.hs b/src/Cohort/Core.hs new file mode 100644 --- /dev/null +++ b/src/Cohort/Core.hs @@ -0,0 +1,167 @@ +{-| +Module : Hasklepias Cohorts +Description : Defines the Cohort type and associated methods +Copyright : (c) NoviSci, Inc 2020 +License : BSD3 +Maintainer : bsaul@novisci.com +-} +{-# OPTIONS_HADDOCK hide #-} +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE TupleSections #-} +{-# LANGUAGE LambdaCase #-} +-- {-# LANGUAGE Safe #-} + +module Cohort.Core( + Subject(..) + , ID + , Population(..) + , ObsUnit(..) + , CohortData(..) + , Cohort(..) + , CohortSpec + , AttritionInfo(..) + , specifyCohort + , makeObsUnitFeatures + , evalCohort + , getCohortIDs + , getCohortData + , getAttritionInfo +) where + +import GHC.Num ( Num((+)), Natural ) +import Data.Aeson ( FromJSON, ToJSON, ToJSONKey ) +import Data.Bool ( Bool ) +import Data.Eq ( Eq ) +import Data.Foldable ( Foldable(length) ) +import Data.Function ( ($) ) +import Data.Functor ( Functor(fmap) ) +import Data.Maybe ( Maybe(..), catMaybes ) +import Data.List ( zipWith, replicate ) +import Data.List.NonEmpty ( NonEmpty(..), zip, fromList, nonEmpty ) +import Data.Map.Strict as Map ( toList, fromListWith ) +import Data.Text ( Text ) +import GHC.Generics ( Generic ) +import GHC.Show ( Show(..) ) +import Cohort.Index ( makeIndex, Index(..) ) +import Cohort.Criteria + +-- | A subject identifier. Currently, simply @Text@. +type ID = Text + +-- | A subject is just a pair of @ID@ and data. +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 + +-- | A population is a list of @'Subject'@s +newtype Population d = MkPopulation [Subject d] + deriving (Eq, Show, Generic) + +instance Functor Population where + fmap f (MkPopulation x) = MkPopulation (fmap (fmap f) x) + +instance (FromJSON d) => FromJSON (Population d) where + +-- | An observational unit is what a subject may be transformed into. +data ObsUnit d = MkObsUnit { + obsID :: ID + , obsData :: d } + deriving (Eq, Show, Generic) + +-- | A container for CohortData +newtype CohortData d = MkCohortData { getObsData :: [ObsUnit d] } + deriving (Eq, Show, Generic) + +-- | A cohort is a list of observational units along with @'AttritionInfo'@ +-- regarding the number of subjects excluded by the @'Criteria'@. +newtype Cohort d = MkCohort (Maybe AttritionInfo, CohortData d) + deriving (Eq, Show, Generic) + +-- | Gets the attrition info from a cohort +getAttritionInfo :: Cohort d -> Maybe AttritionInfo +getAttritionInfo (MkCohort (x, _)) = x + +-- | Unpacks a @'Population'@ to a list of subjects. +getPopulation :: Population d -> [Subject d] +getPopulation (MkPopulation x) = x + +-- | Gets the data out of a @'Subject'@. +getSubjectData :: Subject d -> d +getSubjectData (MkSubject (_, x)) = x + +-- | Tranforms a @'Subject'@ into a @'ObsUnit'@. +makeObsUnitFeatures :: (d1 -> d0) -> Subject d1 -> ObsUnit d0 +makeObsUnitFeatures f (MkSubject (id, dat)) = MkObsUnit id (f dat) + +-- | A cohort specification consist of two functions: one that transforms a subject's +-- input data into a @'Criteria'@ and another that transforms a subject's input data +-- into the desired return type. +data CohortSpec d1 d0 = MkCohortSpec + { runCriteria:: d1 -> Criteria + -- (Feature (Index i a)) + , runFeatures:: d1 -> d0 } + +-- | Creates a @'CohortSpec'@. +specifyCohort :: (d1 -> Criteria) -> (d1 -> d0) -> CohortSpec d1 d0 +specifyCohort = MkCohortSpec + +-- | Evaluates the @'runCriteria'@ of a @'CohortSpec'@ on a @'Population'@ to +-- return a list of @Subject Criteria@ (one per subject in the population). +evalCriteria :: CohortSpec d1 d0 -> Population d1 -> [Subject Criteria] +evalCriteria (MkCohortSpec runCrit _) (MkPopulation pop) = fmap (fmap runCrit) pop + +-- | Convert a list of @Subject Criteria@ into a list of @Subject CohortStatus@ +evalCohortStatus :: [Subject Criteria] -> [Subject CohortStatus] +evalCohortStatus = fmap (fmap checkCohortStatus) + +-- | Runs the input function which transforms a subject into an observational unit. +-- If the subeject is excluded, the result is @Nothing@; otherwise it is @Just@ +-- an observational unit. +evalSubjectCohort :: (d1 -> d0) -> Subject CohortStatus -> Subject d1 -> Maybe (ObsUnit d0) +evalSubjectCohort f (MkSubject (id, status)) subjData = + case status of + Included -> Just $ makeObsUnitFeatures f subjData + ExcludedBy _ -> Nothing + +-- | A type which collects the counts of subjects included or excluded. +newtype AttritionInfo = MkAttritionInfo (NonEmpty (CohortStatus, Natural)) + deriving (Eq, Show, Generic) + +-- | Initializes @AttritionInfo@ from a @'Criteria'@. +initAttritionInfo :: Criteria -> AttritionInfo +initAttritionInfo x = + MkAttritionInfo $ zip (initStatusInfo x) + (0 :| replicate (length (getCriteria x)) 0) + +-- | Creates an @'AttritionInfo'@ from a list of @Subject CohortStatus@. The result +-- is @Nothing@ if the input list is empty. +measureAttrition :: [Subject CohortStatus] -> Maybe AttritionInfo +measureAttrition l = fmap MkAttritionInfo $ nonEmpty $ Map.toList $ + Map.fromListWith (+) $ fmap (\x -> (getSubjectData x, 1)) l + +-- | The internal function to evaluate a @'CohortSpec'@ on a @'Population'@. +evalUnits :: CohortSpec d1 d0 -> Population d1 -> (Maybe AttritionInfo, CohortData d0) +evalUnits spec pop = + ( measureAttrition statuses + , MkCohortData $ catMaybes $ zipWith (evalSubjectCohort (runFeatures spec)) + statuses + (getPopulation pop)) + where crits = evalCriteria spec pop + statuses = evalCohortStatus crits + +-- | Evaluates a @'CohortSpec'@ on a @'Population'@. +evalCohort :: CohortSpec d1 d0 -> Population d1 -> Cohort d0 +evalCohort s p = MkCohort $ evalUnits s p + +-- | Get IDs from a cohort. +getCohortIDs :: Cohort d -> [ID] +getCohortIDs (MkCohort (_, dat)) = fmap obsID ( getObsData dat ) + +-- | Get data from a cohort. +getCohortData :: Cohort d -> [d] +getCohortData (MkCohort (_, dat)) = fmap obsData ( getObsData dat ) diff --git a/src/Cohort/Criteria.hs b/src/Cohort/Criteria.hs new file mode 100644 --- /dev/null +++ b/src/Cohort/Criteria.hs @@ -0,0 +1,144 @@ +{-| +Module : Cohort Criteria +Description : Defines the Criteria and related types and functions +Copyright : (c) NoviSci, Inc 2020 +License : BSD3 +Maintainer : bsaul@novisci.com +-} +{-# OPTIONS_HADDOCK hide #-} +{-# LANGUAGE Safe #-} +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE TupleSections #-} + +module Cohort.Criteria( + Criterion + , Criteria(..) + , Status(..) + , CohortStatus(..) + , criterion + , criteria + , excludeIf + , includeIf + , initStatusInfo + , checkCohortStatus +) where + +import safe GHC.Generics ( Generic ) +import safe GHC.Num ( Num((+)), Natural ) +import safe GHC.Show ( Show(show) ) +import safe GHC.TypeLits ( KnownSymbol, symbolVal ) +import safe Control.Applicative ( Applicative(pure) ) +import safe Control.Monad ( Functor(..) ) +import safe Data.Bifunctor ( Bifunctor(second) ) +import safe Data.Bool ( Bool(..), otherwise, not, (&&) ) +import safe Data.Either ( either ) +import safe Data.Eq ( Eq(..) ) +import safe Data.Function ( ($), (.), const, id ) +import safe qualified Data.List.NonEmpty as NE + ( NonEmpty, zip, fromList, toList, map ) +import safe Data.List ( find, (++) ) +import safe Data.Maybe ( Maybe(..), maybe ) +import safe Data.Ord ( Ord(..), Ordering(..) ) +import safe Data.Semigroup ( Semigroup((<>)) ) +import safe Data.Tuple ( fst, snd ) +import safe Data.Text ( Text, pack ) +import safe Features.Compose ( getFeatureData + , Feature + , nameFeature + , FeatureN(..) ) + +-- | Defines the return type for @'Criterion'@ indicating whether to include or +-- exclude a subject. +data Status = Include | Exclude deriving (Eq, Show) + +-- | Defines subject's diposition in a cohort either included or which criterion +-- they were excluded by. See @'checkCohortStatus'@ for evaluating a @'Criteria'@ +-- to determine CohortStatus. +data CohortStatus = + Included | ExcludedBy (Natural, Text) + deriving (Eq, Show, Generic) + +-- Defines an ordering to put @Included@ last in a container of @'CohortStatus'@. +-- The @'ExcludedBy'@ are ordered by their number value. +instance Ord CohortStatus where + compare Included Included = EQ + compare Included (ExcludedBy _) = GT + compare (ExcludedBy _) Included = LT + compare (ExcludedBy (i, _)) (ExcludedBy (j, _)) = compare i j + +-- | Helper to convert a @Bool@ to a @'Status'@ +-- +-- >>> includeIf True +-- >>> includeIf False +-- Include +-- Exclude +includeIf :: Bool -> Status +includeIf True = Include +includeIf False = Exclude + +-- | Helper to convert a @Bool@ to a @'Status'@ +-- +-- >>> excludeIf True +-- >>> excludeIf False +-- Exclude +-- Include +excludeIf :: Bool -> Status +excludeIf True = Exclude +excludeIf False = Include + +-- | A type that is simply a @'FeatureN Status'@, that is, a feature that +-- identifies whether to @'Include'@ or @'Exclude'@ a subject. +newtype Criterion = MkCriterion ( FeatureN Status ) deriving (Eq, Show) + +-- | Converts a @'Feature'@ to a @'Criterion'@. +criterion :: (KnownSymbol n) => Feature n Status -> Criterion +criterion x = MkCriterion (nameFeature x) + +-- | A nonempty collection of @'Criterion'@ paired with a @Natural@ number. +newtype Criteria = MkCriteria { + getCriteria :: NE.NonEmpty (Natural, Criterion) + } deriving (Eq, Show) + +-- | Constructs a @'Criteria'@ from a @'NE.NonEmpty'@ collection of @'Criterion'@. +criteria :: NE.NonEmpty Criterion -> Criteria +criteria l = MkCriteria $ NE.zip (NE.fromList [1..]) l + +-- | Unpacks a @'Criterion'@ into a (Text, Status) pair where the text is the +-- name of the criterion and its @Status@ is the value of the status in the +-- @'Criterion'@. In the case, that the value of the @'FeatureData'@ within the +-- @'Criterion'@ is @Left@, the status is set to @'Exclude'@. +getStatus :: Criterion -> (Text, Status) +getStatus (MkCriterion x) = + either (const (nm, Exclude)) (nm,) ((getFeatureData . getDataN) x) + where nm = getNameN x + +-- | Converts a subject's @'Criteria'@ into a @'NE.NonEmpty'@ triple of +-- (order of criterion, name of criterion, status) +getStatuses :: + Criteria -> NE.NonEmpty (Natural, Text, Status) +getStatuses (MkCriteria x) = + fmap (\c -> (fst c, (fst.getStatus.snd) c, (snd.getStatus.snd) c)) x + +-- | An internal function used to @'Data.List.find'@ excluded statuses. Used in +-- 'checkCohortStatus'. +findExclude :: + Criteria -> Maybe (Natural, Text, Status) +findExclude x = find (\(_, _, z) -> z == Exclude) (getStatuses x) + +-- | Converts a subject's @'Criteria'@ to a @'CohortStatus'@. The status is set +-- to @'Included'@ if none of the @'Criterion'@ have a status of @'Exclude'@. +checkCohortStatus :: + Criteria -> CohortStatus +checkCohortStatus x = + maybe Included (\(i, n, _) -> ExcludedBy (i, n)) (findExclude x) + +-- | Utility to get the name of a @'Criterion'@. +getCriterionName :: Criterion -> Text +getCriterionName (MkCriterion x) = getNameN x + +-- | Initializes a container of @'CohortStatus'@ from a @'Criteria'@. This can be used +-- to collect generate all the possible Exclusion/Inclusion reasons. +initStatusInfo :: Criteria -> NE.NonEmpty CohortStatus +initStatusInfo (MkCriteria z) = + NE.map (ExcludedBy . Data.Bifunctor.second getCriterionName) z <> pure Included diff --git a/src/Cohort/Index.hs b/src/Cohort/Index.hs new file mode 100644 --- /dev/null +++ b/src/Cohort/Index.hs @@ -0,0 +1,39 @@ +{-| +Module : Cohort Index +Description : Defines the Index and related types and functions +Copyright : (c) NoviSci, Inc 2020 +License : BSD3 +Maintainer : bsaul@novisci.com +-} + +{-# OPTIONS_HADDOCK hide #-} +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE DeriveGeneric #-} +-- {-# LANGUAGE Safe #-} + +module Cohort.Index( + Index + , makeIndex + , getIndex +) where + +import GHC.Show ( Show ) +import GHC.Generics +import Data.Eq ( Eq ) +import IntervalAlgebra ( Intervallic ) +import Data.Aeson + +{-| +An @Index@ is a wrapper for an @Intervallic@ used to indicate that a particular +interval is considered an index interval to which other intervals will be compared. +-} + +newtype Index i a = MkIndex { + getIndex :: i a -- ^ Unwrap an @Index@ + } deriving (Eq, Show, Generic) + +-- | Creates a new @'Index'@. +makeIndex :: Intervallic i a => i a -> Index i a +makeIndex = MkIndex + +instance (Intervallic i a, ToJSON (i a)) => ToJSON (Index i a) diff --git a/src/Cohort/Input.hs b/src/Cohort/Input.hs new file mode 100644 --- /dev/null +++ b/src/Cohort/Input.hs @@ -0,0 +1,97 @@ +{-| +Module : Functions for Parsing Hasklepias populations +Description : Defines FromJSON instances for Hasklepias populations . +Copyright : (c) NoviSci, Inc 2020 +License : BSD3 +Maintainer : bsaul@novisci.com +-} +{-# OPTIONS_HADDOCK hide #-} +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE TupleSections #-} + +module Cohort.Input( + parsePopulationLines + , parsePopulationIntLines + , parsePopulationDayLines + , ParseError(..) +) where + +import Control.Applicative ( Applicative((<*>)), (<$>) ) +import Data.Aeson ( FromJSON(..) + , ToJSON(..) + , eitherDecode + , Value(Array)) +import qualified Data.ByteString.Lazy as B ( fromStrict + , toStrict + , ByteString) +import qualified Data.ByteString.Char8 as C ( lines ) +import Prelude ( + String) +import Data.Bifunctor ( Bifunctor(first) ) +import Data.Either ( Either(..) + , partitionEithers ) +import Data.Eq ( Eq ) +import Data.Function ( ($), id ) +import Data.Functor ( Functor(fmap) ) +import Data.List ( sort, (++), zipWith ) +import qualified Data.Map.Strict as M ( toList, fromListWith) +import Data.Ord ( Ord ) +import Data.Text (Text, pack) +import Data.Time.Calendar ( Day ) +import Data.Vector ( (!) ) +import EventData ( Events, event, Event ) +import EventData.Aeson () +import Cohort.Core ( Population(..) + , ID + , Subject(MkSubject) ) +import GHC.Int ( Int ) +import GHC.Num ( Natural ) +import GHC.Show ( Show ) +import IntervalAlgebra ( IntervalSizeable ) + + +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 )) + +decodeIntoSubj :: (FromJSON a, Show a, IntervalSizeable a b) => + B.ByteString -> Either Text (SubjectEvent a) +decodeIntoSubj x = first pack $ eitherDecode x + +-- | Contains the line number and error message. +newtype ParseError = MkParseError (Natural, Text) deriving (Eq, Show) + +-- | Parse @Event Int@ from json lines. +parseSubjectLines :: + (FromJSON a, Show a, IntervalSizeable a b) => + B.ByteString -> ( [ParseError], [SubjectEvent a] ) +parseSubjectLines l = + partitionEithers $ zipWith + (\x i -> first (\t -> MkParseError (i,t)) (decodeIntoSubj $ B.fromStrict x) ) + (C.lines $ B.toStrict l) + [1..] + +-- | Parse @Event Int@ from json lines. +parsePopulationLines :: (FromJSON a, Show a, IntervalSizeable a b) => + B.ByteString -> ([ParseError], Population (Events a)) +parsePopulationLines x = fmap mapIntoPop (parseSubjectLines x) + +-- | Parse @Event Int@ from json lines. +parsePopulationIntLines :: B.ByteString -> ([ParseError], Population (Events Int)) +parsePopulationIntLines x = fmap mapIntoPop (parseSubjectLines x) + +-- | Parse @Event Day@ from json lines. +parsePopulationDayLines :: B.ByteString -> ([ParseError], Population (Events Day)) +parsePopulationDayLines x = fmap mapIntoPop (parseSubjectLines x) diff --git a/src/Cohort/Output.hs b/src/Cohort/Output.hs new file mode 100644 --- /dev/null +++ b/src/Cohort/Output.hs @@ -0,0 +1,120 @@ +{-| +Module : Hasklepias Cohorts +Description : Defines the options for outputting a cohort +Copyright : (c) NoviSci, Inc 2020 +License : BSD3 +Maintainer : bsaul@novisci.com +-} +{-# OPTIONS_HADDOCK hide #-} +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE DeriveAnyClass #-} + +module Cohort.Output( + CohortShape + , ShapeCohort(..) + , toJSONCohortShape +) where + +import Data.Aeson ( ToJSON(..) + , Value + , object + , (.=) ) +import Data.Function ( (.) ) +import Data.Functor ( Functor(fmap) ) +import Data.List.NonEmpty as NE ( NonEmpty(..) + , head + , fromList + , zip ) +import Data.Tuple ( uncurry ) +import GHC.Generics ( Generic ) +import GHC.Types ( Type ) +import GHC.Show ( Show ) +import Cohort.Core ( AttritionInfo, + Cohort, + ObsUnit, + ID, + CohortData, + getCohortData, + getCohortIDs ) +import Cohort.Criteria ( CohortStatus ) +import Features.Featureset ( FeaturesetList(MkFeaturesetList) + , Featureset + , getFeatureset + , getFeaturesetList + , tpose ) +import Features.Output ( ShapeOutput(dataOnly, nameAttr) + , OutputShape ) + +instance (ToJSON d) => ToJSON (ObsUnit d) where +instance (ToJSON d) => ToJSON (CohortData d) where +instance (ToJSON d) => ToJSON (Cohort d) where +instance ToJSON CohortStatus where +instance ToJSON AttritionInfo where + +-- | A type used to determine the output shape of a Cohort. +data CohortShape d where + ColumnWise :: (Show a, ToJSON a) => a -> CohortShape ColumnWise + RowWise :: (Show a, ToJSON a) => a -> CohortShape RowWise + +deriving instance Show d => Show (CohortShape d) + +-- | Maps CohortShape into an Aeson Value. +-- TODO: implement Generic and ToJSON instance of CohortShape directly. +toJSONCohortShape :: CohortShape shape -> Value +toJSONCohortShape (ColumnWise x) = toJSON x +toJSONCohortShape (RowWise x) = toJSON x + +class ShapeCohort d where + colWise :: Cohort d -> CohortShape ColumnWise + rowWise :: Cohort d -> CohortShape RowWise + +instance ShapeCohort Featureset where + colWise x = ColumnWise (shapeColumnWise x) + rowWise x = RowWise (shapeRowWise x) + +data ColumnWise = MkColumnWise { + colAttributes :: NonEmpty (OutputShape Type) + , ids :: [ID] + , colData :: NonEmpty (NonEmpty (OutputShape Type)) + } deriving ( Show, Generic ) + +instance ToJSON ColumnWise where + toJSON x = object [ "attributes" .= colAttributes x + , "ids" .= ids x + , "data" .= colData x ] + +newtype IDRow = MkIDRow (ID, NonEmpty (OutputShape Type)) + deriving ( Show, Generic ) + +instance ToJSON IDRow where + toJSON (MkIDRow x) = object [ uncurry (.=) x] + +data RowWise = MkRowWise { + attributes :: NonEmpty (OutputShape Type) + , rowData :: NonEmpty IDRow + } deriving ( Show, Generic ) + +instance ToJSON RowWise where + toJSON x = object [ "attributes" .= attributes x + , "data" .= rowData x ] + +shapeColumnWise :: Cohort Featureset -> ColumnWise +shapeColumnWise x = MkColumnWise + (fmap (nameAttr . NE.head . getFeatureset) z) + (getCohortIDs x) + (fmap (fmap dataOnly . getFeatureset) z) + -- TODO: don't use fromList; do something more principled + where z = getFeaturesetList (tpose (MkFeaturesetList (NE.fromList (getCohortData x)))) + +shapeRowWise :: Cohort Featureset -> RowWise +shapeRowWise x = MkRowWise + (fmap (nameAttr . NE.head . getFeatureset) z) + (fmap MkIDRow (zip ids (fmap (fmap dataOnly . getFeatureset) z))) + -- TODO: don't use fromList; do something more principled + where z = NE.fromList (getCohortData x) + ids = fromList (getCohortIDs x) diff --git a/src/FeatureEvents.hs b/src/FeatureEvents.hs deleted file mode 100644 --- a/src/FeatureEvents.hs +++ /dev/null @@ -1,249 +0,0 @@ -{-| -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 @'Features.Feature'@ from -@'EventData.Event'@s. --} -{-# OPTIONS_HADDOCK hide #-} -{-# LANGUAGE NoImplicitPrelude #-} - -module FeatureEvents( - -- ** Container predicates - isNotEmpty - , atleastNofX - , anyGapsWithinAtLeastDuration - , allGapsWithinLessThanDuration - - -- ** Finding occurrences of concepts - , nthConceptOccurrence - , firstConceptOccurrence - - -- ** Reshaping containers - , allPairs - , splitByConcepts - - -- ** Create filters - , makeConceptsFilter - , makePairedFilter - - -- ** Functions for working with Event Domains - , viewBirthYears - , previewBirthYear - - -- ** Function for manipulating intervals - , lookback - , lookahead - - -- ** Misc functions - , computeAgeAt -) where - - -import IntervalAlgebra ( Intervallic - , IntervalSizeable(..) - , ComparativePredicateOf1 - , ComparativePredicateOf2 - , Interval - , IntervalCombinable - , begin - , end - , beginerval - , enderval ) -import IntervalAlgebra.PairedInterval ( PairedInterval, getPairData ) -import IntervalAlgebra.IntervalUtilities ( durations, gapsWithin ) -import EventData ( Events - , Event - , ConceptEvent - , ctxt ) -import EventData.Context ( Concept - , Concepts - , Context - , HasConcept( hasConcepts ) - , facts ) -import EventData.Context.Domain ( Domain - , demo - , info - , _Demographics ) -import Safe ( headMay, lastMay ) -import Control.Applicative ( Applicative(liftA2) ) -import Control.Monad ( Functor(fmap), (=<<) ) -import Control.Lens ( preview, (^.) ) -import Data.Bool ( Bool(..), (&&), not, (||) ) -import Data.Either ( either ) -import Data.Eq ( Eq ) -import Data.Foldable ( Foldable(length, null), all, any ) -import Data.Function ( (.), ($), const ) -import Data.Functor ( Functor(fmap) ) -import Data.Int ( Int ) -import Data.Maybe ( Maybe(..), maybe, mapMaybe ) -import Data.Monoid ( Monoid ) -import Data.Ord ( Ord(..) ) -import Data.Time.Calendar ( Day, Year, diffDays ) -import Data.Text ( Text ) -import Data.Text.Read ( rational ) -import Data.Tuple ( fst ) -import Witherable ( filter, Filterable, Witherable ) -import GHC.Num ( Integer, fromInteger ) -import GHC.Real ( RealFrac(floor), (/) ) - --- | 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 - --- | 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) - - --- | Create a predicate function that checks whether within a provided spanning --- interval, are there (e.g. any, all) gaps of (e.g. <, <=, >=, >) a specified --- duration among the input intervals? -makeGapsWithinPredicate :: - ( Monoid (t (Interval a)) - , Monoid (t (Maybe (Interval a))) - , Applicative t - , Witherable t - , IntervalSizeable a b - , IntervalCombinable i0 a - , IntervalCombinable i1 a) => - ((b -> Bool) -> t b -> Bool) - -> (b -> b -> Bool) - -> (b -> i0 a -> t (i1 a) -> Bool) -makeGapsWithinPredicate f op gapDuration interval l = - maybe False (f (`op` gapDuration) . durations) (gapsWithin interval l) - --- | Within a provided spanning interval, are there any gaps of at least the --- specified duration among the input intervals? -anyGapsWithinAtLeastDuration :: - (IntervalSizeable a b, IntervalCombinable i0 a, IntervalCombinable i1 a) => - b -- ^ duration of gap - -> i0 a -- ^ within this interval - -> [i1 a] - -> Bool -anyGapsWithinAtLeastDuration = makeGapsWithinPredicate any (>=) - --- | Within a provided spanning interval, are all gaps less than the specified --- duration among the input intervals? --- --- >>> allGapsWithinLessThanDuration 30 (beginerval 100 (0::Int)) [beginerval 5 (-1), beginerval 99 10] --- True -allGapsWithinLessThanDuration :: - (IntervalSizeable a b, IntervalCombinable i0 a, IntervalCombinable i1 a) => - b -- ^ duration of gap - -> i0 a -- ^ within this interval - -> [i1 a] - -> Bool -allGapsWithinLessThanDuration = makeGapsWithinPredicate all (<) - --- | Utility for reading text into a maybe integer -intMayMap :: Text -> Maybe Integer -- TODO: this is ridiculous -intMayMap x = fmap floor (either (const Nothing) (Just . fst) (Data.Text.Read.rational x)) - --- | Preview birth year from a domain -previewBirthYear :: Domain -> Maybe Year -previewBirthYear dmn = intMayMap =<< ((^.demo.info) =<< preview _Demographics dmn) - --- | Returns a (possibly emtpy) list of birth years from a set of events -viewBirthYears :: Events a -> [Year] -viewBirthYears = mapMaybe (\e -> previewBirthYear =<< Just (ctxt e^.facts )) - --- | Compute the "age" in years between two calendar days. The difference between --- the days is rounded down. -computeAgeAt :: Day -> Day -> Integer -computeAgeAt bd at = floor (fromInteger (diffDays at bd) / 365.25) - --- | Creates a new @Interval@ of a provided lookback duration ending at the --- 'begin' of the input interval. --- --- >>> lookback 4 (beginerval 10 (1 :: Int)) --- (-3, 1) -lookback :: (Intervallic i a, IntervalSizeable a b) => - b -- ^ lookback duration - -> i a - -> Interval a -lookback d x = enderval d (begin x) - --- | Creates a new @Interval@ of a provided lookahead duration beginning at the --- 'end' of the input interval. --- --- >>> lookahead 4 (beginerval 1 (1 :: Int)) --- (2, 6) -lookahead :: (Intervallic i a, IntervalSizeable a b) => - b -- ^ lookahead duration - -> i a - -> Interval a -lookahead d x = beginerval d (end x) - diff --git a/src/Features/Compose.hs b/src/Features/Compose.hs --- a/src/Features/Compose.hs +++ b/src/Features/Compose.hs @@ -55,7 +55,7 @@ import safe Control.Applicative ( Applicative(..) , liftA3, (<$>) ) import safe Control.Monad ( Functor(..), Monad(..) - , (=<<), join, liftM, liftM2, liftM3) + , (=<<), join, liftM, liftM2, liftM3, liftM4) import safe Data.Either ( Either(..) ) import safe Data.Eq ( Eq(..) ) import safe Data.Foldable ( Foldable(foldr), fold ) @@ -258,6 +258,8 @@ D2A :: (c -> b -> f0 a) -> Definition (f2 c -> f1 b -> f0 a) D3 :: (d -> c -> b -> a) -> Definition (f3 d -> f2 c -> f1 b -> f0 a) D3A :: (d -> c -> b -> f0 a) -> Definition (f3 d -> f2 c -> f1 b -> f0 a) + D4 :: (e -> d -> c -> b -> a) -> Definition (f4 e -> f3 d -> f2 c -> f1 b -> f0 a) + D4A :: (e -> d -> c -> b -> f0 a) -> Definition (f4 e -> f3 d -> f2 c -> f1 b -> f0 a) {- | Define (and @'DefineA@) provide a means to create new @'Definition'@s via @'define'@ (@'defineA'@). The @'define'@ function takes a single function input @@ -299,19 +301,24 @@ instance Define (b -> a) (FeatureData b -> FeatureData a) where define = D1 instance Define (c -> b -> a) (FeatureData c -> FeatureData b -> FeatureData a) where define = D2 instance Define (d -> c -> b -> a) (FeatureData d -> FeatureData c -> FeatureData b -> FeatureData a) where define = D3 +instance Define (e -> d -> c -> b -> a) (FeatureData e -> FeatureData d -> FeatureData c -> FeatureData b -> FeatureData a) where define = D4 instance DefineA (b -> FeatureData a) (FeatureData b -> FeatureData a) where defineA = D1A instance DefineA (c -> b -> FeatureData a) (FeatureData c -> FeatureData b -> FeatureData a) where defineA = D2A instance DefineA (d -> c -> b -> FeatureData a) (FeatureData d -> FeatureData c -> FeatureData b -> FeatureData a) where defineA = D3A +instance DefineA (e -> d -> c -> b -> FeatureData a) (FeatureData e -> FeatureData d -> FeatureData c -> FeatureData b -> FeatureData a) where defineA = D4A instance Define (b -> a) (Feature n1 b -> Feature n0 a) where define = D1 instance Define (c -> b -> a) (Feature n2 c -> Feature n1 b -> Feature n0 a) where define = D2 instance Define (d -> c -> b -> a) (Feature n3 d -> Feature n2 c -> Feature n1 b -> Feature n0 a) where define = D3 +instance Define (e -> d -> c -> b -> a) (Feature n4 e -> Feature n3 d -> Feature n2 c -> Feature n1 b -> Feature n0 a) where define = D4 instance DefineA (b -> Feature n0 a) (Feature n1 b -> Feature n0 a) where defineA = D1A instance DefineA (c -> b -> Feature n0 a) (Feature n2 c -> Feature n1 b -> Feature n0 a) where defineA = D2A instance DefineA (d -> c -> b -> Feature n0 a) (Feature n3 d -> Feature n2 c -> Feature n1 b -> Feature n0 a) where defineA = D3A +instance DefineA (e -> d -> c -> b -> Feature n0 a) (Feature n4 e -> Feature n3 d -> Feature n2 c -> Feature n1 b -> Feature n0 a) where defineA = D4A + {- | Evaluate a @Definition@. Note that (currently), the second argument of 'eval' is a *tuple* of inputs. For example, @@ -379,6 +386,15 @@ eval (D3 f) (MkFeature x, MkFeature y, MkFeature z) = MkFeature $ liftA3 f x y z eval (D3A f) (MkFeature x, MkFeature y, MkFeature z) = case liftA3 f x y z of + MkFeatureData (Left l) -> MkFeature $ MkFeatureData (Left l) + MkFeatureData (Right r) -> r + +instance Eval (Feature n4 e -> Feature n3 d -> Feature n2 c -> Feature n1 b -> Feature n0 a) + (Feature n4 e, Feature n3 d, Feature n2 c, Feature n1 b) (Feature n0 a) + where + eval (D4 f) (MkFeature v, MkFeature x, MkFeature y, MkFeature z) = MkFeature $ liftM4 f v x y z + eval (D4A f) (MkFeature v, MkFeature x, MkFeature y, MkFeature z) = + case liftM4 f v x y z of MkFeatureData (Left l) -> MkFeature $ MkFeatureData (Left l) MkFeatureData (Right r) -> r diff --git a/src/Hasklepias.hs b/src/Hasklepias.hs --- a/src/Hasklepias.hs +++ b/src/Hasklepias.hs @@ -23,10 +23,11 @@ can be found on [hackage](https://hackage.haskell.org/package/interval-algebra). -} - , module FeatureEvents + , module Hasklepias.FeatureEvents + , module Hasklepias.Misc -- * Specifying and building cohorts - , module Hasklepias.Cohort + , module Cohort -- ** Creating an executable cohort application , module Hasklepias.MakeApp @@ -47,10 +48,12 @@ import Features -import FeatureEvents +import Cohort + +import Hasklepias.FeatureEvents +import Hasklepias.Misc import Hasklepias.Reexports import Hasklepias.ReexportsUnsafe -import Hasklepias.Cohort import Hasklepias.MakeApp import Stype diff --git a/src/Hasklepias/Cohort.hs b/src/Hasklepias/Cohort.hs deleted file mode 100644 --- a/src/Hasklepias/Cohort.hs +++ /dev/null @@ -1,35 +0,0 @@ -{-| -Module : Hasklepias Cohorts -Description : Defines the Cohort type and associated methods -Copyright : (c) NoviSci, Inc 2020 -License : BSD3 -Maintainer : bsaul@novisci.com --} -{-# OPTIONS_HADDOCK hide #-} -{-# LANGUAGE NoImplicitPrelude #-} - -module Hasklepias.Cohort( - - -- * Defining Cohorts - module Hasklepias.Cohort.Core - - -- ** Criteria - , module Hasklepias.Cohort.Criteria - -- ** Index - , module Hasklepias.Cohort.Index - - -- * Cohort I/O - -- ** Input - , module Hasklepias.Cohort.Input - -- ** Output - , module Hasklepias.Cohort.Output - - -) where - - -import Hasklepias.Cohort.Core -import Hasklepias.Cohort.Index -import Hasklepias.Cohort.Criteria -import Hasklepias.Cohort.Input -import Hasklepias.Cohort.Output diff --git a/src/Hasklepias/Cohort/Core.hs b/src/Hasklepias/Cohort/Core.hs deleted file mode 100644 --- a/src/Hasklepias/Cohort/Core.hs +++ /dev/null @@ -1,167 +0,0 @@ -{-| -Module : Hasklepias Cohorts -Description : Defines the Cohort type and associated methods -Copyright : (c) NoviSci, Inc 2020 -License : BSD3 -Maintainer : bsaul@novisci.com --} -{-# OPTIONS_HADDOCK hide #-} -{-# LANGUAGE NoImplicitPrelude #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE TupleSections #-} -{-# LANGUAGE LambdaCase #-} --- {-# LANGUAGE Safe #-} - -module Hasklepias.Cohort.Core( - Subject(..) - , ID - , Population(..) - , ObsUnit(..) - , CohortData(..) - , Cohort(..) - , CohortSpec - , AttritionInfo(..) - , specifyCohort - , makeObsUnitFeatures - , evalCohort - , getCohortIDs - , getCohortData - , getAttritionInfo -) where - -import GHC.Num ( Num((+)), Natural ) -import Data.Aeson ( FromJSON, ToJSON, ToJSONKey ) -import Data.Bool ( Bool ) -import Data.Eq ( Eq ) -import Data.Foldable ( Foldable(length) ) -import Data.Function ( ($) ) -import Data.Functor ( Functor(fmap) ) -import Data.Maybe ( Maybe(..), catMaybes ) -import Data.List ( zipWith, replicate ) -import Data.List.NonEmpty ( NonEmpty(..), zip, fromList, nonEmpty ) -import Data.Map.Strict as Map ( toList, fromListWith ) -import Data.Text ( Text ) -import GHC.Generics ( Generic ) -import GHC.Show ( Show(..) ) -import Hasklepias.Cohort.Index ( makeIndex, Index(..) ) -import Hasklepias.Cohort.Criteria - --- | A subject identifier. Currently, simply @Text@. -type ID = Text - --- | A subject is just a pair of @ID@ and data. -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 - --- | A population is a list of @'Subject'@s -newtype Population d = MkPopulation [Subject d] - deriving (Eq, Show, Generic) - -instance Functor Population where - fmap f (MkPopulation x) = MkPopulation (fmap (fmap f) x) - -instance (FromJSON d) => FromJSON (Population d) where - --- | An observational unit is what a subject may be transformed into. -data ObsUnit d = MkObsUnit { - obsID :: ID - , obsData :: d } - deriving (Eq, Show, Generic) - --- | A container for CohortData -newtype CohortData d = MkCohortData { getObsData :: [ObsUnit d] } - deriving (Eq, Show, Generic) - --- | A cohort is a list of observational units along with @'AttritionInfo'@ --- regarding the number of subjects excluded by the @'Criteria'@. -newtype Cohort d = MkCohort (Maybe AttritionInfo, CohortData d) - deriving (Eq, Show, Generic) - --- | Gets the attrition info from a cohort -getAttritionInfo :: Cohort d -> Maybe AttritionInfo -getAttritionInfo (MkCohort (x, _)) = x - --- | Unpacks a @'Population'@ to a list of subjects. -getPopulation :: Population d -> [Subject d] -getPopulation (MkPopulation x) = x - --- | Gets the data out of a @'Subject'@. -getSubjectData :: Subject d -> d -getSubjectData (MkSubject (_, x)) = x - --- | Tranforms a @'Subject'@ into a @'ObsUnit'@. -makeObsUnitFeatures :: (d1 -> d0) -> Subject d1 -> ObsUnit d0 -makeObsUnitFeatures f (MkSubject (id, dat)) = MkObsUnit id (f dat) - --- | A cohort specification consist of two functions: one that transforms a subject's --- input data into a @'Criteria'@ and another that transforms a subject's input data --- into the desired return type. -data CohortSpec d1 d0 = MkCohortSpec - { runCriteria:: d1 -> Criteria - -- (Feature (Index i a)) - , runFeatures:: d1 -> d0 } - --- | Creates a @'CohortSpec'@. -specifyCohort :: (d1 -> Criteria) -> (d1 -> d0) -> CohortSpec d1 d0 -specifyCohort = MkCohortSpec - --- | Evaluates the @'runCriteria'@ of a @'CohortSpec'@ on a @'Population'@ to --- return a list of @Subject Criteria@ (one per subject in the population). -evalCriteria :: CohortSpec d1 d0 -> Population d1 -> [Subject Criteria] -evalCriteria (MkCohortSpec runCrit _) (MkPopulation pop) = fmap (fmap runCrit) pop - --- | Convert a list of @Subject Criteria@ into a list of @Subject CohortStatus@ -evalCohortStatus :: [Subject Criteria] -> [Subject CohortStatus] -evalCohortStatus = fmap (fmap checkCohortStatus) - --- | Runs the input function which transforms a subject into an observational unit. --- If the subeject is excluded, the result is @Nothing@; otherwise it is @Just@ --- an observational unit. -evalSubjectCohort :: (d1 -> d0) -> Subject CohortStatus -> Subject d1 -> Maybe (ObsUnit d0) -evalSubjectCohort f (MkSubject (id, status)) subjData = - case status of - Included -> Just $ makeObsUnitFeatures f subjData - ExcludedBy _ -> Nothing - --- | A type which collects the counts of subjects included or excluded. -newtype AttritionInfo = MkAttritionInfo (NonEmpty (CohortStatus, Natural)) - deriving (Eq, Show, Generic) - --- | Initializes @AttritionInfo@ from a @'Criteria'@. -initAttritionInfo :: Criteria -> AttritionInfo -initAttritionInfo x = - MkAttritionInfo $ zip (initStatusInfo x) - (0 :| replicate (length (getCriteria x)) 0) - --- | Creates an @'AttritionInfo'@ from a list of @Subject CohortStatus@. The result --- is @Nothing@ if the input list is empty. -measureAttrition :: [Subject CohortStatus] -> Maybe AttritionInfo -measureAttrition l = fmap MkAttritionInfo $ nonEmpty $ Map.toList $ - Map.fromListWith (+) $ fmap (\x -> (getSubjectData x, 1)) l - --- | The internal function to evaluate a @'CohortSpec'@ on a @'Population'@. -evalUnits :: CohortSpec d1 d0 -> Population d1 -> (Maybe AttritionInfo, CohortData d0) -evalUnits spec pop = - ( measureAttrition statuses - , MkCohortData $ catMaybes $ zipWith (evalSubjectCohort (runFeatures spec)) - statuses - (getPopulation pop)) - where crits = evalCriteria spec pop - statuses = evalCohortStatus crits - --- | Evaluates a @'CohortSpec'@ on a @'Population'@. -evalCohort :: CohortSpec d1 d0 -> Population d1 -> Cohort d0 -evalCohort s p = MkCohort $ evalUnits s p - --- | Get IDs from a cohort. -getCohortIDs :: Cohort d -> [ID] -getCohortIDs (MkCohort (_, dat)) = fmap obsID ( getObsData dat ) - --- | Get data from a cohort. -getCohortData :: Cohort d -> [d] -getCohortData (MkCohort (_, dat)) = fmap obsData ( getObsData dat ) diff --git a/src/Hasklepias/Cohort/Criteria.hs b/src/Hasklepias/Cohort/Criteria.hs deleted file mode 100644 --- a/src/Hasklepias/Cohort/Criteria.hs +++ /dev/null @@ -1,144 +0,0 @@ -{-| -Module : Cohort Criteria -Description : Defines the Criteria and related types and functions -Copyright : (c) NoviSci, Inc 2020 -License : BSD3 -Maintainer : bsaul@novisci.com --} -{-# OPTIONS_HADDOCK hide #-} -{-# LANGUAGE Safe #-} -{-# LANGUAGE NoImplicitPrelude #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE TupleSections #-} - -module Hasklepias.Cohort.Criteria( - Criterion - , Criteria(..) - , Status(..) - , CohortStatus(..) - , criterion - , criteria - , excludeIf - , includeIf - , initStatusInfo - , checkCohortStatus -) where - -import safe GHC.Generics ( Generic ) -import safe GHC.Num ( Num((+)), Natural ) -import safe GHC.Show ( Show(show) ) -import safe GHC.TypeLits ( KnownSymbol, symbolVal ) -import safe Control.Applicative ( Applicative(pure) ) -import safe Control.Monad ( Functor(..) ) -import safe Data.Bifunctor ( Bifunctor(second) ) -import safe Data.Bool ( Bool(..), otherwise, not, (&&) ) -import safe Data.Either ( either ) -import safe Data.Eq ( Eq(..) ) -import safe Data.Function ( ($), (.), const, id ) -import safe qualified Data.List.NonEmpty as NE - ( NonEmpty, zip, fromList, toList, map ) -import safe Data.List ( find, (++) ) -import safe Data.Maybe ( Maybe(..), maybe ) -import safe Data.Ord ( Ord(..), Ordering(..) ) -import safe Data.Semigroup ( Semigroup((<>)) ) -import safe Data.Tuple ( fst, snd ) -import safe Data.Text ( Text, pack ) -import safe Features.Compose ( getFeatureData - , Feature - , nameFeature - , FeatureN(..) ) - --- | Defines the return type for @'Criterion'@ indicating whether to include or --- exclude a subject. -data Status = Include | Exclude deriving (Eq, Show) - --- | Defines subject's diposition in a cohort either included or which criterion --- they were excluded by. See @'checkCohortStatus'@ for evaluating a @'Criteria'@ --- to determine CohortStatus. -data CohortStatus = - Included | ExcludedBy (Natural, Text) - deriving (Eq, Show, Generic) - --- Defines an ordering to put @Included@ last in a container of @'CohortStatus'@. --- The @'ExcludedBy'@ are ordered by their number value. -instance Ord CohortStatus where - compare Included Included = EQ - compare Included (ExcludedBy _) = GT - compare (ExcludedBy _) Included = LT - compare (ExcludedBy (i, _)) (ExcludedBy (j, _)) = compare i j - --- | Helper to convert a @Bool@ to a @'Status'@ --- --- >>> includeIf True --- >>> includeIf False --- Include --- Exclude -includeIf :: Bool -> Status -includeIf True = Include -includeIf False = Exclude - --- | Helper to convert a @Bool@ to a @'Status'@ --- --- >>> excludeIf True --- >>> excludeIf False --- Exclude --- Include -excludeIf :: Bool -> Status -excludeIf True = Exclude -excludeIf False = Include - --- | A type that is simply a @'FeatureN Status'@, that is, a feature that --- identifies whether to @'Include'@ or @'Exclude'@ a subject. -newtype Criterion = MkCriterion ( FeatureN Status ) deriving (Eq, Show) - --- | Converts a @'Feature'@ to a @'Criterion'@. -criterion :: (KnownSymbol n) => Feature n Status -> Criterion -criterion x = MkCriterion (nameFeature x) - --- | A nonempty collection of @'Criterion'@ paired with a @Natural@ number. -newtype Criteria = MkCriteria { - getCriteria :: NE.NonEmpty (Natural, Criterion) - } deriving (Eq, Show) - --- | Constructs a @'Criteria'@ from a @'NE.NonEmpty'@ collection of @'Criterion'@. -criteria :: NE.NonEmpty Criterion -> Criteria -criteria l = MkCriteria $ NE.zip (NE.fromList [1..]) l - --- | Unpacks a @'Criterion'@ into a (Text, Status) pair where the text is the --- name of the criterion and its @Status@ is the value of the status in the --- @'Criterion'@. In the case, that the value of the @'FeatureData'@ within the --- @'Criterion'@ is @Left@, the status is set to @'Exclude'@. -getStatus :: Criterion -> (Text, Status) -getStatus (MkCriterion x) = - either (const (nm, Exclude)) (nm,) ((getFeatureData . getDataN) x) - where nm = getNameN x - --- | Converts a subject's @'Criteria'@ into a @'NE.NonEmpty'@ triple of --- (order of criterion, name of criterion, status) -getStatuses :: - Criteria -> NE.NonEmpty (Natural, Text, Status) -getStatuses (MkCriteria x) = - fmap (\c -> (fst c, (fst.getStatus.snd) c, (snd.getStatus.snd) c)) x - --- | An internal function used to @'Data.List.find'@ excluded statuses. Used in --- 'checkCohortStatus'. -findExclude :: - Criteria -> Maybe (Natural, Text, Status) -findExclude x = find (\(_, _, z) -> z == Exclude) (getStatuses x) - --- | Converts a subject's @'Criteria'@ to a @'CohortStatus'@. The status is set --- to @'Included'@ if none of the @'Criterion'@ have a status of @'Exclude'@. -checkCohortStatus :: - Criteria -> CohortStatus -checkCohortStatus x = - maybe Included (\(i, n, _) -> ExcludedBy (i, n)) (findExclude x) - --- | Utility to get the name of a @'Criterion'@. -getCriterionName :: Criterion -> Text -getCriterionName (MkCriterion x) = getNameN x - --- | Initializes a container of @'CohortStatus'@ from a @'Criteria'@. This can be used --- to collect generate all the possible Exclusion/Inclusion reasons. -initStatusInfo :: Criteria -> NE.NonEmpty CohortStatus -initStatusInfo (MkCriteria z) = - NE.map (ExcludedBy . Data.Bifunctor.second getCriterionName) z <> pure Included diff --git a/src/Hasklepias/Cohort/Index.hs b/src/Hasklepias/Cohort/Index.hs deleted file mode 100644 --- a/src/Hasklepias/Cohort/Index.hs +++ /dev/null @@ -1,39 +0,0 @@ -{-| -Module : Cohort Index -Description : Defines the Index and related types and functions -Copyright : (c) NoviSci, Inc 2020 -License : BSD3 -Maintainer : bsaul@novisci.com --} - -{-# OPTIONS_HADDOCK hide #-} -{-# LANGUAGE NoImplicitPrelude #-} -{-# LANGUAGE DeriveGeneric #-} --- {-# LANGUAGE Safe #-} - -module Hasklepias.Cohort.Index( - Index - , makeIndex - , getIndex -) where - -import GHC.Show ( Show ) -import GHC.Generics -import Data.Eq ( Eq ) -import IntervalAlgebra ( Intervallic ) -import Data.Aeson - -{-| -An @Index@ is a wrapper for an @Intervallic@ used to indicate that a particular -interval is considered an index interval to which other intervals will be compared. --} - -newtype Index i a = MkIndex { - getIndex :: i a -- ^ Unwrap an @Index@ - } deriving (Eq, Show, Generic) - --- | Creates a new @'Index'@. -makeIndex :: Intervallic i a => i a -> Index i a -makeIndex = MkIndex - -instance (Intervallic i a, ToJSON (i a)) => ToJSON (Index i a) diff --git a/src/Hasklepias/Cohort/Input.hs b/src/Hasklepias/Cohort/Input.hs deleted file mode 100644 --- a/src/Hasklepias/Cohort/Input.hs +++ /dev/null @@ -1,97 +0,0 @@ -{-| -Module : Functions for Parsing Hasklepias populations -Description : Defines FromJSON instances for Hasklepias populations . -Copyright : (c) NoviSci, Inc 2020 -License : BSD3 -Maintainer : bsaul@novisci.com --} -{-# OPTIONS_HADDOCK hide #-} -{-# LANGUAGE NoImplicitPrelude #-} -{-# LANGUAGE UndecidableInstances #-} -{-# LANGUAGE TupleSections #-} - -module Hasklepias.Cohort.Input( - parsePopulationLines - , parsePopulationIntLines - , parsePopulationDayLines - , ParseError(..) -) where - -import Control.Applicative ( Applicative((<*>)), (<$>) ) -import Data.Aeson ( FromJSON(..) - , ToJSON(..) - , eitherDecode - , Value(Array)) -import qualified Data.ByteString.Lazy as B ( fromStrict - , toStrict - , ByteString) -import qualified Data.ByteString.Char8 as C ( lines ) -import Prelude ( - String) -import Data.Bifunctor ( Bifunctor(first) ) -import Data.Either ( Either(..) - , partitionEithers ) -import Data.Eq ( Eq ) -import Data.Function ( ($), id ) -import Data.Functor ( Functor(fmap) ) -import Data.List ( sort, (++), zipWith ) -import qualified Data.Map.Strict as M ( toList, fromListWith) -import Data.Ord ( Ord ) -import Data.Text (Text, pack) -import Data.Time.Calendar ( Day ) -import Data.Vector ( (!) ) -import EventData ( Events, event, Event ) -import EventData.Aeson () -import Hasklepias.Cohort.Core ( Population(..) - , ID - , Subject(MkSubject) ) -import GHC.Int ( Int ) -import GHC.Num ( Natural ) -import GHC.Show ( Show ) -import IntervalAlgebra ( IntervalSizeable ) - - -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 )) - -decodeIntoSubj :: (FromJSON a, Show a, IntervalSizeable a b) => - B.ByteString -> Either Text (SubjectEvent a) -decodeIntoSubj x = first pack $ eitherDecode x - --- | Contains the line number and error message. -newtype ParseError = MkParseError (Natural, Text) deriving (Eq, Show) - --- | Parse @Event Int@ from json lines. -parseSubjectLines :: - (FromJSON a, Show a, IntervalSizeable a b) => - B.ByteString -> ( [ParseError], [SubjectEvent a] ) -parseSubjectLines l = - partitionEithers $ zipWith - (\x i -> first (\t -> MkParseError (i,t)) (decodeIntoSubj $ B.fromStrict x) ) - (C.lines $ B.toStrict l) - [1..] - --- | Parse @Event Int@ from json lines. -parsePopulationLines :: (FromJSON a, Show a, IntervalSizeable a b) => - B.ByteString -> ([ParseError], Population (Events a)) -parsePopulationLines x = fmap mapIntoPop (parseSubjectLines x) - --- | Parse @Event Int@ from json lines. -parsePopulationIntLines :: B.ByteString -> ([ParseError], Population (Events Int)) -parsePopulationIntLines x = fmap mapIntoPop (parseSubjectLines x) - --- | Parse @Event Day@ from json lines. -parsePopulationDayLines :: B.ByteString -> ([ParseError], Population (Events Day)) -parsePopulationDayLines x = fmap mapIntoPop (parseSubjectLines x) diff --git a/src/Hasklepias/Cohort/Output.hs b/src/Hasklepias/Cohort/Output.hs deleted file mode 100644 --- a/src/Hasklepias/Cohort/Output.hs +++ /dev/null @@ -1,120 +0,0 @@ -{-| -Module : Hasklepias Cohorts -Description : Defines the options for outputting a cohort -Copyright : (c) NoviSci, Inc 2020 -License : BSD3 -Maintainer : bsaul@novisci.com --} -{-# OPTIONS_HADDOCK hide #-} -{-# LANGUAGE NoImplicitPrelude #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE StandaloneDeriving #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE DeriveAnyClass #-} - -module Hasklepias.Cohort.Output( - CohortShape - , ShapeCohort(..) - , toJSONCohortShape -) where - -import Data.Aeson ( ToJSON(..) - , Value - , object - , (.=) ) -import Data.Function ( (.) ) -import Data.Functor ( Functor(fmap) ) -import Data.List.NonEmpty as NE ( NonEmpty(..) - , head - , fromList - , zip ) -import Data.Tuple ( uncurry ) -import GHC.Generics ( Generic ) -import GHC.Types ( Type ) -import GHC.Show ( Show ) -import Hasklepias.Cohort.Core ( AttritionInfo, - Cohort, - ObsUnit, - ID, - CohortData, - getCohortData, - getCohortIDs ) -import Hasklepias.Cohort.Criteria ( CohortStatus ) -import Features.Featureset ( FeaturesetList(MkFeaturesetList) - , Featureset - , getFeatureset - , getFeaturesetList - , tpose ) -import Features.Output ( ShapeOutput(dataOnly, nameAttr) - , OutputShape ) - -instance (ToJSON d) => ToJSON (ObsUnit d) where -instance (ToJSON d) => ToJSON (CohortData d) where -instance (ToJSON d) => ToJSON (Cohort d) where -instance ToJSON CohortStatus where -instance ToJSON AttritionInfo where - --- | A type used to determine the output shape of a Cohort. -data CohortShape d where - ColumnWise :: (Show a, ToJSON a) => a -> CohortShape ColumnWise - RowWise :: (Show a, ToJSON a) => a -> CohortShape RowWise - -deriving instance Show d => Show (CohortShape d) - --- | Maps CohortShape into an Aeson Value. --- TODO: implement Generic and ToJSON instance of CohortShape directly. -toJSONCohortShape :: CohortShape shape -> Value -toJSONCohortShape (ColumnWise x) = toJSON x -toJSONCohortShape (RowWise x) = toJSON x - -class ShapeCohort d where - colWise :: Cohort d -> CohortShape ColumnWise - rowWise :: Cohort d -> CohortShape RowWise - -instance ShapeCohort Featureset where - colWise x = ColumnWise (shapeColumnWise x) - rowWise x = RowWise (shapeRowWise x) - -data ColumnWise = MkColumnWise { - colAttributes :: NonEmpty (OutputShape Type) - , ids :: [ID] - , colData :: NonEmpty (NonEmpty (OutputShape Type)) - } deriving ( Show, Generic ) - -instance ToJSON ColumnWise where - toJSON x = object [ "attributes" .= colAttributes x - , "ids" .= ids x - , "data" .= colData x ] - -newtype IDRow = MkIDRow (ID, NonEmpty (OutputShape Type)) - deriving ( Show, Generic ) - -instance ToJSON IDRow where - toJSON (MkIDRow x) = object [ uncurry (.=) x] - -data RowWise = MkRowWise { - attributes :: NonEmpty (OutputShape Type) - , rowData :: NonEmpty IDRow - } deriving ( Show, Generic ) - -instance ToJSON RowWise where - toJSON x = object [ "attributes" .= attributes x - , "data" .= rowData x ] - -shapeColumnWise :: Cohort Featureset -> ColumnWise -shapeColumnWise x = MkColumnWise - (fmap (nameAttr . NE.head . getFeatureset) z) - (getCohortIDs x) - (fmap (fmap dataOnly . getFeatureset) z) - -- TODO: don't use fromList; do something more principled - where z = getFeaturesetList (tpose (MkFeaturesetList (NE.fromList (getCohortData x)))) - -shapeRowWise :: Cohort Featureset -> RowWise -shapeRowWise x = MkRowWise - (fmap (nameAttr . NE.head . getFeatureset) z) - (fmap MkIDRow (zip ids (fmap (fmap dataOnly . getFeatureset) z))) - -- TODO: don't use fromList; do something more principled - where z = NE.fromList (getCohortData x) - ids = fromList (getCohortIDs x) diff --git a/src/Hasklepias/FeatureEvents.hs b/src/Hasklepias/FeatureEvents.hs new file mode 100644 --- /dev/null +++ b/src/Hasklepias/FeatureEvents.hs @@ -0,0 +1,269 @@ +{-| +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 @'Features.Feature'@ from +@'EventData.Event'@s. +-} +{-# OPTIONS_HADDOCK hide #-} +{-# LANGUAGE NoImplicitPrelude #-} + +module Hasklepias.FeatureEvents( + -- ** Container predicates + isNotEmpty + , atleastNofX + , anyGapsWithinAtLeastDuration + , allGapsWithinLessThanDuration + + -- ** Finding occurrences of concepts + , nthConceptOccurrence + , firstConceptOccurrence + + -- ** Reshaping containers + , allPairs + , splitByConcepts + + -- ** Create filters + , makeConceptsFilter + , makePairedFilter + + -- ** Functions for working with Event Domains + , viewBirthYears + , previewBirthYear + + -- ** Function for manipulating intervals + , lookback + , lookahead + + -- ** Misc functions + , computeAgeAt +) where + + +import IntervalAlgebra ( Intervallic + , IntervalSizeable(..) + , ComparativePredicateOf1 + , ComparativePredicateOf2 + , Interval + , IntervalCombinable + , begin + , end + , beginerval + , enderval ) +import IntervalAlgebra.PairedInterval ( PairedInterval, getPairData ) +import IntervalAlgebra.IntervalUtilities ( durations, gapsWithin ) +import EventData ( Events + , Event + , ConceptEvent + , ctxt ) +import EventData.Context ( Concept + , Concepts + , Context + , HasConcept( hasConcepts ) + , facts ) +import EventData.Context.Domain ( Domain + , demo + , info + , _Demographics ) +import Safe ( headMay, lastMay ) +import Control.Applicative ( Applicative(liftA2) ) +import Control.Monad ( Functor(fmap), (=<<) ) +import Control.Lens ( preview, (^.) ) +import Data.Bool ( Bool(..), (&&), not, (||) ) +import Data.Either ( either ) +import Data.Eq ( Eq ) +import Data.Foldable ( Foldable(length, null) + , all + , any + , toList ) +import Data.Function ( (.), ($), const ) +import Data.Functor ( Functor(fmap) ) +import Data.Int ( Int ) +import Data.Maybe ( Maybe(..), maybe, mapMaybe ) +import Data.Monoid ( Monoid ) +import Data.Ord ( Ord(..) ) +import Data.Time.Calendar ( Day, Year, diffDays ) +import Data.Text ( Text ) +import Data.Text.Read ( rational ) +import Data.Tuple ( fst ) +import Witherable ( filter, Filterable, Witherable ) +import GHC.Num ( Integer, fromInteger ) +import GHC.Real ( RealFrac(floor), (/) ) + +-- | Is the input list empty? +isNotEmpty :: [a] -> Bool +isNotEmpty = not.null + +-- | Filter 'Events' to those that have any of the provided concepts. +makeConceptsFilter :: + ( Filterable f ) => + [Text] -- ^ the list of concepts by which to filter + -> f (Event a) + -> f (Event 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 :: + ( Filterable f ) => + (f (Event a) -> Maybe (Event a)) -- ^ function used to select a single event + -> [Text] + -> f (Event 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 :: + ( Witherable f ) => + [Text] + -> f (Event a) + -> Maybe (Event a) +firstConceptOccurrence = nthConceptOccurrence (headMay . toList) + +-- | Finds the *last* occurrence of an 'Event' with at least one of the concepts. +-- Assumes the input 'Events' list is appropriately sorted. +lastConceptOccurrence :: + ( Witherable f ) => + [Text] + -> f (Event a) + -> Maybe (Event a) +lastConceptOccurrence = nthConceptOccurrence (lastMay . toList) + +-- | 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 + +-- | 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 :: + ( Filterable f ) => + [Text] + -> [Text] + -> f (Event a) + -> (f (Event a), f (Event a)) +splitByConcepts c1 c2 es = ( filter (`hasConcepts` c1) es + , filter (`hasConcepts` c2) es) + +-- | Create a predicate function that checks whether within a provided spanning +-- interval, are there (e.g. any, all) gaps of (e.g. <, <=, >=, >) a specified +-- duration among the input intervals? +makeGapsWithinPredicate :: + ( Monoid (t (Interval a)) + , Monoid (t (Maybe (Interval a))) + , Applicative t + , Witherable t + , IntervalSizeable a b + , IntervalCombinable i0 a + , IntervalCombinable i1 a) => + ((b -> Bool) -> t b -> Bool) + -> (b -> b -> Bool) + -> (b -> i0 a -> t (i1 a) -> Bool) +makeGapsWithinPredicate f op gapDuration interval l = + maybe False (f (`op` gapDuration) . durations) (gapsWithin interval l) + +-- | Within a provided spanning interval, are there any gaps of at least the +-- specified duration among the input intervals? +anyGapsWithinAtLeastDuration :: + ( IntervalSizeable a b + , IntervalCombinable i0 a + , IntervalCombinable i1 a + , Monoid (t (Interval a)) + , Monoid (t (Maybe (Interval a))) + , Applicative t + , Witherable t) => + b -- ^ duration of gap + -> i0 a -- ^ within this interval + -> t (i1 a) + -> Bool +anyGapsWithinAtLeastDuration = makeGapsWithinPredicate any (>=) + +-- | Within a provided spanning interval, are all gaps less than the specified +-- duration among the input intervals? +-- +-- >>> allGapsWithinLessThanDuration 30 (beginerval 100 (0::Int)) [beginerval 5 (-1), beginerval 99 10] +-- True +allGapsWithinLessThanDuration :: + ( IntervalSizeable a b + , IntervalCombinable i0 a + , IntervalCombinable i1 a + , Monoid (t (Interval a)) + , Monoid (t (Maybe (Interval a))) + , Applicative t + , Witherable t) => + b -- ^ duration of gap + -> i0 a -- ^ within this interval + -> t (i1 a) + -> Bool +allGapsWithinLessThanDuration = makeGapsWithinPredicate all (<) + +-- | Utility for reading text into a maybe integer +intMayMap :: Text -> Maybe Integer -- TODO: this is ridiculous +intMayMap x = fmap floor (either (const Nothing) (Just . fst) (Data.Text.Read.rational x)) + +-- | Preview birth year from a domain +previewBirthYear :: Domain -> Maybe Year +previewBirthYear dmn = intMayMap =<< ((^.demo.info) =<< preview _Demographics dmn) + +-- | Returns a (possibly emtpy) list of birth years from a set of events +viewBirthYears :: Events a -> [Year] +viewBirthYears = mapMaybe (\e -> previewBirthYear =<< Just (ctxt e^.facts )) + +-- | Compute the "age" in years between two calendar days. The difference between +-- the days is rounded down. +computeAgeAt :: Day -> Day -> Integer +computeAgeAt bd at = floor (fromInteger (diffDays at bd) / 365.25) + +-- | Creates a new @Interval@ of a provided lookback duration ending at the +-- 'begin' of the input interval. +-- +-- >>> lookback 4 (beginerval 10 (1 :: Int)) +-- (-3, 1) +lookback :: (Intervallic i a, IntervalSizeable a b) => + b -- ^ lookback duration + -> i a + -> Interval a +lookback d x = enderval d (begin x) + +-- | Creates a new @Interval@ of a provided lookahead duration beginning at the +-- 'end' of the input interval. +-- +-- >>> lookahead 4 (beginerval 1 (1 :: Int)) +-- (2, 6) +lookahead :: (Intervallic i a, IntervalSizeable a b) => + b -- ^ lookahead duration + -> i a + -> Interval a +lookahead d x = beginerval d (end x) + diff --git a/src/Hasklepias/MakeApp.hs b/src/Hasklepias/MakeApp.hs --- a/src/Hasklepias/MakeApp.hs +++ b/src/Hasklepias/MakeApp.hs @@ -36,7 +36,7 @@ import GHC.IO ( IO ) import EventData ( Events ) -import Hasklepias.Cohort +import Cohort import IntervalAlgebra ( IntervalSizeable ) import Control.Monad.IO.Class (MonadIO, liftIO) diff --git a/src/Hasklepias/Misc.hs b/src/Hasklepias/Misc.hs new file mode 100644 --- /dev/null +++ b/src/Hasklepias/Misc.hs @@ -0,0 +1,89 @@ +{-| +Module : Misc types and functions +Description : Misc types and functions useful in Hasklepias. +Copyright : (c) NoviSci, Inc 2020 +License : BSD3 +Maintainer : bsaul@novisci.com + +These functions may be moved to more appropriate modules in future versions. +-} +{-# OPTIONS_HADDOCK hide #-} +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE DeriveGeneric #-} + +module Hasklepias.Misc ( + F + , Def + , Occurrence(..) + , makeOccurrence + , getOccurrenceReason + , getOccurrenceTime + , CensoringReason(..) + , OccurrenceReason(..) + , CensoredOccurrence(..) + , adminCensor + +) where + +import Features.Compose ( Feature, Definition ) +import Data.Bool ( otherwise, (&&) ) +import Data.Eq ( Eq(..) ) +import Data.Ord ( Ord(..), Ordering(..) ) +import Data.Semigroup ( Semigroup((<>)) ) +import GHC.Generics ( Generic ) +import GHC.Show ( Show(..) ) +import Stype.Numeric.Censored ( MaybeCensored(..) ) +import Stype.Numeric.Continuous ( EventTime ) + +-- | Type synonym for 'Feature'. +type F n a = Feature n a + +-- | Type synonym for 'Definition'. +type Def d = Definition d + +-- | A simple typeclass for making a type a "reason" for an event. +class (Ord a, Show a) => OccurrenceReason a where + +-- | A type containing the time and when something occurred +newtype Occurrence what when = MkOccurrence ( what , EventTime when ) + deriving (Eq, Show, Generic) + +-- | Create an 'Occurrence' +makeOccurrence :: (OccurrenceReason what) => + what -> EventTime b -> Occurrence what b +makeOccurrence r t = MkOccurrence (r , t) + +-- | Get the reason for an 'Occurrence'. +getOccurrenceReason :: Occurrence what b -> what +getOccurrenceReason (MkOccurrence (r, t)) = r + +-- | Get the time of an 'Occurrence'. +getOccurrenceTime :: Occurrence what b -> EventTime b +getOccurrenceTime (MkOccurrence (r, t)) = t + +-- Define a custom ordering based on times and then reasons. +instance (OccurrenceReason r, Ord b) => Ord (Occurrence r b) where + compare (MkOccurrence (r1, t1)) (MkOccurrence (r2, t2)) + | t1 < t2 = LT + | t1 == t2 && r1 < r2 = LT + | t1 == t2 && r1 == r2 = EQ + | otherwise = GT + +-- | Sum type for possible censoring and outcome reasons, including administrative +-- censoring. +data CensoringReason cr or = AdminCensor | C cr | O or + deriving (Eq, Show, Generic) + +-- | A type to represent censored 'Occurrence'. +data CensoredOccurrence censors outcomes b = MkCensoredOccurrence { + reason :: CensoringReason censors outcomes + , time :: MaybeCensored ( EventTime b )} + deriving (Eq, Generic) + +instance (OccurrenceReason c, OccurrenceReason o, Show b) => + Show ( CensoredOccurrence c o b ) where + show (MkCensoredOccurrence r t) = "(" <> show t <> ", " <> show r <> ")" + +-- | Creates an administratively censored occurrence. +adminCensor :: EventTime b -> CensoredOccurrence c o b +adminCensor t = MkCensoredOccurrence AdminCensor ( RightCensored t ) diff --git a/src/Hasklepias/Reexports.hs b/src/Hasklepias/Reexports.hs --- a/src/Hasklepias/Reexports.hs +++ b/src/Hasklepias/Reexports.hs @@ -13,22 +13,26 @@ -- * Re-exports module GHC.Num + , module GHC.Real , module GHC.Generics , module GHC.Show , module GHC.TypeLits , module Control.Monad , module Control.Applicative + , module Data.Bifunctor , module Data.Bool , module Data.Either , module Data.Eq , module Data.Int , module Data.Maybe , module Data.Monoid + , module Data.Foldable , module Data.Function - , module Data.Functor , module Data.List , module Data.List.NonEmpty , module Data.Ord + , module Data.Proxy + , module Set , module Data.Time.Calendar , module Data.Text , module Data.Tuple @@ -42,21 +46,32 @@ , module Witherable ) where -import safe GHC.Num ( Integer ) +import safe GHC.Num ( Integer(..) + , Num(..) + , Natural(..) ) +import safe GHC.Real ( Integral(..), toInteger ) import safe GHC.Generics ( Generic ) import safe GHC.Show ( Show(..) ) -import safe GHC.TypeLits ( KnownSymbol ) -import safe Control.Monad ( Functor(fmap), Monad(..) ) +import safe GHC.TypeLits ( KnownSymbol(..) + , symbolVal ) import safe Control.Applicative ( (<$>), Applicative(..) ) +import safe Control.Monad ( Functor(..) + , Monad(..) + , join + , (>>=) + , (=<<) ) +import safe Data.Bifunctor ( Bifunctor(..) ) import safe Data.Bool ( Bool(..) , (&&), not, (||) , bool , otherwise ) import safe Data.Either ( Either(..)) import safe Data.Eq ( Eq, (==)) -import safe Data.Function ( (.), ($), const, id ) -import safe Data.Functor ( fmap ) -import safe Data.Int ( Int ) +import safe Data.Foldable ( Foldable(..) + , minimum + , maximum ) +import safe Data.Function ( (.), ($), const, id, flip ) +import safe Data.Int ( Int(..) ) import safe Data.List ( all , any , map @@ -79,8 +94,11 @@ mapMaybe, maybeToList ) import safe Data.Monoid ( Monoid(..), (<>) ) -import safe Data.Ord ( Ord((>=), (<), (>), (<=)) +import safe Data.Ord ( Ord(..) + , Ordering(..) , max, min ) +import safe Data.Proxy ( Proxy(..) ) +import safe Data.Set as Set ( Set(..), fromList, member) import safe Data.Time.Calendar ( Day, MonthOfYear, Year , CalendarDiffDays(..) , addGregorianDurationClip @@ -94,6 +112,6 @@ import safe IntervalAlgebra.IntervalUtilities import safe IntervalAlgebra.PairedInterval -import safe Witherable ( Filterable(filter) ) +import safe Witherable ( Filterable(filter), Witherable ) import safe Flow ( (!>), (.>), () ) import Safe ( headMay, lastMay ) diff --git a/test/Cohort/CoreSpec.hs b/test/Cohort/CoreSpec.hs new file mode 100644 --- /dev/null +++ b/test/Cohort/CoreSpec.hs @@ -0,0 +1,72 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE DataKinds #-} + +module Cohort.CoreSpec ( + spec + ) where + +import Features +import Cohort +import Data.List.NonEmpty +import Test.Hspec ( describe, pending, shouldBe, it, Spec ) + +-- data Feat1 + +d1 :: Definition (Feature "feat" Int -> Feature "feat1" Bool) +d1 = + defineA + (\x -> + if x < 0 then + makeFeature $ featureDataL $ Other "at least 1 < 0" + else + pure ((x + 1) == 5) + ) + + +d2 :: Definition (Feature "feat" Int -> Feature "feat2" Status) +d2 = define (\x -> includeIf (x*2 > 4)) + +d3 :: Definition (Feature "feat" Int -> Feature "feat3" Int) +d3 = define (+ 2) + + +testSubject1 :: Subject Int +testSubject1 = MkSubject ("1", 0) +testSubject2 :: Subject Int +testSubject2 = MkSubject ("2", 54) + +testPopulation :: Population Int +testPopulation = MkPopulation [testSubject1, testSubject2] + +buildCriteria :: Int -> Criteria +buildCriteria dat = criteria $ pure ( criterion feat1 ) + where feat1 = eval d2 $ pure dat + +type Features = (Feature "feat1" Bool, Feature "feat3" Int) +buildFeatures :: Int -> Features +buildFeatures dat = + ( eval d1 input + , eval d3 input + ) + where input = pure dat + +testCohort :: CohortSpec Int Features +testCohort = specifyCohort buildCriteria buildFeatures + +testOut :: Cohort Features +testOut = MkCohort + ( Just $ MkAttritionInfo $ (ExcludedBy (1, "feat2"), 1) :| [ (Included, 1) ] + , MkCohortData [MkObsUnit "2" + ( makeFeature (featureDataR False) + , makeFeature (featureDataR 56)) ]) + +-- evalCohort testCohort testPopulation +spec :: Spec +spec = do + + describe "checking d1" $ + do + + it "include f1" $ + evalCohort testCohort testPopulation `shouldBe` testOut + diff --git a/test/Cohort/CriteriaSpec.hs b/test/Cohort/CriteriaSpec.hs new file mode 100644 --- /dev/null +++ b/test/Cohort/CriteriaSpec.hs @@ -0,0 +1,48 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE DataKinds #-} +module Cohort.CriteriaSpec ( + spec + ) where + +import Features +import Cohort.Criteria +import Test.Hspec ( describe, pending, shouldBe, it, Spec ) +import Data.List.NonEmpty + + +f1 :: Status -> Criterion +f1 s = criterion (makeFeature (featureDataR s) :: Feature "f1" Status) + +f2 :: Status -> Criterion +f2 s = criterion (makeFeature (featureDataR s) :: Feature "f2" Status) + +f3 :: Status -> Criterion +f3 s = criterion (makeFeature (featureDataR s) :: Feature "f3" Status) + +f4 :: Criterion +f4 = criterion ( makeFeature (featureDataL $ Other "something") :: Feature "f4" Status) + +spec :: Spec +spec = do + + describe "checking d1" $ + do + + it "include f1" $ + checkCohortStatus (criteria $ pure (f1 Include)) `shouldBe` Included + + it "include f1, f2, f3" $ + checkCohortStatus (criteria $ f1 Include :| [f2 Include, f3 Include] ) + `shouldBe` Included + + it "exclude on f2" $ + checkCohortStatus (criteria $ f2 Exclude :| [f3 Include]) + `shouldBe` ExcludedBy (1, "f2") + + it "exclude on f2" $ + checkCohortStatus (criteria $ f1 Include :| [f2 Exclude, f3 Include]) + `shouldBe` ExcludedBy (2, "f2") + + it "error on f4" $ + checkCohortStatus (criteria $ f1 Include :| [f2 Include, f3 Include, f4]) + `shouldBe` ExcludedBy (4, "f4") diff --git a/test/Cohort/InputSpec.hs b/test/Cohort/InputSpec.hs new file mode 100644 --- /dev/null +++ b/test/Cohort/InputSpec.hs @@ -0,0 +1,72 @@ +{-# LANGUAGE OverloadedStrings #-} +module Cohort.InputSpec (spec) where + +import IntervalAlgebra +import EventData +import 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\"}}]" + +testInputsDayBad :: B.ByteString +testInputsDayBad = + "[\"ghi\", \"2020-01-01\", null, \"Diagnosis\",\ + \[\"someThing\"],\ + \{\"time\":{\"begin\":\"2020-01-01\",\"end\":\"2020-01-02\"}}]\n\ + \[\"ghi\", \"2020-01-05\", null, \"Diagnosis\",\ + \[\"someThing\"],\ + \{\"domain\":\"Diagnosis\",\ + \ \"time\":{\"begin\":\"2020-01-05\",\"end\":\"2020-01-04\"}}]" + +testInput = testInputsDay1 <> "\n" <> testInputsDay2 + + +testOutDay1 = event (beginerval 1 (fromGregorian 2020 1 1)) + (HC.context ( UnimplementedDomain () ) (packConcepts ["someThing"])) +testOutDay2 = event (beginerval 1 (fromGregorian 2020 1 5)) + (HC.context ( 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) + + it "a population is parsed" $ + parsePopulationDayLines (testInput <> "\n" <> testInputsDayBad)`shouldBe` + ([MkParseError (5, "Error in $: key \"domain\" not found") + , MkParseError (6, "Error in $: 2020-01-04<2020-01-05")], testOutPop) diff --git a/test/EventDataSpec.hs b/test/EventDataSpec.hs --- a/test/EventDataSpec.hs +++ b/test/EventDataSpec.hs @@ -3,7 +3,7 @@ import IntervalAlgebra import IntervalAlgebra.IntervalUtilities -import FeatureEvents +import Hasklepias.FeatureEvents import EventData import EventData.Context as HC import EventData.Context.Domain ( Domain(UnimplementedDomain) ) diff --git a/test/FeatureEventsSpec.hs b/test/FeatureEventsSpec.hs deleted file mode 100644 --- a/test/FeatureEventsSpec.hs +++ /dev/null @@ -1,32 +0,0 @@ -{-# 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 EventData.Context.Domain -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 (UnimplementedDomain ()) (packConcepts ["c1", "c2"] )) -evnt2 :: Event Int -evnt2 = event ( beginerval (4 :: Int) (2 :: Int) ) - ( HC.context (UnimplementedDomain ()) (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/Features/OutputSpec.hs b/test/Features/OutputSpec.hs --- a/test/Features/OutputSpec.hs +++ b/test/Features/OutputSpec.hs @@ -8,7 +8,7 @@ import IntervalAlgebra import EventData import EventData.Context -import FeatureEvents +import Hasklepias.FeatureEvents import Features import Data.Aeson (encode) import Data.Maybe diff --git a/test/Hasklepias/Cohort/CoreSpec.hs b/test/Hasklepias/Cohort/CoreSpec.hs deleted file mode 100644 --- a/test/Hasklepias/Cohort/CoreSpec.hs +++ /dev/null @@ -1,72 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE DataKinds #-} - -module Hasklepias.Cohort.CoreSpec ( - spec - ) where - -import Features -import Hasklepias.Cohort -import Data.List.NonEmpty -import Test.Hspec ( describe, pending, shouldBe, it, Spec ) - --- data Feat1 - -d1 :: Definition (Feature "feat" Int -> Feature "feat1" Bool) -d1 = - defineA - (\x -> - if x < 0 then - makeFeature $ featureDataL $ Other "at least 1 < 0" - else - pure ((x + 1) == 5) - ) - - -d2 :: Definition (Feature "feat" Int -> Feature "feat2" Status) -d2 = define (\x -> includeIf (x*2 > 4)) - -d3 :: Definition (Feature "feat" Int -> Feature "feat3" Int) -d3 = define (+ 2) - - -testSubject1 :: Subject Int -testSubject1 = MkSubject ("1", 0) -testSubject2 :: Subject Int -testSubject2 = MkSubject ("2", 54) - -testPopulation :: Population Int -testPopulation = MkPopulation [testSubject1, testSubject2] - -buildCriteria :: Int -> Criteria -buildCriteria dat = criteria $ pure ( criterion feat1 ) - where feat1 = eval d2 $ pure dat - -type Features = (Feature "feat1" Bool, Feature "feat3" Int) -buildFeatures :: Int -> Features -buildFeatures dat = - ( eval d1 input - , eval d3 input - ) - where input = pure dat - -testCohort :: CohortSpec Int Features -testCohort = specifyCohort buildCriteria buildFeatures - -testOut :: Cohort Features -testOut = MkCohort - ( Just $ MkAttritionInfo $ (ExcludedBy (1, "feat2"), 1) :| [ (Included, 1) ] - , MkCohortData [MkObsUnit "2" - ( makeFeature (featureDataR False) - , makeFeature (featureDataR 56)) ]) - --- evalCohort testCohort testPopulation -spec :: Spec -spec = do - - describe "checking d1" $ - do - - it "include f1" $ - evalCohort testCohort testPopulation `shouldBe` testOut - diff --git a/test/Hasklepias/Cohort/CriteriaSpec.hs b/test/Hasklepias/Cohort/CriteriaSpec.hs deleted file mode 100644 --- a/test/Hasklepias/Cohort/CriteriaSpec.hs +++ /dev/null @@ -1,48 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE DataKinds #-} -module Hasklepias.Cohort.CriteriaSpec ( - spec - ) where - -import Features -import Hasklepias.Cohort.Criteria -import Test.Hspec ( describe, pending, shouldBe, it, Spec ) -import Data.List.NonEmpty - - -f1 :: Status -> Criterion -f1 s = criterion (makeFeature (featureDataR s) :: Feature "f1" Status) - -f2 :: Status -> Criterion -f2 s = criterion (makeFeature (featureDataR s) :: Feature "f2" Status) - -f3 :: Status -> Criterion -f3 s = criterion (makeFeature (featureDataR s) :: Feature "f3" Status) - -f4 :: Criterion -f4 = criterion ( makeFeature (featureDataL $ Other "something") :: Feature "f4" Status) - -spec :: Spec -spec = do - - describe "checking d1" $ - do - - it "include f1" $ - checkCohortStatus (criteria $ pure (f1 Include)) `shouldBe` Included - - it "include f1, f2, f3" $ - checkCohortStatus (criteria $ f1 Include :| [f2 Include, f3 Include] ) - `shouldBe` Included - - it "exclude on f2" $ - checkCohortStatus (criteria $ f2 Exclude :| [f3 Include]) - `shouldBe` ExcludedBy (1, "f2") - - it "exclude on f2" $ - checkCohortStatus (criteria $ f1 Include :| [f2 Exclude, f3 Include]) - `shouldBe` ExcludedBy (2, "f2") - - it "error on f4" $ - checkCohortStatus (criteria $ f1 Include :| [f2 Include, f3 Include, f4]) - `shouldBe` ExcludedBy (4, "f4") diff --git a/test/Hasklepias/Cohort/InputSpec.hs b/test/Hasklepias/Cohort/InputSpec.hs deleted file mode 100644 --- a/test/Hasklepias/Cohort/InputSpec.hs +++ /dev/null @@ -1,73 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} -module Hasklepias.Cohort.InputSpec (spec) where - -import IntervalAlgebra -import EventData --- import Hasklepias.Cohort.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\"}}]" - -testInputsDayBad :: B.ByteString -testInputsDayBad = - "[\"ghi\", \"2020-01-01\", null, \"Diagnosis\",\ - \[\"someThing\"],\ - \{\"time\":{\"begin\":\"2020-01-01\",\"end\":\"2020-01-02\"}}]\n\ - \[\"ghi\", \"2020-01-05\", null, \"Diagnosis\",\ - \[\"someThing\"],\ - \{\"domain\":\"Diagnosis\",\ - \ \"time\":{\"begin\":\"2020-01-05\",\"end\":\"2020-01-04\"}}]" - -testInput = testInputsDay1 <> "\n" <> testInputsDay2 - - -testOutDay1 = event (beginerval 1 (fromGregorian 2020 1 1)) - (HC.context ( UnimplementedDomain () ) (packConcepts ["someThing"])) -testOutDay2 = event (beginerval 1 (fromGregorian 2020 1 5)) - (HC.context ( 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) - - it "a population is parsed" $ - parsePopulationDayLines (testInput <> "\n" <> testInputsDayBad)`shouldBe` - ([MkParseError (5, "Error in $: key \"domain\" not found") - , MkParseError (6, "Error in $: 2020-01-04<2020-01-05")], testOutPop) diff --git a/test/Hasklepias/FeatureEventsSpec.hs b/test/Hasklepias/FeatureEventsSpec.hs new file mode 100644 --- /dev/null +++ b/test/Hasklepias/FeatureEventsSpec.hs @@ -0,0 +1,32 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE FlexibleContexts #-} +module Hasklepias.FeatureEventsSpec (spec) where + +import IntervalAlgebra +import Hasklepias.FeatureEvents ( firstConceptOccurrence ) +import EventData ( Event, event ) +import EventData.Context as HC ( context, packConcepts ) +import EventData.Context.Domain +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 (UnimplementedDomain ()) (packConcepts ["c1", "c2"] )) +evnt2 :: Event Int +evnt2 = event ( beginerval (4 :: Int) (2 :: Int) ) + ( HC.context (UnimplementedDomain ()) (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