hasklepias 0.8.3 → 0.12.0

raw patch · 38 files changed

+1972/−568 lines, 38 filesdep +cmdargsdep +co-logdep +ghc-primdep ~bytestringdep ~containersdep ~textnew-component:exe:exampleApp

Dependencies added: cmdargs, co-log, ghc-prim, mtl, process, tasty, tasty-hspec, tasty-hunit

Dependency ranges changed: bytestring, containers, text, time, unordered-containers, vector, witherable

Files

• ChangeLog.md +25/−0
• README.md +2/−55
• exampleApp/Main.hs +66/−0
• examples/ExampleCohort1.hs +421/−0
• examples/ExampleEvents.hs +2/−2
• examples/ExampleFeatures1.hs +25/−12
• examples/Main.hs +22/−12
• hasklepias.cabal +36/−20
• src/EventData.hs +11/−21
• src/EventData/Aeson.hs +22/−19
• src/EventData/Arbitrary.hs +1/−0
• src/EventData/Context.hs +7/−20
• src/EventData/Context/Arbitrary.hs +5/−3
• src/EventData/Context/Domain.hs +6/−6
• src/EventData/Context/Domain/Demographics.hs +14/−6
• src/FeatureCompose.hs +327/−105
• src/FeatureCompose/Aeson.hs +15/−8
• src/FeatureCompose/Criteria.hs +0/−78
• src/FeatureEvents.hs +137/−30
• src/Hasklepias.hs +37/−10
• src/Hasklepias/Aeson.hs +58/−26
• src/Hasklepias/Cohort.hs +113/−12
• src/Hasklepias/Cohort/Criteria.hs +144/−0
• src/Hasklepias/Cohort/Index.hs +36/−0
• src/Hasklepias/MakeApp.hs +116/−0
• src/Hasklepias/Reexports.hs +19/−0
• src/Hasklepias/ReexportsUnsafe.hs +23/−0
• test/EventData/AesonSpec.hs +18/−18
• test/EventData/ContextSpec.hs +3/−5
• test/EventDataSpec.hs +4/−2
• test/FeatureCompose/AesonSpec.hs +3/−2
• test/FeatureCompose/CriteriaSpec.hs +0/−46
• test/FeatureComposeSpec.hs +108/−38
• test/FeatureEventsSpec.hs +3/−2
• test/Hasklepias/AesonSpec.hs +24/−9
• test/Hasklepias/Cohort/CriteriaSpec.hs +48/−0
• test/Hasklepias/CohortSpec.hs +71/−0
• test/Spec.hs +0/−1

@@ -1,5 +1,30 @@ # Changelog for hasklepias +## 0.12.0++* Converts `AttritionStatus` from a List to a NonEmpty container.+* Adds the `MakeApp` module with a single function `makeCohortApp` which takes a list of cohort specifications and returns an application (an `IO ()` function). Currently, the application is bare bones, printing the resulting cohorts (one per specification) to `stdout` and any parsing errors to `stderr`. For example usage, see the code in `exampleApp`.++## 0.11.1++* Modifies a `Context` so that its `_facts` are no longer `Maybe Domain` and now just `Domain`.++## 0.11.0++* Refactors the `FeatureCompose` module. `FeatureSpec` and `FeatureDefinition` types are dropped, and now there is a single `Definition` type with two related typeclasses: `Define` (with function `define`) and `DefineA` (with function `defineA`). Both of these typeclasses can lift functions to functions of either Features or FeatureData. For example `define` can take a function `c -> b -> a`, and, depending on the type annotation gives back a definition `Definition (FeatureData c -> FeatureData b -> FeatureData a)` or `Definition (Feature name2 c -> Feature name1 b -> Feature name0 a)`. The `defineA` works similarly for a function of type `c -> b -> f a`, where `f` is either `FeatureData` or `Feature`. The `eval` function takes any `Definition` and an appropriate argument to give back the desired return type. For example, to evaluate `def` of type `Definition (FeatureData c -> FeatureData b -> FeatureData a)`, you would call `eval def (x, y)`, where `(x, y) :: FeatureData c, FeatureData b)`.  At this time, one can define `Definition`s with up to 3 inputs.+* For now, the `Attributes` component of `Feature`s is dropped. This will be rethought and added back in at later time.++## 0.10.0++* Refactors `FeatureSpec`s and `Feature`s to have a `Symbol` as its name, rather than `Text`.+* Updates `parseEventLines` and related functions to keep parse errors. Similarly for `parseSubjectLines` which keeps the error message as well as the line number.++## 0.9.0++* Refactors cohort building types and functions. Still aways to go, but the basic ideas are there now.+* Adds the `ExampleCohort1` module to demonstrate the updates on calendar based cohorts.+* Adds several new functions and modules to `Reexports` including the `Test.Tasty` and `Test.Tasty.HUnit` testing modules for testing cohort building.+ ## 0.8.3  * Modifies `FromJSON` instance for events to use `parseEvent` as well as create a moment from the provided `begin` in the case that `end` is missing.

@@ -3,7 +3,7 @@ _Asclepias (n)_:  1. The genus of North American milkweeds, named after Linnaeus after the greek god of healing, Asclepius.-2. A language and software project for defining and deriving features from temporally ordered events using the [interval algebra](https://hackage.haskell.org/package/interval-algebra-0.8.0).+2. A language and software project for defining and deriving features from temporally ordered events using the [interval algebra](https://hackage.haskell.org/package/interval-algebra).  ## Current status @@ -11,57 +11,4 @@  ## Getting started -The official implementation of Asclepias is the embedded domain specific language (eDSL) provided by the `hasklepias` [Haskell](https://www.haskell.org/) library. To get started then, you'll need to install the Haskell toolchain, especially the [Glasgow Haskell Compiler](https://www.haskell.org/ghc/) (GHC) and the building and packaging system [cabal](https://www.haskell.org/cabal/), for which you can use the [`ghcup` utility](https://www.haskell.org/ghcup/).--You can use any development environment you chose, but for maximum coding pleasure, it is highly recommended that you install the [Haskell language server](https://github.com/haskell/haskell-language-server) (`hsl`). This can be installed using `ghcup` or some integrated development environments, such as [Visual Studio Code](https://code.visualstudio.com/), have [excellent `hsl` integration](https://marketplace.visualstudio.com/items?itemName=haskell.haskell).--## Defining features--At this time, `hasklepias` can be used for experimenting with `Feature` definitions. A `Feature d` is currently a wrapper of an [`Either`](https://hackage.haskell.org/package/base-4.15.0.0/docs/Data-Either.html) type:--```haskell-type Feature d = Feature { getFeatureData :: Either MissingReason d }-```--The `Either` type means there are two possibilities for the type of a `Feature`. The `Left` can be a `MissingReason`, which is a sum type enumerating the reasons that the data is missing:--```haskell-data MissingReason = -- this list may grow/change in the future-    InsufficientData-  | Excluded-  | Other String-  | Unknown-```--The `Right` has the type `d`, meaning it can be any type you choose. In the module`ExampleFeatures1`, the `index` feature has type `Feature (Interval a)`. The (`Right`) type of `index` is an `Interval a`, where again `a` can be any type you chose, subject to the constraints of intervals. The `hasDuckHistory` feature has the type `Feature (Bool, Maybe (Interval a)`, where the `Bool` is used an indicator of a history with ducks and the `Maybe (Interval a)` is the `Interval a` of the last encounter with a duck if it exists. The `countOfHospitalEvents` feature has the type `Feature (Int, Maybe b)` where the `Int` is the count of hospital visits and `Maybe b` is the duration of the last visit if one exists. These examples show how the data (or shape) of a `Feature` can be defined as `Interval a`, `(Bool, Maybe (Interval a))`, or `(Int, Maybe b)`. In fact, as long as the data is derivable from other `Feature`s and/or a list of `Event`s, you can shape a `Feature` however you'd like!--## Interactive use/development--To run the examples interactively, open a `ghci` session with:--```sh-cabal repl hasklepias:examples --repl-options -itest-```--The option flag `--repl-options -itest` allows to make changes to the files in the `examples` folder and reload with `:reload` (or `:r`) without exiting the `ghci` session. Developers working on `src` files can add the `--repl-options -isrc` option flag to make changes to `src` files too.--In `ghci` you have access to all exposed functions in `hasklepias`, `interval-algebra`, and those in the `examples` folders. For example, `exampleEvents1` is a list of events used to check some of the example features, which you can interact with:--```sh-*Main> headMay exampleEvents1-Just {(1, 10), Context {getConcepts = ["enrollment"], getFacts = Nothing, getSource = Nothing}}-*Main> length exampleEvents1-24-*Main> combineIntervals $ intervals exampleEvents1-[(1, 10),(11, 20),(21, 30),(31, 40),(45, 100)]-*Main> mapM_ print exampleEvents1-{(1, 10), Context {getConcepts = fromList ["enrollment"], getFacts = Nothing, getSource = Nothing}}-{(2, 3), Context {getConcepts = fromList ["wasScratchedByCat"], getFacts = Nothing, getSource = Nothing}}-{(5, 6), Context {getConcepts = fromList ["hadMinorSurgery"], getFacts = Nothing, getSource = Nothing}}-{(5, 10), Context {getConcepts = fromList ["tookAntibiotics"], getFacts = Nothing, getSource = Nothing}}-{(11, 20), Context {getConcepts = fromList ["enrollment"], getFacts = Nothing, getSource = Nothing}}-{(21, 30), Context {getConcepts = fromList ["enrollment"], getFacts = Nothing, getSource = Nothing}}-{(31, 40), Context {getConcepts = fromList ["enrollment"], getFacts = Nothing, getSource = Nothing}}-{(45, 46), Context {getConcepts = fromList ["wasStruckByDuck"], getFacts = Nothing, getSource = Nothing}}-<<<result truncated>>>-```+See the [manual](doc/manual.adoc) and the [examples](examples)

@@ -0,0 +1,66 @@+{-|+Module      : ExampleCohortApp+Description : Demostrates how to define a cohort using Hasklepias+Copyright   : (c) NoviSci, Inc 2020+License     : BSD3+Maintainer  : bsaul@novisci.com+-}++{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE NoImplicitPrelude #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE LambdaCase #-}+module Main(+  main+) where+import Hasklepias++{-------------------------------------------------------------------------------+  Features used by inclusion/exclusion (and possibly other places too)+-------------------------------------------------------------------------------}++-- | Lift a subject's events in a feature+featureEvents :: Events Day -> Feature "allEvents" (Events Day)+featureEvents = pure++-- | Lift a subject's events in a feature+featureDummy :: Definition+   ( Feature "allEvents" (Events Day)+   -> Feature "dummy" Bool)+featureDummy = define $ pure True++-- | Include the subject if she has an enrollment interval concurring with index.+critTrue :: Definition+   ( Feature "allEvents" (Events Day)+   -> Feature "dummy" Status)+critTrue = define $ pure Include ++{-------------------------------------------------------------------------------+  Cohort Specifications and evaluation+-------------------------------------------------------------------------------}++-- | Make a function that runs the criteria+makeCriteriaRunner :: Events Day -> Criteria+makeCriteriaRunner events =+  criteria $ pure (criterion crit1)+  where crit1   = eval critTrue featEvs+        featEvs = featureEvents events++-- | Define the shape of features for a cohort+type CohortFeatures = ( Feature "dummy"  Bool )++-- | Make a function that runs the features for a calendar index+makeFeatureRunner ::+       Events Day+    -> CohortFeatures+makeFeatureRunner events = eval featureDummy ef+    where ef  = featureEvents events++-- | Make a cohort specification for each calendar time+cohortSpecs :: [CohortSpec (Events Day) CohortFeatures]+cohortSpecs = [specifyCohort makeCriteriaRunner makeFeatureRunner]++main :: IO ()+main = makeCohortApp "testCohort" "v0.1.0" cohortSpecs

@@ -0,0 +1,421 @@+{-|+Module      : ExampleCohort1+Description : Demostrates how to define a cohort using Hasklepias+Copyright   : (c) NoviSci, Inc 2020+License     : BSD3+Maintainer  : bsaul@novisci.com+-}++{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE NoImplicitPrelude #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE LambdaCase #-}+module ExampleCohort1(+  exampleCohort1tests+) where+import Hasklepias+{-------------------------------------------------------------------------------+  Constants+-------------------------------------------------------------------------------}++-- | Lookback duration for baseline+baselineLookback :: Integer+baselineLookback = 455++-- | Duration of follow up in months+followupDuration :: CalendarDiffDays+followupDuration = CalendarDiffDays 3 0++-- | Calendar indices: first day of each quarter for 2017-2018+indices :: [Index Interval Day]+indices =  map (\(y, m) -> makeIndex $ beginerval 0 (fromGregorian y m 1))+           (allPairs [2017..2018] [1, 4, 7, 10])++{-------------------------------------------------------------------------------+  Utility functions +-------------------------------------------------------------------------------}++-- | Creates a baseline interval from index+baselineInterval :: Index Interval Day -> Interval Day+baselineInterval index = lookback baselineLookback (getIndex index)++-- | Shifts an interval by a calendar amount+shiftIntervalDay :: CalendarDiffDays -> Interval Day -> Interval Day+shiftIntervalDay cd i = beginerval (duration i) (addGregorianDurationClip cd (begin i))++-- | Creates an interval *beginning the same day as the index* and +--   ending 'followupDuration' days later.+followupInterval :: Index Interval Day -> Interval Day+followupInterval index = beginerval (diff bi (end $ shiftIntervalDay followupDuration i)) bi+    where i = getIndex index+          bi = begin i++-- | A predicate function that determines if some interval is before index+beforeIndex :: Intervallic i Day => Index Interval Day -> i Day -> Bool+beforeIndex index = before (getIndex index)++-- | Creates a filter for events to those that 'concur' with the baseline interval.+getBaselineConcur ::  Index Interval Day -> Events Day -> [Event Day]+getBaselineConcur index = filterConcur (baselineInterval index)++{-------------------------------------------------------------------------------+  Feature patterns: functions for defining features by a given pattern +-------------------------------------------------------------------------------}++-- | Defines a feature that returns 'True' ('False' otherwise) if either:+--   * at least 1 event during the baseline interval has any of the 'c1' concepts+--   * there are at least 2 event that have 'c2' concepts which have at least+--     7 days between them during the baseline interval+twoOutOneIn ::+       [Text]+    -> [Text]+    -> Definition+    ( Feature "calendarIndex" (Index Interval Day)+    -> Feature "allEvents" (Events Day)+    -> Feature name Bool )+twoOutOneIn cpts1 cpts2 = define+    (\index events ->+        atleastNofX 1 cpts1  (getBaselineConcur index events) +        || ( +          events +        |> makeConceptsFilter cpts2 +        |> map toConceptEvent+        |> anyGapsWithinAtLeastDuration 7 (baselineInterval index)) +          +    )++-- | Defines a feature that returns 'True' ('False' otherwise) if either:+--   * any events concuring with baseline with concepts in 'cpts' have a +--     duration >= 90 days+--   * at least 2 events with concepts in 'cpts' have the same interval +medHx :: [Text]+  -> Definition+ ( Feature "calendarIndex" (Index Interval Day)+  -> Feature "allEvents" (Events Day)+  -> Feature name Bool )+medHx cpt = define+    (\index events ->+            ( events+                |> getBaselineConcur index+                |> makeConceptsFilter cpt+                |> combineIntervals+                |> durations+                |> any (>= 90) )+            ||+            ( events+                |> getBaselineConcur index+                |> relations+                |> filter (== Equals)+                |> not . null) +    )+++{-------------------------------------------------------------------------------+  Features used by inclusion/exclusion (and possibly other places too)+-------------------------------------------------------------------------------}++-- | Lift a subject's events in a feature+featureEvents :: Events Day -> Feature "allEvents" (Events Day)+featureEvents = pure++-- | Lift a calendar index into a feature+featureIndex :: Index Interval Day -> Feature "calendarIndex"  (Index Interval Day)+featureIndex = pure++--- | Gets all enrollment intervals and combines them any place they concur. +--    Returns an error if there are no enrollment intervals.+enrollmentIntervals :: Definition+  (  Feature "allEvents" (Events Day)+  -> Feature "enrollmentIntervals" [Interval Day])+enrollmentIntervals =+  defineA+      (\events ->+              events+          |> makeConceptsFilter ["enrollment"]+          |> combineIntervals+          |> (\x -> if null x then makeFeature $ missingBecause $ Other "no enrollment intervals"+                    else pure x)+      )++-- | The subject's age at time of index. Returns an error if there no birth year+--   records.+age :: Definition+  (   Feature "calendarIndex" (Index Interval Day)+   -> Feature "allEvents" (Events Day)+   -> Feature "age" Integer)+age =+  defineA+    (\index events ->+      events+      |> makeConceptsFilter ["is_birth_year"]+      |> viewBirthYears+      |> headMay+      |> fmap (\y  -> fromGregorian y 1 7)  -- Use July 1 YEAR as birthdate+      |> fmap (\bday -> computeAgeAt bday (begin $ getIndex index) )+      |> \case+            Nothing -> makeFeature $ featureDataL $ Other "No numeric birth year found"+            Just age -> pure age+    )++-- | Just the day of death (the first if there are multiple). Nothing if there+--   are no death records.+deathDay :: Definition+  (   Feature "allEvents" (Events Day)+   -> Feature "deathDay" (Maybe (Interval Day)))+deathDay =+  define+    (\events ->+           events+        |> makeConceptsFilter ["is_death"]+        |> intervals+        |> headMay+    )++{-------------------------------------------------------------------------------+  Inclusion/Exclusion features +-------------------------------------------------------------------------------}++-- | Include the subject if female; Exclude otherwise+critFemale :: Definition+ (   Feature "allEvents" (Events Day)+  -> Feature "isFemale" Status)++critFemale =+    define+      (\events ->+            events+        |> makeConceptsFilter ["is_female"]+        |> headMay+        |> \case+            Nothing -> Exclude+            Just _  -> Include+      )++-- | Include the subject if over 50; Exclude otherwise.+critOver50 :: Definition+  (   Feature "age" Integer+   -> Feature "isOver50" Status)+critOver50 = define (includeIf . (>= 50))++-- | Include the subject if she has an enrollment interval concurring with index.+critEnrolled :: Definition+  (   Feature "calendarIndex" (Index Interval Day)+   -> Feature "enrollmentIntervals" [Interval Day]+   -> Feature "isEnrolled" Status )+critEnrolled =+  define+      (\index enrollmentIntervals ->+        enrollmentIntervals+        |> any (concur $ getIndex index)+        |> includeIf+      )++-- | Include the subject if both:+--     * she is enrolled on index ('critEnrolled')+--     * she all the gaps between the (combined) enrolled intervals within baseline +--       are less than 30 days+critEnrolled455 :: Definition+  (   Feature "calendarIndex" (Index Interval Day)+   -> Feature "enrollmentIntervals" [Interval Day]+   -> Feature "isEnrolled" Status+   -> Feature "isContinuousEnrolled" Status )+critEnrolled455 =+  define+      (\index enrollIntrvls isEnrolled ->+        case isEnrolled of+          Exclude -> Exclude+          Include -> includeIf ( allGapsWithinLessThanDuration 30 (baselineInterval index) enrollIntrvls)+      )++-- | Exclude if the subject is dead before the time of index.+critDead :: Definition+  (  Feature "calendarIndex" (Index Interval Day)+  -> Feature "deathDay" (Maybe (Interval Day))+  -> Feature "isDead" Status)+critDead =+  define+      (\index mDeadDay ->+          case mDeadDay of+            Nothing -> Include+            Just deadDay  -> excludeIf $ beforeIndex index deadDay+        --  excludeIf ( maybe False (beforeIndex index) mDeadDay) -- different way to write logic+      )++++{-------------------------------------------------------------------------------+  Covariate features+-------------------------------------------------------------------------------}++type BoolFeatDef n =+    Definition+    (    Feature "calendarIndex" (Index Interval Day)+      -> Feature "allEvents" (Events Day)+      -> Feature n Bool+    )++type BoolFeat n = Feature n  Bool++diabetes :: BoolFeatDef "diabetes"+diabetes = twoOutOneIn ["is_diabetes_outpatient"] ["is_diabetes_inpatient"]++ckd :: BoolFeatDef "ckd"+ckd =  twoOutOneIn ["is_ckd_outpatient"] ["is_ckd_inpatient"]++ppi :: BoolFeatDef "ppi"+ppi = medHx ["is_ppi"]++glucocorticoids :: BoolFeatDef "glucocorticoids"+glucocorticoids = medHx ["is_glucocorticoids"]++{-------------------------------------------------------------------------------+  Cohort Specifications and evaluation+-------------------------------------------------------------------------------}++++-- | Make a function that runs the criteria for a calendar index+makeCriteriaRunner :: Index Interval Day -> Events Day -> Criteria+makeCriteriaRunner index events =+  criteria $+      criterion crit1 :| -- Note use of NonEmpty constructor+    [ criterion crit2+    , criterion crit3+    , criterion crit4+    , criterion crit5 ]+  where crit1   = eval critFemale featEvs+        crit2   = eval critOver50 agefeat+        crit3   = eval critEnrolled (featInd, enrll)+        crit4   = eval critEnrolled455 (featInd, enrll, crit3)+        crit5   = eval critDead (featInd, dead)+        agefeat = eval age (featInd, featEvs)+        enrll   = eval enrollmentIntervals featEvs+        dead    = eval deathDay featEvs+        featInd = featureIndex index+        featEvs = featureEvents events++-- | Define the shape of features for a cohort+type ExampleFeatures =+    ( Feature "calendarIndex"  (Index Interval Day)+    , BoolFeat "diabetes"+    , BoolFeat "ckd"+    , BoolFeat "ppi"+    , BoolFeat "glucocorticoids"+    )++-- | Make a function that runs the features for a calendar index+makeFeatureRunner ::+       Index Interval Day+    -> Events Day+    -> ExampleFeatures+makeFeatureRunner index events = (+      idx+    , eval diabetes (idx,  ef)+    , eval ckd (idx,  ef)+    , eval ppi (idx,  ef)+    , eval glucocorticoids (idx, ef)+    )+    where idx = featureIndex index+          ef  = featureEvents events++-- | Make a cohort specification for each calendar time+cohortSpecs :: [CohortSpec (Events Day) ExampleFeatures]+cohortSpecs =+  map (\x -> specifyCohort (makeCriteriaRunner x) (makeFeatureRunner x))+  indices++-- | A function that evaluates all the calendar cohorts for a population+evalCohorts :: Population (Events Day) -> [Cohort ExampleFeatures]+evalCohorts pop = map (`evalCohort` pop) cohortSpecs++{-------------------------------------------------------------------------------+  Testing +  This would generally be in a separate file+-------------------------------------------------------------------------------}+m :: Year -> MonthOfYear -> Int -> Integer -> [Text] -> Domain -> Event Day+m y m d dur c dmn = event (beginerval dur (fromGregorian y m d)) (context dmn (packConcepts c))++testData1 :: Events Day+testData1 = sort+    [ m 2010 1 1 1   ["is_female"] (Demographics (DemographicsFacts (DemographicsInfo Gender  (Just "Female")) ))+    , m 2010 1 1 1   ["is_birth_year"] (Demographics (DemographicsFacts (DemographicsInfo BirthYear (Just "1960")) ))+    , m 2016 1 1 699 ["enrollment"] ( UnimplementedDomain ())+    , m 2018 1 1 30  ["enrollment"] ( UnimplementedDomain ())+    , m 2018 2 1 30  ["enrollment"] ( UnimplementedDomain ())+    , m 2017 6 5 1   ["is_diabetes_inpatient"] (UnimplementedDomain ())+    , m 2017 8 1 91  ["is_ppi"] (UnimplementedDomain ())+    ]++testSubject1 :: Subject (Events Day)+testSubject1 = MkSubject ("a", testData1)++testData2 :: Events Day+testData2 = sort+    [ m 2010 1 1 1   ["is_female"] (Demographics (DemographicsFacts (DemographicsInfo Gender  (Just "Female")) ))+    , m 2010 1 1 1   ["is_birth_year"] (Demographics (DemographicsFacts (DemographicsInfo BirthYear (Just "1980")) ))+    , m 2016 1 1 730 ["enrollment"] (UnimplementedDomain ())+    , m 2018 1 1 30  ["enrollment"] (UnimplementedDomain ())+    , m 2018 2 1 30  ["enrollment"] (UnimplementedDomain ())+    ]++testSubject2 :: Subject (Events Day)+testSubject2 = MkSubject ("b", testData2)++testPop :: Population (Events Day)+testPop = MkPopulation [testSubject1, testSubject2]++makeExpectedCovariate :: (KnownSymbol name) => FeatureData Bool -> Feature name  Bool+makeExpectedCovariate = makeFeature++makeExpectedFeatures ::+  FeatureData (Index Interval Day)+  -> (FeatureData Bool, FeatureData Bool, FeatureData Bool, FeatureData Bool)+  -> ExampleFeatures+makeExpectedFeatures i (b1, b2, b3, b4) =+        ( makeFeature  i :: Feature "calendarIndex"  (Index Interval Day)+        , makeExpectedCovariate b1+        , makeExpectedCovariate b2+        , makeExpectedCovariate b3+        , makeExpectedCovariate b4+        )++expectedFeatures1 :: [ExampleFeatures]+expectedFeatures1 =+  map (uncurry makeExpectedFeatures)+    [ (pure $ makeIndex $ beginerval 1 (fromGregorian 2017 4 1),+          (pure False, pure False, pure False, pure False))+    , (pure $ makeIndex $ beginerval 1 (fromGregorian 2017 7 1),+           (pure True, pure False, pure False, pure False))+    , (pure $ makeIndex $ beginerval 1 (fromGregorian 2017 10 1),+           (pure True, pure False, pure True, pure False))+    ]++expectedObsUnita :: [ObsUnit ExampleFeatures]+expectedObsUnita = zipWith (curry MkObsUnit) (replicate 5 "a") expectedFeatures1++makeExpectedCohort :: AttritionInfo -> [ObsUnit ExampleFeatures] -> Cohort ExampleFeatures+makeExpectedCohort a x = MkCohort (Just a, x)++expectedCohorts :: [Cohort ExampleFeatures]+expectedCohorts =+  zipWith+  (curry MkCohort)+  [+    Just $ MkAttritionInfo $ (ExcludedBy (2, "isOver50"), 1) :| [(ExcludedBy (4, "isContinuousEnrolled"), 1)]+  , Just $ MkAttritionInfo $ (ExcludedBy (2, "isOver50"), 1) :| [(Included, 1)]+  , Just $ MkAttritionInfo $ (ExcludedBy (2, "isOver50"), 1) :| [(Included, 1)]+  , Just $ MkAttritionInfo $ (ExcludedBy (2, "isOver50"), 1) :| [(Included, 1)]+  , Just $ MkAttritionInfo $ (ExcludedBy (2, "isOver50"), 1) :| [(ExcludedBy (4, "isContinuousEnrolled"), 1)]+  , Just $ MkAttritionInfo $ (ExcludedBy (2, "isOver50"), 1) :| [(ExcludedBy (3, "isEnrolled"), 1)]+  , Just $ MkAttritionInfo $ (ExcludedBy (2, "isOver50"), 1) :| [(ExcludedBy (3, "isEnrolled"), 1)]+  , Just $ MkAttritionInfo $ (ExcludedBy (2, "isOver50"), 1) :| [(ExcludedBy (3, "isEnrolled"), 1)]+  ]+  ([[]] ++ transpose [expectedObsUnita] ++ [[], [], [], []])++exampleCohort1tests :: TestTree+exampleCohort1tests = testGroup "Unit tests for calendar cohorts"+  [ testCase "expected Features for testData1" $+       evalCohorts testPop @?= expectedCohorts+  ]

@@ -1,6 +1,6 @@ {-| Module      : Example Hasklepias Events-Description : TODO+Description : example events with which to toy with hasklepias Copyright   : (c) NoviSci, Inc 2020 License     : BSD3 Maintainer  : bsaul@novisci.com@@ -39,7 +39,7 @@ type EventData a = (a, a, Text)  toEvent :: (IntervalSizeable a a, Show a) => EventData a -> Event a-toEvent x = event (beginerval (t1 x) (t2 x)) (context Nothing (packConcepts [t3 x]))+toEvent x = event (beginerval (t1 x) (t2 x)) (context (UnimplementedDomain ()) (packConcepts [t3 x]))  toEvents :: (Ord a, Show a, IntervalSizeable a a) => [EventData a] -> Events a toEvents = sort.map toEvent

@@ -9,7 +9,7 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE NoImplicitPrelude #-}-+{-# LANGUAGE DataKinds #-} module ExampleFeatures1(     exampleFeatures1Spec ) where@@ -22,10 +22,11 @@ {- Index is defined as the first occurrence of an Orca bite. -}-indexDef :: (Ord a) => FeatureDefinition-  (FeatureData (Events a))-  (Interval a)-indexDef = defineM (\events ->+indexDef :: (Ord a) => Definition (FeatureData (Events a) -> FeatureData (Interval a))+-- FeatureDefinition+--   (FeatureData (Events a))+--   (Interval a)+indexDef = defineA (\events ->   case firstConceptOccurrence ["wasBitByOrca"]  events of         Nothing -> featureDataL (Other "No occurrence of Orca bite")         Just x  -> pure (getInterval x))@@ -64,10 +65,8 @@       |> maybe False (all (< allowableGap) . durations)  enrolledDef :: IntervalSizeable a b =>-      b-      -> FeatureDefinition-         (FeatureData (Interval a), FeatureData (Events a)) Bool-enrolledDef allowableGap = define2 (enrolled allowableGap)+      b -> Definition (FeatureData (Interval a) -> FeatureData (Events a) -> FeatureData Bool)+enrolledDef allowableGap = define (enrolled allowableGap) {- Define features that identify whether a subject as bit/struck by a duck and bit/struck by a macaw.@@ -93,6 +92,11 @@       -> (Bool, Maybe (Interval a)) macawHxDef = makeHxDef ["wasBitByMacaw", "wasStruckByMacaw"] +-- | a helper function for 'twoMinorOrOneMajorDef' +twoXOrOneY :: [Text] -> [Text] -> Events a -> Bool+twoXOrOneY x y es = atleastNofX 2 x es ||+                    atleastNofX 1 y es+ -- | Define an event that identifies whether the subject has two minor or one major --   surgery. twoMinorOrOneMajorDef :: (Ord a) =>@@ -149,7 +153,6 @@           ["tookAntibiotics"])     events - type MyData =       ( FeatureData (Interval Int)      , FeatureData Bool@@ -167,6 +170,8 @@ getUnitFeatures x = (     eval indexDef evs   , eval (enrolledDef 8) (bline evs, evs)  +  -- TODO: feature functions below need to be put into a FeatureDefintion+  --      in order to run eval   , liftA2 duckHxDef  (bline evs) evs   , liftA2 macawHxDef (bline evs) evs   , liftA2 twoMinorOrOneMajorDef (bline evs) evs@@ -175,6 +180,13 @@   , liftA2 discontinuationDef (flwup evs) evs   ) where evs = pure x ++includeAll :: Events Int -> Criteria +includeAll x = criteria $ pure (criterion (makeFeature (featureDataR Include)  :: Feature "includeAll" Status))++testCohortSpec :: CohortSpec  (Events Int) MyData+testCohortSpec = specifyCohort includeAll getUnitFeatures+ example1results :: MyData example1results =       ( pure (beginerval 1 (60 :: Int))@@ -209,6 +221,7 @@       getUnitFeatures exampleEvents2 `shouldBe` example2results      it "mapping a population to cohort" $-      makeCohort getUnitFeatures (MkPopulation [exampleSubject1, exampleSubject2 ]) `shouldBe`-            MkCohort [MkObsUnit ("a", example1results), MkObsUnit ("b", example2results)]+      evalCohort testCohortSpec (MkPopulation [exampleSubject1, exampleSubject2 ]) `shouldBe`+            MkCohort (Just $ MkAttritionInfo $ pure (Included, 2),+                      [MkObsUnit ("a", example1results), MkObsUnit ("b", example2results)]) 

@@ -1,18 +1,28 @@ module Main(-    module Hasklepias-  , module ExampleEvents-  , module ExampleFeatures1+    module ExampleFeatures1   , main ) where -import Hasklepias-import ExampleEvents-import ExampleFeatures1-import ExampleFeatures2-import ExampleFeatures3-import Test.Hspec ( hspec )+import ExampleFeatures1 ( exampleFeatures1Spec )+import ExampleFeatures2 ( exampleFeatures2Spec ) +import ExampleFeatures3 ( exampleFeatures3Spec ) +import ExampleCohort1   ( exampleCohort1tests )+import Test.Tasty+import Test.Tasty.Hspec ( testSpec )+import Test.Hspec       ( hspec ) +-- NOTE: testSpec is used because the project orginally used the Hspec testing +-- framework. We have since moved to Tasty. The tests in exampleFeatures(1-3)Spec+-- should be updated to Tasty at some point.  main :: IO ()-main = hspec $ do exampleFeatures1Spec-                  exampleFeatures2Spec-                  exampleFeatures3Spec +main = do+  spec1 <- testSpec "spec1" exampleFeatures1Spec+  spec2 <- testSpec "spec2" exampleFeatures2Spec+  spec3 <- testSpec "spec3" exampleFeatures3Spec +  defaultMain+    (testGroup "tests"+      [ spec1+      , spec2+      , spec3 +      , testGroup "Tests" [exampleCohort1tests]+      ])

@@ -1,6 +1,6 @@ cabal-version:  2.2 name:           hasklepias-version:        0.8.3+version:        0.12.0 description:    Please see the README on GitHub at <https://github.com/novisci/asclepias#readme> homepage:       https://github.com/novisci/asclepias/#readme bug-reports:    https://github.com/novisci/asclepias/issues@@ -8,7 +8,7 @@ maintainer:     bsaul@novisci.com copyright:      NoviSci, Inc category:       Data Science-synopsis:       Define features from events+synopsis:       embedded DSL for defining epidemiologic cohorts license:        BSD-3-Clause license-file:   LICENSE build-type:     Simple@@ -31,12 +31,15 @@       EventData.Context.Domain.Demographics       FeatureCompose       FeatureCompose.Aeson-      FeatureCompose.Criteria       FeatureEvents       Hasklepias       Hasklepias.Aeson+      Hasklepias.MakeApp       Hasklepias.Reexports+      Hasklepias.ReexportsUnsafe       Hasklepias.Cohort+      Hasklepias.Cohort.Criteria+      Hasklepias.Cohort.Index   other-modules:       Paths_hasklepias   autogen-modules:@@ -46,19 +49,26 @@   build-depends:       aeson >=1.4.0.0 && <2     , base >=4.14 && <4.15-    , bytestring >=0.10-    , containers >=0.6.0+    , bytestring == 0.10.12.0+    , cmdargs == 0.10.21+    , containers == 0.6.5.1+    , co-log == 0.4.0.1     , flow == 1.0.22+    , ghc-prim == 0.6.1     , interval-algebra == 0.8.2     , lens == 5.0.1     , lens-aeson == 1.1.1+    , mtl == 2.2.2+    , process == 1.6.12.0     , safe >= 0.3-    , text >=1.2.3-    , time >=1.11+    , tasty  == 1.4.1+    , tasty-hunit == 0.10.0.3+    , text == 1.2.4.1+    , time == 1.11.1.2     , QuickCheck-    , unordered-containers >=0.2.10-    , vector >=0.12-    , witherable >= 0.4+    , unordered-containers == 0.2.14.0+    , vector == 0.12.2.0+    , witherable == 0.4.1   default-language: Haskell2010  test-suite hasklepias-test@@ -71,9 +81,10 @@       EventData.Context.DomainSpec       EventData.Context.Domain.DemographicsSpec       FeatureComposeSpec-      FeatureCompose.CriteriaSpec       FeatureCompose.AesonSpec       Hasklepias.AesonSpec+      Hasklepias.CohortSpec+      Hasklepias.Cohort.CriteriaSpec       FeatureEventsSpec       Paths_hasklepias   autogen-modules:@@ -106,19 +117,24 @@       ExampleFeatures1       ExampleFeatures2       ExampleFeatures3+      ExampleCohort1   hs-source-dirs:       examples   build-depends:       hasklepias     , hspec     , base >=4.14 && <4.15-    , flow == 1.0.22-    , interval-algebra == 0.8.2 -    , text >=1.2.3-    , bytestring >=0.10-    , containers >=0.6.0-    , time >=1.11-    , aeson >=1.4.0.0 && <2-    , unordered-containers >=0.2.10-    , vector >=0.12+    , tasty  == 1.4.1+    , tasty-hunit == 0.10.0.3+    , tasty-hspec == 1.2+  default-language: Haskell2010+++executable exampleApp+  -- type: exitcode-stdio-1.0+  main-is: Main.hs+  hs-source-dirs:+      exampleApp+  build-depends:+      hasklepias   default-language: Haskell2010

@@ -6,12 +6,15 @@ License     : BSD3 Maintainer  : bsaul@novisci.com -}+{-# OPTIONS_HADDOCK hide #-} {-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE TypeSynonymInstances #-} {-# LANGUAGE FlexibleInstances #-} -- {-# LANGUAGE Safe #-}  module EventData(++ -- * Events    Event  , Events  , ConceptEvent@@ -20,7 +23,6 @@  , toConceptEvent  , toConceptEventOf  , mkConceptEvent- , module EventData.Context ) where  import GHC.Show                         ( Show(show) )@@ -38,16 +40,13 @@                                         , Concept                                         , packConcept                                         , Context(..)-                                        , fromConcepts+                                        , getConcepts                                         , toConcepts )   -- | An Event @a@ is simply a pair @(Interval a, Context)@. type Event a = PairedInterval Context a --- instance (Ord a, Show a) => Show (Event a) where---   show x = "{" ++ show (getInterval x) ++ ", " ++ show (ctxt x) ++ "}"- instance HasConcept (Event a) where     hasConcept x y = ctxt x `hasConcept` y @@ -55,42 +54,33 @@ event :: Interval a -> Context -> Event a event i c = makePairedInterval c i --- | Access the 'Context' of an 'Event a'.+-- | Get the 'Context' of an 'Event a'. ctxt :: Event a -> Context ctxt = getPairData  -- | An event containing only concepts and an interval type ConceptEvent a = PairedInterval Concepts a --- instance (Ord a, Show a) => Show (ConceptEvent a) where---   show x = "{" ++ show (getInterval x) ++ ", " ++ show (getPairData x) ++ "}"- instance HasConcept (ConceptEvent a) where-    hasConcept e concept = member (packConcept concept) (fromConcepts $ getPairData e)+    hasConcept e concept = member (packConcept concept) (getConcepts $ getPairData e)  -- | Drops an @Event@ to a @ConceptEvent@ by moving the concepts in the data --   position in the paired interval and throwing out the facts and source. toConceptEvent :: (Show a, Ord a) => Event a -> ConceptEvent a toConceptEvent e = makePairedInterval (_concepts $ ctxt e) (getInterval e) +-- | Creates a new @'ConceptEvent'@ from an @'Event'@ by taking the intersection+-- of the list of Concepts in the first argument and any Concepts in the @'Event'@.+-- This is a way to keep only the concepts you want in an event. toConceptEventOf :: (Show a, Ord a) => [Concept] -> Event a -> ConceptEvent a toConceptEventOf cpts e =     makePairedInterval-        (toConcepts $ intersection (fromList cpts) (fromConcepts $ _concepts $ ctxt e))+        (toConcepts $ intersection (fromList cpts) (getConcepts $ _concepts $ ctxt e))         (getInterval e) --- |+-- | Create a new @'ConceptEvent'@. mkConceptEvent :: (Show a, Ord a) => Interval a -> Concepts -> ConceptEvent a mkConceptEvent i c = makePairedInterval c i  -- | A @List@ of @Event a@--- --- NOTE (20190911): I (B. Saul) am starting out the Events type as a --- list of the Event type. This may be not be the optimal approach,--- especially with regards to lookup/filtering the list. Ideally,--- we could do one pass through the ordered container (whatever it is)--- to identify events by concept; rather than repeated evaluations of--- the lookup predicates. This could be handled by, for example, --- representing Events has a Map with a list of concept indices. --- But this gets us off the ground. type Events a = [Event a]

@@ -5,6 +5,7 @@ License     : BSD3 Maintainer  : bsaul@novisci.com -}+{-# OPTIONS_HADDOCK hide #-} {-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE FlexibleInstances, OverloadedStrings #-} {-# LANGUAGE TypeApplications #-}@@ -36,23 +37,22 @@                                             , withObject                                             , FromJSON(parseJSON)                                             , Value(Array) )-import Data.Either                          ( Either(..) )-import Data.Maybe                           ( maybe )+import Data.Either                          ( Either(..), partitionEithers, either )+import Data.Maybe                           ( fromMaybe ) import Data.Text                            ( Text ) import Data.Time                            ( Day ) import Data.Vector                          ((!)) import qualified Data.ByteString.Lazy as B import qualified Data.ByteString.Char8 as C-import Data.Either                          (rights, either)-import Control.Monad +import Control.Monad  instance (FromJSON a, Show a, IntervalSizeable a b) => FromJSON (Interval a) where     parseJSON = withObject "Time" $ \o -> do         t <- o .: "time"         b <- t .: "begin"-        e <- t .:? "end" +        e <- t .:? "end"         -- In the case that the end is missing, create a moment-        let e2 = maybe (add (moment @a) b) (id) e +        let e2 = fromMaybe (add (moment @a) b) e         let ei = parseInterval b e2         case ei of             Left e  -> fail e@@ -72,28 +72,31 @@     parseJSON c = toConcepts <$> parseJSON c  instance FromJSON Context where-    parseJSON (Array v) = context <$>-        parseJSON (v ! 5) <*>-        parseJSON (v ! 4)-    -- parseJSON v = context <$> parseJSON v+    parseJSON (Array v) =+        context <$>+            parseJSON (v ! 5) <*>+            parseJSON (v ! 4)  instance  (FromJSON a, Show a, IntervalSizeable a b) => FromJSON (Event a) where-    parseJSON (Array v) = event <$> parseJSON (v ! 5) <*> parseJSON (Array v)-    -- parseJSON (Array v) = event <$>-    --         parseJSON (v ! 5) <*>-    --         parseJSON (v ! 4)+    parseJSON (Array v) =+        event+            <$> parseJSON (v ! 5)+            <*> parseJSON (Array v)  -- |  Parse @Event Int@ from json lines.-parseEventLines :: (FromJSON a, Show a, IntervalSizeable a b) => B.ByteString -> [Event a]+parseEventLines :: (FromJSON a, Show a, IntervalSizeable a b) =>+    B.ByteString -> ([String], [Event a]) parseEventLines l =-    rights $ fmap +    partitionEithers $ fmap     (\x -> eitherDecode $ B.fromStrict x :: (FromJSON a, Show a, IntervalSizeable a b) =>  Either String (Event a))         (C.lines $ B.toStrict l) --parseEventIntLines :: B.ByteString -> [Event Int]+-- |  Parse @Event Int@ from json lines.+parseEventIntLines :: (FromJSON a, Show a, IntervalSizeable a b) =>+    B.ByteString -> ([String], [Event a]) parseEventIntLines = parseEventLines  -- |  Parse @Event Day@ from json lines.-parseEventDayLines :: B.ByteString -> [Event Day]+parseEventDayLines :: (FromJSON a, Show a, IntervalSizeable a b) =>+    B.ByteString -> ([String], [Event a]) parseEventDayLines = parseEventLines

@@ -6,6 +6,7 @@ Maintainer  : bsaul@novisci.com Stability   : experimental -}+{-# OPTIONS_HADDOCK hide #-} {-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE FlexibleContexts #-}

@@ -7,6 +7,7 @@ Maintainer  : bsaul@novisci.com -} +{-# OPTIONS_HADDOCK hide #-} {-# LANGUAGE NoImplicitPrelude #-} -- {-# LANGUAGE Safe #-} {-# LANGUAGE TemplateHaskell #-}@@ -17,12 +18,11 @@   , facts   , source   , context-  , emptyContext    , Concept   , Concepts   , toConcepts-  , fromConcepts+  , getConcepts   , packConcept   , unpackConcept   , packConcepts@@ -51,33 +51,23 @@ -- later versions of hasklepias.  data Context = Context {       _concepts :: Concepts-    , _facts    :: Maybe Domain+    , _facts    :: Domain     , _source   :: Maybe Source } deriving (Eq, Show)  data Source = Source deriving (Eq, Show) -instance Semigroup Context where-    x <> y = Context (_concepts x <> _concepts y) Nothing Nothing--instance Monoid Context where-    mempty = emptyContext- instance HasConcept Context where     hasConcept ctxt concept = -        member (packConcept concept) (fromConcepts $ _concepts ctxt)+        member (packConcept concept) (getConcepts $ _concepts ctxt)  -- | Smart contructor for Context type -- -- Creates 'Context' from a list of 'Concept's. At this time, the @facts@ and -- @source@ are both set to 'Nothing'.-context :: Maybe Domain -> Concepts -> Context+context :: Domain -> Concepts -> Context context d x = Context x d Nothing --- | Just an empty Context-emptyContext :: Context-emptyContext = Context mempty Nothing Nothing- -- | A @Concept@ is textual "tag" for a context. newtype Concept = Concept Text deriving (Eq, Ord) @@ -92,8 +82,8 @@ unpackConcept :: Concept -> Text  unpackConcept (Concept x) =  x --- | @Concepts@ is a 'Set' of 'Concepts's.-newtype Concepts = Concepts ( Set Concept )+-- | @Concepts@ is a 'Set' of 'Concept's.+newtype Concepts = Concepts { getConcepts :: Set Concept }     deriving (Eq, Show)  instance Semigroup Concepts where@@ -105,9 +95,6 @@ -- | Constructor for 'Concepts'. toConcepts :: Set Concept -> Concepts toConcepts = Concepts--fromConcepts :: Concepts -> Set Concept-fromConcepts (Concepts x) = x  -- | Put a list of text into a set concepts. packConcepts :: [Text] -> Concepts

@@ -5,14 +5,14 @@ License     : BSD3 Maintainer  : bsaul@novisci.com -}-+{-# OPTIONS_HADDOCK hide #-} {-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE OverloadedStrings #-} -- {-# LANGUAGE Safe #-}  module EventData.Context.Arbitrary() where -import Test.QuickCheck              ( Arbitrary(arbitrary), elements, sublistOf ) +import Test.QuickCheck              ( Arbitrary(arbitrary), elements, sublistOf ) import Data.Function                ( (.) ) import Data.Functor                 ( Functor(fmap) ) import Data.List                    ( map )@@ -25,6 +25,7 @@                                     , toConcepts                                     , packConcepts                                     , packConcept)+import EventData.Context.Domain     ( Domain(UnimplementedDomain) )  conceptChoices :: [Concept] conceptChoices = map packConcept ["A", "B", "C", "D", "E", "F", "G", "H", "I", "J"]@@ -33,7 +34,8 @@     arbitrary = elements conceptChoices  instance Arbitrary Context where-    arbitrary = fmap (\x -> context Nothing ((toConcepts . fromList) x)) (sublistOf conceptChoices)+    arbitrary = fmap (context (UnimplementedDomain ()) . (toConcepts . fromList))+                (sublistOf conceptChoices)  -- instance Arbitrary Concepts where --     arbitrary = fmap fromList (sublistOf conceptChoices)

@@ -6,7 +6,7 @@ License     : BSD3 Maintainer  : bsaul@novisci.com -}-+{-# OPTIONS_HADDOCK hide #-} {-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE Trustworthy #-} {-# LANGUAGE DeriveGeneric #-}@@ -19,15 +19,15 @@     , module EventData.Context.Domain.Demographics ) where -import Prelude                                  ( Show, Eq-                                                , ($), (<$>), (<*>), fail, drop-                                                , pure ) import Control.Lens                             ( makePrisms )-import GHC.Generics                             ( Generic )-import Data.Foldable+import Data.Eq                                  ( Eq ) import Data.Text                                ( Text, empty )+import GHC.Generics                             ( Generic )+import GHC.Show                                 ( Show )+ import EventData.Context.Domain.Demographics +-- | Defines the available domains. data Domain =       Demographics DemographicsFacts     | UnimplementedDomain ()

@@ -6,7 +6,7 @@ License     : BSD3 Maintainer  : bsaul@novisci.com -}-+{-# OPTIONS_HADDOCK hide #-} {-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE Trustworthy #-} {-# LANGUAGE DeriveGeneric #-}@@ -16,29 +16,37 @@       DemographicsFacts(..)     , DemographicsInfo(..)     , DemographicsField(..)-    , demo+    , demo      , field      , info ) where -import Prelude                  ( drop, Show, Eq, Maybe ) import Control.Lens             ( makeLenses )-import GHC.Generics             ( Generic )-import Data.Text                ( Text )+ import Data.Aeson               ( FromJSON(..)                                 , genericParseJSON                                 , defaultOptions-                                , fieldLabelModifier )  +                                , fieldLabelModifier )+import Data.List                ( drop )+import Data.Eq                  ( Eq )+import Data.Maybe               ( Maybe )+import Data.Text                ( Text )+import GHC.Generics             ( Generic )+import GHC.Show                 ( Show ) ++-- | a demographic fact newtype DemographicsFacts =      DemographicsFacts { _demo :: DemographicsInfo                       } deriving( Eq, Show, Generic ) +-- | information of a demographic fact data DemographicsInfo =      DemographicsInfo { _field :: DemographicsField                      , _info :: Maybe Text                      } deriving ( Eq, Show, Generic ) +-- | fields available in a demographic fact data DemographicsField =       BirthYear     | BirthDate

@@ -5,146 +5,368 @@ Copyright   : (c) NoviSci, Inc 2020 License     : BSD3 Maintainer  : bsaul@novisci.com+ -}+{-# OPTIONS_HADDOCK hide #-}  {-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE Safe #-}-{-# LANGUAGE OverloadedStrings #-}- {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE FunctionalDependencies #-}+{-# LANGUAGE AllowAmbiguousTypes #-}+{-# LANGUAGE OverloadedStrings #-}  module FeatureCompose(-    -- * Types-      FeatureSpec(..)-    , Feature(..)-    , FeatureData(..)-    , MissingReason(..)-    -- , FeatureDefinition(..)-    , FeatureDefinition(..)-    , makeFeatureSpec-    , featureDataR-    , featureDataL-    , define-    , defineM-    , define2-    , defineM2-    , eval+  -- * Features and FeatureData+    FeatureData+  , MissingReason(..)+  , Feature+  , FeatureN+  , featureDataL+  , featureDataR+  , missingBecause+  , makeFeature+  , getFeatureData+  , getData+  , getDataN+  , getNameN+  , nameFeature++  -- * Defining and evaluating Features+  , Definition(..)+  , Define(..)+  , DefineA(..)+  , Eval+  , eval+ ) where -import safe GHC.Read                   ( Read )-import safe GHC.Show                   ( Show(show) )-import safe GHC.Generics               ( Generic )-import safe Control.Applicative        ( Applicative(..) )-import safe Control.Monad              ( Functor(..), Monad(..), join, liftM, liftM2)+import safe Control.Applicative        ( Applicative(..)+                                        , liftA3, (<$>) )+import safe Control.Monad              ( Functor(..), Monad(..)+                                       , (=<<), join, liftM, liftM2, liftM3) import safe Data.Either                ( Either(..) )-import safe Data.Eq                    ( Eq )+import safe Data.Eq                    ( Eq(..) )+import safe Data.Foldable              ( Foldable(foldr) ) import safe Data.Function              ( ($), (.) )-import safe Data.List                  ( (++), zipWith )-import safe Data.Maybe                 ( Maybe(..), maybe )-import safe Data.Ord                   ( Ord )+import safe Data.List                  ( (++) )+import safe Data.Proxy                 ( Proxy(..) )+import safe Data.Text                  ( Text, pack ) import safe Data.Traversable           ( Traversable(..) )-import safe Data.Text                  ( Text )-import safe Data.Tuple                 ( uncurry, curry )---- import safe Test.QuickCheck       ( Property )+import safe GHC.Generics               ( Generic )+import safe GHC.Show                   ( Show(show) )+import safe GHC.TypeLits               ( KnownSymbol, Symbol, symbolVal ) -{- | A 'FeatureSpec' contains all the information needed to derive a 'Feature':-      * its name-      * its attributes-      * the function needed to derive a feature (i.e. the 'FeatureDefinition')+{- | +Defines the reasons that a @'FeatureData'@ value may be missing. Can be used to+indicate the reason that a @'Feature'@'s data was unable to be derived or does+not need to be derived.  -}-data (Show b) => FeatureSpec b di d0 = MkFeatureSpec {-        getSpecName :: Text-      , getSpecAttr :: b-      , getDefn :: FeatureDefinition di d0-      -- To add in future: an optional list of properties to check-      -- , getProp :: Maybe [Feature d -> Events a -> Property] -    }+data MissingReason =+    InsufficientData -- ^ Insufficient information available to derive data.+  | Other Text -- ^ User provided reason for missingness+  deriving (Eq, Show, Generic) --- | TODO-makeFeatureSpec :: Show b =>-     Text-  -> b-  -> FeatureDefinition di d0-  -> FeatureSpec b di d0-makeFeatureSpec = MkFeatureSpec+{- | +The @FeatureData@ type is a container for an (almost) arbitrary type @d@ that can+have a "failed" or "missing" state. The failure is represented by the @'Left'@ of +an @'Either'@, while the data @d@ is contained in the @'Either'@'s @'Right'@. -{- | A 'Feature' contains the following:-      * a name-      * its attributes-      * 'FeatureData'+To construct a successful value, use @'featureDataR'@. A missing value can be +constructed with @'featureDataL'@ or its synonym @'missingBecause'@.+ -}-data (Show b) => Feature b d = MkFeature {-        getName :: Text-      , getAttr :: b-      , getData :: FeatureData d-      } deriving (Eq)+newtype FeatureData d = MkFeatureData { +    getFeatureData :: Either MissingReason d  -- ^ Unwrap FeatureData.+  }+  deriving (Eq, Show, Generic) -instance (Show b, Show d) => Show (Feature b d) where-    show x = "(" ++ show (getName x) ++ ": (" ++ show (getAttr x) ++ ") "  ++ show (getData x) ++ " )\n"+-- | Creates a non-missing 'FeatureData'. Since @'FeatureData'@ is an instance of+-- @'Applicative'@, @'pure'@ is also a synonym of for @'featureDataR'@.+-- +-- >>> featureDataR "aString"+-- MkFeatureData (Right "aString")+-- >>> featureDataR (1 :: P.Int)+-- MkFeatureData (Right 1)+-- +-- >>> featureDataR ("aString", (1 :: P.Int))+-- MkFeatureData (Right ("aString",1))+--+featureDataR :: d -> FeatureData d+featureDataR = MkFeatureData . Right -instance (Show b) => Functor (Feature b) where-  fmap f (MkFeature n a d) = MkFeature n a (fmap f d)+-- | Creates a missing 'FeatureData'.+-- +-- >>> featureDataL (Other "no good reason") :: FeatureData P.Int+-- MkFeatureData (Left (Other "no good reason"))+--+-- >>> featureDataL (Other "no good reason") :: FeatureData Text+-- MkFeatureData (Left (Other "no good reason"))+--+featureDataL :: MissingReason -> FeatureData d+featureDataL = MkFeatureData . Left -{- | 'FeatureData' is @'Either' 'MissingReason' d@, where @d@ can be any type -     of data derivable from 'Hasklepias.Event.Events'.--}-newtype FeatureData d = MkFeatureData { getFeatureData :: Either MissingReason [d] }-  deriving (Generic, Show, Eq)+-- | A synonym for 'featureDataL'.+missingBecause :: MissingReason -> FeatureData d+missingBecause = featureDataL +{- FeatureData instances -}++-- | Transform ('fmap') @'FeatureData'@ of one type to another.+--+-- >>> x = featureDataR (1 :: P.Int)+-- >>> :type x+-- >>> :type ( fmap show x )+-- x :: FeatureData Int+-- ( fmap show x ) :: FeatureData String+-- +-- Note that 'Left' values are carried along while the type changes:+--+-- >>> x = ( featureDataL InsufficientData ) :: FeatureData P.Int+-- >>> :type x+-- >>> x+-- >>> :type ( fmap show x )+-- >>> fmap show x +-- x :: FeatureData Int+-- MkFeatureData {getFeatureData = Left InsufficientData}+-- ( fmap show x ) :: FeatureData String+-- MkFeatureData {getFeatureData = Left InsufficientData}+-- instance Functor FeatureData where-  fmap f (MkFeatureData x) = MkFeatureData (fmap (fmap f) x)+  fmap f (MkFeatureData x) = MkFeatureData (fmap f x)  instance Applicative FeatureData where-  pure = featureDataR . pure-  liftA2 f (MkFeatureData x) (MkFeatureData y) =-    MkFeatureData ( liftA2 (zipWith f) x y )+  pure = featureDataR+  liftA2 f (MkFeatureData x) (MkFeatureData y) = MkFeatureData (liftA2 f x y)  instance Monad FeatureData where-  (MkFeatureData x) >>= f = -- TODO: surely there's a cleaner way-    case fmap (fmap f) x of-         Left l  -> featureDataL l-         Right v -> case getFeatureData (sequenceA v) of-                      Left l  -> featureDataL l-                      Right v -> MkFeatureData $ Right (join v)+  (MkFeatureData x) >>= f =+      case fmap f x of+         Left l  -> MkFeatureData $ Left l+         Right v -> v --- | Create the 'Right' side of 'FeatureData'.-featureDataR :: [d] -> FeatureData d-featureDataR = MkFeatureData . Right+instance Foldable FeatureData where+  foldr f x (MkFeatureData z) = foldr f x z --- | Create the 'Left' side of 'FeatureData'.-featureDataL :: MissingReason -> FeatureData d-featureDataL = MkFeatureData . Left+instance Traversable FeatureData where+  traverse f (MkFeatureData z) = MkFeatureData <$> traverse f z --- | 'FeatureData' may be missing for any number of reasons. -data MissingReason =-    InsufficientData-  | Excluded-  | Other Text-  | Unknown-  deriving (Eq, Read, Show, Generic)+{- | +The @'Feature'@ is an abstraction for @name@d @d@ata, where the @name@ is a+*type*. Essentially, it is a container for @'FeatureData'@ that assigns a @name@+to the data. --- TODO: the code below should be generalized so that there is a single define/eval---       interface and the recursive structure is realizing and not hacked together.-newtype FeatureDefinition di d0 = MkFeatureDefinition (di -> FeatureData d0)+Except when using @'pure'@ to lift data into a @Feature@, @Feature@s can only be+derived from other @Feature@ via a @'Definition'@.+-}+newtype (KnownSymbol name) => Feature name d =+  MkFeature { getFData :: FeatureData d }+  deriving (Eq) -class Eval di d0 where-  eval :: FeatureDefinition di d0 -> di -> FeatureData d0-  eval (MkFeatureDefinition f) = f+-- | A utility for constructing a @'Feature'@ from @'FeatureData'@.+-- Since @name@ is a type, you may need to annotate the type when using this+-- function.+--+-- >>> makeFeature (pure "test") :: Feature "dummy" Text+-- "dummy": MkFeatureData {getFeatureData = Right "test"}+--+makeFeature :: (KnownSymbol name) => FeatureData d -> Feature name d+makeFeature = MkFeature -instance Eval (FeatureData d1) d0 where-instance Eval (FeatureData d2, FeatureData d1) d0 where+-- | A utility for getting the (inner) @'FeatureData'@ content of a @'Feature'@.+getData :: Feature n d -> Either MissingReason d+getData (MkFeature x) = getFeatureData x -defineM :: (d1 -> FeatureData d0) -> FeatureDefinition (FeatureData d1) d0-defineM f = MkFeatureDefinition (>>= f)+{- Feature instances -}+instance (KnownSymbol name, Show a) => Show (Feature name a) where+  show (MkFeature x) = show (symbolVal (Proxy @name)) ++ ": " ++ show x -defineM2 :: (d2 -> d1 -> FeatureData d0) -> FeatureDefinition (FeatureData d2, FeatureData d1) d0-defineM2 f = MkFeatureDefinition (\ (x, y) -> join (liftA2 f x y))+instance Functor (Feature name) where+  fmap f (MkFeature x) = MkFeature (fmap f x) -define :: (d1 -> d0) -> FeatureDefinition (FeatureData d1) d0-define f = MkFeatureDefinition (fmap f)+instance Applicative (Feature name) where+  pure x = MkFeature (pure x)+  liftA2 f (MkFeature x) (MkFeature y) = MkFeature (liftA2 f x y) -define2 :: (d2 -> d1 -> d0) -> FeatureDefinition (FeatureData d2, FeatureData d1) d0-define2 f = MkFeatureDefinition $ uncurry (liftA2 f)+instance Foldable (Feature name) where+  foldr f x (MkFeature t) = foldr f x t++instance Traversable (Feature name) where+  traverse f (MkFeature x) = MkFeature <$> traverse f x++instance Monad (Feature name) where+   (MkFeature x) >>= f =+        case fmap f x of+          MkFeatureData (Left l)  -> MkFeature $ MkFeatureData (Left l)+          MkFeatureData (Right r) ->  r++{- |+The @'FeatureN'@ type is similar to @'Feature'@ where the @name@ is included+as a @Text@ field. This type is mainly for internal purposes in order to collect+@Feature@s of the same type @d@ into a homogeneous container like a @'Data.List'@.+-}+data FeatureN d = MkFeatureN {+        getNameN :: Text  -- ^ Get the name of a @FeatureN@.+      , getDataN :: FeatureData d -- ^ Get the data of a @FeatureN@+      } deriving (Eq, Show)++-- | A utility for converting a @'Feature'@ to @'FeatureN'@.+nameFeature :: forall name d . (KnownSymbol name) => Feature name d -> FeatureN d+nameFeature (MkFeature d) = MkFeatureN (pack $ symbolVal (Proxy @name)) d++{- | A @Definition@ can be thought of as a lifted function. Specifically, the+@'define'@ function takes an arbitrary function (currently up to three arguments)+and returns a @Defintion@ where the arguments have been lifted to a new domain.++For example, here we take @f@ and lift to to a function of @Feature@s.++@+f :: Int -> String -> Bool+f i s +  | 1 "yes" = True+  | otherwise = FALSE++myFeature :: Definition (Feature "A" Int -> Feature "B" String -> Feature "C" Bool )+myFeature = define f+@++See @'eval'@ for evaluating @Defintions@. ++-}++data Definition d where+  D1  :: (b -> a) -> Definition (f1 b -> f0 a)+  D1A :: (b -> f0 a) -> Definition (f1 b -> f0 a)+  D2  :: (c -> b -> a) -> Definition (f2 c -> f1 b -> f0 a)+  D2A :: (c -> b -> f0 a) -> Definition (f2 c -> f1 b -> f0 a)+  D3  :: (d -> c -> b -> a) -> Definition (f3 d -> f2 c -> f1 b -> f0 a)+  D3A :: (d -> c -> b -> f0 a) -> Definition (f3 d -> f2 c -> f1 b -> f0 a)++{- | Define (and @'DefineA@) provide a means to create new @'Definition'@s via +@'define'@ (@'defineA'@). The @'define'@ function takes a single function input +and returns a lifted function. For example,++@+f :: Int -> String -> Bool+f i s +  | 1 "yes" = True+  | otherwise = FALSE++myFeature :: Definition (Feature "A" Int -> Feature "B" String -> Feature "C" Bool )+myFeature = define f+@++The @'defineA'@ function is similar, except that the return type of the input+function is already lifted. In the example below, an input of @Nothing@ is +considered a missing state: ++@+f :: Int -> Maybe String -> Feature "C" Bool+f i s +  | 1 (Just "yes")   = pure True+  | _ (Just _ )      = pure False -- False for any Int and any (Just String)+  | otherwise        = pure $ missingBecause InsufficientData -- missing if no string++myFeature :: Definition (Feature "A" Int -> Feature "B" String -> Feature "C" Bool )+myFeature = defineA f+@++-}+class Define inputs def | def -> inputs where+  define :: inputs -> Definition def++-- | See @'Define'@.+class DefineA inputs def | def -> inputs where+  defineA :: inputs -> Definition def++instance Define (b -> a) (FeatureData b -> FeatureData a) where define = D1+instance Define (c -> b -> a) (FeatureData c -> FeatureData b -> FeatureData a) where define = D2+instance Define (d -> c -> b -> a) (FeatureData d -> FeatureData c -> FeatureData b -> FeatureData a) where define = D3++instance 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 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 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++{- | Evaluate a @Definition@. Note that (currently), the second argument of 'eval'+is a *tuple* of inputs. For example,++@+f :: Int -> String -> Bool+f i s +  | 1 "yes" = True+  | otherwise = FALSE++myFeature :: Definition (Feature "A" Int -> Feature "B" String -> Feature "C" Bool )+myFeature = define f++a :: Feature "A" Int+a = pure 1++b :: Feature "B" String+b = pure "yes"++c = eval myFeature (a, b)+@++-}+class Eval def args return | def -> args return where+  eval :: Definition def -- ^ a @'Definition'@+                     -> args -- ^ a tuple of arguments to the @'Definition'@+                     -> return++instance Eval (FeatureData b -> FeatureData a) +              (FeatureData b)  (FeatureData a) where+  eval (D1 f)  x = fmap f x+  eval (D1A f) x = x >>= f++instance Eval (Feature n1 b -> Feature n0 a)+              (Feature n1 b)  (Feature n0 a) where+  eval (D1 f) (MkFeature x) = MkFeature $ fmap f x+  eval (D1A f) (MkFeature x) =+       case fmap f x of+          MkFeatureData (Left l)  -> MkFeature $ MkFeatureData (Left l)+          MkFeatureData (Right r) -> r+++instance Eval (FeatureData c -> FeatureData b -> FeatureData a) +              (FeatureData c,   FeatureData b) (FeatureData a) where+  eval (D2 f) (x, y) = liftA2 f x y+  eval (D2A f) (x, y) = join (liftA2 f x y)++instance Eval (Feature n2 c -> Feature n1 b -> Feature n0 a)+              (Feature n2 c,   Feature n1 b)  (Feature n0 a)+  where+  eval (D2 f) (MkFeature x, MkFeature y) = MkFeature $ liftA2 f x y+  eval (D2A f) (MkFeature x, MkFeature y) =+      case liftA2 f x y of+          MkFeatureData (Left l)  -> MkFeature $ MkFeatureData (Left l)+          MkFeatureData (Right r) ->  r++instance Eval (FeatureData d -> FeatureData c -> FeatureData b -> FeatureData a)+              (FeatureData d,   FeatureData c,   FeatureData b)  (FeatureData a)+  where+  eval (D3 f) (x, y, z) = liftA3 f x y z+  eval (D3A f) (x, y, z) = join (liftA3 f x y z)++instance Eval (Feature n3 d -> Feature n2 c -> Feature n1 b -> Feature n0 a)+              (Feature n3 d,   Feature n2 c,   Feature n1 b)  (Feature n0 a)+   where+  eval (D3 f) (MkFeature x, MkFeature y, MkFeature z) = 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

@@ -5,29 +5,36 @@ License     : BSD3 Maintainer  : bsaul@novisci.com -}-+{-# OPTIONS_HADDOCK hide #-} {-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE ScopedTypeVariables #-}  module FeatureCompose.Aeson( ) where +import GHC.TypeLits                 ( KnownSymbol, symbolVal ) import IntervalAlgebra              ( Interval, Intervallic(end, begin) )-import FeatureCompose               ( Feature(..)+import FeatureCompose               ( Feature                                     , MissingReason-                                    , FeatureData(..) )+                                    , FeatureData+                                    , getFeatureData+                                    , getData ) import Data.Aeson                   ( object, KeyValue((.=)), ToJSON(toJSON) )+import Data.Proxy                   ( Proxy(Proxy) )  instance (ToJSON a, Ord a, Show a)=> ToJSON (Interval a) where     toJSON x = object ["begin" .= begin x, "end" .= end x] -instance ToJSON MissingReason +instance ToJSON MissingReason  instance (ToJSON d)=> ToJSON (FeatureData d) where-    toJSON  x = case getFeatureData x of +    toJSON  x = case getFeatureData x of       (Left l)  -> toJSON l       (Right r) -> toJSON r -instance (Show b, ToJSON b, ToJSON d) => ToJSON (Feature b d) where-    toJSON x = object [ "name"   .= getName x-                       , "attrs" .= toJSON (getAttr x)+instance (KnownSymbol n, ToJSON d) => ToJSON (Feature n d) where+    toJSON x = object [ --"name"   .= getName x+                         "name"  .= show (symbolVal (Proxy @n))+                      --  , "attrs" .= toJSON (getAttr x)                        , "data"  .= toJSON (getData x) ]

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

@@ -5,41 +5,54 @@ License     : BSD3 Maintainer  : bsaul@novisci.com -Provides functions used in defining 'Feature's.+Provides functions used in defining @'FeatureCompose.Feature'@ from +@'EventData.Event'@s. -}-+{-# OPTIONS_HADDOCK hide #-} {-# LANGUAGE NoImplicitPrelude #-}-{-# LANGUAGE FlexibleContexts #-}--- {-# LANGUAGE Safe #-}  module FeatureEvents(--    -- * Container predicates+    -- ** Container predicates       isNotEmpty     , atleastNofX-    , twoXOrOneY+    , anyGapsWithinAtLeastDuration+    , allGapsWithinLessThanDuration -    -- * Finding occurrences of concepts+    -- **  Finding occurrences of concepts     , nthConceptOccurrence     , firstConceptOccurrence -    -- * Reshaping containers+    -- ** Reshaping containers     , allPairs     , splitByConcepts -    -- * Create filters+    -- ** Create filters     , makeConceptsFilter     , makePairedFilter++    -- ** Functions for working with Event Domains+    , viewBirthYears+    , previewBirthYear++    -- ** Function for manipulating intervals+    , lookback+    , lookahead++    -- ** Misc functions+    , computeAgeAt ) where -import Data.Text                            ( Text )-import Control.Applicative                  ( Applicative(liftA2) )+ import IntervalAlgebra                      ( Intervallic(..)+                                            , IntervalSizeable(..)                                             , ComparativePredicateOf1                                             , ComparativePredicateOf2-                                            , Interval )+                                            , Interval+                                            , IntervalCombinable+                                            , beginerval+                                            , enderval ) import IntervalAlgebra.PairedInterval       ( PairedInterval, getPairData )--- import IntervalAlgebra.IntervalUtilities    ( compareIntervals )+import IntervalAlgebra.IntervalUtilities    ( durations, gapsWithin, gaps' ) import EventData                            ( Events                                             , Event                                             , ConceptEvent@@ -47,15 +60,33 @@ import EventData.Context                    ( Concept                                             , Concepts                                             , Context-                                            , HasConcept( hasConcepts ) )-import Safe                                 ( headMay, lastMay ) -import Data.Bool                       ( Bool, (&&), not, (||) )-import Data.Function                   ( (.), ($) )-import Data.Int                        ( Int )-import Data.List                       ( filter, length, null )-import Data.Maybe                      ( Maybe(..) )-import Data.Ord                        ( Ord((>=)) )-+                                            , 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 )+import GHC.Num                              ( Integer, fromInteger )+import GHC.Real                             ( RealFrac(floor), (/) )  -- | Is the input list empty?  isNotEmpty :: [a] -> Bool@@ -101,11 +132,6 @@    -> Events a -> Bool atleastNofX n x es = length (makeConceptsFilter x es) >= n --- | TODO-twoXOrOneY :: [Text] -> [Text] -> Events a -> Bool-twoXOrOneY x y es = atleastNofX 2 x es ||-                    atleastNofX 1 y es- -- | Takes a predicate of intervals and a predicate on the data part of a  --   paired interval to create a single predicate such that both input --   predicates should hold.@@ -117,7 +143,7 @@ makePairPredicate pi i pd x =  pi i x && pd (getPairData x)  -- | -makePairedFilter :: Ord a => +makePairedFilter :: Ord a =>        ComparativePredicateOf2 (i0 a) ((PairedInterval b) a)     -> i0 a     -> (b -> Bool)@@ -132,9 +158,90 @@ -- | 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] +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 ::+       ( Foldable t+       , Monoid (t (Interval a))+       , Applicative t+       , Filterable 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)+

@@ -5,36 +5,63 @@ Copyright   : (c) NoviSci, Inc 2020 License     : BSD3 Maintainer  : bsaul@novisci.com++See the examples folder and manual for further documentation. -}  module Hasklepias (       module EventData-    , module EventData.Aeson+    -- ** Event Contexts     , module EventData.Context+    -- ** Event Domains     , module EventData.Context.Domain+    -- ** Parsing Events+    , module EventData.Aeson+    -- ** Generating arbitrary events+    , module EventData.Arbitrary+         , module FeatureCompose-    , module FeatureCompose.Criteria+    -- ** Writing Features to JSON     , module FeatureCompose.Aeson++    -- * Utilities for defining Features from Events+    {- |+    Much of logic needed to define features from events depends on the +    [interval-algebra](https://hackage.haskell.org/package/interval-algebra) library.+    Its main functions and types are re-exported in Hasklepias, but the documentation+    can be found on [hackage](https://hackage.haskell.org/package/interval-algebra).++    -}     , module FeatureEvents-    , module Hasklepias.Reexports-    , module IntervalAlgebra-    , module IntervalAlgebra.IntervalUtilities-    , module IntervalAlgebra.PairedInterval+    +    -- * Specifying and building cohorts     , module Hasklepias.Cohort+    -- ** Writing Cohorts to JSON     , module Hasklepias.Aeson+    -- ** Creating an executable cohort application+    , module Hasklepias.MakeApp++    -- * Rexported Functions and modules+    , module Hasklepias.Reexports+    , module Hasklepias.ReexportsUnsafe ) where -import IntervalAlgebra-import IntervalAlgebra.IntervalUtilities-import IntervalAlgebra.PairedInterval import EventData import EventData.Aeson+import EventData.Arbitrary import EventData.Context import EventData.Context.Domain++import IntervalAlgebra+import IntervalAlgebra.IntervalUtilities+import IntervalAlgebra.PairedInterval+ import FeatureCompose import FeatureCompose.Aeson-import FeatureCompose.Criteria import FeatureEvents import Hasklepias.Reexports+import Hasklepias.ReexportsUnsafe import Hasklepias.Cohort+import Hasklepias.Cohort.Criteria import Hasklepias.Aeson+import Hasklepias.MakeApp

@@ -5,61 +5,93 @@ License     : BSD3 Maintainer  : bsaul@novisci.com -}+{-# OPTIONS_HADDOCK hide #-} {-# LANGUAGE NoImplicitPrelude #-}-{-# LANGUAGE FlexibleInstances, OverloadedStrings #-} {-# LANGUAGE UndecidableInstances #-}+{-# LANGUAGE TupleSections #-}  module Hasklepias.Aeson(-      parsePopulationIntLines+      parsePopulationLines+    , parsePopulationIntLines     , parsePopulationDayLines+    , ParseError(..) ) where -import IntervalAlgebra-import EventData-import EventData.Aeson -import Hasklepias.Cohort+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                              ( (<$>), (<*>), ($), fmap-                                            , Int, String, Ord, Show)-import Data.Either                          ( Either, rights )-import Data.List                            ( sort, (++) )+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.Vector                          ( (!) )+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                    ( 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 (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 ))+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.-parsePopulationLines :: -    (FromJSON a, Show a, IntervalSizeable a b) => -        B.ByteString -> Population (Events a)-parsePopulationLines l =-    mapIntoPop $ rights $ fmap -    (\x -> eitherDecode $ B.fromStrict x :: (FromJSON a, Show a, IntervalSizeable a b) => Either String (SubjectEvent a))-        (C.lines $ B.toStrict l)+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) -parsePopulationIntLines :: B.ByteString -> Population (Events Int)-parsePopulationIntLines = parsePopulationLines+-- |  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 -> Population (Events Day)-parsePopulationDayLines = parsePopulationLines+parsePopulationDayLines :: B.ByteString -> ([ParseError], Population (Events Day))+parsePopulationDayLines x = fmap mapIntoPop (parseSubjectLines x)

@@ -5,8 +5,12 @@ License     : BSD3 Maintainer  : bsaul@novisci.com -}+{-# OPTIONS_HADDOCK hide #-} {-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE TupleSections #-}+{-# LANGUAGE LambdaCase #-}+-- {-# LANGUAGE Safe #-}  module Hasklepias.Cohort(       Subject(..)@@ -14,16 +18,40 @@     , Population(..)     , ObsUnit(..)     , Cohort(..)+    , CohortSpec+    , AttritionInfo(..)+    , specifyCohort     , makeObsUnitFeatures-    , makeCohort+    , evalCohort++    -- ** Criteria+    , module Hasklepias.Cohort.Criteria++    -- ** Index+    , module Hasklepias.Cohort.Index ) where -import Prelude                  ( Eq, Show, Functor(..) )     -import Data.Aeson               ( FromJSON, ToJSON )        -import Data.Text                ( Text )-import GHC.Generics             ( Generic)+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) @@ -32,26 +60,99 @@  instance (FromJSON d) => FromJSON (Subject d) where -newtype Population d = MkPopulation [Subject d]+-- | A population is a list of @'Subject'@s+newtype Population d = MkPopulation  [Subject d]      deriving (Eq, Show, Generic) -instance (FromJSON d) => FromJSON (Population d) where- instance Functor Population where     fmap f (MkPopulation x) = MkPopulation (fmap (fmap f) x) +instance (FromJSON d) => FromJSON (Population d) where++-- | An observational unit is what a subject may be transformed into. newtype ObsUnit d = MkObsUnit (ID, d)     deriving (Eq, Show, Generic)  instance (ToJSON d) => ToJSON (ObsUnit d) where -newtype Cohort d = MkCohort [ObsUnit d]+-- | 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, [ObsUnit d])     deriving (Eq, Show, Generic)  instance (ToJSON d) => ToJSON (Cohort d) where -makeObsUnitFeatures :: (d1 -> d0) -> Subject d1 -> ObsUnit d0 +-- | 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) -makeCohort :: (d1 -> d0) -> Population d1 -> Cohort d0-makeCohort f (MkPopulation x) = MkCohort (fmap (makeObsUnitFeatures f) x)+-- | 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 b (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)++instance ToJSON CohortStatus where+instance ToJSON AttritionInfo where++-- | 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, [ObsUnit d0])+evalUnits spec pop =+    ( measureAttrition statuses+    , 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

@@ -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 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 FeatureCompose              ( 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

@@ -0,0 +1,36 @@+{-|+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 Safe #-}++module Hasklepias.Cohort.Index(+    Index+  , makeIndex+  , getIndex+) where++import safe GHC.Show                    ( Show )+import safe Data.Eq                     ( Eq )+import safe IntervalAlgebra             ( Intervallic )++{-|+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 (Intervallic i a) => Index i a = MkIndex { +    getIndex :: i a -- ^ Unwrap an @Index@+  } deriving (Eq, Show)++-- | Creates a new @'Index'@.+makeIndex :: Intervallic i a => i a -> Index i a+makeIndex = MkIndex++

@@ -0,0 +1,116 @@+{-# LANGUAGE BlockArguments #-}+{-|+Module      : Hasklepias.MakeApp+Description : Functions for creating a cohort application+Copyright   : (c) NoviSci, Inc 2020+License     : BSD3+Maintainer  : bsaul@novisci.com+-}+{-# OPTIONS_HADDOCK hide #-}+{-# LANGUAGE NoImplicitPrelude #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE DerivingStrategies #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE FlexibleContexts      #-}+{-# LANGUAGE FlexibleInstances     #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE DeriveDataTypeable #-}+module Hasklepias.MakeApp (+   makeCohortApp+) where++import Control.Monad                        ( Monad(return), Functor(fmap) )+import Control.Applicative                  ( Applicative )+import Data.Aeson                           ( encode, FromJSON, ToJSON(..) )+import Data.Bifunctor                       ( Bifunctor(second) )+import qualified Data.ByteString.Lazy as B+import Data.ByteString.Lazy.Char8 as C      ( putStrLn )+import Data.Function                        ( ($), (.) )+import Data.List                            ( (++) )+import Data.Monoid                          ( Monoid(mconcat) )+import Data.String                          ( String )+import Data.Text                            ( pack, Text )+import Data.Tuple                           ( fst, snd )+import GHC.Show                             ( Show(show) )+import GHC.IO                               ( IO )++import EventData                            ( Events )+import Hasklepias.Aeson                     ( parsePopulationLines, ParseError )+import Hasklepias.Cohort                    ( evalCohort, Cohort, CohortSpec )+import IntervalAlgebra                      ( IntervalSizeable )++import Control.Monad.IO.Class               (MonadIO, liftIO)+import Control.Monad.Reader                 (MonadReader (..), ReaderT (..))+import Colog                                ( Message+                                            , HasLog(..)+                                            , WithLog+                                            , LogAction(..)+                                            , richMessageAction+                                            , logInfo+                                            , logError+                                            , logStringStdout+                                            , logStringStderr+                                            , logText+                                            , withLog+                                            , logPrint+                                            , logPrintStderr +                                            , (<&)+                                            , (>$)+                                            , log )+import System.Console.CmdArgs               ( Data, Typeable+                                            , cmdArgs, summary, help, (&=) )+import System.Environment                   (getArgs)++-- a stub to add more arguments to later+data MakeCohort = MakeCohort deriving (Show, Data, Typeable)++makeAppArgs ::+     String  -- ^ name of the application+  -> String  -- ^ version of the application +  -> MakeCohort+makeAppArgs name version = MakeCohort+    {+    } &= help "Pass event data via stdin."+      &= summary (name ++ " " ++ version)++makeCohortBuilder :: (FromJSON a, Show a, IntervalSizeable a b, ToJSON d0, Monad m) =>+     [CohortSpec (Events a) d0]+  -> m (B.ByteString -> m ([ParseError], [Cohort d0]))+makeCohortBuilder specs =+  return (return . second (\pop -> fmap (`evalCohort` pop) specs) . parsePopulationLines)++-- logging based on example here:+-- https://github.com/kowainik/co-log/blob/main/co-log/tutorials/Main.hs+parseErrorL :: LogAction IO ParseError+parseErrorL = logPrintStderr++logParseErrors :: [ParseError] -> IO ()+logParseErrors x = mconcat $ fmap (parseErrorL <&) x++-- | Make a command line cohort building application.+makeCohortApp :: (FromJSON a, Show a, IntervalSizeable a b, ToJSON d0) =>+       String  -- ^ cohort name+    -> String  -- ^ app version+    -> [CohortSpec (Events a) d0]  -- ^ a list of cohort specifications+    -> IO ()+makeCohortApp name version spec =+    do+      args <- cmdArgs ( makeAppArgs name version )+      let logger = logStringStdout++      logger <& "Creating cohort builder..."+      app <- makeCohortBuilder spec++      logger <& "Reading data from stdin..."+      dat  <- B.getContents++      logger <& "Bulding cohort..."+      res <- app dat++      logParseErrors (fst res)++      logger <& "Encoding cohort(s) output and writing to stdout..."+      C.putStrLn (encode ( toJSON (snd res) ))++      logger <& "Cohort build complete!"+

@@ -15,6 +15,7 @@       module GHC.Num     , module GHC.Generics     , module GHC.Show+    , module GHC.TypeLits     , module Control.Monad     , module Control.Applicative     , module Data.Bool@@ -25,10 +26,16 @@     , module Data.Function     , module Data.Functor     , module Data.List+    , module Data.List.NonEmpty     , module Data.Ord     , module Data.Time.Calendar      , module Data.Text     , module Data.Tuple++    , module IntervalAlgebra+    , module IntervalAlgebra.IntervalUtilities+    , module IntervalAlgebra.PairedInterval+     , module Safe     , module Flow     , module Witherable@@ -37,6 +44,7 @@ import safe GHC.Num                         ( Integer ) import safe GHC.Generics                    ( Generic ) import safe GHC.Show                        ( Show(..) )+import safe GHC.TypeLits                    ( KnownSymbol ) import safe Control.Monad                   ( Functor(fmap), Monad(..) ) import safe Control.Applicative             ( (<$>), Applicative(..) ) import safe Data.Bool                       ( Bool(..)@@ -54,8 +62,11 @@                                             , length                                             , null                                             , zipWith+                                            , replicate+                                            , transpose                                             , sort                                             , (++) )+import safe Data.List.NonEmpty              ( NonEmpty(..) ) import safe Data.Maybe                      ( Maybe(..),                                               maybe,                                               isJust,@@ -69,10 +80,18 @@ import safe Data.Ord                        ( Ord((>=), (<), (>), (<=))                                             , max, min ) import safe Data.Time.Calendar              ( Day, MonthOfYear, Year+                                            , CalendarDiffDays(..)+                                            , addGregorianDurationClip                                             , fromGregorian+                                            , gregorianMonthLength                                             , diffDays ) import safe Data.Text                       ( pack, Text ) import safe Data.Tuple                      ( fst, snd, uncurry, curry )++import safe IntervalAlgebra+import safe IntervalAlgebra.IntervalUtilities+import safe IntervalAlgebra.PairedInterval+ import safe Witherable                      ( Filterable(filter) ) import safe Flow                            ( (!>), (.>), (<!), (<.), (<|), (|>) ) import Safe                                 ( headMay, lastMay )

@@ -0,0 +1,23 @@+{-|+Module      : Hasklepias Types+Description : Re-exports functions from other libraries needed for using+              Hasklepias as a standalone import.+Copyright   : (c) NoviSci, Inc 2020+License     : BSD3+Maintainer  : bsaul@novisci.com+-}+++module Hasklepias.ReexportsUnsafe (++    -- * Re-exports+      module GHC.IO+    , module Test.Tasty+    , module Test.Tasty.HUnit+) where++import GHC.IO            ( IO(..) )++-- import GHC.Types                       ( Any )+import Test.Tasty hiding (after)+import Test.Tasty.HUnit 

@@ -18,7 +18,7 @@           \{\"domain\":\"Diagnosis\",\"time\":{\"begin\":0,\"end\":1}}]"  testInputsInt :: B.ByteString-testInputsInt = +testInputsInt =       "[\"abc\", 0, 1, \"Diagnosis\",\       \[\"someThing\"],\       \{\"domain\":\"Diagnosis\",\"time\":{\"begin\":0,\"end\":1}}]\n\@@ -40,7 +40,7 @@   testInputsDay :: B.ByteString-testInputsDay = +testInputsDay =       "[\"abc\", \"2020-01-01\", \"2020-01-02\", \"Diagnosis\",\       \[\"someThing\"],\       \{\"domain\":\"Diagnosis\",\@@ -51,7 +51,7 @@       \ \"time\":{\"begin\":\"2020-01-05\",\"end\":\"2020-01-06\"}}]"  testInputsDay2 :: B.ByteString-testInputsDay2 = +testInputsDay2 =       "[\"abc\", \"2020-01-01\", null, \"Diagnosis\",\       \[\"someThing\"],\       \{\"domain\":\"Diagnosis\",\@@ -61,13 +61,13 @@       \{\"domain\":\"Diagnosis\",\       \ \"time\":{\"begin\":\"2020-01-05\",\"end\":\"2020-01-06\"}}]" -testOutInt1 = event (beginerval 1 (0 :: Int)) (HC.context ( Just $ UnimplementedDomain () ) (packConcepts ["someThing"]))-testOutInt2 = event (beginerval 1 (5 :: Int)) (HC.context ( Just $ UnimplementedDomain () ) (packConcepts ["someThing"]))+testOutInt1 = event (beginerval 1 (0 :: Int)) (HC.context ( UnimplementedDomain () ) (packConcepts ["someThing"]))+testOutInt2 = event (beginerval 1 (5 :: Int)) (HC.context ( UnimplementedDomain () ) (packConcepts ["someThing"]))  testOutDay1 = event (beginerval 1 (fromGregorian 2020 1 1))-                     (HC.context ( Just $ UnimplementedDomain () ) (packConcepts ["someThing"]))-testOutDay2 = event (beginerval 1 (fromGregorian 2020 1 5)) -               (HC.context ( Just $ UnimplementedDomain () ) (packConcepts [ "someThing"]))+                     (HC.context (UnimplementedDomain () ) (packConcepts ["someThing"]))+testOutDay2 = event (beginerval 1 (fromGregorian 2020 1 5))+               (HC.context (  UnimplementedDomain () ) (packConcepts [ "someThing"]))   dmo :: Domain@@ -79,19 +79,19 @@ jsonOtherTest :: B.ByteString jsonOtherTest = "{\"domain\":\"Labs\",\"facts\":{\"code\":{\"code\":\"XYZ\"}}}" -spec :: Spec -spec = do -    it "an Int event is parsed correctly" $ -       ( decode testInInt )  `shouldBe` (Just testOutInt1)+spec :: Spec+spec = do+    it "an Int event is parsed correctly" $+       decode testInInt  `shouldBe` Just testOutInt1     it "lines of Int events are parsed correctly" $-       (parseEventIntLines testInputsInt) `shouldBe` [testOutInt1, testOutInt2]+       parseEventIntLines testInputsInt `shouldBe` ([], [testOutInt1, testOutInt2]) -    it "a Day event is parsed correctly" $ -       ( decode testInDay )  `shouldBe` (Just testOutDay1)-    it "a Day event with missing end day is parsed correctly" $ -       ( decode testInDay2 )  `shouldBe` (Just testOutDay1)+    it "a Day event is parsed correctly" $+       decode testInDay  `shouldBe` Just testOutDay1+    it "a Day event with missing end day is parsed correctly" $+       decode testInDay2  `shouldBe` Just testOutDay1     it "lines of Int events are parsed correctly" $-       (parseEventDayLines testInputsDay) `shouldBe` [testOutDay1, testOutDay2]+       parseEventDayLines testInputsDay `shouldBe` ([], [testOutDay1, testOutDay2])     it "jsonDemoTest is parsed correctly" $        decode jsonDemoTest  `shouldBe` Just dmo     it "jsonOtherTest is parsed correctly" $

@@ -5,12 +5,13 @@ import Test.Hspec ( shouldBe, it, Spec ) import Data.Maybe (Maybe(Nothing)) import Data.Set(fromList)+import EventData.Context.Domain  ctxt1 :: Context-ctxt1 = HC.context Nothing (packConcepts  ["c1", "c2"])+ctxt1 = HC.context (UnimplementedDomain ()) (packConcepts  ["c1", "c2"])  ctxt2 :: Context-ctxt2 = HC.context Nothing (packConcepts ["c2", "c3"])+ctxt2 = HC.context (UnimplementedDomain ())  (packConcepts ["c2", "c3"])  spec :: Spec spec = do@@ -24,6 +25,3 @@       (ctxt1 `hasConcepts` ["c3", "c1"]) `shouldBe` True     it "hasConcepts returns False when no concept is in context" $       (ctxt1 `hasConcepts` ["c3", "c4"]) `shouldBe` False--    it "<> combines contexts" $-      (ctxt1 <> ctxt2) `shouldBe` HC.context Nothing (packConcepts ["c1", "c2", "c3"])

@@ -6,15 +6,17 @@ import FeatureEvents  import EventData import EventData.Context as HC+import EventData.Context.Domain ( Domain(UnimplementedDomain) ) import Data.Maybe import Test.Hspec ( it, shouldBe, Spec ) + evnt1 :: Event Int evnt1 = event ( beginerval 4 (1 :: Int))-              (HC.context Nothing (packConcepts ["c1", "c2"] ))+              (HC.context (UnimplementedDomain ()) (packConcepts ["c1", "c2"] )) evnt2 :: Event Int evnt2 = event ( beginerval 4 (2 :: Int)  )-              (HC.context Nothing (packConcepts ["c3", "c4"] ))+              (HC.context (UnimplementedDomain ())  (packConcepts ["c3", "c4"] )) evnts :: [Event Int] evnts = [evnt1, evnt2] 

@@ -13,10 +13,11 @@ import Data.Time as DT import Test.Hspec ( shouldBe, it, Spec ) import qualified Data.ByteString.Lazy as B+import EventData.Context.Domain   ex1 :: Events Int-ex1 = [event (beginerval 10 0) (context Nothing (packConcepts ["enrollment"]))]+ex1 = [event (beginerval 10 0) (context (UnimplementedDomain ()) (packConcepts ["enrollment"]))]  index:: (Ord a) =>      Events a@@ -30,6 +31,6 @@ spec :: Spec spec = do     it "an Int event is parsed correctly" $-       encode (index ex1)  `shouldBe` "[{\"end\":10,\"begin\":0}]"+       encode (index ex1)  `shouldBe` "{\"end\":10,\"begin\":0}"  

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

@@ -1,63 +1,133 @@ {-# LANGUAGE OverloadedStrings #-}--module FeatureComposeSpec (spec) where+{-# LANGUAGE DataKinds #-}+module FeatureComposeSpec (+ spec+) where  import FeatureCompose-import Control.Applicative import Test.Hspec ( describe, pending, shouldBe, it, Spec )-import Data.Foldable -d1 :: FeatureDefinition (FeatureData Int) Int-d1 = defineM++-----------------------------------+-- example :: Feature "test" ()+-- example = MkFeature $ pure ()++-- d0 :: Definition (FeatureData Int)+-- d0 = define 5++d1 :: Definition (FeatureData Int -> FeatureData Int)+d1 = defineA   (\x ->     if x < 0 then-      featureDataL $ Other "at least 1 < 0"+      missingBecause $ Other "at least 1 < 0"     else       pure (x + 1)    ) -d2 :: FeatureDefinition (FeatureData Int) Int+d2 :: Definition (FeatureData Int -> FeatureData Int) d2 = define (*2) -d3 ::  FeatureDefinition (FeatureData Int, FeatureData Int) Int-d3 = define2 (+) +d3 ::  Definition (FeatureData Int -> FeatureData Int -> FeatureData Int)+d3 = define (+)++f1 :: Int -> Int+f1 = (+2)++f1D :: Definition (FeatureData Int -> FeatureData Int)+f1D = define f1++f1F :: Definition (Feature "someInt" Int -> Feature "anotherInt" Int)+f1F = define f1++f2 :: Bool -> FeatureData Int+f2 True = pure 1+f2 False = missingBecause $ Other "test"++f2D :: Definition (FeatureData Bool -> FeatureData Int)+f2D = defineA f2++f2' :: Bool -> Feature "someInt" Int+f2' True = pure 1+f2' False = makeFeature $ missingBecause $ Other "test"++f2F :: Definition (Feature "someBool" Bool -> Feature "someInt" Int)+f2F = defineA f2'++f3 :: Bool -> Int -> String+f3 True 1 = "this"+f3 False 9 = "that"+f3 _ _ = "otherwise"++f3D :: Definition (FeatureData Bool -> FeatureData Int -> FeatureData String)+f3D = define f3++f3F :: Definition (Feature "myBool" Bool -> Feature "someInt" Int -> Feature "myString" String)+f3F = define f3++ spec :: Spec spec = do    describe "checking d1" $     do--      it "eval of d1 returns correct values for List" $-        eval d1 (featureDataR [5, 6, 7]) `shouldBe`-          featureDataR [6, 7, 8]-      it "d1 returns correct error for List" $-        eval d1 (featureDataR [-1, 5, 6]) `shouldBe`-          (featureDataL (Other "at least 1 < 0") :: (FeatureData Int))+      it "eval of d1 on d0" $+        eval d1 (pure 5) `shouldBe` featureDataR  6+      it "eval of d1 returns correct value" $+        eval d1 (featureDataR 5 ) `shouldBe`+          featureDataR 6+      it "d1 returns correct error" $+        eval d1 (featureDataR (-1)) `shouldBe`+          missingBecause (Other "at least 1 < 0")    describe "checking d2" $     do-      it "eval of d2 returns correct values for List" $-        eval d2 (featureDataR [5]) `shouldBe`-          featureDataR [10]-      it "eval of d2 returns correct values for List" $-        eval d2 (featureDataR [5, 6, 7]) `shouldBe`-          featureDataR [10, 12, 14]-      it "d2 returns correct error for List" $-        eval d2 (featureDataL (Other "at least 1 < 0")) `shouldBe`-          (featureDataL (Other "at least 1 < 0") :: (FeatureData Int))+      it "eval of d2 returns correct value" $+        eval d2 (featureDataR 5) `shouldBe`+          featureDataR 10+      it "eval of d2 returns correct value" $+        eval d2 (featureDataR 5) `shouldBe`+          featureDataR 10+      it "d2 returns correct error" $+        eval d2 (featureDataL (Other "at least 1 < 0") ) `shouldBe`+          featureDataL (Other "at least 1 < 0")    describe "checking d3" $     do-      it "eval of d2 returns correct values for List" $-        eval d3 (featureDataR [5], featureDataR [6])  `shouldBe`-          featureDataR [11]-      it "eval of d3 returns correct values for List" $-        eval d3 (featureDataR [5, 6, 7], featureDataR [5, 6, 7]) `shouldBe`-          featureDataR [10, 12, 14]-      it "d3 returns correct error for List" $-        eval d3 (featureDataL (Other "at least 1 < 0"), featureDataR [6])  `shouldBe`-          (featureDataL (Other "at least 1 < 0") :: (FeatureData Int))-      it "d3 returns correct error for List" $-        eval d3 (featureDataR [6], featureDataL (Other "at least 1 < 0")) `shouldBe`-          (featureDataL (Other "at least 1 < 0") :: (FeatureData Int))+      it "eval of d2 returns correct values" $+        eval d3 (featureDataR 5, featureDataR 6)  `shouldBe`+          featureDataR 11+      it "eval of d3 returns correct values" $+        eval d3 (featureDataR 5, featureDataR 5) `shouldBe`+          featureDataR 10+      it "d3 returns correct error" $+        eval d3 (featureDataL (Other "at least 1 < 0"), featureDataR 6)  `shouldBe`+          featureDataL (Other "at least 1 < 0")+      it "d3 returns correct error" $+        eval d3 (featureDataR 6, featureDataL (Other "at least 1 < 0")) `shouldBe`+          featureDataL (Other "at least 1 < 0")++  describe "checking f1" $+    do+      it "eval of f1F on d0 returns correct value" $+        eval f1F (pure 5) `shouldBe` pure 7++  describe "checking f2" $+    do+      it "eval of f2D on d0 returns correct value" $+        eval f2D (pure True) `shouldBe` pure 1+      it "eval of f1F on d0 returns correct value" $+        eval f2D (pure False) `shouldBe` missingBecause (Other "test")+      it "eval of f1F on d0 returns correct value" $+        eval f2F (pure False) `shouldBe` makeFeature (missingBecause (Other "test"))++  describe "checking f3" $+    do+      it "eval of f3D returns correct value" $+        eval f3D (pure True, pure 1) `shouldBe` pure "this"+      it "eval of f3D returns correct value" $+        eval f3D (pure True, pure 9) `shouldBe` pure "otherwise"+      it "eval of f3F returns correct value" $+        eval f3F (pure True, eval f2F (pure False)) `shouldBe` makeFeature (missingBecause (Other "test"))+      it "eval of f3F  returns correct value" $+        eval f3F (pure True, eval f2F (pure True)) `shouldBe` pure "this"

@@ -8,16 +8,17 @@ 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 Nothing (packConcepts ["c1", "c2"] ))+        ( HC.context (UnimplementedDomain ()) (packConcepts ["c1", "c2"] )) evnt2 :: Event Int evnt2 = event ( beginerval (4 :: Int) (2 :: Int) )-         ( HC.context Nothing (packConcepts ["c3", "c4"] ))+         ( HC.context (UnimplementedDomain ())  (packConcepts ["c3", "c4"] )) evnts :: [Event Int] evnts = [evnt1, evnt2] 

@@ -16,7 +16,7 @@   testInputsDay1 :: B.ByteString-testInputsDay1 = +testInputsDay1 =       "[\"abc\", \"2020-01-01\", \"2020-01-02\", \"Diagnosis\",\       \[\"someThing\"],\       \{\"domain\":\"Diagnosis\",\@@ -28,7 +28,7 @@   testInputsDay2 :: B.ByteString-testInputsDay2 = +testInputsDay2 =       "[\"def\", \"2020-01-01\", null, \"Diagnosis\",\       \[\"someThing\"],\       \{\"domain\":\"Diagnosis\",\@@ -38,12 +38,23 @@       \{\"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 ( Just $ UnimplementedDomain () ) (packConcepts ["someThing"]))-testOutDay2 = event (beginerval 1 (fromGregorian 2020 1 5)) -               (HC.context ( Just $ UnimplementedDomain () ) (packConcepts [ "someThing"]))+               (HC.context ( UnimplementedDomain () ) (packConcepts ["someThing"]))+testOutDay2 = event (beginerval 1 (fromGregorian 2020 1 5))+               (HC.context ( UnimplementedDomain () ) (packConcepts [ "someThing"]))   testOutPop = MkPopulation [@@ -51,8 +62,12 @@         , MkSubject ("def", [testOutDay1, testOutDay2])       ] -spec :: Spec -spec = do -    it "a population is parsed" $ -       ( parsePopulationDayLines testInput ) `shouldBe` (testOutPop)+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)

@@ -0,0 +1,48 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE DataKinds #-}+module Hasklepias.Cohort.CriteriaSpec (+  spec+ ) where++import FeatureCompose+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")

@@ -0,0 +1,71 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE DataKinds #-}++module Hasklepias.CohortSpec (+  spec+ ) where++import FeatureCompose+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) ]+  , [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+

@@ -1,2 +1,1 @@ {-# OPTIONS_GHC -F -pgmF hspec-discover #-}-