packages feed

hasklepias 0.16.1 → 0.17.0

raw patch · 46 files changed

+3174/−1601 lines, 46 filesdep +contravariantdep +tupledep ~interval-algebra

Dependencies added: contravariant, tuple

Dependency ranges changed: interval-algebra

Files

ChangeLog.md view
@@ -1,5 +1,29 @@ # Changelog for hasklepias +## 0.17.0++* Adds the `Cohort.AssessmentIntervals` modules, which provides types and safe constructors for intervals during which features can be evaluated. The module currently provides the `BaselineInterval` type, with constructors `baseline` and `baselineBefore`. These two constructors guarantee that the resulting `BaselineInterval` will `meet` or `precede` (respectively) the provided `Index`. Use `baseline` if you want a `BaselineInterval` that ends at the beginning of the `Index`; use `baselineBefore` if you need space between the end of the baseline interval and `Index`. Similarly, there is a `FollowupInterval` type, with constructors `followup`, `followupMetBy`, and `followupAfter`. Note that the `followup` function always returns a `FollowupInterval` such that `end index < end (followup duration index)` for any provided `duration`. The `baseline` and `followup` functions were not named with their associated relation to `Index` (meets and startedBy, resp.), since they are most likely the most common use case. The `AssessmentInterval` type is a sum type with (currently) two variants: one containing a `BaselineInterval` and the other a `FollowupInterval`. The following functions create `AssesmentmentIntervals` using the corresponding function:+  * `makeBaselineFromIndex`: `baseline`+  * `makeBaselineBeforeIndex`: `baselineBefore`+  * `makeFollowupFromIndex`: `followup`+  * `makeFollowupMetByIndex`: `followupMetBy`+  * `makeFollowupAfterIndex`: `followupAfter`+* Modifies the continuous enrollment template to take a function `Index i a -> AssessmentInterval a` as an argument to enforce that functions that create valid assessment interval are used. Updates `ExampleCohort1` accordingly.+* Updates `interval-algebra` dependency to 0.10.2, and updates functions as needed.+* Adds the `EventData.Predicate` module which exposes `Predicate`s on `Event`s. For example, `isEnrollmentEvent` has the type `Predicate (Event a)` (so `getPredicate isEnrollmentEvent :: (Event a -> Bool)`). This module also includes two utilities for composing `Predicate`s: `(&&&)` and `(|||)` for conjunction and disjunction respectively. For example, running `isEnrollmentEvent ||| isBirthYearEvent` would return `True` if an event either has the Enrollment domain or has the Demographic domain with BirthYear as its field. You can also form Predicates on the interval part of an Event. Something like `Predicate (\x -> before index x) &&& isBirthYearEvent` is a predicate that returns `True` when an event is before `index` and the event contains a `BirthYear` fact+* Adds the `EventData.Accessors` module and moves functions such as `viewBirthYears` from `Hasklepias.FeatureEvents` to this new module.+* Adds an initial framework for feature definition builders (i.e templates for functions that define features). These are found in the `Hasklepias.Templates.Features` module. Adds a basic set of builders including:+  * `buildIsEnrolled`: identifies whether there is an event concurring with index+  * `buildContinuousEnrollment`: identifies whether a set of events meets continuous enrollment criteria given an allowable gap between enrollment intervals+  * `buildNofX`: a template that finds whether there are N events of some predicate X+  * `buildNofXBool`: `buildNofX` specialized to return `Bool`+  * `buildNofXBinary`: `buildNofX` specialized to return `Binary`+  * and several more++## 0.16.2++* Reexports `ToJSON` typeclass so users can export data as needed.+ ## 0.16.1  * Updates `FromJSON` instance for `Domain`, so that a JSON event with `"domain" = "Enrollment"` is deserialized into `Event` whose `Domain` is `Enrollment`.
exampleApp/Main.hs view
@@ -16,10 +16,10 @@ {-# LANGUAGE DataKinds #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE MultiParamTypeClasses #-}-module Main(-  main-) where-import Hasklepias+module Main+  ( main+  ) where+import           Hasklepias  {-------------------------------------------------------------------------------   Features used by inclusion/exclusion (and possibly other places too)@@ -30,22 +30,19 @@ featureEvents = pure  -- | Lift a subject's events in a feature-featureDummy :: Definition-   ( Feature "allEvents" (Events Day)-   -> Feature "dummy" Count)+featureDummy+  :: Definition (Feature "allEvents" (Events Day) -> Feature "dummy" Count) featureDummy = define $ pure 5  -- | Lift a subject's events in a feature-anotherDummy :: Bool -  -> Definition-   ( Feature "allEvents" (Events Day)-   -> Feature "another" Bool)+anotherDummy+  :: Bool+  -> Definition (Feature "allEvents" (Events Day) -> Feature "another" Bool) anotherDummy x = define $ const x  -- | Include the subject if she has an enrollment interval concurring with index.-critTrue :: Definition-   ( Feature "allEvents" (Events Day)-   -> Feature "dummy" Status)+critTrue+  :: Definition (Feature "allEvents" (Events Day) -> Feature "dummy" Status) critTrue = define $ pure Include  instance HasAttributes "dummy" Count where@@ -59,19 +56,18 @@  -- | 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+makeCriteriaRunner events = criteria $ pure (criterion crit1)+ where+  crit1   = eval critTrue featEvs+  featEvs = featureEvents events  -- | Make a function that runs the features for a calendar index-makeFeatureRunner ::-       Events Day-    -> Featureset-makeFeatureRunner events = featureset -    ( packFeature ( eval featureDummy ef ) :|-      [packFeature ( eval (anotherDummy True ) ef)])-    where ef  = featureEvents events+makeFeatureRunner :: Events Day -> Featureset+makeFeatureRunner events = featureset+  (  packFeature (eval featureDummy ef)+  :| [packFeature (eval (anotherDummy True) ef)]+  )+  where ef = featureEvents events  -- | Make a cohort specification for each calendar time cohortSpecs :: [CohortSpec (Events Day) Featureset]
examples/ExampleCohort1.hs view
@@ -13,17 +13,17 @@ {-# LANGUAGE LambdaCase #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-}-module ExampleCohort1(-  exampleCohort1tests-) where-import Hasklepias+module ExampleCohort1+  ( exampleCohort1tests+  ) where+import           Hasklepias {-------------------------------------------------------------------------------   Constants -------------------------------------------------------------------------------}  -- | Lookback duration for baseline-baselineLookback :: Integer-baselineLookback = 455+lookback455 :: Integer+lookback455 = 455  -- | Duration of follow up in months followupDuration :: CalendarDiffDays@@ -31,26 +31,29 @@  -- | 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])+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 = lookback baselineLookback+baselineInterval :: Index Interval Day -> AssessmentInterval Day+baselineInterval = makeBaselineFromIndex lookback455  -- | Shifts an interval by a calendar amount-shiftIntervalDay :: (Intervallic i Day) => CalendarDiffDays -> i Day -> Interval Day-shiftIntervalDay cd i = beginerval (duration i) (addGregorianDurationClip cd (begin i))+shiftIntervalDay+  :: (Intervallic i Day) => CalendarDiffDays -> i 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 (begin index) (end $ shiftIntervalDay followupDuration index)) (begin index)+followupInterval index = beginerval+  (diff (begin index) (end $ shiftIntervalDay followupDuration index))+  (begin index)   -- | A predicate function that determines if some interval is before index@@ -58,7 +61,7 @@ beforeIndex = before  -- | Creates a filter for events to those that 'concur' with the baseline interval.-getBaselineConcur ::  Index Interval Day -> Events Day -> [Event Day]+getBaselineConcur :: Index Interval Day -> Events Day -> [Event Day] getBaselineConcur index = filterConcur (baselineInterval index)  {-------------------------------------------------------------------------------@@ -69,49 +72,52 @@ --   * at least 1 event during the baseline interval has any of the 'cpts1' concepts --   * there are at least 2 event that have 'cpts2' concepts which have at least --     7 days between them during the baseline interval-twoOutOneIn ::-       [Text] -- ^ cpts1-    -> [Text] -- ^ cpts2-    -> 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))--    )+twoOutOneIn+  :: [Text] -- ^ cpts1+  -> [Text] -- ^ cpts2+  -> 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]+medHx+  :: [Text]   -> Definition- ( Feature "calendarIndex" (Index Interval Day)-  -> Feature "allEvents" (Events Day)-  -> Feature name Bool )+       (  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-                |> relationsL-                |> filter (== Equals)-                |> not . null)-    )+  (\index events ->+    (  events+      |> getBaselineConcur index+      |> makeConceptsFilter cpt+      |> combineIntervals+      |> durations+      |> any (>= 90)+      )+      || (  events+         |> getBaselineConcur index+         |> relationsL+         |> filter (== Equals)+         |> not+         .  null+         )+  )   {-------------------------------------------------------------------------------@@ -123,153 +129,140 @@ featureEvents = pure  -- | Lift a calendar index into a feature-featureIndex :: Index Interval Day -> Feature "calendarIndex"  (Index Interval Day)+featureIndex+  :: Index Interval Day -> Feature "calendarIndex" (Index Interval Day) featureIndex = pure  -- | 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+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 index) )+      |> fmap (\y -> fromGregorian y 1 7)  -- Use July 1 YEAR as birthdate+      |> fmap (\bday -> computeAgeAt bday (begin index))       |> \case-            Nothing -> makeFeature $ featureDataL $ Other "No numeric birth year found"-            Just age -> pure age-    )+           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-    )+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-      )+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 :: 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 "allEvents" [Event Day]-   -> Feature "isEnrolled" Status )-critEnrolled = defIsEnrolled+critEnrolled+  :: Definition+       (  Feature "calendarIndex" (Index Interval Day)+       -> Feature "allEvents" [Event Day]+       -> Feature "isEnrolled" Status+       )+critEnrolled = buildIsEnrolled isEnrollmentEvent  -- | 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 "allEvents" [Event Day]-   -> Feature "isEnrolled" Status-   -> Feature "isContinuousEnrolled" Status )-critEnrolled455 = defContinuousEnrollment baselineInterval 30+critEnrolled455+  :: Definition+       (  Feature "calendarIndex" (Index Interval Day)+       -> Feature "allEvents" [Event Day]+       -> Feature "isEnrolled" Status+       -> Feature "isContinuousEnrolled" Status+       )+critEnrolled455 = buildContinuousEnrollment baselineInterval isEnrollmentEvent 30  -- | 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+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)+type BoolFeatDef n+  = Definition+      (  Feature "calendarIndex" (Index Interval Day)       -> Feature "allEvents" (Events Day)       -> Feature n Bool-    )+      ) -type BoolFeat n = Feature n  Bool+type BoolFeat n = Feature n Bool  diabetes :: BoolFeatDef "diabetes" diabetes = twoOutOneIn ["is_diabetes_outpatient"] ["is_diabetes_inpatient"]  instance HasAttributes  "diabetes" Bool where-  getAttributes _ = basicAttributes-    "Has Diabetes"-    "Has Diabetes within baseline"-    [Covariate]-    ["baseline"]+  getAttributes _ = basicAttributes "Has Diabetes"+                                    "Has Diabetes within baseline"+                                    [Covariate]+                                    ["baseline"]   ckd :: BoolFeatDef "ckd"-ckd =  twoOutOneIn ["is_ckd_outpatient"] ["is_ckd_inpatient"]+ckd = twoOutOneIn ["is_ckd_outpatient"] ["is_ckd_inpatient"]  instance HasAttributes  "ckd" Bool where-  getAttributes _ = basicAttributes-    "Has ckd"-    "Has CKD within baseline"-    [Covariate]-    ["baseline"]+  getAttributes _ =+    basicAttributes "Has ckd" "Has CKD within baseline" [Covariate] ["baseline"]  ppi :: BoolFeatDef "ppi" ppi = medHx ["is_ppi"]  instance HasAttributes  "ppi" Bool where-  getAttributes _ = basicAttributes-    "Has ppi"-    "Has PPI within baseline"-    [Covariate]-    ["baseline"]+  getAttributes _ =+    basicAttributes "Has ppi" "Has PPI within baseline" [Covariate] ["baseline"]  glucocorticoids :: BoolFeatDef "glucocorticoids" glucocorticoids = medHx ["is_glucocorticoids"]  instance HasAttributes  "glucocorticoids" Bool where-  getAttributes _ = basicAttributes-    "Has glucocorticoids"-    "Has glucocorticoids within baseline"-    [Covariate]-    ["baseline"]+  getAttributes _ = basicAttributes "Has glucocorticoids"+                                    "Has glucocorticoids within baseline"+                                    [Covariate]+                                    ["baseline"]  {-------------------------------------------------------------------------------   Cohort Specifications and evaluation@@ -278,42 +271,39 @@ -- | 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, featEvs)-        crit4   = eval critEnrolled455 (featInd, featEvs, crit3)-        crit5   = eval critDead (featInd, dead)-        agefeat = eval age (featInd, featEvs)-        dead    = eval deathDay featEvs-        featInd = featureIndex index-        featEvs = featureEvents events+  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, featEvs)+  crit4   = eval critEnrolled455 (featInd, featEvs, crit3)+  crit5   = eval critDead (featInd, dead)+  agefeat = eval age (featInd, featEvs)+  dead    = eval deathDay featEvs+  featInd = featureIndex index+  featEvs = featureEvents events  -- | Make a function that runs the features for a calendar index-makeFeatureRunner ::-       Index Interval Day-    -> Events Day-    -> Featureset+makeFeatureRunner :: Index Interval Day -> Events Day -> Featureset makeFeatureRunner index events = featureset-    (packFeature idx :|-    [ packFeature $ eval diabetes (idx,  ef)-    , packFeature $ eval ckd (idx,  ef)-    , packFeature $ eval ppi (idx,  ef)-    , packFeature $ eval glucocorticoids (idx, ef)-    ])-    where idx = featureIndex index-          ef  = featureEvents events+  (  packFeature idx+  :| [ packFeature $ eval diabetes (idx, ef)+     , packFeature $ eval ckd (idx, ef)+     , packFeature $ eval ppi (idx, ef)+     , packFeature $ eval glucocorticoids (idx, ef)+     ]+  )+ where+  idx = featureIndex index+  ef  = featureEvents events  -- | Make a cohort specification for each calendar time cohortSpecs :: [CohortSpec (Events Day) Featureset] cohortSpecs =-  map (\x -> specifyCohort (makeCriteriaRunner x) (makeFeatureRunner x))-  indices+  map (\x -> specifyCohort (makeCriteriaRunner x) (makeFeatureRunner x)) indices  -- | A function that evaluates all the calendar cohorts for a population evalCohorts :: Population (Events Day) -> [Cohort Featureset]@@ -324,30 +314,57 @@   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))+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"] (Enrollment (EnrollmentFacts ()))-    , m 2018 1 1 30  ["enrollment"] (Enrollment (EnrollmentFacts ()))-    , m 2018 2 1 30  ["enrollment"] (Enrollment (EnrollmentFacts ()))-    , m 2017 6 5 1   ["is_diabetes_inpatient"] (UnimplementedDomain ())-    , m 2017 8 1 91  ["is_ppi"] (UnimplementedDomain ())-    ]+  [ 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"]            (Enrollment (EnrollmentFacts ()))+  , m 2018 1 1 30  ["enrollment"]            (Enrollment (EnrollmentFacts ()))+  , m 2018 2 1 30  ["enrollment"]            (Enrollment (EnrollmentFacts ()))+  , 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"] (Enrollment (EnrollmentFacts ()))-    , m 2018 1 1 30  ["enrollment"] (Enrollment (EnrollmentFacts ()))-    , m 2018 2 1 30  ["enrollment"] (Enrollment (EnrollmentFacts ()))-    ]+  [ 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"] (Enrollment (EnrollmentFacts ()))+  , m 2018 1 1 30  ["enrollment"] (Enrollment (EnrollmentFacts ()))+  , m 2018 2 1 30  ["enrollment"] (Enrollment (EnrollmentFacts ()))+  ]  testSubject2 :: Subject (Events Day) testSubject2 = MkSubject ("b", testData2)@@ -355,64 +372,83 @@ testPop :: Population (Events Day) testPop = MkPopulation [testSubject1, testSubject2] -makeExpectedCovariate :: (KnownSymbol name) => FeatureData Bool -> Feature name  Bool+makeExpectedCovariate+  :: (KnownSymbol name) => FeatureData Bool -> Feature name Bool makeExpectedCovariate = makeFeature  instance HasAttributes "calendarIndex" (Index Interval Day) where -makeExpectedFeatures ::-  FeatureData (Index Interval Day)+makeExpectedFeatures+  :: FeatureData (Index Interval Day)   -> (FeatureData Bool, FeatureData Bool, FeatureData Bool, FeatureData Bool)   -> Featureset-makeExpectedFeatures i (b1, b2, b3, b4) =-        featureset-        ( packFeature (makeFeature  i :: Feature "calendarIndex"  (Index Interval Day)) :|-        [ packFeature ( makeExpectedCovariate b1 :: Feature "diabetes"  Bool )-        , packFeature ( makeExpectedCovariate b2 :: Feature "ckd"  Bool )-        , packFeature ( makeExpectedCovariate b3 :: Feature "ppi"  Bool )-        , packFeature ( makeExpectedCovariate b4 :: Feature "glucocorticoids"  Bool )-        ])+makeExpectedFeatures i (b1, b2, b3, b4) = featureset+  (  packFeature (makeFeature i :: Feature "calendarIndex" (Index Interval Day))+  :| [ packFeature (makeExpectedCovariate b1 :: Feature "diabetes" Bool)+     , packFeature (makeExpectedCovariate b2 :: Feature "ckd" Bool)+     , packFeature (makeExpectedCovariate b3 :: Feature "ppi" Bool)+     , packFeature+       (makeExpectedCovariate b4 :: Feature "glucocorticoids" Bool)+     ]+  )  expectedFeatures1 :: [Featureset]-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))-    ]+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 Featureset] expectedObsUnita = zipWith MkObsUnit (replicate 5 "a") expectedFeatures1 -makeExpectedCohort :: AttritionInfo -> [ObsUnit Featureset] -> Cohort Featureset+makeExpectedCohort+  :: AttritionInfo -> [ObsUnit Featureset] -> Cohort Featureset makeExpectedCohort a x = MkCohort (Just a, MkCohortData x)  expectedCohorts :: [Cohort Featureset]-expectedCohorts =-  zipWith+expectedCohorts = zipWith   (curry MkCohort)-  [-    Just $ MkAttritionInfo $ (ExcludedBy (2, "isOver50"), 1) :| [(ExcludedBy (4, "isContinuousEnrolled"), 1)]+  [ 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)]+  , 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)]   ]-  (  fmap MkCohortData (-        [[]] -    ++ transpose [expectedObsUnita]-    ++ [[], [],  [], []] ))+  (fmap MkCohortData ([[]] ++ transpose [expectedObsUnita] ++ [[], [], [], []]))  exampleCohort1tests :: TestTree-exampleCohort1tests = testGroup "Unit tests for calendar cohorts"-  [ testCase "expected Features for testData1" $+exampleCohort1tests = testGroup+  "Unit tests for calendar cohorts"+  [ testCase "expected Features for testData1"+    $       -- Featureable cannot be tested for equality directly, hence encoding to        -- JSON bytestring and testing that for equality-       encode (evalCohorts testPop) @?= encode expectedCohorts+        encode (evalCohorts testPop)+    @?= encode expectedCohorts   ]
examples/ExampleEvents.hs view
@@ -7,16 +7,16 @@ -} {-# LANGUAGE OverloadedStrings #-} -module ExampleEvents (-      exampleEvents1-    , exampleEvents2-    , exampleEvents3-    , exampleEvents4-    , exampleSubject1-    , exampleSubject2-) where+module ExampleEvents+  ( exampleEvents1+  , exampleEvents2+  , exampleEvents3+  , exampleEvents4+  , exampleSubject1+  , exampleSubject2+  ) where -import Hasklepias+import           Hasklepias  exampleEvents1 :: Events Int exampleEvents1 = toEvents exampleEvents1Data@@ -24,10 +24,10 @@ exampleEvents2 :: Events Int exampleEvents2 = toEvents exampleEvents2Data -exampleEvents3 :: Events Int +exampleEvents3 :: Events Int exampleEvents3 = toEvents exampleEvents3Data -exampleEvents4 :: Events Int +exampleEvents4 :: Events Int exampleEvents4 = toEvents exampleEvents4Data  exampleSubject1 :: Subject (Events Int)@@ -39,100 +39,101 @@ 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 (UnimplementedDomain ()) (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+toEvents = sort . map toEvent  t1 :: (a, b, c) -> a-t1 (x , _ , _) = x+t1 (x, _, _) = x t2 :: (a, b, c) -> b-t2 (_ , x , _) = x+t2 (_, x, _) = x t3 :: (a, b, c) -> c-t3 (_ , _ , x) = x+t3 (_, _, x) = x  exampleEvents1Data :: [EventData Int]-exampleEvents1Data = [-    (9, 1,   "enrollment")-  , (9, 11,  "enrollment")-  , (9, 21,  "enrollment")-  , (9, 31,  "enrollment")-  , (5, 45,  "enrollment")-  , (9, 51,  "enrollment")-  , (2, 61,  "enrollment")-  , (9, 71,  "enrollment")+exampleEvents1Data =+  [ (9 , 1 , "enrollment")+  , (9 , 11, "enrollment")+  , (9 , 21, "enrollment")+  , (9 , 31, "enrollment")+  , (5 , 45, "enrollment")+  , (9 , 51, "enrollment")+  , (2 , 61, "enrollment")+  , (9 , 71, "enrollment")   , (19, 81, "enrollment")-  , (1, 2,   "wasScratchedByCat")-  , (1, 45,  "wasStruckByDuck")-  , (1, 46,  "wasBitByDuck")-  , (1, 49,  "wasBitByDuck")-  , (1,  51, "wasBitByDuck")-  , (1, 60,  "wasBitByOrca")-  , (1, 91,  "wasStuckByCow")-  , (1, 5,   "hadMinorSurgery")-  , (1, 52,  "hadMajorSurgery")-  , (5, 5,   "tookAntibiotics")-  , (8, 52,  "wasHospitalized")-  , (6, 45,  "tookAntibiotics")+  , (1 , 2 , "wasScratchedByCat")+  , (1 , 45, "wasStruckByDuck")+  , (1 , 46, "wasBitByDuck")+  , (1 , 49, "wasBitByDuck")+  , (1 , 51, "wasBitByDuck")+  , (1 , 60, "wasBitByOrca")+  , (1 , 91, "wasStuckByCow")+  , (1 , 5 , "hadMinorSurgery")+  , (1 , 52, "hadMajorSurgery")+  , (5 , 5 , "tookAntibiotics")+  , (8 , 52, "wasHospitalized")+  , (6 , 45, "tookAntibiotics")   , (13, 60, "tookAntibiotics")-  , (3, 80,  "tookAntibiotics")-  , (1, 95,  "died")- ]+  , (3 , 80, "tookAntibiotics")+  , (1 , 95, "died")+  ]  exampleEvents2Data :: [EventData Int]-exampleEvents2Data = [-    (9, 1,   "enrollment")+exampleEvents2Data =+  [ (9 , 1 , "enrollment")   , (14, 21, "enrollment")-  , (9, 31,  "enrollment")+  , (9 , 31, "enrollment")   , (14, 45, "enrollment")-  , (9, 60,  "enrollment")-  , (2, 61,  "enrollment")-  , (9, 80,  "enrollment")-  , (1, 2,   "wasPeckedByChicken")-  , (1, 3,   "wasPeckedByChicken")-  , (1, 4,   "wasPeckedByChicken")-  , (1, 5,   "wasPeckedByChicken")-  , (1, 10,  "wasInjuredBySquirrel")-  , (1, 15,  "wasDiagnosedWithSciurophobia")-  , (1, 20,  "hadSquirrelContact")-  , (1, 20,  "hadAnxietyAttack")- ]+  , (9 , 60, "enrollment")+  , (2 , 61, "enrollment")+  , (9 , 80, "enrollment")+  , (1 , 2 , "wasPeckedByChicken")+  , (1 , 3 , "wasPeckedByChicken")+  , (1 , 4 , "wasPeckedByChicken")+  , (1 , 5 , "wasPeckedByChicken")+  , (1 , 10, "wasInjuredBySquirrel")+  , (1 , 15, "wasDiagnosedWithSciurophobia")+  , (1 , 20, "hadSquirrelContact")+  , (1 , 20, "hadAnxietyAttack")+  ]  exampleEvents3Data :: [EventData Int]-exampleEvents3Data = [-    (9, 1,   "enrollment")-  , (9, 11,  "enrollment")-  , (9, 21,  "enrollment")-  , (9, 31,  "enrollment")-  , (5, 45,  "enrollment")-  , (9, 51,  "enrollment")-  , (2, 61,  "enrollment")-  , (9, 71,  "enrollment")+exampleEvents3Data =+  [ (9 , 1 , "enrollment")+  , (9 , 11, "enrollment")+  , (9 , 21, "enrollment")+  , (9 , 31, "enrollment")+  , (5 , 45, "enrollment")+  , (9 , 51, "enrollment")+  , (2 , 61, "enrollment")+  , (9 , 71, "enrollment")   , (19, 81, "enrollment")-  , (1, 2,   "wasScratchedByCat")-  , (1, 45,  "wasStruckByDuck")-  , (1, 46,  "wasBitByDuck")-  , (1, 49,  "wasBitByDuck")-  , (1, 51,  "wasBitByDuck")-  , (1, 60,  "wasBitByOrca")-  , (1, 91,  "wasStuckByCow")-  , (1, 5,   "hadMinorSurgery")-  , (1, 52,  "hadMajorSurgery")-  , (5, 5,   "tookAntibiotics")-  , (8, 52,  "wasHospitalized")+  , (1 , 2 , "wasScratchedByCat")+  , (1 , 45, "wasStruckByDuck")+  , (1 , 46, "wasBitByDuck")+  , (1 , 49, "wasBitByDuck")+  , (1 , 51, "wasBitByDuck")+  , (1 , 60, "wasBitByOrca")+  , (1 , 91, "wasStuckByCow")+  , (1 , 5 , "hadMinorSurgery")+  , (1 , 52, "hadMajorSurgery")+  , (5 , 5 , "tookAntibiotics")+  , (8 , 52, "wasHospitalized")   , (10, 45, "tookAntibiotics")   , (15, 58, "tookAntibiotics")-  , (3, 80,  "tookAntibiotics")-  , (1, 95,  "died") - ]+  , (3 , 80, "tookAntibiotics")+  , (1 , 95, "died")+  ]  exampleEvents4Data :: [EventData Int]-exampleEvents4Data = [-    (1, 1,   "c1")-  , (3, 11,  "c1")-  , (9, 16,  "c1")-  , (9, 31,  "c1")-  , (5, 45,  "c1")-  , (1, 10,  "c2")-  , (1, 13,  "c2")- ]+exampleEvents4Data =+  [ (1, 1 , "c1")+  , (3, 11, "c1")+  , (9, 16, "c1")+  , (9, 31, "c1")+  , (5, 45, "c1")+  , (1, 10, "c2")+  , (1, 13, "c2")+  ]
examples/ExampleFeatures1.hs view
@@ -10,29 +10,25 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE DataKinds #-}-module ExampleFeatures1(-    exampleFeatures1Spec-) where+module ExampleFeatures1+  ( exampleFeatures1Spec+  ) where -import Hasklepias-import ExampleEvents-import Test.Hspec-import Control.Monad+import           Control.Monad+import           ExampleEvents+import           Hasklepias+import           Test.Hspec  {- Index is defined as the first occurrence of an Orca bite. -}-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))---- indexSpec :: (Ord a) => FeatureSpec Text (*) (Events a) (Interval a)--- indexSpec = makeFeatureSpec "index" "" (define indexDef)+indexDef+  :: (Ord a) => Definition (FeatureData (Events a) -> FeatureData (Interval a))+indexDef = defineA+  (\events -> case firstConceptOccurrence ["wasBitByOrca"] events of+    Nothing -> featureDataL (Other "No occurrence of Orca bite")+    Just x  -> pure (getInterval x)+  )  {-   The baseline interval is the interval (b - 60, b), where b is the begin of @@ -40,13 +36,15 @@ as an argument, so that the baseline FeatureData can be used to filter events based on different predicate functions. -}-bline :: (IntervalSizeable a b) =>-     FeatureData (Events a)+bline+  :: (IntervalSizeable a b)+  => FeatureData (Events a)   -> FeatureData (Interval a) bline x = fmap (enderval 60 . begin) (eval indexDef x) -flwup :: (IntervalSizeable a b) =>-     FeatureData (Events a)+flwup+  :: (IntervalSizeable a b)+  => FeatureData (Events a)   -> FeatureData (Interval a) flwup x = fmap (beginerval 30 . begin) (eval indexDef x) @@ -54,64 +52,55 @@ Define enrolled as the indicator of whether all of the gaps between the union of  all enrollment intervals (+ allowableGap)  -}-enrolled :: (IntervalSizeable a b) =>-      b-      -> Interval a -> Events a -> Bool+enrolled :: (IntervalSizeable a b) => b -> Interval a -> Events a -> Bool enrolled allowableGap i events =-    events-      |> makeConceptsFilter ["enrollment"]-      |> combineIntervals-      |> gapsWithin i-      |> maybe False (all (< allowableGap) . durations)+  events+    |> makeConceptsFilter ["enrollment"]+    |> combineIntervals+    |> gapsWithin i+    |> maybe False (all (< allowableGap) . durations) -enrolledDef :: IntervalSizeable a b =>-      b -> Definition (FeatureData (Interval a) -> FeatureData (Events a) -> FeatureData Bool)+enrolledDef+  :: IntervalSizeable a b+  => b+  -> Definition+       (  FeatureData (Interval a)+       -> FeatureData (Events a)+       -> FeatureData Bool+       ) enrolledDef allowableGap = define (enrolled allowableGap) {- Define features that identify whether a subject as bit/struck by a duck and bit/struck by a macaw. -}-makeHxDef :: (Ord a) =>-         [Text]-      -> Interval a-      -> Events a-      -> (Bool, Maybe (Interval a))+makeHxDef+  :: (Ord a) => [Text] -> Interval a -> Events a -> (Bool, Maybe (Interval a)) makeHxDef cnpts i events =-   (isNotEmpty (f i events), lastMay $ intervals (f i events))-   where f i x = makePairedFilter enclose i (`hasConcepts` cnpts) x+  (isNotEmpty (f i events), lastMay $ intervals (f i events))+  where f i x = makePairedFilter enclose i (`hasConcepts` cnpts) x -duckHxDef :: (Ord a) =>-         Interval a-      -> Events a-      -> (Bool, Maybe (Interval a))+duckHxDef :: (Ord a) => Interval a -> Events a -> (Bool, Maybe (Interval a)) duckHxDef = makeHxDef ["wasBitByDuck", "wasStruckByDuck"] -macawHxDef :: (Ord a) =>-         Interval a-      -> Events a-      -> (Bool, Maybe (Interval a))+macawHxDef :: (Ord a) => Interval a -> Events a -> (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+twoXOrOneY x y es = atleastNofX 2 x es || atleastNofX 1 y es  -- | Define an event that identifies whether the subject has two minor or one major --   surgery.-twoMinorOrOneMajorDef :: (Ord a) =>-         Interval a -> Events a ->  Bool+twoMinorOrOneMajorDef :: (Ord a) => Interval a -> Events a -> Bool twoMinorOrOneMajorDef i events =-    twoXOrOneY ["hadMinorSurgery"] ["hadMajorSurgery"] (filterEnclose i events)+  twoXOrOneY ["hadMinorSurgery"] ["hadMajorSurgery"] (filterEnclose i events)  -- | Time from end of baseline to end of most recent Antibiotics --   with 5 day grace period-timeSinceLastAntibioticsDef :: (IntervalSizeable a b) =>-      Interval a-      -> Events a-      -> Maybe b-timeSinceLastAntibioticsDef i  =-      lastMay                                 -- want the last one+timeSinceLastAntibioticsDef+  :: (IntervalSizeable a b) => Interval a -> Events a -> Maybe b+timeSinceLastAntibioticsDef i =+  lastMay                                 -- want the last one     . map (max 0 . diff (end i) . end)        -- distances between end of baseline and antibiotic intervals     . filterNotDisjoint i                     -- filter to intervals not disjoint from baseline interval     . combineIntervals                        -- combine overlapping intervals@@ -119,12 +108,10 @@     . makeConceptsFilter ["tookAntibiotics"]  -- filter to only antibiotics events   -- | Count of hospital events in a interval and duration of the last one-countOfHospitalEventsDef :: (IntervalSizeable a b) =>-      Interval a -      -> Events a -      -> (Int, Maybe b)+countOfHospitalEventsDef+  :: (IntervalSizeable a b) => Interval a -> Events a -> (Int, Maybe b) countOfHospitalEventsDef i =-       (\x -> (length x, duration <$> lastMay x))+  (\x -> (length x, duration <$> lastMay x))     . filterNotDisjoint i                    -- filter to intervals not disjoint from interval     . combineIntervals                       -- combine overlapping intervals     . makeConceptsFilter ["wasHospitalized"]  -- filter to only antibiotics events@@ -136,92 +123,103 @@ so :: Ord a => ComparativePredicateOf1 (Interval a) so = unionPredicates [startedBy, overlappedBy] -discontinuationDef :: (IntervalSizeable a b) =>-      Interval a -      -> Events a-      -> Maybe (a, b)-discontinuationDef i events = -    (\x -> Just (begin x       -- we want the begin of this interval -          , diff (begin x) (begin i)))+discontinuationDef+  :: (IntervalSizeable a b) => Interval a -> Events a -> Maybe (a, b)+discontinuationDef i events =+  (\x -> Just+      ( begin x       -- we want the begin of this interval +      , diff (begin x) (begin i)+      )+    )     =<< headMay                    -- if there are any gaps the first one is the first discontinuation     =<< gapsWithin i               -- find gaps to intervals clipped to i-    =<< (nothingIfNone (so i)      -- if none of the intervals start or overlap +    =<< ( nothingIfNone (so i)      -- if none of the intervals start or overlap                          -- the followup, then never started antibiotics-    . combineIntervals          -- combine overlapping intervals-    . map (expandr 5)           -- allow grace period-    . makeConceptsFilter        -- filter to only antibiotics events-          ["tookAntibiotics"])-    events+        . combineIntervals          -- combine overlapping intervals+        . map (expandr 5)           -- allow grace period+        . makeConceptsFilter        -- filter to only antibiotics events+                             ["tookAntibiotics"]+        )+          events -type MyData = -     ( FeatureData (Interval Int)-     , FeatureData Bool-     , FeatureData (Bool, Maybe (Interval Int))-     , FeatureData (Bool, Maybe (Interval Int))-     , FeatureData Bool-     , FeatureData (Maybe Int)-     , FeatureData (Int, Maybe Int)-     , FeatureData (Maybe (Int, Int))-     )+type MyData+  = ( FeatureData (Interval Int)+    , FeatureData Bool+    , FeatureData (Bool, Maybe (Interval Int))+    , FeatureData (Bool, Maybe (Interval Int))+    , FeatureData Bool+    , FeatureData (Maybe Int)+    , FeatureData (Int, Maybe Int)+    , FeatureData (Maybe (Int, Int))+    ) -getUnitFeatures ::-      Events Int-  -> MyData-getUnitFeatures x = (-    eval indexDef evs-  , eval (enrolledDef 8) (bline evs, evs)  +getUnitFeatures :: Events Int -> MyData+getUnitFeatures x =+  ( eval indexDef        evs+  , eval (enrolledDef 8) (bline evs, evs)   -- TODO: feature functions below need to be put into a FeatureDefintion   --      in order to run eval-  , liftA2 duckHxDef  (bline evs) evs-  , liftA2 macawHxDef (bline evs) evs-  , liftA2 twoMinorOrOneMajorDef (bline evs) evs+  , liftA2 duckHxDef                   (bline evs) evs+  , liftA2 macawHxDef                  (bline evs) evs+  , liftA2 twoMinorOrOneMajorDef       (bline evs) evs   , liftA2 timeSinceLastAntibioticsDef (bline evs) evs-  , liftA2 countOfHospitalEventsDef (bline evs) evs-  , liftA2 discontinuationDef (flwup evs) evs-  ) where evs = pure x+  , liftA2 countOfHospitalEventsDef    (bline evs) evs+  , liftA2 discontinuationDef          (flwup evs) evs+  )+  where evs = pure x  -includeAll :: Events Int -> Criteria -includeAll x = criteria $ pure (criterion (makeFeature (featureDataR Include)  :: Feature "includeAll" Status))+includeAll :: Events Int -> Criteria+includeAll x = criteria $ pure+  (criterion (makeFeature (featureDataR Include) :: Feature "includeAll" Status)+  ) -testCohortSpec :: CohortSpec  (Events Int) MyData+testCohortSpec :: CohortSpec (Events Int) MyData testCohortSpec = specifyCohort includeAll getUnitFeatures  example1results :: MyData example1results =-      ( pure (beginerval 1 (60 :: Int))-      , pure True-      , pure (True, Just $ beginerval 1 (51 :: Int))-      , pure (False, Nothing)-      , pure True-      , pure $ Just 4-      , pure (1, Just 8)-      , pure $ Just (78, 18)-      )+  ( pure (beginerval 1 (60 :: Int))+  , pure True+  , pure (True, Just $ beginerval 1 (51 :: Int))+  , pure (False, Nothing)+  , pure True+  , pure $ Just 4+  , pure (1, Just 8)+  , pure $ Just (78, 18)+  )  example2results :: MyData-example2results = -      ( featureDataL (Other "No occurrence of Orca bite")-      , featureDataL (Other "No occurrence of Orca bite")-      , featureDataL (Other "No occurrence of Orca bite")-      , featureDataL (Other "No occurrence of Orca bite")-      , featureDataL (Other "No occurrence of Orca bite")-      , featureDataL (Other "No occurrence of Orca bite")-      , featureDataL (Other "No occurrence of Orca bite")-      , featureDataL (Other "No occurrence of Orca bite")-      )+example2results =+  ( featureDataL (Other "No occurrence of Orca bite")+  , featureDataL (Other "No occurrence of Orca bite")+  , featureDataL (Other "No occurrence of Orca bite")+  , featureDataL (Other "No occurrence of Orca bite")+  , featureDataL (Other "No occurrence of Orca bite")+  , featureDataL (Other "No occurrence of Orca bite")+  , featureDataL (Other "No occurrence of Orca bite")+  , featureDataL (Other "No occurrence of Orca bite")+  )  exampleFeatures1Spec :: Spec exampleFeatures1Spec = do -    it "getUnitFeatures from exampleEvents1" $-      getUnitFeatures exampleEvents1 `shouldBe` example1results+  it "getUnitFeatures from exampleEvents1"+    $          getUnitFeatures exampleEvents1+    `shouldBe` example1results -    it "getUnitFeatures from exampleEvents2" $-      getUnitFeatures exampleEvents2 `shouldBe` example2results+  it "getUnitFeatures from exampleEvents2"+    $          getUnitFeatures exampleEvents2+    `shouldBe` example2results -    it "mapping a population to cohort" $-      evalCohort testCohortSpec (MkPopulation [exampleSubject1, exampleSubject2 ]) `shouldBe`-            MkCohort (Just $ MkAttritionInfo $ pure (Included, 2),-                      MkCohortData [MkObsUnit "a" example1results, MkObsUnit "b" example2results])+  it "mapping a population to cohort"+    $          evalCohort testCohortSpec+                          (MkPopulation [exampleSubject1, exampleSubject2])+    `shouldBe` MkCohort+                 ( Just $ MkAttritionInfo $ pure (Included, 2)+                 , MkCohortData+                   [ MkObsUnit "a" example1results+                   , MkObsUnit "b" example2results+                   ]+                 )
examples/ExampleFeatures2.hs view
@@ -9,34 +9,32 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE NoImplicitPrelude #-}-module ExampleFeatures2(-    exampleFeatures2Spec-) where+module ExampleFeatures2+  ( exampleFeatures2Spec+  ) where -import Hasklepias-import ExampleEvents-import Test.Hspec+import           ExampleEvents+import           Hasklepias+import           Test.Hspec -durationOfHospitalizedAntibiotics:: ( Show a-                                    , IntervalSizeable a b) =>-     Events a-  -> FeatureData [b]-durationOfHospitalizedAntibiotics es-    | null y    = featureDataL $ Other "no cases"-    | otherwise = pure $ durations y-    where conceptsText = ["wasHospitalized", "tookAntibiotics"] -          concepts = map packConcept conceptsText-          x = formMeetingSequence (map (toConceptEventOf concepts) es)-          y = filter (\z -> hasAllConcepts (getPairData z) conceptsText ) x +durationOfHospitalizedAntibiotics ::+  (Show a, IntervalSizeable a b) => Events a -> FeatureData [b]+durationOfHospitalizedAntibiotics es | null y = featureDataL $ Other "no cases"+                                     | otherwise = pure $ durations y+ where+  conceptsText = ["wasHospitalized", "tookAntibiotics"]+  concepts     = map packConcept conceptsText+  x            = formMeetingSequence (map (toConceptEventOf concepts) es)+  y            = filter (\z -> hasAllConcepts (getPairData z) conceptsText) x   exampleFeatures2Spec :: Spec exampleFeatures2Spec = do -    it "durationOfHospitalizedAntibiotics from exampleEvents1" $-        durationOfHospitalizedAntibiotics exampleEvents1 `shouldBe` -            featureDataL (Other "no cases")+  it "durationOfHospitalizedAntibiotics from exampleEvents1"+    $          durationOfHospitalizedAntibiotics exampleEvents1+    `shouldBe` featureDataL (Other "no cases") -    it "durationOfHospitalizedAntibiotics from exampleEvents3" $-        durationOfHospitalizedAntibiotics exampleEvents3 `shouldBe` -            pure [3, 2]+  it "durationOfHospitalizedAntibiotics from exampleEvents3"+    $          durationOfHospitalizedAntibiotics exampleEvents3+    `shouldBe` pure [3, 2]
examples/ExampleFeatures3.hs view
@@ -10,32 +10,32 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE NoImplicitPrelude #-} -module ExampleFeatures3(-    exampleFeatures3Spec-) where+module ExampleFeatures3+  ( exampleFeatures3Spec+  ) where -import Hasklepias-import ExampleEvents ( exampleEvents4 )-import Test.Hspec+import           ExampleEvents                  ( exampleEvents4 )+import           Hasklepias+import           Test.Hspec  -examplePairComparison :: (IntervalSizeable a b) =>-    Interval a-    -> Events a-    -> (Bool, Maybe a)-examplePairComparison i es = -    es+examplePairComparison+  :: (IntervalSizeable a b) => Interval a -> Events a -> (Bool, Maybe a)+examplePairComparison i es =+  es     |> filterConcur i                   -- filter to concurring with followup interval         |> splitByConcepts ["c1"] ["c2"]    -- form a list of pairs where first element     |> uncurry allPairs                 -- has "c1" events and second has "c2" events    -                                        +     |> filter                           -- filter this list of pairs to cases -        (\pr -> fst pr `concur`             -- where "c1" event concurs with +/- 3-            expand 3 3 (snd pr) )           -- of any "c2" event +              (\pr -> fst pr `concur`             -- where "c1" event concurs with +/- 3+                                      expand 3 3 (snd pr))           -- of any "c2" event      |> fmap fst     |> (\x ->-        ( isNotEmpty x                  -- are there any?-        , fmap begin (lastMay x)))      -- if exists, keep the begin of the last "c1" interval+         ( isNotEmpty x                  -- are there any?+         , fmap begin (lastMay x)+         )+       )      -- if exists, keep the begin of the last "c1" interval  flwup :: FeatureData (Interval Int) flwup = pure $ beginerval 50 0@@ -43,7 +43,6 @@ exampleFeatures3Spec :: Spec exampleFeatures3Spec = do -    it "examplePairComparison"  $-        liftA2 examplePairComparison flwup (pure exampleEvents4)-             `shouldBe`-        pure (True, Just 16)+  it "examplePairComparison"+    $          liftA2 examplePairComparison flwup (pure exampleEvents4)+    `shouldBe` pure (True, Just 16)
examples/ExampleFeatures4.hs view
@@ -14,13 +14,19 @@ {-# LANGUAGE LambdaCase #-} {-# LANGUAGE TypeApplications #-} -module ExampleFeatures4(-    exampleFeatures4Spec-) where+module ExampleFeatures4+  ( exampleFeatures4Spec+  ) where -import Hasklepias-import ExampleEvents ( exampleEvents4 )-import Test.Hspec ( shouldBe, it, Spec, xcontext, describe, pending )+import           ExampleEvents                  ( exampleEvents4 )+import           Hasklepias+import           Test.Hspec                     ( Spec+                                                , describe+                                                , it+                                                , pending+                                                , shouldBe+                                                , xcontext+                                                )  {-   Example Data and utilities to create such@@ -29,61 +35,45 @@ type EventData a b = (b, a, Text)  t1 :: (a, b, c) -> a-t1 (x , _ , _) = x+t1 (x, _, _) = x t2 :: (a, b, c) -> b-t2 (_ , x , _) = x+t2 (_, x, _) = x t3 :: (a, b, c) -> c-t3 (_ , _ , x) = x+t3 (_, _, x) = x -toEvent :: (IntervalSizeable a b, Show a, Integral b) => -  EventData a b-> Event a+toEvent+  :: (IntervalSizeable a b, Show a, Integral b) => EventData a b -> Event a toEvent x = event (beginerval (t1 x) (t2 x))-    (context (UnimplementedDomain ()) (packConcepts [t3 x]))+                  (context (UnimplementedDomain ()) (packConcepts [t3 x])) -toEvents :: (Show a, IntervalSizeable a b, Integral b) =>-  [EventData a b] -> Events a-toEvents = sort.map toEvent+toEvents+  :: (Show a, IntervalSizeable a b, Integral b) => [EventData a b] -> Events a+toEvents = sort . map toEvent  sapExample1 :: Events Day-sapExample1 = toEvents [-    (1, fromGregorian 2017 1 1, "index")-  , (1, fromGregorian 2017 3 1, "pcsk")- ]+sapExample1 = toEvents+  [(1, fromGregorian 2017 1 1, "index"), (1, fromGregorian 2017 3 1, "pcsk")]  sapExample2 :: Events Day-sapExample2 = toEvents [-    (1, fromGregorian 2017 1 1,   "index")+sapExample2 = toEvents+  [ (1, fromGregorian 2017 1 1, "index")   , (1, fromGregorian 2017 3 1, "wellness")- ]+  ]  p1Events :: Events Int-p1Events = toEvents [-    (1, 1,   "index")-  , (1, 7 + 15, "pcsk")- ]+p1Events = toEvents [(1, 1, "index"), (1, 7 + 15, "pcsk")]  p2Events :: Events Int-p2Events = toEvents [-    (1, 1,   "index")-  , (1, 7 + 60, "pcsk")- ]+p2Events = toEvents [(1, 1, "index"), (1, 7 + 60, "pcsk")]  p3Events :: Events Int-p3Events = toEvents [-    (1, 1,   "index")-  , (1, 7 + 120, "pcsk")- ]+p3Events = toEvents [(1, 1, "index"), (1, 7 + 120, "pcsk")]  p4Events :: Events Int-p4Events = toEvents [-    (1, 1,   "index")-  , (1, 7 + 240, "pcsk")- ]+p4Events = toEvents [(1, 1, "index"), (1, 7 + 240, "pcsk")]  p5Events :: Events Int-p5Events = toEvents [-    (1, 1,   "index")- ]+p5Events = toEvents [(1, 1, "index")]  {-   Types used for features@@ -110,44 +100,56 @@  instance OccurrenceReason OutcomeReason -data NegOutcomes b = MkNegOutcome {-    g1 :: CensoredOccurrence CensorReason OutcomeReason b+data NegOutcomes b = MkNegOutcome+  { g1 :: CensoredOccurrence CensorReason OutcomeReason b   , g2 :: CensoredOccurrence CensorReason OutcomeReason b   , g3 :: CensoredOccurrence CensorReason OutcomeReason b   , g4 :: CensoredOccurrence CensorReason OutcomeReason b   , g5 :: CensoredOccurrence CensorReason OutcomeReason b- } deriving (Eq)+  }+  deriving Eq  instance (Show b) => Show ( NegOutcomes b ) where   show (MkNegOutcome x1 x2 x3 x4 x5) =-    "\n g1: " ++ show x1 ++-    "\n g2: " ++ show x2 ++-    "\n g3: " ++ show x3 ++-    "\n g4: " ++ show x4 ++-    "\n g5: " ++ show x5 ++-    "\n"+    "\n g1: "+      ++ show x1+      ++ "\n g2: "+      ++ show x2+      ++ "\n g3: "+      ++ show x3+      ++ "\n g4: "+      ++ show x4+      ++ "\n g5: "+      ++ show x5+      ++ "\n"  data ProtocolStatus a =     Compliant   | NonCompliant (EventTime a)   deriving (Eq, Show) -data Protocols a = MkProtocols {-    noInit  :: ProtocolStatus a+data Protocols a = MkProtocols+  { noInit  :: ProtocolStatus a   , init30  :: ProtocolStatus a   , init90  :: ProtocolStatus a   , init180 :: ProtocolStatus a   , init365 :: ProtocolStatus a- } deriving (Eq)+  }+  deriving Eq  instance (Show a) => Show (Protocols a) where   show (MkProtocols x1 x2 x3 x4 x5) =-    "\n " ++ show x1 ++-    "\n " ++ show x2 ++-    "\n " ++ show x3 ++-    "\n " ++ show x4 ++-    "\n " ++ show x5 ++-    "\n"+    "\n "+      ++ show x1+      ++ "\n "+      ++ show x2+      ++ "\n "+      ++ show x3+      ++ "\n "+      ++ show x4+      ++ "\n "+      ++ show x5+      ++ "\n"  {-   Helper functions@@ -163,380 +165,408 @@  -- | Creates an interval *starting 7 days after the index* and  --   ending 'followupDuration' days later.-makeFollowupInterval :: ( Integral b-                        , Intervallic i a-                        , IntervalSizeable a b) => -    b -> Index i a -> Interval a-makeFollowupInterval dur index =  +makeFollowupInterval+  :: (Integral b, Intervallic i a, IntervalSizeable a b)+  => b+  -> Index i a+  -> Interval a+makeFollowupInterval dur index =   beginerval dur (add washoutDuration (begin index))  -- | Creates an interval *starting 7 days after the index* and  --   ending 'followupDuration' days later.-followupInterval :: (Integral b, IntervalSizeable a b) => -    Index Interval a -> Interval a+followupInterval+  :: (Integral b, IntervalSizeable a b) => Index Interval a -> Interval a followupInterval = makeFollowupInterval 365  {-   Functions for defining the study's exposure protocol(s) -} -protocol :: ( Intervallic i0 a-            , Intervallic i1 a-            , Intervallic i2 a-            , IntervalSizeable a b-            , Filterable container) =>-       (Index i2 a -> i0 a)+protocol+  :: ( Intervallic i0 a+     , Intervallic i1 a+     , Intervallic i2 a+     , IntervalSizeable a b+     , Filterable container+     )+  => (Index i2 a -> i0 a)     -- ^ Function that maps an index interval to interval during which protocol is evaluated-    -> (i0 a -> container (i1 a) -> ProtocolStatus b)+  -> (i0 a -> container (i1 a) -> ProtocolStatus b)     -- ^ Function that maps data to a @ProtocolStatus@.-    -> Index i2 a-    -> container (i1 a)-    -> ProtocolStatus b-protocol g f i dat = f (g i) ( filterConcur (g i) dat )+  -> Index i2 a+  -> container (i1 a)+  -> ProtocolStatus b+protocol g f i dat = f (g i) (filterConcur (g i) dat) -compliantIfNone :: (  IntervalSizeable a b-                    , Intervallic i0 a-                    , Intervallic i1 a-                    , Witherable container ) =>-        i0 a-    -> container (i1 a)-    -> ProtocolStatus b+compliantIfNone+  :: ( IntervalSizeable a b+     , Intervallic i0 a+     , Intervallic i1 a+     , Witherable container+     )+  => i0 a+  -> container (i1 a)+  -> ProtocolStatus b compliantIfNone i x-  | null x     = Compliant-  | otherwise  = NonCompliant (mkEventTime (fmap (`diff` begin i) (end <$> headMay (toList x))))+  | null x = Compliant+  | otherwise = NonCompliant+    (mkEventTime (fmap (`diff` begin i) (end <$> headMay (toList x)))) -compliantIfSome :: ( IntervalSizeable a b-                    , Intervallic i0 a-                    , Intervallic i1 a-                    , Witherable container) =>-       i0 a-    -> container (i1 a)-    -> ProtocolStatus b+compliantIfSome+  :: ( IntervalSizeable a b+     , Intervallic i0 a+     , Intervallic i1 a+     , Witherable container+     )+  => i0 a+  -> container (i1 a)+  -> ProtocolStatus b compliantIfSome i x-  | null x     = NonCompliant (mkEventTime (Just $ diff (end i) (begin i)))-  | otherwise  = Compliant+  | null x    = NonCompliant (mkEventTime (Just $ diff (end i) (begin i)))+  | otherwise = Compliant -protocolNoInit :: ( Integral b-                  , IntervalSizeable a b-                  , Intervallic i0 a-                  , Intervallic i1 a-                  , Witherable container) =>-       Index i0 a-    -> container (i1 a)-    -> ProtocolStatus b+protocolNoInit+  :: ( Integral b+     , IntervalSizeable a b+     , Intervallic i0 a+     , Intervallic i1 a+     , Witherable container+     )+  => Index i0 a+  -> container (i1 a)+  -> ProtocolStatus b protocolNoInit = protocol (makeFollowupInterval 365) compliantIfNone -protocols :: (  Integral b-              , IntervalSizeable a b-              , Intervallic i0 a-              , Intervallic i1 a-              , Witherable container) =>-       Index i0 a-    -> container (i1 a)-    -> Protocols b+protocols+  :: ( Integral b+     , IntervalSizeable a b+     , Intervallic i0 a+     , Intervallic i1 a+     , Witherable container+     )+  => Index i0 a+  -> container (i1 a)+  -> Protocols b protocols i e = MkProtocols-  ( protocol (makeFollowupInterval 365) compliantIfNone i e)-  ( protocol (makeFollowupInterval 30 ) compliantIfSome i e)-  ( protocol (makeFollowupInterval 90 ) compliantIfSome i e)-  ( protocol (makeFollowupInterval 180) compliantIfSome i e)-  ( protocol (makeFollowupInterval 365) compliantIfSome i e)+  (protocol (makeFollowupInterval 365) compliantIfNone i e)+  (protocol (makeFollowupInterval 30) compliantIfSome i e)+  (protocol (makeFollowupInterval 90) compliantIfSome i e)+  (protocol (makeFollowupInterval 180) compliantIfSome i e)+  (protocol (makeFollowupInterval 365) compliantIfSome i e)  -- adminCensor :: (Integral b) => EventTime b -> CensoredOccurrence c o b -- adminCensor t = MkCensoredOccurrence AdminCensor ( RightCensored t ) -compliantOutcome :: (Integral b) => -     EventTime b+compliantOutcome+  :: (Integral b)+  => EventTime b   -> Occurrence OutcomeReason b   -> Occurrence CensorReason b   -> CensoredOccurrence CensorReason OutcomeReason b-compliantOutcome-      adminTime-      (MkOccurrence  (oreason, otime))-      (MkOccurrence  (creason, ctime))-  | all (adminTime <) [otime, ctime]   = adminCensor adminTime-  | all (otime <=)    [ctime]          = MkCensoredOccurrence (O oreason) (Uncensored otime)-  | otherwise                          = MkCensoredOccurrence (C creason) (RightCensored ctime)+compliantOutcome adminTime (MkOccurrence (oreason, otime)) (MkOccurrence (creason, ctime))+  | all (adminTime <) [otime, ctime]+  = adminCensor adminTime+  | all (otime <=) [ctime]+  = MkCensoredOccurrence (O oreason) (Uncensored otime)+  | otherwise+  = MkCensoredOccurrence (C creason) (RightCensored ctime) -nonCompliantOutcome :: (Integral b) => -     EventTime b+nonCompliantOutcome+  :: (Integral b)+  => EventTime b   -> EventTime b   -> Occurrence OutcomeReason b   -> Occurrence CensorReason b   -> CensoredOccurrence CensorReason OutcomeReason b-nonCompliantOutcome-      etime-      adminTime-      (MkOccurrence  (oreason, otime))-      (MkOccurrence  (creason, ctime))-  | all (adminTime <) [otime, ctime, etime] = adminCensor adminTime-  | all (otime <=)    [ctime, etime]        = MkCensoredOccurrence (O oreason) (Uncensored otime)-  | etime <= ctime                          = MkCensoredOccurrence (C Noncompliance) (RightCensored etime)-  | otherwise                               = MkCensoredOccurrence (C creason) (RightCensored ctime)+nonCompliantOutcome etime adminTime (MkOccurrence (oreason, otime)) (MkOccurrence (creason, ctime))+  | all (adminTime <) [otime, ctime, etime]+  = adminCensor adminTime+  | all (otime <=) [ctime, etime]+  = MkCensoredOccurrence (O oreason) (Uncensored otime)+  | etime <= ctime+  = MkCensoredOccurrence (C Noncompliance) (RightCensored etime)+  | otherwise+  = MkCensoredOccurrence (C creason) (RightCensored ctime) -decideOutcome :: (Integral b) =>-     EventTime b      -- ^ admin censoring time+decideOutcome+  :: (Integral b)+  => EventTime b      -- ^ admin censoring time   -> ProtocolStatus b -- ^ pcsk   -> Occurrence OutcomeReason b    -- ^ time of outcome   -> Occurrence CensorReason b    -- ^ time of censoring (other than noncompliance)   -> CensoredOccurrence CensorReason OutcomeReason b-decideOutcome  adminTime exposure outcomeTime censorTime =-  case exposure of-    Compliant      -> compliantOutcome adminTime outcomeTime censorTime-    NonCompliant t -> nonCompliantOutcome t adminTime outcomeTime censorTime+decideOutcome adminTime exposure outcomeTime censorTime = case exposure of+  Compliant      -> compliantOutcome adminTime outcomeTime censorTime+  NonCompliant t -> nonCompliantOutcome t adminTime outcomeTime censorTime  {-    Features needed to evaluate censoring and outcome events -}-index :: (Ord a)=> -  Def (F "events" (Events a) -> F "index" (Index Interval a))-index = defineA (-       makeConceptsFilter ["index"]-    .> intervals-    .> headMay-    .> \case-          Nothing -> makeFeature $ featureDataL ( Other "no index" )-          Just x  -> pure $ makeIndex x-      )+index :: (Ord a) => Def (F "events" (Events a) -> F "index" (Index Interval a))+index = defineA+  (makeConceptsFilter ["index"] .> intervals .> headMay .> \case+    Nothing -> makeFeature $ featureDataL (Other "no index")+    Just x  -> pure $ makeIndex x+  ) -flupEvents :: (Integral b, IntervalSizeable a b) => -    Def (-     F "index" (Index Interval a)-  -> F "events" (Events a)-  -> F "allFollowupEvents" (Events b))-flupEvents = define (\index es ->-      es-      |> filterConcur ( followupInterval index)-      |> fmap ( diffFromBegin ( followupInterval index ) )-    )+flupEvents+  :: (Integral b, IntervalSizeable a b)+  => Def+       (  F "index" (Index Interval a)+       -> F "events" (Events a)+       -> F "allFollowupEvents" (Events b)+       )+flupEvents = define+  (\index es -> es |> filterConcur (followupInterval index) |> fmap+    (diffFromBegin (followupInterval index))+  )  {-    Censoring Events -} -death :: Integral b => Def (-     F "allFollowupEvents" (Events b)-  -> F "death" (EventTime b))+death+  :: Integral b+  => Def (F "allFollowupEvents" (Events b) -> F "death" (EventTime b)) death = define (mkEventTime . fmap begin . firstConceptOccurrence ["death"]) -disenrollment :: (Integral b, IntervalSizeable a b) =>-  Def (-     F "index" (Index Interval a)+disenrollment+  :: (Integral b, IntervalSizeable a b)+  => Def+       (  F "index" (Index Interval a)      -- using all events rather than just follow-up events because enrollment      -- intervals need to be combined first-  -> F "events" (Events a)-  -> F "disenrollment" (EventTime b))-disenrollment = define (\i events ->-  events-  |> makeConceptsFilter ["enrollment"]+       -> F "events" (Events a)+       -> F "disenrollment" (EventTime b)+       )+disenrollment = define+  (\i events ->+    events+      |> makeConceptsFilter ["enrollment"]   -- combine any concurring enrollment intervals-  |> combineIntervals+      |> combineIntervals   -- find gaps between any enrollment intervals (as well as bounds of followup )-  |> gapsWithin (followupInterval i)+      |> gapsWithin (followupInterval i)   -- get the first gap longer than 30 days (if it exists)-  |> \x -> (headMay . filter (\x -> duration x > 30)) =<< x+      |> \x ->+           (headMay . filter (\x -> duration x > 30))+             =<< x   -- Shift endpoints of intervals so that end of follow up is reference point-  |> fmap (diffFromBegin (followupInterval i))+             |>  fmap (diffFromBegin (followupInterval i))   -- take the end of this gap as the time of disenrollment-  |> fmap end-  |> mkEventTime )+             |>  fmap end+             |>  mkEventTime+  )  -- | A collector feature for all censors (except noncompliance)-censorTime :: (Integral b) => Def (-     F "death" (EventTime b)-  -> F "disenrollment" (EventTime b)+censorTime+  :: (Integral b)+  => Def+       (  F "death" (EventTime b)+       -> F "disenrollment" (EventTime b)   -- etc-  -> F "censortime" (Occurrence CensorReason b))-censorTime = define (-  \dth disrl  ->-      minimum [ makeOccurrence Death dth-              , makeOccurrence Disenrollment disrl+       -> F "censortime" (Occurrence CensorReason b)+       )+censorTime = define+  (\dth disrl -> minimum+    [ makeOccurrence Death         dth+    , makeOccurrence Disenrollment disrl               -- etc-              ]-   )+    ]+  )  {-    Exposure Definitions -} -pcskEvents :: Def (-     F "events" (Events a)-  -> F "pcskEvents" (Events a))-pcskEvents = define ( makeConceptsFilter ["pcsk"] )+pcskEvents :: Def (F "events" (Events a) -> F "pcskEvents" (Events a))+pcskEvents = define (makeConceptsFilter ["pcsk"]) -pcskProtocols :: (Integral b, IntervalSizeable a b) => -  Def (-     F "index" (Index Interval a)-  -> F "pcskEvents" (Events a)-  -> F "pcskProtocols" (Protocols b) )+pcskProtocols+  :: (Integral b, IntervalSizeable a b)+  => Def+       (  F "index" (Index Interval a)+       -> F "pcskEvents" (Events a)+       -> F "pcskProtocols" (Protocols b)+       ) pcskProtocols = define protocols  {-   Outcome definitions -} -makeg :: (Integral b, IntervalSizeable a b) => -      b-    -> Index Interval a-    -> ProtocolStatus b-    -> Occurrence OutcomeReason b-    -> Occurrence CensorReason b-    -> CensoredOccurrence CensorReason OutcomeReason b-makeg dur i = decideOutcome -    (mkEventTime $ Just $ duration (makeFollowupInterval dur i))+makeg+  :: (Integral b, IntervalSizeable a b)+  => b+  -> Index Interval a+  -> ProtocolStatus b+  -> Occurrence OutcomeReason b+  -> Occurrence CensorReason b+  -> CensoredOccurrence CensorReason OutcomeReason b+makeg dur i =+  decideOutcome (mkEventTime $ Just $ duration (makeFollowupInterval dur i)) -makeNegOutcomes :: (Integral b, IntervalSizeable a b) => -      Index Interval a-   -> Protocols b-   -> Occurrence CensorReason b -   -> Occurrence OutcomeReason b-   -> NegOutcomes b+makeNegOutcomes+  :: (Integral b, IntervalSizeable a b)+  => Index Interval a+  -> Protocols b+  -> Occurrence CensorReason b+  -> Occurrence OutcomeReason b+  -> NegOutcomes b makeNegOutcomes i (MkProtocols p1 p2 p3 p4 p5) c o = MkNegOutcome-    (makeg 365 i p1 o c)-    (makeg 30  i p2 o c)-    (makeg 90  i p3 o c)-    (makeg 180 i p4 o c)-    (makeg 365 i p5 o c)+  (makeg 365 i p1 o c)+  (makeg 30 i p2 o c)+  (makeg 90 i p3 o c)+  (makeg 180 i p4 o c)+  (makeg 365 i p5 o c) -type OutcomeFeature name a b = -     F "index" (Index Interval a)+type OutcomeFeature name a b+  =  F "index" (Index Interval a)   -> F "allFollowupEvents" (Events b)   -> F "pcskProtocols" (Protocols b)   -> F "censortime" (Occurrence CensorReason b)   -> F name (NegOutcomes b) -makeOutcomeDefinition :: -  ( KnownSymbol name-  , Integral b-  , IntervalSizeable  a b) =>-    [Text]+makeOutcomeDefinition+  :: (KnownSymbol name, Integral b, IntervalSizeable a b)+  => [Text]   -> OutcomeReason-  -> Def (   F "index" (Index Interval a)-          -> F "allFollowupEvents" (Events b)-          -> F "pcskProtocols" (Protocols b)-          -> F "censortime" ( Occurrence CensorReason b) -          -> F name ( NegOutcomes b))-makeOutcomeDefinition cpt oreason  = define (-    \index events protocols censor  ->-      events-      |> firstConceptOccurrence cpt-      |> \x -> makeOccurrence oreason (mkEventTime (fmap begin x))-      |> makeNegOutcomes index protocols censor+  -> Def+       (  F "index" (Index Interval a)+       -> F "allFollowupEvents" (Events b)+       -> F "pcskProtocols" (Protocols b)+       -> F "censortime" (Occurrence CensorReason b)+       -> F name (NegOutcomes b)+       )+makeOutcomeDefinition cpt oreason = define+  (\index events protocols censor ->+    events |> firstConceptOccurrence cpt |> \x ->+      makeOccurrence oreason (mkEventTime (fmap begin x))+        |> makeNegOutcomes index protocols censor   ) -o1 :: (Integral b, IntervalSizeable  a b ) => -  Def ( OutcomeFeature "wellness" a b)+o1 :: (Integral b, IntervalSizeable a b) => Def (OutcomeFeature "wellness" a b) o1 = makeOutcomeDefinition ["wellness"] Wellness -o2 :: (Integral b, IntervalSizeable  a b ) => -  Def ( OutcomeFeature "accident" a b)-o2 = makeOutcomeDefinition ["accident"] Accident +o2 :: (Integral b, IntervalSizeable a b) => Def (OutcomeFeature "accident" a b)+o2 = makeOutcomeDefinition ["accident"] Accident  {-     Tests of protocols -} -testProtocols :: (Integral b, IntervalSizeable a b ) => -  [Event a] -> Feature "pcskProtocols" (Protocols b)-testProtocols input = eval pcskProtocols (idx,  pcev)-  where evs   = pure input-        idx   = eval index evs-        pcev  = eval pcskEvents evs+testProtocols+  :: (Integral b, IntervalSizeable a b)+  => [Event a]+  -> Feature "pcskProtocols" (Protocols b)+testProtocols input = eval pcskProtocols (idx, pcev)+ where+  evs  = pure input+  idx  = eval index evs+  pcev = eval pcskEvents evs  p1Protocols :: Feature "pcskProtocols" (Protocols Int)-p1Protocols = pure $ MkProtocols-    ( NonCompliant (mkEventTime (Just 15)) )-      Compliant-      Compliant-      Compliant-      Compliant+p1Protocols = pure $ MkProtocols (NonCompliant (mkEventTime (Just 15)))+                                 Compliant+                                 Compliant+                                 Compliant+                                 Compliant  p2Protocols :: Feature "pcskProtocols" (Protocols Int)-p2Protocols = pure $ MkProtocols-    ( NonCompliant (mkEventTime (Just 60)) )-    ( NonCompliant (mkEventTime (Just 30)) )-      Compliant-      Compliant-      Compliant+p2Protocols = pure $ MkProtocols (NonCompliant (mkEventTime (Just 60)))+                                 (NonCompliant (mkEventTime (Just 30)))+                                 Compliant+                                 Compliant+                                 Compliant  p3Protocols :: Feature "pcskProtocols" (Protocols Int)-p3Protocols = pure $ MkProtocols-    ( NonCompliant (mkEventTime (Just 120)) )-    ( NonCompliant (mkEventTime (Just 30)) )-    ( NonCompliant (mkEventTime (Just 90)) )-      Compliant-      Compliant+p3Protocols = pure $ MkProtocols (NonCompliant (mkEventTime (Just 120)))+                                 (NonCompliant (mkEventTime (Just 30)))+                                 (NonCompliant (mkEventTime (Just 90)))+                                 Compliant+                                 Compliant  p4Protocols :: Feature "pcskProtocols" (Protocols Int)-p4Protocols = pure $ MkProtocols-    ( NonCompliant (mkEventTime (Just 240)) )-    ( NonCompliant (mkEventTime (Just 30)) )-    ( NonCompliant (mkEventTime (Just 90)) )-    ( NonCompliant (mkEventTime (Just 180)) )-      Compliant+p4Protocols = pure $ MkProtocols (NonCompliant (mkEventTime (Just 240)))+                                 (NonCompliant (mkEventTime (Just 30)))+                                 (NonCompliant (mkEventTime (Just 90)))+                                 (NonCompliant (mkEventTime (Just 180)))+                                 Compliant  p5Protocols :: Feature "pcskProtocols" (Protocols Int)-p5Protocols = pure $ MkProtocols-      Compliant-    ( NonCompliant (mkEventTime (Just 30)) )-    ( NonCompliant (mkEventTime (Just 90)) )-    ( NonCompliant (mkEventTime (Just 180)) )-    ( NonCompliant (mkEventTime (Just 365)) )+p5Protocols = pure $ MkProtocols Compliant+                                 (NonCompliant (mkEventTime (Just 30)))+                                 (NonCompliant (mkEventTime (Just 90)))+                                 (NonCompliant (mkEventTime (Just 180)))+                                 (NonCompliant (mkEventTime (Just 365)))  {-     Tests of outcomes -} -testOutcomes :: ( Integral b, IntervalSizeable  a b ) => -      [Event a]-   -> (Feature "wellness" ( NegOutcomes b ), Feature "accident" (NegOutcomes b) )-testOutcomes input = (-      eval o1 (idx, flevs, prot, ctime) -    , eval o2 (idx, flevs, prot, ctime) )-  where evs   = pure input-        idx   = eval index evs-        flevs = eval flupEvents (idx, evs)-        pcev  = eval pcskEvents evs-        dth   = eval death flevs-        disen = eval disenrollment (idx, evs)-        prot  = eval pcskProtocols (idx, pcev)-        ctime = eval censorTime (dth, disen)+testOutcomes+  :: (Integral b, IntervalSizeable a b)+  => [Event a]+  -> ( Feature "wellness" (NegOutcomes b)+     , Feature "accident" (NegOutcomes b)+     )+testOutcomes input =+  (eval o1 (idx, flevs, prot, ctime), eval o2 (idx, flevs, prot, ctime))+ where+  evs   = pure input+  idx   = eval index evs+  flevs = eval flupEvents (idx, evs)+  pcev  = eval pcskEvents evs+  dth   = eval death flevs+  disen = eval disenrollment (idx, evs)+  prot  = eval pcskProtocols (idx, pcev)+  ctime = eval censorTime (dth, disen) -p1Outcomes :: (Integral b) => -  ( Feature "wellness" ( NegOutcomes b)-  , Feature "accident" ( NegOutcomes b)) -p1Outcomes = (-    pure $ MkNegOutcome -      (MkCensoredOccurrence (C Noncompliance) (RightCensored (mkEventTime (Just 15))))-      (MkCensoredOccurrence  AdminCensor      (RightCensored (mkEventTime (Just 30))))-      (MkCensoredOccurrence  AdminCensor      (RightCensored (mkEventTime (Just 90))))-      (MkCensoredOccurrence  AdminCensor      (RightCensored (mkEventTime (Just 180))))-      (MkCensoredOccurrence  AdminCensor      (RightCensored (mkEventTime (Just 365))))-  , pure $ MkNegOutcome -      (MkCensoredOccurrence (C Noncompliance) (RightCensored (mkEventTime (Just 15))))-      (MkCensoredOccurrence  AdminCensor      (RightCensored (mkEventTime (Just 30))))-      (MkCensoredOccurrence  AdminCensor      (RightCensored (mkEventTime (Just 90))))-      (MkCensoredOccurrence  AdminCensor      (RightCensored (mkEventTime (Just 180))))-      (MkCensoredOccurrence  AdminCensor      (RightCensored (mkEventTime (Just 365)))) - )+p1Outcomes+  :: (Integral b)+  => (Feature "wellness" (NegOutcomes b), Feature "accident" (NegOutcomes b))+p1Outcomes =+  ( pure $ MkNegOutcome+    (MkCensoredOccurrence (C Noncompliance)+                          (RightCensored (mkEventTime (Just 15)))+    )+    (MkCensoredOccurrence AdminCensor (RightCensored (mkEventTime (Just 30))))+    (MkCensoredOccurrence AdminCensor (RightCensored (mkEventTime (Just 90))))+    (MkCensoredOccurrence AdminCensor (RightCensored (mkEventTime (Just 180))))+    (MkCensoredOccurrence AdminCensor (RightCensored (mkEventTime (Just 365))))+  , pure $ MkNegOutcome+    (MkCensoredOccurrence (C Noncompliance)+                          (RightCensored (mkEventTime (Just 15)))+    )+    (MkCensoredOccurrence AdminCensor (RightCensored (mkEventTime (Just 30))))+    (MkCensoredOccurrence AdminCensor (RightCensored (mkEventTime (Just 90))))+    (MkCensoredOccurrence AdminCensor (RightCensored (mkEventTime (Just 180))))+    (MkCensoredOccurrence AdminCensor (RightCensored (mkEventTime (Just 365))))+  )  -p1Outcomes' :: (Integral b) => -  ( Feature "wellness" (NegOutcomes b)-  , Feature "accident" (NegOutcomes b)) -p1Outcomes' = (-    pure $ MkNegOutcome -      (MkCensoredOccurrence (C Noncompliance) (RightCensored (mkEventTime (Just 15))))-      (MkCensoredOccurrence  AdminCensor      (RightCensored (mkEventTime (Just 30))))-      (MkCensoredOccurrence (O Wellness)      (Uncensored (mkEventTime (Just 51))))-      (MkCensoredOccurrence (O Wellness)      (Uncensored (mkEventTime (Just 51))))-      (MkCensoredOccurrence (O Wellness)      (Uncensored (mkEventTime (Just 51))))-  , pure $ MkNegOutcome -      (MkCensoredOccurrence (C Noncompliance) (RightCensored (mkEventTime (Just 15))))-      (MkCensoredOccurrence  AdminCensor      (RightCensored (mkEventTime (Just 30))))-      (MkCensoredOccurrence  AdminCensor      (RightCensored (mkEventTime (Just 90))))-      (MkCensoredOccurrence  AdminCensor      (RightCensored (mkEventTime (Just 180))))-      (MkCensoredOccurrence  AdminCensor      (RightCensored (mkEventTime (Just 365)))) - )+p1Outcomes'+  :: (Integral b)+  => (Feature "wellness" (NegOutcomes b), Feature "accident" (NegOutcomes b))+p1Outcomes' =+  ( pure $ MkNegOutcome+    (MkCensoredOccurrence (C Noncompliance)+                          (RightCensored (mkEventTime (Just 15)))+    )+    (MkCensoredOccurrence AdminCensor (RightCensored (mkEventTime (Just 30))))+    (MkCensoredOccurrence (O Wellness) (Uncensored (mkEventTime (Just 51))))+    (MkCensoredOccurrence (O Wellness) (Uncensored (mkEventTime (Just 51))))+    (MkCensoredOccurrence (O Wellness) (Uncensored (mkEventTime (Just 51))))+  , pure $ MkNegOutcome+    (MkCensoredOccurrence (C Noncompliance)+                          (RightCensored (mkEventTime (Just 15)))+    )+    (MkCensoredOccurrence AdminCensor (RightCensored (mkEventTime (Just 30))))+    (MkCensoredOccurrence AdminCensor (RightCensored (mkEventTime (Just 90))))+    (MkCensoredOccurrence AdminCensor (RightCensored (mkEventTime (Just 180))))+    (MkCensoredOccurrence AdminCensor (RightCensored (mkEventTime (Just 365))))+  )  {-   Test specs@@ -544,26 +574,18 @@  exampleFeatures4Spec :: Spec exampleFeatures4Spec = do-    describe "tests of exposure protocols" $-      do-        it "p1" $-          testProtocols p1Events `shouldBe` p1Protocols-        it "p2" $-          testProtocols p2Events `shouldBe` p2Protocols-        it "p3" $-          testProtocols p3Events `shouldBe` p3Protocols-        it "p4" $-          testProtocols p4Events `shouldBe` p4Protocols-        it "p5" $-          testProtocols p5Events `shouldBe` p5Protocols+  describe "tests of exposure protocols" $ do+    it "p1" $ testProtocols p1Events `shouldBe` p1Protocols+    it "p2" $ testProtocols p2Events `shouldBe` p2Protocols+    it "p3" $ testProtocols p3Events `shouldBe` p3Protocols+    it "p4" $ testProtocols p4Events `shouldBe` p4Protocols+    it "p5" $ testProtocols p5Events `shouldBe` p5Protocols -    describe "tests of outcomes" $-      do-        it "p1" $-          testOutcomes p1Events `shouldBe` p1Outcomes-        it "p1'" $-          testOutcomes (sort p1Events <> [toEvent (1, 59, "wellness")] ) -            `shouldBe` p1Outcomes'+  describe "tests of outcomes" $ do+    it "p1" $ testOutcomes p1Events `shouldBe` p1Outcomes+    it "p1'"+      $          testOutcomes (sort p1Events <> [toEvent (1, 59, "wellness")])+      `shouldBe` p1Outcomes'      -- describe "SAP examples" $      --   do
examples/Main.hs view
@@ -1,16 +1,16 @@-module Main(-    module ExampleFeatures1+module Main+  ( module ExampleFeatures1   , main-) where+  ) where -import ExampleFeatures1 ( exampleFeatures1Spec )-import ExampleFeatures2 ( exampleFeatures2Spec ) -import ExampleFeatures3 ( exampleFeatures3Spec ) -import ExampleFeatures4 ( exampleFeatures4Spec ) -import ExampleCohort1   ( exampleCohort1tests )-import Test.Tasty-import Test.Tasty.Hspec ( testSpec )-import Test.Hspec       ( hspec )+import           ExampleCohort1                 ( exampleCohort1tests )+import           ExampleFeatures1               ( exampleFeatures1Spec )+import           ExampleFeatures2               ( exampleFeatures2Spec )+import           ExampleFeatures3               ( exampleFeatures3Spec )+import           ExampleFeatures4               ( exampleFeatures4Spec )+import           Test.Hspec                     ( hspec )+import           Test.Tasty+import           Test.Tasty.Hspec               ( testSpec )  -- 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@@ -20,12 +20,9 @@   spec1 <- testSpec "spec1" exampleFeatures1Spec   spec2 <- testSpec "spec2" exampleFeatures2Spec   spec3 <- testSpec "spec3" exampleFeatures3Spec-  spec4 <- testSpec "spec4" exampleFeatures4Spec +  spec4 <- testSpec "spec4" exampleFeatures4Spec   defaultMain-    (testGroup "tests"-      [ spec1-      , spec2-      , spec3-      , spec4-      , testGroup "Tests" [exampleCohort1tests]-      ])+    (testGroup+      "tests"+      [spec1, spec2, spec3, spec4, testGroup "Tests" [exampleCohort1tests]]+    )
hasklepias.cabal view
@@ -1,6 +1,6 @@ cabal-version:  2.2 name:           hasklepias-version:        0.16.1+version:        0.17.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@@ -31,6 +31,8 @@       EventData.Context.Domain       EventData.Context.Domain.Demographics       EventData.Context.Domain.Enrollment+      EventData.Accessors+      EventData.Predicates       Features       Features.Attributes       Features.Compose@@ -38,6 +40,7 @@       Features.Output       Features.Featureset       Cohort+      Cohort.AssessmentIntervals       Cohort.Core       Cohort.Input       Cohort.Output@@ -54,6 +57,7 @@       Hasklepias.Templates.Tests       Hasklepias.Templates.TestUtilities       Hasklepias.Templates.Features.Enrollment+      Hasklepias.Templates.Features.NsatisfyP       Stype       Stype.Aeson       Stype.Numeric@@ -75,10 +79,11 @@     , bytestring == 0.10.12.0     , cmdargs == 0.10.21     , containers == 0.6.5.1+    , contravariant >= 1.4     , co-log == 0.4.0.1     , flow == 1.0.22     , ghc-prim == 0.6.1-    , interval-algebra == 0.10.0+    , interval-algebra == 0.10.2     , lens == 5.0.1     , lens-aeson == 1.1.1     , mtl == 2.2.2@@ -89,6 +94,7 @@     , tasty-hunit == 0.10.0.3     , text == 1.2.4.1     , time >= 1.11+    , tuple == 0.3.0.2     , QuickCheck     , unordered-containers == 0.2.14.0     , vector == 0.12.2.0@@ -101,6 +107,7 @@   other-modules:       EventDataSpec       EventData.AesonSpec+      EventData.AccessorsSpec       EventData.ContextSpec       EventData.Context.DomainSpec       EventData.Context.Domain.DemographicsSpec@@ -109,6 +116,7 @@       Features.FeaturesetSpec       Cohort.InputSpec       Cohort.CoreSpec+      Cohort.AssessmentIntervalsSpec       Cohort.CriteriaSpec       Hasklepias.FeatureEventsSpec       Stype.AesonSpec@@ -127,7 +135,7 @@     , flow == 1.0.22     , hasklepias     , hspec-    , interval-algebra == 0.10.0+    , interval-algebra == 0.10.2     , lens == 5.0.1     , text >=1.2.3     , time >=1.11
src/Cohort.hs view
@@ -8,28 +8,29 @@ {-# OPTIONS_HADDOCK hide #-} {-# LANGUAGE NoImplicitPrelude #-} -module Cohort(--   -- * Defining Cohorts-      module Cohort.Core--    -- ** Criteria-    , module Cohort.Criteria-    -- ** Index-    , module Cohort.Index--    -- * Cohort I/O-    -- ** Input-    , module Cohort.Input   -    -- ** Output-    , module Cohort.Output+module Cohort+  ( +   -- ** Defining Cohorts+    module Cohort.Core -) where+   -- ** Index+  , module Cohort.Index+   -- ** Assessment Intervals+  , module Cohort.AssessmentIntervals+   -- ** Criteria+  , module Cohort.Criteria +   -- ** Cohort I/O+   -- *** Input+  , module Cohort.Input+   -- *** Output+  , module Cohort.Output+  ) where -import Cohort.Core-import Cohort.Index-import Cohort.Criteria-import Cohort.Input-import Cohort.Output+import           Cohort.AssessmentIntervals+import           Cohort.Core+import           Cohort.Criteria+import           Cohort.Index+import           Cohort.Input+import           Cohort.Output
+ src/Cohort/AssessmentIntervals.hs view
@@ -0,0 +1,359 @@+{-|+Module      : Cohort Index +Description : Defines the Index and related types and functions+Copyright   : (c) NoviSci, Inc 2020+License     : BSD3+Maintainer  : bsaul@novisci.com+-}++{-# OPTIONS_HADDOCK hide #-}+{-# LANGUAGE NoImplicitPrelude #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}+-- {-# LANGUAGE Safe #-}++module Cohort.AssessmentIntervals(+  {- |+The assessment intervals provided are:++* 'Baseline': an interval which either 'IntervalAlgebra.meets' or+  'IntervalAlgebra.precedes' index. Covariates are typically assessed during+  baseline intervals. A cohort's specification may include multiple baseline+  intervals, as different features may require different baseline intervals.+  For example, one feature may use a baseline interval of 365 days prior to+  index, while another uses a baseline interval of 90 days before index up+  to 30 days before index.+* `Followup`: an interval which is 'IntervalAlgebra.startedBy', +  'IntervalAlgebra.metBy', or 'IntervalAlgebra.after' an 'Index'. Outcomes+  are typically assessed during followup intervals. Similar to 'Baseline',+    a cohort's specification may include multiple followup intervals, +    as different features may require different followup intervals. ++In future versions, one subject may have multiple values for an 'Index'+corresponding to unique 'Cohort.Core.ObsUnit'. That is, there is a 1-to-1 map between +index values and observational units, but there may be a 1-to-many map from +subjects to indices.++While users are protected from forming invalid assessment intervals, they still+need to carefully consider how to filter events based on the assessment interval. +Consider the following data:++@+               _      <- Index    (15, 16)+     ----------       <- Baseline (5, 15)+ ---                  <- A (1, 4)+  ---                 <- B (2, 5)+    ---               <- C (4, 7)+      ---             <- D (5, 8)+         ---          <- E (8, 11)+            ---       <- F (12, 15)+              ---     <- G (14, 17)+                 ___  <- H (17, 20)+|----|----|----|----|+0         10        20+@++We have index, baseline, and 8 events (A-H). If Baseline is our assessment interval,+then the events concuring (i.e. not disjoint) with Baseline are C-G.  While C-F+probably make sense to use in deriving some covariate, what about G? The event G+begins during baseline but ends after index. If you want, for example, to know+how many events started during baseline, then you’d want to include G in your+filter (using 'IntervalAlgebra.concur'). But if you wanted to know the durations +of events enclosed by baseline, then you wouldn’t want to filter using concur +and instead perhaps use 'IntervalAlgebra.enclosedBy'.+++    -}+    BaselineInterval+  , Baseline(..)+  , FollowupInterval+  , Followup(..)+  , AssessmentInterval+  , makeBaselineFromIndex+  , makeBaselineBeforeIndex+  , makeFollowupFromIndex+  , makeFollowupMeetingIndex+  , makeFollowupAfterIndex+) where++import GHC.Generics                ( Generic )+import GHC.Num                     ( Num((+)) )+import GHC.Show                    ( Show )+import Data.Eq                     ( Eq )+import Data.Functor                ( Functor(fmap) )+import Data.Function               ( ($) )+import Data.Ord                    ( Ord, (<=) )+import IntervalAlgebra             ( Interval+                                   , Intervallic(..)+                                   , IntervalSizeable(..)+                                   , enderval+                                   , begin+                                   , end+                                   , beginerval+                                   , duration )+import Cohort.Index                ( Index )++{-| A type to contain baseline intervals. See the 'Baseline' typeclass for methods+to create values of this type.+-}+newtype BaselineInterval a = MkBaselineInterval (Interval a)+  deriving (Eq, Show, Generic)++instance Functor BaselineInterval where+  fmap f (MkBaselineInterval x) = MkBaselineInterval (fmap f x)++instance (Ord a) => Intervallic BaselineInterval a where+  getInterval (MkBaselineInterval x)   = getInterval x+  setInterval (MkBaselineInterval x) y = MkBaselineInterval (setInterval x y)++{-| +Provides functions for creating a 'BaselineInterval' from an 'Index'. The +'baseline' function should satify:++[Meets]++  @'IntervalAlgebra.relate' ('baseline' d i) i = 'IntervalAlgebra.Meets'@++The 'baselineBefore' function should satisfy:++[Before]+  +  @'IntervalAlgebra.relate' ('baselineBefore' s d i) i = 'IntervalAlgebra.Before'@++>>> import Cohort.Index+>>> import IntervalAlgebra+>>> x = makeIndex (beginerval 1 10)+>>> b =baseline 10 x+>>> b+>>> relate b x+MkBaselineInterval (0, 10)+Meets++>>> import Cohort.Index+>>> import IntervalAlgebra+>>> x = makeIndex (beginerval 1 10)+>>> b = baselineBefore 2 4 x+>>> b+>>> relate b x+MkBaselineInterval (4, 8)+Before+-}+class Intervallic i a => Baseline i a where+  -- | Creates a 'BaselineInterval' of the given duration that 'IntervalAlgebra.Meets'+  -- the 'Index' interval.+  baseline :: +    ( IntervalSizeable a b) => +      b -- ^ duration of baseline+    -> Index i a -- ^ the 'Index' event+    -> BaselineInterval a+  baseline dur index = MkBaselineInterval (enderval dur (begin index))++  -- | Creates a 'BaselineInterval' of the given duration that 'IntervalAlgebra.precedes'+  -- the 'Index' interval. +  baselineBefore :: +    ( IntervalSizeable a b) => +       b -- ^ duration to shift back +    -> b -- ^ duration of baseline+    -> Index i a -- ^ the 'Index' event+    -> BaselineInterval a+  baselineBefore shiftBy dur index = +    MkBaselineInterval $ enderval dur (begin (enderval shiftBy (begin index)))++instance (Ord a) => Baseline Interval a++{-| A type to contain followup intervals. See the 'Followup' typeclass for methods+to create values of this type.+-}+newtype FollowupInterval a = MkFollowupInterval (Interval a)+  deriving (Eq, Show, Generic)++instance Functor FollowupInterval where+  fmap f (MkFollowupInterval x) = MkFollowupInterval (fmap f x)++instance (Ord a) => Intervallic FollowupInterval a where+  getInterval (MkFollowupInterval x)   = getInterval x+  setInterval (MkFollowupInterval x) y = MkFollowupInterval (setInterval x y)++{-| +Provides functions for creating a 'FollowupInterval' from an 'Index'. The +'followup' function should satify:++[StartedBy]++  @'IntervalAlgebra.relate' ('followup' d i) i = 'IntervalAlgebra.StartedBy'@++The 'followupMetBy' function should satisfy:++[MetBy]+  +  @'IntervalAlgebra.relate' ('followupMetBy' d i) i = 'IntervalAlgebra.MetBy'@++The 'followupAfter' function should satisfy:++[After]++  @'IntervalAlgebra.relate' ('followupAfter' s d i) i = 'IntervalAlgebra.After'@++>>> import Cohort.Index+>>> import IntervalAlgebra+>>> x = makeIndex (beginerval 1 10)+>>> f = followup 10 x+>>> f+>>> relate f x+MkFollowupInterval (10, 20)+StartedBy++Note the consequence of providing a duration less than or equal to the duration +of the index: a 'IntervalAlgebra.moment' is added to the duration, so that the +end of the 'FollowupInterval' is greater than the end of the 'Index'.++>>> import Cohort.Index+>>> import IntervalAlgebra+>>> x = makeIndex (beginerval 1 10)+>>> f = followup 1 x+>>> f+>>> relate f x+MkFollowupInterval (10, 12)+StartedBy++>>> import Cohort.Index+>>> import IntervalAlgebra+>>> x = makeIndex (beginerval 1 10)+>>> f = followupMetBy 9 x+>>> f+>>> relate f x+MkFollowupInterval (11, 20)+MetBy++>>> import Cohort.Index+>>> import IntervalAlgebra+>>> x = makeIndex (beginerval 1 10)+>>> f = followupAfter 1 9 x+>>> f+>>> relate f x+MkFollowupInterval (12, 21)+After+-}+class Intervallic i a => Followup i a where+  followup :: +    ( IntervalSizeable a b+    , Intervallic i a) => +      b -- ^ duration of followup+    -> Index i a -- ^ the 'Index' event+    -> FollowupInterval a+  followup dur index = MkFollowupInterval (beginerval d2 (begin index))+    where d2 = if dur <= duration index+                 then duration index + moment' index+                 else dur++  followupMetBy :: +    ( IntervalSizeable a b+    , Intervallic i a) => +      b -- ^ duration of followup+    -> Index i a -- ^ the 'Index' event+    -> FollowupInterval a+  followupMetBy dur index = MkFollowupInterval (beginerval dur (end index))++  followupAfter :: +    ( IntervalSizeable a b+    , Intervallic i a) =>+       b -- ^ duration add between the end of index and begin of followup+    -> b -- ^ duration of followup+    -> Index i a -- ^ the 'Index' event+    -> FollowupInterval a+  followupAfter shiftBy dur index = +    MkFollowupInterval $ beginerval dur (end (beginerval shiftBy (end index)))++instance (Ord a) => Followup Interval a++-- | A data type that contains variants of intervals during which assessment+-- may occur.+data AssessmentInterval a =+      Bl (BaselineInterval a) -- ^ holds a 'BaselineInterval'+    | Fl (FollowupInterval a) -- ^ holds a 'FollowupInterval'+    deriving (Eq, Show, Generic)++instance (Ord a) => Intervallic AssessmentInterval a where+  getInterval (Bl x)   = getInterval x+  getInterval (Fl x)   = getInterval x++  setInterval (Bl x) y = Bl (setInterval x y)+  setInterval (Fl x) y = Fl (setInterval x y)++instance Functor AssessmentInterval where+  fmap f (Bl x) = Bl (fmap f x)+  fmap f (Fl x) = Fl (fmap f x)++-- | Creates an 'AssessmentInterval' using the 'baseline' function. +-- +-- >>> import Cohort.Index+-- >>> x = makeIndex $ beginerval 1 10+-- >>> makeBaselineFromIndex 10 x+-- Bl (MkBaselineInterval (0, 10))+--+makeBaselineFromIndex :: +  (Baseline i a, IntervalSizeable a b) => +     b +  -> Index i a+  -> AssessmentInterval a+makeBaselineFromIndex dur index = Bl ( baseline dur index )++-- | Creates an 'AssessmentInterval' using the 'baselineBefore' function. +-- +-- >>> import Cohort.Index+-- >>> x = makeIndex $ beginerval 1 10+-- >>> makeBaselineBeforeIndex 2 10 x+-- Bl (MkBaselineInterval (-2, 8))+--+makeBaselineBeforeIndex :: +  (Baseline i a, IntervalSizeable a b) => +     b+  -> b +  -> Index i a+  -> AssessmentInterval a+makeBaselineBeforeIndex shiftBy dur index = +  Bl ( baselineBefore shiftBy dur index )++-- | Creates an 'AssessmentInterval' using the 'followup' function. +-- +-- >>> import Cohort.Index+-- >>> x = makeIndex $ beginerval 1 10+-- >>> makeFollowupFromIndex 10 x+-- Fl (MkFollowupInterval (10, 20))+--+makeFollowupFromIndex :: +  (Followup i a, IntervalSizeable a b) => +      b+  -> Index i a+  -> AssessmentInterval a+makeFollowupFromIndex dur index = Fl ( followup dur index )++-- | Creates an 'AssessmentInterval' using the 'followupMetBy' function. +-- +-- >>> import Cohort.Index+-- >>> x = makeIndex $ beginerval 1 10+-- >>> makeFollowupMeetingIndex 10 x+-- Fl (MkFollowupInterval (11, 21))+--+makeFollowupMeetingIndex :: +  (Followup i a, IntervalSizeable a b) => +      b+  -> Index i a+  -> AssessmentInterval a+makeFollowupMeetingIndex dur index = Fl ( followupMetBy dur index )++-- | Creates an 'AssessmentInterval' using the 'followupAfter' function. +-- +-- >>> import Cohort.Index+-- >>> x = makeIndex $ beginerval 1 10+-- >>> makeFollowupAfterIndex 10 10 x+-- Fl (MkFollowupInterval (21, 31))+--+makeFollowupAfterIndex :: +  (Followup i a, IntervalSizeable a b) => +     b+  -> b+  -> Index i a+  -> AssessmentInterval a+makeFollowupAfterIndex shiftBy dur index = Fl ( followupAfter shiftBy dur index )
src/Cohort/Criteria.hs view
@@ -106,8 +106,8 @@  -- | 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'@. +-- @'Criterion'@. In the case, that the value of the @'Features.Compose.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)
src/Cohort/Index.hs view
@@ -14,21 +14,29 @@ -- {-# LANGUAGE Safe #-}  module Cohort.Index(-    Index(..)+  {- |+    An 'Index' is an interval of time from which the assessment intervals for an+   observational unit may be derived. Assessment intervals (encoded in the type+   'Cohort.AssessmentInterval') are intervals of time during which features are evaluated. +   -}+    Index   , makeIndex ) where  import GHC.Show                    ( Show ) import GHC.Generics                ( Generic ) import Data.Eq                     ( Eq )-import IntervalAlgebra             ( Intervallic(..) )+import Data.Functor                ( Functor(fmap) )+import Data.Ord                    ( Ord )+import IntervalAlgebra             ( Interval+                                   , Intervallic(..)+                                   ) import Data.Aeson                  ( ToJSON )  {-| An @Index@ is a wrapper for an @Intervallic@ used to indicate that a particular interval is considered an index interval to which other intervals will be compared. -}- newtype Index i a = MkIndex {      getIndex :: i a -- ^ Unwrap an @Index@   } deriving (Eq, Show, Generic)@@ -37,8 +45,12 @@ makeIndex :: Intervallic i a => i a -> Index i a makeIndex = MkIndex +instance (Functor i) => Functor (Index i) where+  fmap f (MkIndex x) = MkIndex (fmap f x)+ instance (Intervallic i a) => Intervallic (Index i) a where   getInterval (MkIndex x) = getInterval x   setInterval (MkIndex x) y = MkIndex (setInterval x y)  instance (Intervallic i a, ToJSON (i a)) => ToJSON (Index i a) +
src/Cohort/Output.hs view
@@ -69,6 +69,7 @@ toJSONCohortShape (ColumnWise x) = toJSON x toJSONCohortShape (RowWise x)    = toJSON x +-- | Provides methods for reshaping a 'Cohort.Cohort' to a 'CohortShape'. class ShapeCohort d where   colWise :: Cohort d -> CohortShape ColumnWise   rowWise :: Cohort d -> CohortShape RowWise
src/EventData.hs view
@@ -9,25 +9,28 @@ {-# OPTIONS_HADDOCK hide #-} {-# LANGUAGE NoImplicitPrelude #-} -module EventData(--    -- * Events-        module EventData.Core+module EventData+  ( -- * Events+    module EventData.Core     -- ** Event Contexts-    , module EventData.Context+  , module EventData.Context     -- ** Event Domains-    , module EventData.Context.Domain+  , module EventData.Context.Domain+    -- ** Predicates+  , module EventData.Predicates+    -- ** Accessing data in Events+  , module EventData.Accessors     -- ** Parsing Events-    , module EventData.Aeson+  , module EventData.Aeson     -- ** Generating arbitrary events-    , module EventData.Arbitrary---) where+  , module EventData.Arbitrary+  ) where -import EventData.Core-import EventData.Context-import EventData.Context.Domain-import EventData.Arbitrary-import EventData.Aeson+import           EventData.Aeson+import           EventData.Arbitrary+import           EventData.Context+import           EventData.Context.Domain+import           EventData.Core+import           EventData.Predicates+import           EventData.Accessors
+ src/EventData/Accessors.hs view
@@ -0,0 +1,97 @@+{-|+Module      : Hasklepias Event accessors+Description : Methods fro accessing data in events.+Copyright   : (c) NoviSci, Inc 2020+License     : BSD3+Maintainer  : bsaul@novisci.com+-}+{-# OPTIONS_HADDOCK hide #-}+{-# LANGUAGE NoImplicitPrelude #-}++module EventData.Accessors+  ( viewBirthYears+  , viewGenders+  , viewStates+  , previewDemoInfo+  , previewBirthYear+  ) where++import           Control.Lens                   ( (^.)+                                                , preview+                                                )+import           Control.Monad                  ( (=<<)+                                                , Functor(fmap)+                                                )+import           Data.Either                    ( either )+import           Data.Foldable                  ( toList )+import           Data.Function                  ( ($)+                                                , (.)+                                                , const+                                                )+import           Data.Functor.Contravariant     ( Predicate(..) )+import           Data.Maybe                     ( Maybe(..) )+import           Data.Ord                       ( Ord )+import           Data.Text                      ( Text )+import           Data.Text.Read                 ( rational )+import           Data.Time.Calendar             ( Day+                                                , DayOfMonth+                                                , MonthOfYear+                                                , Year+                                                , diffDays+                                                , toGregorian+                                                )+import           Data.Tuple                     ( fst )+import           EventData.Context              ( Concepts+                                                , Context(..)+                                                , Source+                                                , facts+                                                , hasConcepts+                                                )+import           EventData.Context.Domain       ( Domain+                                                , _Demographics+                                                , demo+                                                , info+                                                )+import           EventData.Core                 ( Event+                                                , ctxt+                                                )+import           EventData.Predicates           ( isBirthYearEvent+                                                , isGenderFactEvent+                                                , isStateFactEvent+                                                )+import           GHC.Num                        ( Integer+                                                , fromInteger+                                                )+import           GHC.Real                       ( RealFrac(floor) )+import           Witherable                     ( Filterable(filter, mapMaybe)+                                                , Witherable+                                                )++-- | Preview demographics information from a domain+previewDemoInfo :: Domain -> Maybe Text+previewDemoInfo dmn = (^. demo . info) =<< preview _Demographics dmn++-- | 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 =<< previewDemoInfo dmn++-- | Returns a (possibly empty) list of birth years from a set of events+viewBirthYears :: (Witherable f) => f (Event a) -> [Year]+viewBirthYears x = mapMaybe+  (\e -> previewBirthYear =<< Just (ctxt e ^. facts))+  (toList $ filter (getPredicate isBirthYearEvent) x)++-- | Returns a (possibly empty) list of Gender values from a set of events+viewGenders :: (Witherable f) => f (Event a) -> [Text]+viewGenders x = mapMaybe (\e -> previewDemoInfo =<< Just (ctxt e ^. facts))+                         (toList $ filter (getPredicate isGenderFactEvent) x)++-- | Returns a (possibly empty) list of Gender values from a set of events+viewStates :: (Witherable f) => f (Event a) -> [Text]+viewStates x = mapMaybe (\e -> previewDemoInfo =<< Just (ctxt e ^. facts))+                        (toList $ filter (getPredicate isStateFactEvent) x)
src/EventData/Aeson.hs view
@@ -12,92 +12,115 @@ {-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE ScopedTypeVariables #-} -module EventData.Aeson(-      parseEventIntLines-    , parseEventDayLines-) where+module EventData.Aeson+  ( parseEventIntLines+  , parseEventDayLines+  ) where -import IntervalAlgebra                      ( beginerval-                                            , parseInterval-                                            , Interval-                                            , IntervalSizeable(add, diff, moment) )-import EventData.Context                    ( Concepts-                                            , Concept-                                            , Context-                                            , context-                                            , packConcept-                                            , toConcepts )-import EventData.Core                       ( Event, event )-import EventData.Context.Domain-import Prelude                              ( (<$>), (<*>), ($)-                                            , fmap, pure, id-                                            , Int, String, Ord, Show)-import Data.Aeson                           ( eitherDecode-                                            , (.:), (.:?)-                                            , withObject-                                            , FromJSON(parseJSON)-                                            , Value(Array) )-import Data.Either                          ( Either(..), 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 Control.Monad+import           Control.Monad+import           Data.Aeson                     ( (.:)+                                                , (.:?)+                                                , FromJSON(parseJSON)+                                                , Value(Array)+                                                , eitherDecode+                                                , withObject+                                                )+import qualified Data.ByteString.Char8         as C+import qualified Data.ByteString.Lazy          as B+import           Data.Either                    ( Either(..)+                                                , either+                                                , partitionEithers+                                                )+import           Data.Maybe                     ( fromMaybe )+import           Data.Text                      ( Text )+import           Data.Time                      ( Day )+import           Data.Vector                    ( (!) )+import           EventData.Context              ( Concept+                                                , Concepts+                                                , Context+                                                , context+                                                , packConcept+                                                , toConcepts+                                                )+import           EventData.Context.Domain+import           EventData.Core                 ( Event+                                                , event+                                                )+import           IntervalAlgebra                ( Interval+                                                , IntervalSizeable+                                                  ( add+                                                  , diff+                                                  , moment+                                                  )+                                                , beginerval+                                                , parseInterval+                                                )+import           Prelude                        ( ($)+                                                , (<$>)+                                                , (<*>)+                                                , Int+                                                , Ord+                                                , Show+                                                , String+                                                , fmap+                                                , id+                                                , pure+                                                )  instance (FromJSON a, Show a, IntervalSizeable a b) => FromJSON (Interval a) where-    parseJSON = withObject "Time" $ \o -> do-        t <- o .: "time"-        b <- t .: "begin"-        e <- t .:? "end"-        -- In the case that the end is missing, create a moment-        let e2 = fromMaybe (add (moment @a) b) e-        let ei = parseInterval b e2-        case ei of-            Left e  -> fail e-            Right i -> return i+  parseJSON = withObject "Time" $ \o -> do+    t <- o .: "time"+    b <- t .: "begin"+    e <- t .:? "end"+    -- In the case that the end is missing, create a moment+    let e2 = fromMaybe (add (moment @a) b) e+    let ei = parseInterval b e2+    case ei of+      Left  e -> fail e+      Right i -> return i  instance FromJSON Domain where-    parseJSON = withObject "Domain" $ \o -> do-        domain :: Text <- o .: "domain"-        case domain of-            "Demographics" -> Demographics <$> o .: "facts"-            "Enrollment"   -> pure $ Enrollment (EnrollmentFacts () )  -            _              -> pure (UnimplementedDomain ())+  parseJSON = withObject "Domain" $ \o -> do+    domain :: Text <- o .: "domain"+    case domain of+      "Demographics" -> Demographics <$> o .: "facts"+      "Enrollment"   -> pure $ Enrollment (EnrollmentFacts ())+      _              -> pure (UnimplementedDomain ())  instance FromJSON Concept where-    parseJSON c = packConcept <$> parseJSON  c+  parseJSON c = packConcept <$> parseJSON c  instance FromJSON Concepts where-    parseJSON c = toConcepts <$> parseJSON c+  parseJSON c = toConcepts <$> parseJSON c  instance FromJSON Context where-    parseJSON (Array v) =-        context <$>-            parseJSON (v ! 5) <*>-            parseJSON (v ! 4)+  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 (Array v)  -- |  Parse @Event Int@ from json lines.-parseEventLines :: (FromJSON a, Show a, IntervalSizeable a b) =>-    B.ByteString -> ([String], [Event a])-parseEventLines l =-    partitionEithers $ fmap-    (\x -> eitherDecode $ B.fromStrict x :: (FromJSON a, Show a, IntervalSizeable a b) =>  Either String (Event a))-        (C.lines $ B.toStrict l)+parseEventLines+  :: (FromJSON a, Show a, IntervalSizeable a b)+  => B.ByteString+  -> ([String], [Event a])+parseEventLines l = partitionEithers $ fmap+  (\x ->+    eitherDecode $ B.fromStrict x :: (FromJSON a, Show a, IntervalSizeable a b)+      => Either String (Event a)+  )+  (C.lines $ B.toStrict l)  -- |  Parse @Event Int@ from json lines.-parseEventIntLines :: (FromJSON a, Show a, IntervalSizeable a b) =>-    B.ByteString -> ([String], [Event a])+parseEventIntLines+  :: (FromJSON a, Show a, IntervalSizeable a b)+  => B.ByteString+  -> ([String], [Event a]) parseEventIntLines = parseEventLines  -- |  Parse @Event Day@ from json lines.-parseEventDayLines :: (FromJSON a, Show a, IntervalSizeable a b) =>-    B.ByteString -> ([String], [Event a])+parseEventDayLines+  :: (FromJSON a, Show a, IntervalSizeable a b)+  => B.ByteString+  -> ([String], [Event a]) parseEventDayLines = parseEventLines
src/EventData/Arbitrary.hs view
@@ -10,39 +10,45 @@ {-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE FlexibleContexts #-}-module EventData.Arbitrary(-     generateEventsInt-) where+module EventData.Arbitrary+  ( generateEventsInt+  ) where -import Test.QuickCheck (-    Arbitrary(arbitrary, shrink)-    , Gen-    , sample'-    , sample-    , generate-    , resize-    , suchThat -    , orderedList  )-import GHC.Show ( Show )-import GHC.IO ( IO )-import Control.Monad ( Functor(fmap), liftM2 )-import Data.Eq ( Eq((==)) )-import Data.Function (($))-import Data.Int ( Int )-import Data.Ord ( Ord )-import Data.List(length)-import IntervalAlgebra ( Interval )-import IntervalAlgebra.Arbitrary ()-import EventData.Core ( event, Event, ConceptEvent, toConceptEvent )-import EventData.Context.Arbitrary ()+import           Control.Monad                  ( Functor(fmap)+                                                , liftM2+                                                )+import           Data.Eq                        ( Eq((==)) )+import           Data.Function                  ( ($) )+import           Data.Int                       ( Int )+import           Data.List                      ( length )+import           Data.Ord                       ( Ord )+import           EventData.Context.Arbitrary    ( )+import           EventData.Core                 ( ConceptEvent+                                                , Event+                                                , event+                                                , toConceptEvent+                                                )+import           GHC.IO                         ( IO )+import           GHC.Show                       ( Show )+import           IntervalAlgebra                ( Interval )+import           IntervalAlgebra.Arbitrary      ( )+import           Test.QuickCheck                ( Arbitrary(arbitrary, shrink)+                                                , Gen+                                                , generate+                                                , orderedList+                                                , resize+                                                , sample+                                                , sample'+                                                , suchThat+                                                )  instance (Arbitrary (Interval a)) => Arbitrary (Event a) where-    arbitrary = liftM2 event arbitrary arbitrary+  arbitrary = liftM2 event arbitrary arbitrary  instance (Ord a, Show a, Arbitrary (Interval a)) => Arbitrary (ConceptEvent a) where-    arbitrary = fmap toConceptEvent arbitrary+  arbitrary = fmap toConceptEvent arbitrary  -- | Generate @n@ @Event Int@ generateEventsInt :: Int -> IO [Event Int]-generateEventsInt i = -    generate $ suchThat (orderedList :: Gen [Event Int]) (\x -> length x == i)+generateEventsInt i =+  generate $ suchThat (orderedList :: Gen [Event Int]) (\x -> length x == i)
src/EventData/Context.hs view
@@ -12,13 +12,12 @@ -- {-# LANGUAGE Safe #-} {-# LANGUAGE TemplateHaskell #-} -module EventData.Context(-    Context(..)+module EventData.Context+  ( Context(..)   , concepts   , facts   , source   , context-   , Concept   , Concepts   , toConcepts@@ -28,38 +27,54 @@   , packConcepts   , unpackConcepts   , HasConcept(..)-) where+  , Source+  ) where -import Control.Lens             ( makeLenses )-import GHC.Show                 ( Show(show) )-import Data.Bool                ( Bool )-import Data.Eq                  ( Eq )-import Data.Function            ( (.), ($) )-import Data.List                ( all, any, map )-import Data.Maybe               ( Maybe(Nothing) )-import Data.Monoid              ( (<>), Monoid(mempty) )-import Data.Ord                 ( Ord )-import Data.Semigroup           ( Semigroup((<>)) )-import Data.Text                ( Text )-import Data.Set                 ( Set-                                , fromList, union, empty, map, toList, member)-import EventData.Context.Domain ( Domain )+import           Control.Lens                   ( makeLenses )+import           Data.Bool                      ( Bool )+import           Data.Eq                        ( Eq )+import           Data.Function                  ( ($)+                                                , (.)+                                                )+import           Data.List                      ( all+                                                , any+                                                , map+                                                )+import           Data.Maybe                     ( Maybe(Nothing) )+import           Data.Monoid                    ( (<>)+                                                , Monoid(mempty)+                                                )+import           Data.Ord                       ( Ord )+import           Data.Semigroup                 ( Semigroup((<>)) )+import           Data.Set                       ( Set+                                                , empty+                                                , fromList+                                                , map+                                                , member+                                                , toList+                                                , union+                                                )+import           Data.Text                      ( Text )+import           EventData.Context.Domain       ( Domain )+import           GHC.Show                       ( Show(show) )  -- | A @Context@ consists of three parts: @concepts@, @facts@, and @source@.  --  -- At this time, @facts@ and @source@ are simply stubs to be fleshed out in  -- later versions of hasklepias. -data Context = Context {-      _concepts :: Concepts-    , _facts    :: Domain-    , _source   :: Maybe Source-} deriving (Eq, Show)+data Context = Context+  { _concepts :: Concepts+  , _facts    :: Domain+  , _source   :: Maybe Source+  }+  deriving (Eq, Show) -data Source = Source deriving (Eq, Show)+data Source = Source+  deriving (Eq, Show)  instance HasConcept Context where-    hasConcept ctxt concept = -        member (packConcept concept) (getConcepts $ _concepts ctxt)+  hasConcept ctxt concept =+    member (packConcept concept) (getConcepts $ _concepts ctxt)  -- | Smart contructor for Context type --@@ -72,25 +87,29 @@ newtype Concept = Concept Text deriving (Eq, Ord)  instance Show Concept where-    show (Concept x) = show x+  show (Concept x) = show x  -- | Pack text into a concept packConcept :: Text -> Concept packConcept = Concept  -- | Unpack text from a concept-unpackConcept :: Concept -> Text -unpackConcept (Concept x) =  x+unpackConcept :: Concept -> Text+unpackConcept (Concept x) = x  -- | @Concepts@ is a 'Set' of 'Concept's.-newtype Concepts = Concepts { getConcepts :: Set Concept }+newtype Concepts = Concepts ( Set Concept )     deriving (Eq, Show) +-- | Unwrap the `Concepts' newtype.+getConcepts :: Concepts -> Set Concept+getConcepts (Concepts x) = x+ instance Semigroup Concepts where-    Concepts x <> Concepts y = Concepts (x <> y)+  Concepts x <> Concepts y = Concepts (x <> y)  instance Monoid Concepts where-    mempty = Concepts mempty+  mempty = Concepts mempty  -- | Constructor for 'Concepts'. toConcepts :: Set Concept -> Concepts@@ -102,7 +121,7 @@  -- | Take a set of concepts to a list of text. unpackConcepts :: Concepts -> [Text]-unpackConcepts (Concepts x) = toList $ Data.Set.map unpackConcept x +unpackConcepts (Concepts x) = toList $ Data.Set.map unpackConcept x  {- | The 'HasConcept' typeclass provides predicate functions for determining whether@@ -118,9 +137,9 @@      -- | Does an @a@ have *all* of a list of `Concept's?     hasAllConcepts :: a -> [Text] -> Bool-    hasAllConcepts x = all (\c -> x `hasConcept` c) +    hasAllConcepts x = all (\c -> x `hasConcept` c)  instance HasConcept Concepts where-    hasConcept (Concepts e) concept = member (packConcept concept) e+  hasConcept (Concepts e) concept = member (packConcept concept) e  makeLenses ''Context
src/EventData/Core.hs view
@@ -12,43 +12,46 @@ {-# LANGUAGE FlexibleInstances #-} -- {-# LANGUAGE Safe #-} -module EventData.Core(-- -- * Events-   Event- , Events- , ConceptEvent- , event- , ctxt- , toConceptEvent- , toConceptEventOf- , mkConceptEvent-) where+module EventData.Core+  ( Event+  , Events+  , ConceptEvent+  , event+  , ctxt+  , toConceptEvent+  , toConceptEventOf+  , mkConceptEvent+  ) where -import GHC.Show                         ( Show(show) )-import Data.Function                    ( ($) )-import Data.Set                         ( member, fromList, intersection )-import Data.Ord                         ( Ord )-import IntervalAlgebra                  ( Interval-                                        , Intervallic-                                        , Intervallic (getInterval) )-import IntervalAlgebra.PairedInterval   ( PairedInterval-                                        , makePairedInterval-                                        , getPairData )-import EventData.Context                ( HasConcept(..)-                                        , Concepts-                                        , Concept-                                        , packConcept-                                        , Context(..)-                                        , getConcepts-                                        , toConcepts )+import           Data.Function                  ( ($) )+import           Data.Ord                       ( Ord )+import           Data.Set                       ( fromList+                                                , intersection+                                                , member+                                                )+import           EventData.Context              ( Concept+                                                , Concepts+                                                , Context(..)+                                                , HasConcept(..)+                                                , getConcepts+                                                , packConcept+                                                , toConcepts+                                                )+import           GHC.Show                       ( Show(show) )+import           IntervalAlgebra                ( Interval+                                                , Intervallic(getInterval)+                                                )+import           IntervalAlgebra.PairedInterval ( PairedInterval+                                                , getPairData+                                                , makePairedInterval+                                                )   -- | An Event @a@ is simply a pair @(Interval a, Context)@. type Event a = PairedInterval Context a  instance HasConcept (Event a) where-    hasConcept x y = ctxt x `hasConcept` y+  hasConcept x y = ctxt x `hasConcept` y  -- | A smart constructor for 'Event a's. event :: Interval a -> Context -> Event a@@ -62,7 +65,8 @@ type ConceptEvent a = PairedInterval Concepts a  instance HasConcept (ConceptEvent a) where-    hasConcept e concept = member (packConcept concept) (getConcepts $ 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.@@ -73,10 +77,9 @@ -- 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) (getConcepts $ _concepts $ ctxt e))-        (getInterval e)+toConceptEventOf cpts e = makePairedInterval+  (toConcepts $ intersection (fromList cpts) (getConcepts $ _concepts $ ctxt e))+  (getInterval e)  -- | Create a new @'ConceptEvent'@. mkConceptEvent :: (Show a, Ord a) => Interval a -> Concepts -> ConceptEvent a
+ src/EventData/Predicates.hs view
@@ -0,0 +1,130 @@+{-|+Module      : Hasklepias Event Type+Description : Defines the Event type and its component types, constructors, +              and class instance+Copyright   : (c) NoviSci, Inc 2020+License     : BSD3+Maintainer  : bsaul@novisci.com+-}+{-# OPTIONS_HADDOCK hide #-}+{-# LANGUAGE NoImplicitPrelude #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}+-- {-# LANGUAGE Safe #-}++module EventData.Predicates+  ( isEnrollmentEvent+  , isStateFactEvent+  , isGenderFactEvent+  , isBirthYearEvent+  , containsConcepts+  , Predicatable(..)+  ) where++import           Data.Bool                      ( (&&)+                                                , Bool(..)+                                                , (||)+                                                )+import           Data.Function                  ( (.) )+import           Data.Functor.Contravariant     ( Contravariant(contramap)+                                                , Predicate(..)+                                                )+import           Data.Maybe                     ( Maybe )+import           Data.Ord                       ( Ord )+import           Data.Text                      ( Text )+import           EventData.Context              ( Concepts+                                                , Context(..)+                                                , Source+                                                , hasConcepts+                                                )+import           EventData.Context.Domain       ( Domain(..) )+import           EventData.Context.Domain.Demographics+import           EventData.Core                 ( Event+                                                , ctxt+                                                )+import           IntervalAlgebra                ( Interval+                                                , Intervallic(getInterval)+                                                )++{- |+  Provides methods for composing predicate functions (i.e. @a -> Bool@) or +  'Predicate's by conjunction or disjunction.+-}+class Predicatable a where+  (|||) :: a -> a -> a+  (&&&) :: a -> a -> a++instance Predicatable (a -> Bool) where+  (|||) f g = \x -> f x || g x+  (&&&) f g = \x -> f x && g x++instance Predicatable (Predicate a) where+  (|||) p1 p2 = Predicate (getPredicate p1 ||| getPredicate p2)+  (&&&) p1 p2 = Predicate (getPredicate p1 &&& getPredicate p2)++{- |+  Provides a common interface to lift a 'Predicate' on a component of an 'Event'+  to a 'Predicate (Event a)'.+-}+class EventPredicate element a where+  liftToEventPredicate :: Predicate element -> Predicate (Event a)++instance EventPredicate Context a where+  liftToEventPredicate = contramap ctxt++instance EventPredicate Domain a where+  liftToEventPredicate = contramap (_facts . ctxt)++instance EventPredicate Concepts a where+  liftToEventPredicate = contramap (_concepts . ctxt)++instance EventPredicate (Maybe Source) a where+  liftToEventPredicate = contramap (_source . ctxt)++instance (Ord a) => EventPredicate (Interval a) a where+  liftToEventPredicate = contramap getInterval++{----------- Predicates  -----------------}++-- | Predicate for State facts+isEnrollmentDomain :: Domain -> Bool+isEnrollmentDomain (Enrollment _) = True+isEnrollmentDomain _              = False++-- | Predicate for enrollment events+isEnrollmentEvent :: Predicate (Event a)+isEnrollmentEvent = liftToEventPredicate (Predicate isEnrollmentDomain)++-- | Predicate for Birth Year facts+isBirthYear :: Domain -> Bool+isBirthYear (Demographics (DemographicsFacts (DemographicsInfo BirthYear _))) =+  True+isBirthYear _ = False++-- | Predicate for events containing Birth Year facts+isBirthYearEvent :: Predicate (Event a)+isBirthYearEvent = liftToEventPredicate (Predicate isBirthYear)++-- | Predicate for Gender facts+isGenderFact :: Domain -> Bool+isGenderFact (Demographics (DemographicsFacts (DemographicsInfo Gender _))) =+  True+isGenderFact _ = False++-- | Predicate for events containing Gender facts+isGenderFactEvent :: Predicate (Event a)+isGenderFactEvent = liftToEventPredicate (Predicate isGenderFact)++-- | Predicate for State facts+isStateFact :: Domain -> Bool+isStateFact (Demographics (DemographicsFacts (DemographicsInfo State _))) =+  True+isStateFact _ = False++-- | Predicate for events containing  State facts+isStateFactEvent :: Predicate (Event a)+isStateFactEvent = liftToEventPredicate (Predicate isStateFact)++-- | Creates a predicate to check that an 'Event' contains a set of 'EventData.Context.Concept's. +containsConcepts :: [Text] -> Predicate (Event a)+containsConcepts cpt = Predicate (`hasConcepts` cpt)
src/Features.hs view
@@ -9,9 +9,10 @@ -} {-# OPTIONS_HADDOCK hide #-} -module Features(+module Features+  ( -  -- ** Defining and evaluating Features+  -- ** Creating Features     module Features.Compose    -- ** Adding Attributes to Features@@ -21,10 +22,10 @@   , module Features.Featureable   , module Features.Featureset   , module Features.Output-) where+  ) where -import Features.Compose-import Features.Attributes-import Features.Featureable-import Features.Featureset-import Features.Output+import           Features.Attributes+import           Features.Compose+import           Features.Featureable+import           Features.Featureset+import           Features.Output
src/Features/Attributes.hs view
@@ -50,7 +50,7 @@  } deriving (Eq, Show, Generic)  {- |-A data type for holding attritbutes of Features. This type and the @HasAttributes@+A data type for holding attritbutes of Features. This type and the @'HasAttributes'@ are likely to change in future versions. -} data Attributes = MkAttributes {
src/Features/Compose.hs view
@@ -25,8 +25,9 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE InstanceSigs #-} -module Features.Compose(-  -- * Features and FeatureData+module Features.Compose+  (+  -- *** Features and FeatureData     FeatureData   , MissingReason(..)   , Feature@@ -42,32 +43,54 @@   , getNameN   , nameFeature -  -- * Defining and evaluating Features+  -- *** Feature Definitions   , Definition(..)   , Define(..)   , DefineA(..)-  , Eval-  , eval -  -- , HasAttributes(..)-) where+  --- *** Evalution of Definitions+  , Eval(..) -import safe Control.Applicative        ( Applicative(..)-                                        , liftA3, (<$>) )-import safe Control.Monad              ( Functor(..), Monad(..)-                                       , (=<<), join, liftM, liftM2, liftM3, liftM4)-import safe Data.Either                ( Either(..) )-import safe Data.Eq                    ( Eq(..) )-import safe Data.Foldable              ( Foldable(foldr), fold )-import safe Data.Function              ( ($), (.), id )-import safe Data.List                  ( (++), transpose, concat )-import safe Data.Proxy                 ( Proxy(..) )-import safe Data.Text                  ( Text, pack )-import safe Data.Traversable           ( Traversable(..) )-import safe GHC.Generics               ( Generic )-import safe GHC.Show                   ( Show(show) )-import safe GHC.TypeLits               ( KnownSymbol, Symbol, symbolVal )+  ) where +import safe      Control.Applicative            ( (<$>)+                                                , Applicative(..)+                                                , liftA3+                                                )+import safe      Control.Monad                  ( (=<<)+                                                , Functor(..)+                                                , Monad(..)+                                                , join+                                                , liftM+                                                , liftM2+                                                , liftM3+                                                , liftM4+                                                )+import safe      Data.Either                    ( Either(..) )+import safe      Data.Eq                        ( Eq(..) )+import safe      Data.Foldable                  ( Foldable(foldr)+                                                , fold+                                                )+import safe      Data.Function                  ( ($)+                                                , (.)+                                                , id+                                                )+import safe      Data.List                      ( (++)+                                                , concat+                                                , transpose+                                                )+import safe      Data.Proxy                     ( Proxy(..) )+import safe      Data.Text                      ( Text+                                                , pack+                                                )+import safe      Data.Traversable               ( Traversable(..) )+import safe      GHC.Generics                   ( Generic )+import safe      GHC.Show                       ( Show(show) )+import safe      GHC.TypeLits                   ( KnownSymbol+                                                , Symbol+                                                , symbolVal+                                                )+ {- |  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@@ -155,10 +178,9 @@   liftA2 f (MkFeatureData x) (MkFeatureData y) = MkFeatureData (liftA2 f x y)  instance Monad FeatureData where-  (MkFeatureData x) >>= f =-      case fmap f x of-         Left l  -> MkFeatureData $ Left l-         Right v -> v+  (MkFeatureData x) >>= f = case fmap f x of+    Left  l -> MkFeatureData $ Left l+    Right v -> v  instance Foldable FeatureData where   foldr f x (MkFeatureData z) = foldr f x z@@ -176,10 +198,14 @@ -} {- tag::feature[] -} newtype (KnownSymbol name) => Feature name d =-  MkFeature { getFData :: FeatureData d }+  MkFeature  ( FeatureData d ) {- end::feature[] -}   deriving (Eq) +-- | Gets the 'FeatureData' from a 'Feature'.+getFData :: Feature name d -> FeatureData d+getFData (MkFeature d) = d+ -- | A utility for constructing a @'Feature'@ from @'FeatureData'@. -- Since @name@ is a type, you may need to annotate the type when using this -- function.@@ -212,23 +238,24 @@   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+  (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)+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+  :: 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@@ -250,16 +277,15 @@ See @'eval'@ for evaluating @Defintions@.   -}- data Definition d where-  D1  :: (b -> a) -> Definition (f1 b -> f0 a)-  D1A :: (b -> f0 a) -> Definition (f1 b -> f0 a)-  D2  :: (c -> b -> a) -> Definition (f2 c -> f1 b -> f0 a)-  D2A :: (c -> b -> f0 a) -> Definition (f2 c -> f1 b -> f0 a)-  D3  :: (d -> c -> b -> a) -> Definition (f3 d -> f2 c -> f1 b -> f0 a)-  D3A :: (d -> c -> b -> f0 a) -> Definition (f3 d -> f2 c -> f1 b -> f0 a)-  D4  :: (e -> d -> c -> b -> a) -> Definition (f4 e -> f3 d -> f2 c -> f1 b -> f0 a) -  D4A :: (e -> d -> c -> b -> f0 a) -> Definition (f4 e -> f3 d -> f2 c -> f1 b -> f0 a) +  D1  ::(b -> a) -> Definition (f1 b -> f0 a)+  D1A ::(b -> f0 a) -> Definition (f1 b -> f0 a)+  D2  ::(c -> b -> a) -> Definition (f2 c -> f1 b -> f0 a)+  D2A ::(c -> b -> f0 a) -> Definition (f2 c -> f1 b -> f0 a)+  D3  ::(d -> c -> b -> a) -> Definition (f3 d -> f2 c -> f1 b -> f0 a)+  D3A ::(d -> c -> b -> f0 a) -> Definition (f3 d -> f2 c -> f1 b -> f0 a)+  D4  ::(e -> d -> c -> b -> a) -> Definition (f4 e -> f3 d -> f2 c -> f1 b -> f0 a)+  D4A ::(e -> d -> c -> b -> f0 a) -> Definition (f4 e -> f3 d -> f2 c -> f1 b -> f0 a)  {- | Define (and @'DefineA@) provide a means to create new @'Definition'@s via  @'define'@ (@'defineA'@). The @'define'@ function takes a single function input @@ -298,25 +324,41 @@ class DefineA inputs def | def -> inputs where   defineA :: inputs -> Definition def -instance Define (b -> a) (FeatureData b -> FeatureData a) where define = D1-instance Define (c -> b -> a) (FeatureData c -> FeatureData b -> FeatureData a) where define = D2-instance Define (d -> c -> b -> a) (FeatureData d -> FeatureData c -> FeatureData b -> FeatureData a) where define = D3-instance Define (e -> d -> c -> b -> a) (FeatureData e -> FeatureData d -> FeatureData c -> FeatureData b -> FeatureData a) where define = D4+instance Define (b -> a) (FeatureData b -> FeatureData a) where+  define = D1+instance Define (c -> b -> a) (FeatureData c -> FeatureData b -> FeatureData a) where+  define = D2+instance Define (d -> c -> b -> a) (FeatureData d -> FeatureData c -> FeatureData b -> FeatureData a) where+  define = D3+instance Define (e -> d -> c -> b -> a) (FeatureData e -> FeatureData d -> FeatureData c -> FeatureData b -> FeatureData a) where+  define = D4 -instance DefineA (b -> FeatureData a) (FeatureData b -> FeatureData a) where defineA = D1A-instance DefineA (c -> b -> FeatureData a) (FeatureData c -> FeatureData b -> FeatureData a) where defineA = D2A-instance DefineA (d -> c -> b -> FeatureData a) (FeatureData d -> FeatureData c -> FeatureData b -> FeatureData a) where defineA = D3A-instance DefineA (e -> d -> c -> b -> FeatureData a) (FeatureData e -> FeatureData d -> FeatureData c -> FeatureData b -> FeatureData a) where defineA = D4A+instance DefineA (b -> FeatureData a) (FeatureData b -> FeatureData a) where+  defineA = D1A+instance DefineA (c -> b -> FeatureData a) (FeatureData c -> FeatureData b -> FeatureData a) where+  defineA = D2A+instance DefineA (d -> c -> b -> FeatureData a) (FeatureData d -> FeatureData c -> FeatureData b -> FeatureData a) where+  defineA = D3A+instance DefineA (e -> d -> c -> b -> FeatureData a) (FeatureData e -> FeatureData d -> FeatureData c -> FeatureData b -> FeatureData a) where+  defineA = D4A -instance Define (b -> a) (Feature n1 b -> Feature n0 a) where define = D1-instance Define (c -> b -> a) (Feature n2 c -> Feature n1 b -> Feature n0 a) where define = D2-instance Define (d -> c -> b -> a) (Feature n3 d -> Feature n2 c -> Feature n1 b -> Feature n0 a) where define = D3-instance Define (e -> d -> c -> b -> a) (Feature n4 e -> Feature n3 d -> Feature n2 c -> Feature n1 b -> Feature n0 a) where define = D4+instance Define (b -> a) (Feature n1 b -> Feature n0 a) where+  define = D1+instance Define (c -> b -> a) (Feature n2 c -> Feature n1 b -> Feature n0 a) where+  define = D2+instance Define (d -> c -> b -> a) (Feature n3 d -> Feature n2 c -> Feature n1 b -> Feature n0 a) where+  define = D3+instance Define (e -> d -> c -> b -> a) (Feature n4 e -> Feature n3 d -> Feature n2 c -> Feature n1 b -> Feature n0 a) where+  define = D4 -instance DefineA (b -> Feature n0 a) (Feature n1 b -> Feature n0 a) where defineA = D1A-instance DefineA (c -> b -> Feature n0 a) (Feature n2 c -> Feature n1 b -> Feature n0 a) where defineA = D2A-instance DefineA (d -> c -> b -> Feature n0 a) (Feature n3 d -> Feature n2 c -> Feature n1 b -> Feature n0 a) where defineA = D3A-instance DefineA (e -> d -> c -> b -> Feature n0 a) (Feature n4 e -> Feature n3 d -> Feature n2 c -> Feature n1 b -> Feature n0 a) where defineA = D4A+instance DefineA (b -> Feature n0 a) (Feature n1 b -> Feature n0 a) where+  defineA = D1A+instance DefineA (c -> b -> Feature n0 a) (Feature n2 c -> Feature n1 b -> Feature n0 a) where+  defineA = D2A+instance DefineA (d -> c -> b -> Feature n0 a) (Feature n3 d -> Feature n2 c -> Feature n1 b -> Feature n0 a) where+  defineA = D3A+instance DefineA (e -> d -> c -> b -> Feature n0 a) (Feature n4 e -> Feature n3 d -> Feature n2 c -> Feature n1 b -> Feature n0 a) where+  defineA = D4A   {- | Evaluate a @Definition@. Note that (currently), the second argument of 'eval'@@ -348,55 +390,54 @@  instance Eval (FeatureData b -> FeatureData a)               (FeatureData b)  (FeatureData a) where-  eval (D1 f)  x = fmap f x+  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+  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 (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+  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 (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+  eval (D3 f) (MkFeature x, MkFeature y, MkFeature z) =+    MkFeature $ liftA3 f x y z+  eval (D3A f) (MkFeature x, MkFeature y, MkFeature z) = case liftA3 f x y z of+    MkFeatureData (Left  l) -> MkFeature $ MkFeatureData (Left l)+    MkFeatureData (Right r) -> r  instance Eval (Feature n4 e -> Feature n3 d -> Feature n2 c -> Feature n1 b -> Feature n0 a)               (Feature n4 e,   Feature n3 d,   Feature n2 c,   Feature n1 b)  (Feature n0 a)    where-  eval (D4 f)  (MkFeature v, MkFeature x, MkFeature y, MkFeature z) = MkFeature $ liftM4 f v x y z+  eval (D4 f) (MkFeature v, MkFeature x, MkFeature y, MkFeature z) =+    MkFeature $ liftM4 f v x y z   eval (D4A f) (MkFeature v, MkFeature x, MkFeature y, MkFeature z) =-      case liftM4 f v x y z of-          MkFeatureData (Left l)  -> MkFeature $ MkFeatureData (Left l)-          MkFeatureData (Right r) -> r+    case liftM4 f v x y z of+      MkFeatureData (Left  l) -> MkFeature $ MkFeatureData (Left l)+      MkFeatureData (Right r) -> r  {- | Initializes @Feature@ @Attributes@ to empty strings -}
src/Features/Featureable.hs view
@@ -26,7 +26,7 @@ import Data.Typeable                  ( Typeable )  {- | Existential type to hold features, which allows for Features to be put-into a heterogeneous list.+into a homogeneous list. -} data Featureable = forall d . (Show d, ToJSON d, ShapeOutput d) => MkFeatureable d  Attributes
src/Features/Featureset.hs view
@@ -52,6 +52,7 @@ instance ToJSON Featureset where   toJSON (MkFeatureset x) = toJSON x +-- | A newtype wrapper for a 'NE.NonEmpty' 'Featureset'. newtype FeaturesetList = MkFeaturesetList (NE.NonEmpty Featureset)    deriving (Show)
src/Features/Output.hs view
@@ -64,6 +64,7 @@   NameData :: (ToJSON a, Show a) => a -> OutputShape b   NameAttr :: (ToJSON a, Show a) => a -> OutputShape b  +-- | A class that provides methods for transforming some type to an 'OutputShape'. class (ToJSON a) => ShapeOutput a where   dataOnly :: a -> OutputShape b   nameOnly :: a -> OutputShape b
src/Hasklepias.hs view
@@ -9,12 +9,19 @@ See the examples folder and manual for further documentation. -} -module Hasklepias (-      module EventData-    +module Hasklepias+  ( module EventData+     -- * Working with Features-    , module Features+  , module Features +    -- * Feature definition builders +    {- | +    A collection of pre-defined functions which build common feature definitions+    used in epidemiologic cohorts.+    -}++  , module Hasklepias.Templates     -- * Utilities for defining Features from Events     {- |     Much of logic needed to define features from events depends on the @@ -23,41 +30,38 @@     can be found on [hackage](https://hackage.haskell.org/package/interval-algebra).      -}-    , module Hasklepias.FeatureEvents-    , module Hasklepias.Misc-    -    -- ** Feature definition templates-    , module Hasklepias.Templates-    +  , module Hasklepias.FeatureEvents+  , module Hasklepias.Misc+     -- * Specifying and building cohorts-    , module Cohort+  , module Cohort      -- ** Creating an executable cohort application-    , module Hasklepias.MakeApp+  , module Hasklepias.MakeApp      -- * Statistical Types-    , module Stype+  , module Stype      -- * Rexported Functions and modules-    , module Hasklepias.Reexports-    , module Hasklepias.ReexportsUnsafe-) where+  , module Hasklepias.Reexports+  , module Hasklepias.ReexportsUnsafe+  ) where -import EventData+import           EventData -import IntervalAlgebra-import IntervalAlgebra.IntervalUtilities-import IntervalAlgebra.PairedInterval+import           IntervalAlgebra+import           IntervalAlgebra.IntervalUtilities+import           IntervalAlgebra.PairedInterval -import Features+import           Features -import Cohort+import           Cohort -import Hasklepias.FeatureEvents-import Hasklepias.Misc-import Hasklepias.Reexports-import Hasklepias.ReexportsUnsafe-import Hasklepias.MakeApp-import Hasklepias.Templates+import           Hasklepias.FeatureEvents+import           Hasklepias.MakeApp+import           Hasklepias.Misc+import           Hasklepias.Reexports+import           Hasklepias.ReexportsUnsafe+import           Hasklepias.Templates -import Stype+import           Stype
src/Hasklepias/FeatureEvents.hs view
@@ -10,6 +10,7 @@ -} {-# OPTIONS_HADDOCK hide #-} {-# LANGUAGE NoImplicitPrelude #-}+{-# LANGUAGE TupleSections #-}  module Hasklepias.FeatureEvents(     -- ** Container predicates@@ -24,24 +25,13 @@      -- ** Reshaping containers     , allPairs+    , pairs     , splitByConcepts      -- ** Create filters     , makeConceptsFilter     , makePairedFilter -    -- ** Functions for working with Event Domains-    , viewBirthYears-    , viewGenders-    , viewStates-    , previewDemoInfo-    , previewBirthYear-    , isBirthYear-    , isGenderFact-    , isStateFact-    , isEnrollment-    , filterByDomain-     -- ** Manipulating Dates     , yearFromDay     , monthFromDay@@ -53,6 +43,7 @@      -- ** Misc functions     , computeAgeAt+    , pairGaps ) where  @@ -61,7 +52,7 @@                                             , ComparativePredicateOf1                                             , ComparativePredicateOf2                                             , Interval-                                            , IntervalCombinable+                                            , IntervalCombinable(..)                                             , begin                                             , end                                             , beginerval@@ -71,7 +62,9 @@ import EventData                            ( Events                                             , Event                                             , ConceptEvent-                                            , ctxt, context, Domain (Demographics) )+                                            , ctxt+                                            , context+                                            , Domain (Demographics) ) import EventData.Context                    ( Concept                                             , Concepts                                             , Context@@ -88,8 +81,7 @@ 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.Bool                            ( Bool(..), (&&), not, (||), otherwise ) import Data.Either                          ( either ) import Data.Eq                              ( Eq ) import Data.Foldable                        ( Foldable(length, null)@@ -100,7 +92,7 @@ import Data.Functor                         ( Functor(fmap) ) import Data.Int                             ( Int ) import Data.Maybe                           ( Maybe(..), maybe, mapMaybe )-import Data.Monoid                          ( Monoid )+import Data.Monoid                          ( Monoid(..), (<>) ) import Data.Ord                             ( Ord(..) ) import Data.Time.Calendar                   ( Day                                             , Year@@ -109,11 +101,10 @@                                             , diffDays                                             , toGregorian ) import Data.Text                            ( Text )-import Data.Text.Read                       ( rational )-import Data.Tuple                           ( fst )+import Data.Tuple                           ( fst, uncurry ) import Witherable                           ( filter, Filterable, Witherable )-import GHC.Num                              ( Integer, fromInteger )-import GHC.Real                             ( RealFrac(floor), (/) )+import           GHC.Num                        ( Integer, fromInteger )+import           GHC.Real                       ( RealFrac(floor), (/) )  -- | Is the input list empty?  isNotEmpty :: [a] -> Bool@@ -121,7 +112,7 @@  -- | Filter 'Events' to those that have any of the provided concepts. makeConceptsFilter ::-    ( Filterable f ) => +    ( Filterable f ) =>        [Text]    -- ^ the list of concepts by which to filter      -> f (Event a)     -> f (Event a)@@ -131,7 +122,7 @@ --   with the provided concepts. For example, see 'firstConceptOccurrence' and --  'lastConceptOccurrence'. nthConceptOccurrence ::-    ( Filterable f ) => +    ( Filterable f ) =>        (f (Event a) -> Maybe (Event a)) -- ^ function used to select a single event     -> [Text]     -> f (Event a)@@ -141,7 +132,7 @@ -- | Finds the *first* occurrence of an 'Event' with at least one of the concepts. --   Assumes the input 'Events' list is appropriately sorted. firstConceptOccurrence ::-    ( Witherable f ) => +    ( Witherable f ) =>       [Text]     -> f (Event a)     -> Maybe (Event a)@@ -183,13 +174,23 @@ makePairedFilter fi i fc = filter (makePairPredicate fi i fc)  -- | Generate all pair-wise combinations from two lists.-allPairs :: [a] -> [b] -> [(a, b)]+allPairs :: Applicative f => f a  -> f b -> f (a, b) allPairs = liftA2 (,) +-- | Generate all pair-wise combinations of a single list.+pairs :: [a]  -> [(a,a)]+-- copied from the hgeometry library (https://hackage.haskell.org/package/hgeometry-0.12.0.4/docs/src/Data.Geometry.Arrangement.Internal.html#allPairs)+-- TODO: better naming differences between pairs and allPairs?+-- TODO: generalize this function over more containers?+pairs = go+  where+    go []     = []+    go (x:xs) = fmap (x,) xs <> go xs+ -- | 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 :: +splitByConcepts ::     ( Filterable f ) =>        [Text]     -> [Text]@@ -198,6 +199,13 @@ splitByConcepts c1 c2 es = ( filter (`hasConcepts` c1) es                            , filter (`hasConcepts` c2) es) +-- | Gets the durations of gaps (via 'IntervalAlgebra.(><)') between all pairs +--   of the input. +pairGaps :: (Intervallic i a, IntervalSizeable a b, IntervalCombinable i a) =>+     [i a]+  -> [Maybe b]+pairGaps es = fmap (fmap duration . uncurry (><)) (pairs 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?@@ -207,7 +215,7 @@        , Applicative t        , Witherable t        , IntervalSizeable a b-       , IntervalCombinable i0 a+       , Intervallic i0 a        , IntervalCombinable i1 a) =>           ((b -> Bool) ->  t b -> Bool)         -> (b -> b -> Bool)@@ -219,7 +227,7 @@ --   specified duration among the input intervals? anyGapsWithinAtLeastDuration ::       ( IntervalSizeable a b-      , IntervalCombinable i0 a+      , Intervallic i0 a       , IntervalCombinable i1 a       , Monoid (t (Interval a))       , Monoid (t (Maybe (Interval a)))@@ -238,7 +246,7 @@ -- True allGapsWithinLessThanDuration ::       ( IntervalSizeable a b-      , IntervalCombinable i0 a+      , Intervallic i0 a       , IntervalCombinable i1 a       , Monoid (t (Interval a))       , Monoid (t (Maybe (Interval a)))@@ -249,60 +257,6 @@         -> t (i1 a)         -> Bool allGapsWithinLessThanDuration = makeGapsWithinPredicate all (<)---- | Preview demographics information from a domain-previewDemoInfo :: Domain -> Maybe Text-previewDemoInfo dmn = (^.demo.info) =<< preview _Demographics dmn---- | 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 =<< previewDemoInfo dmn---- | Predicate for Birth Year facts-isBirthYear :: Domain -> Bool -isBirthYear (Demographics (DemographicsFacts (DemographicsInfo BirthYear  _))) = True-isBirthYear _ = False---- | Predicate for Gender facts-isGenderFact :: Domain -> Bool -isGenderFact (Demographics (DemographicsFacts (DemographicsInfo Gender _))) = True-isGenderFact _ = False---- | Predicate for State facts-isStateFact :: Domain -> Bool -isStateFact (Demographics (DemographicsFacts (DemographicsInfo State _))) = True-isStateFact _ = False---- | Predicate for State facts-isEnrollment :: Domain -> Bool -isEnrollment (Enrollment _) = True-isEnrollment _ = False---- | Filters a container of 'Event's by the 'Domain'.-filterByDomain :: (Witherable f) => (Domain -> Bool) -> f (Event a) -> f (Event a)-filterByDomain f = filter (f . _facts . ctxt) ---- | Returns a (possibly empty) list of birth years from a set of events-viewBirthYears :: (Witherable f) => f (Event a) -> [Year]-viewBirthYears x = -  mapMaybe (\e -> previewBirthYear =<< Just (ctxt e^.facts )) -           (toList $ filterByDomain isBirthYear x)---- | Returns a (possibly empty) list of Gender values from a set of events-viewGenders :: (Witherable f) => f (Event a) -> [Text]-viewGenders x = -  mapMaybe (\e -> previewDemoInfo =<< Just (ctxt e^.facts )) -           (toList $ filterByDomain isGenderFact x)---- | Returns a (possibly empty) list of Gender values from a set of events-viewStates :: (Witherable f) => f (Event a) -> [Text]-viewStates x = -  mapMaybe (\e -> previewDemoInfo =<< Just (ctxt e^.facts )) -          (toList $ filterByDomain isStateFact x)  -- | Compute the "age" in years between two calendar days. The difference between --   the days is rounded down.
src/Hasklepias/Reexports.hs view
@@ -26,16 +26,20 @@     , module Data.Int     , module Data.Maybe     , module Data.Monoid+    , module Data.Functor.Contravariant     , module Data.Foldable     , module Data.Function     , module Data.List     , module Data.List.NonEmpty+    , module M     , module Data.Ord     , module Data.Proxy     , module Set     , module Data.Time.Calendar      , module Data.Text+    , module Data.Traversable      , module Data.Tuple+    , module Data.Tuple.Curry      , module IntervalAlgebra     , module IntervalAlgebra.IntervalUtilities@@ -44,12 +48,17 @@     , module Safe     , module Flow     , module Witherable+    , setFromList +    , mapFromList+    , mapToList ) where  import safe GHC.Num                         ( Integer(..)                                             , Num(..)-                                            , Natural(..) )-import safe GHC.Real                        ( Integral(..), toInteger )+                                            , Natural(..)+                                            , naturalToInt )+import safe GHC.Real                        ( Integral(..)+                                            , toInteger ) import safe GHC.Generics                    ( Generic ) import safe GHC.Show                        ( Show(..) ) import safe GHC.TypeLits                    ( KnownSymbol(..)@@ -69,7 +78,10 @@ import safe Data.Eq                         ( Eq, (==)) import safe Data.Foldable                   ( Foldable(..)                                             , minimum-                                            , maximum )+                                            , maximum+                                             )+import safe Data.Functor.Contravariant      ( Contravariant(contramap)+                                            , Predicate(..) ) import safe Data.Function                   ( (.), ($), const, id, flip ) import safe Data.Int                        ( Int(..) ) import safe Data.List                       ( all@@ -77,12 +89,20 @@                                             , map                                             , length                                             , null+                                            , zip                                             , zipWith+                                            , unzip                                             , replicate                                             , transpose                                             , sort-                                            , (++) )+                                            , (++)+                                            , scanl1+                                            , scanl' ) import safe Data.List.NonEmpty              ( NonEmpty(..) )+import safe qualified Data.Map.Strict as M  ( Map(..)+                                            , toList+                                            , fromList+                                            , fromListWith ) import safe Data.Maybe                      ( Maybe(..),                                               maybe,                                               isJust,@@ -98,7 +118,8 @@                                             , Ordering(..)                                             , max, min ) import safe Data.Proxy                      ( Proxy(..) )-import safe Data.Set as Set                 ( Set(..), fromList, member)+import safe qualified Data.Set as Set       ( Set(..), member, fromList )+import safe Data.Traversable                ( Traversable(..) ) import safe Data.Time.Calendar              ( Day                                             , DayOfWeek                                             , DayOfMonth@@ -115,11 +136,23 @@                                             , dayQuarter ) import safe Data.Text                       ( pack, Text ) import safe Data.Tuple                      ( fst, snd, uncurry, curry )-+import safe Data.Tuple.Curry                ( curryN, uncurryN ) import safe IntervalAlgebra import safe IntervalAlgebra.IntervalUtilities import safe IntervalAlgebra.PairedInterval -import safe Witherable                      ( Filterable(filter), Witherable )+import safe Witherable                      ( Filterable(filter), Witherable(..) ) import safe Flow                            ( (!>), (.>), (<!), (<.), (<|), (|>) ) import Safe                                 ( headMay, lastMay )+-- import Data.Vector.Fusion.Bundle (scanl1)+-- import Data.Map (fromList)+-- import qualified Data.Map as Set++setFromList :: (Ord a) =>  [a] -> Set.Set a+setFromList = Set.fromList++mapFromList :: (Ord k) => [(k, a)] -> M.Map k a+mapFromList = M.fromList++mapToList :: (Ord k) =>  M.Map k a -> [(k, a)] +mapToList = M.toList
src/Hasklepias/ReexportsUnsafe.hs view
@@ -17,7 +17,7 @@     , module Test.Tasty.HUnit ) where -import Data.Aeson        (encode)+import Data.Aeson        ( encode, ToJSON(..)) import GHC.IO            ( IO(..) )  -- import GHC.Types                       ( Any )
src/Hasklepias/Templates/Features.hs view
@@ -9,8 +9,21 @@ {-# LANGUAGE NoImplicitPrelude #-}  module Hasklepias.Templates.Features (-   module Hasklepias.Templates.Features.Enrollment-+     module Hasklepias.Templates.Features.Enrollment+   , module Hasklepias.Templates.Features.NsatisfyP ) where -import Hasklepias.Templates.Features.Enrollment (defIsEnrolled, defContinuousEnrollment)+import Hasklepias.Templates.Features.Enrollment+    ( buildIsEnrolled,+      buildContinuousEnrollment,+    )+import Hasklepias.Templates.Features.NsatisfyP +   (  buildNofX+    , buildNofXBool+    , buildNofXBinary+    , buildNofXBinaryConcurBaseline+    , buildNofConceptsBinaryConcurBaseline+    , buildNofXWithGap+    , buildNofXWithGapBool+    , buildNofXWithGapBinary+    , buildNofUniqueBegins)
src/Hasklepias/Templates/Features/Enrollment.hs view
@@ -11,190 +11,234 @@ {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE FlexibleContexts #-}--module Hasklepias.Templates.Features.Enrollment (-    defIsEnrolled -  , defContinuousEnrollment-  , defEnrollmentTests-) where--import Control.Applicative              ( Applicative(..) )-import GHC.Int                          ( Int )-import GHC.TypeLits                     ( KnownSymbol )-import GHC.Show                         ( Show )-import Flow                             ( (|>), (.>) )-import IntervalAlgebra-import IntervalAlgebra.IntervalUtilities ( combineIntervals )-import IntervalAlgebra.PairedInterval   ( intervals )-import Witherable                       ( Witherable )-import Data.Eq                          ( Eq )-import Data.Foldable                    (Foldable(..), any)-import Data.Function                    ( ($), (.) )-import Data.Functor                     ( Functor(.. ) )-import Data.Maybe                       ( Maybe )-import Data.Monoid                      ( Monoid(..) )-import Data.Text                        ( Text )-import Data.Tuple                       ( uncurry )                     -import Test.Tasty                       ( testGroup, TestName, TestTree )-import Test.Tasty.HUnit                 ( testCase )+{-# LANGUAGE MultiParamTypeClasses #-} -import EventData                        ( Event-                                        , Domain(..)-                                        , EnrollmentFacts(..)-                                        , event-                                        , context-                                        )-import Features.Compose                 ( Feature-                                        , Definition(..)-                                        , Define(..)-                                        , Eval(..)-                                        , makeFeature )-import Hasklepias.FeatureEvents         ( allGapsWithinLessThanDuration-                                        , makeConceptsFilter-                                        , filterByDomain-                                        , isEnrollment, lookback )-import Hasklepias.Templates.TestUtilities-                                        ( makeAssertion-                                        , TemplateTestCase(..) )-import Hasklepias.Misc                  ( F )-import Cohort.Index                     ( Index(..) )-import Cohort.Criteria                  ( Status(..), includeIf )+module Hasklepias.Templates.Features.Enrollment+  ( buildIsEnrolled+  , buildContinuousEnrollment+  , buildEnrollmentTests+  ) where +import           Cohort+import           EventData                  +import           Features+import           Hasklepias.Misc                ( F )+import           Hasklepias.FeatureEvents+import           Hasklepias.Templates.TestUtilities+import           Hasklepias.Reexports+import           Hasklepias.ReexportsUnsafe  {-| Is Enrolled  TODO: describe this  -}-defIsEnrolled ::-  ( Intervallic i0 a-  , Monoid (container (Interval a))-  , Applicative container-  , Witherable container) =>-  Definition-  (   Feature indexName  (Index i0 a)-   -> Feature eventsName (container (Event a))-   -> Feature varName     Status )-defIsEnrolled =-  define-      (\index ->-           filterByDomain isEnrollment-        .> combineIntervals-        .> any (concur index)-        .> includeIf-      )+buildIsEnrolled+  :: ( Intervallic i0 a+     , Monoid (container (Interval a))+     , Applicative container+     , Witherable container+     )+  => +  Predicate (Event a) -- ^ The predicate to filter to Enrollment events (e.g. 'FeatureEvents.isEnrollment')+  -> Definition+       (  Feature indexName (Index i0 a)+       -> Feature eventsName (container (Event a))+       -> Feature varName Status+       )+buildIsEnrolled predicate = define+  (\index ->+    filter (getPredicate predicate)+      .> combineIntervals+      .> any (concur index)+      .> includeIf+  ) -makeIsEnrolledTestInputs :: (IntervalSizeable a b) =>-     TestName-  -> b -  -> a+makeIsEnrolledTestInputs+  :: (Integral b, IntervalSizeable a b)+  => TestName+  -> Predicate (Event a)+  -> (a, a)   -> [Event a]   -> Status-  -> TemplateTestCase (F "index" (Index Interval a), F "events" [Event a]) Status-makeIsEnrolledTestInputs name dur bgn e s = -  MkTemplateTestCase name (pure (MkIndex $ beginerval dur bgn), pure e) (pure s)+  -> TestCase+       (F "index" (Index Interval a), F "events" [Event a])+       Status+       (Predicate (Event a))+makeIsEnrolledTestInputs name buildArgs intrvl e s = MkTestCase+  buildArgs+  name+  (pure (makeIndex $ readIntervalSafe intrvl), pure e)+  (pure s) -makeEnrollmentEvent :: (IntervalSizeable a b) => b -> a -> Event a-makeEnrollmentEvent dur bgn = -  event (beginerval dur bgn) (context ( Enrollment (EnrollmentFacts ())) mempty) -defIsEnrolledTestCases :: [TemplateTestCase-   (F "index" (Index Interval Int), F "events" [Event Int]) Status]-defIsEnrolledTestCases = [ -      f "Exclude if no events" 1 (0::Int) []   Exclude-    , f "Exclude if only interval meets" 1 (0::Int) [g 5 1]  Exclude-    , f "Include if concurring interval" 1 (0::Int) [g 5 (-1)] Include-    , f "Include if concurring interval" 1 (0::Int) [g 2 (-1), g 5 1]  Include -  ] where f = makeIsEnrolledTestInputs-          g = makeEnrollmentEvent+buildIsEnrolledTestCases+  :: [ TestCase+         (F "index" (Index Interval Int), F "events" [Event Int])+         Status+         (Predicate (Event Int))+     ]+buildIsEnrolledTestCases =+  [ f "Exclude if no events" isEnrollmentEvent (0, 1) [] Exclude+  , f "Exclude if only interval meets"+      isEnrollmentEvent+      (0, 1)+      [g (1, 6)]+      Exclude+  , f "Include if concurring interval"+      isEnrollmentEvent+      (0, 1)+      [g (-1, 4)]+      Include+  , f "Include if concurring interval"+      isEnrollmentEvent+      (0, 1)+      [g (-1, 1), g (1, 4)]+      Include+  ] where+  f = makeIsEnrolledTestInputs+  g = makeEnrollmentEvent -defIsEnrolledTests :: TestTree-defIsEnrolledTests = testGroup "Tests of isEnrolled template"-     ( fmap (\x -> testCase (getTestName x) (makeAssertion x defIsEnrolled) )-       defIsEnrolledTestCases )+buildIsEnrolledTests :: TestTree+buildIsEnrolledTests = testGroup+  "Tests of isEnrolled template"+  (fmap+    (\x -> testCase (getTestName x)+                    (makeAssertion x (buildIsEnrolled (getBuilderArgs x)))+    )+    buildIsEnrolledTestCases+  )   {-| Continuous Enrollment   TODO: describe this+ -}-defContinuousEnrollment ::-  ( Monoid (container (Interval a))-  , Monoid (container (Maybe (Interval a)))-  , Applicative container-  , Witherable container-  , IntervalCombinable i1 a-  , IntervalSizeable a b) =>-    (Index i0 a -> i1 a) -- ^ function which maps index interval to interval in which to assess enrollment-  -> b                   -- ^ duration of allowable gap between enrollment intervals+buildContinuousEnrollment+  :: ( Monoid (container (Interval a))+     , Monoid (container (Maybe (Interval a)))+     , Applicative container+     , Witherable container+     , IntervalSizeable a b+     )+  => (Index i0 a -> AssessmentInterval a) -- ^ function which maps index interval to interval in which to assess enrollment+  -> Predicate (Event a)  -- ^ The predicate to filter to Enrollment events (e.g. 'FeatureEvents.isEnrollment')+  -> b  -- ^ duration of allowable gap between enrollment intervals   -> Definition-  (   Feature indexName  (Index i0 a)-   -> Feature eventsName (container (Event a))-   -> Feature prevName    Status-   -> Feature varName     Status )-defContinuousEnrollment formInterval allowableGap =-  define-    (\index events prevStatus ->-      case prevStatus of-        Exclude -> Exclude-        Include -> includeIf-          ( allGapsWithinLessThanDuration-                allowableGap-                (formInterval index)-                (combineIntervals $ filterByDomain isEnrollment events))-    )+       (  Feature indexName (Index i0 a)+       -> Feature eventsName (container (Event a))+       -> Feature prevName Status+       -> Feature varName Status+       )+buildContinuousEnrollment makeAssessmentInterval predicate allowableGap = define+  (\index events prevStatus -> case prevStatus of+    Exclude -> Exclude+    Include -> includeIf+      (allGapsWithinLessThanDuration+        allowableGap+        (makeAssessmentInterval index)+        (combineIntervals $ filter (getPredicate predicate) events)+      )+  ) -makeContinuousEnrollmentTestInputs :: (IntervalSizeable a b) =>-     TestName-  -> b -  -> a++type ContEnrollArgs+  = (Index Interval Int -> AssessmentInterval Int, Predicate (Event Int), Int)++makeContinuousEnrollmentTestInputs+  :: (Integral b, IntervalSizeable a b)+  => TestName+  -> ContEnrollArgs+  -> (a, a)   -> [Event a]   -> Status   -> Status-  -> TemplateTestCase (F "index" (Index Interval a), F "events" [Event a], F "prev" Status) Status-makeContinuousEnrollmentTestInputs name dur bgn e prev s = -  MkTemplateTestCase name (pure (MkIndex $ beginerval dur bgn), pure e, pure prev) (pure s)+  -> TestCase+       ( F "index" (Index Interval a)+       , F "events" [Event a]+       , F "prev" Status+       )+       Status+       ContEnrollArgs+makeContinuousEnrollmentTestInputs name buildArgs intrvl e prev s = MkTestCase+  buildArgs+  name+  (pure (makeIndex (readIntervalSafe intrvl)), pure e, pure prev)+  (pure s) -defContinuousEnrollmentTestCases :: [TemplateTestCase-   (F "index" (Index Interval Int), F "events" [Event Int], F "prev" Status) Status]-defContinuousEnrollmentTestCases = [ -      f "Exclude if previously excluded" 1 (0::Int) []  Exclude  Exclude-    , f "Exclude if no events" 1 (0::Int) []  Include  Exclude+commonArgs+  :: (Index Interval Int -> AssessmentInterval Int, Predicate (Event a), Int)+commonArgs = (makeBaselineFromIndex 10, isEnrollmentEvent, 3)++buildContinuousEnrollmentTestCases+  :: [ TestCase+         ( F "index" (Index Interval Int)+         , F "events" [Event Int]+         , F "prev" Status+         )+         Status+         ContEnrollArgs+     ]+buildContinuousEnrollmentTestCases =+  [ f "Exclude if previously excluded" commonArgs (0, 1) [] Exclude Exclude+  , f "Exclude if no events"           commonArgs (0, 1) [] Include Exclude+  , f "Exclude if gap >= 3"+      commonArgs+      (10, 11)+      [g (1, 4), g (9, 12)]+      Include+      Exclude       {-                   -           <- Index          ----------           <- Baseline          ---     ---          <- Enrollment         |--------------|       -}-    , f "Exclude if gap >= 3" 1 (10::Int) [g 3 1, g 3 9]  Include Exclude+  , f "Exclude if gap >= 3" commonArgs (10, 11) [g (1, 7)]  Include Exclude       {-                   -           <- Index         ----------            <- Baseline          ------               <- Enrollment         |--------------|       -}-    , f "Exclude if gap >= 3" 1 (10::Int) [g 6 1]   Include Exclude+  , f "Exclude if gap >= 3" commonArgs (10, 11) [g (6, 13)] Include Exclude         {-                   -           <- Index          ----------           <- Baseline               -------         <- Enrollment         |--------------|       -}-    , f "Exclude if gap >= 3" 1 (10::Int) [g 7 6]   Include Exclude+  , f "Include if gaps less than 3"+      commonArgs+      (10, 11)+      [g (1, 3), g (5, 12)]+      Include+      Include       {-                   -           <- Index          ----------           <- Baseline          --  -------          <- Enrollment         |--------------|       -}-    , f "Include if gaps less than 3" 1 (10::Int) [g 2 1, g 7 5]  Include Include+  , f "Include if gaps less than 3"+      commonArgs+      (10, 11)+      [g (2, 9)]+      Include+      Include       {-                   -           <- Index          ----------           <- Baseline           -------             <- Enrollment         |--------------|       -}-    , f "Include if gaps less than 3" 1 (10::Int) [g 7 2]  Include Include+  , f "Include if gaps less than 3"+      commonArgs+      (10, 11)+      [g (1, 6), g (4, 8)]+      Include+      Include         {-                   -           <- Index          ----------           <- Baseline@@ -202,15 +246,24 @@              ----         |--------------|       -}-    , f "Include if gaps less than 3" 1 (10::Int) [g 5 1, g 4 4]  Include Include-  ] where f = makeContinuousEnrollmentTestInputs-          g = makeEnrollmentEvent+  ] where+  f = makeContinuousEnrollmentTestInputs+  g = makeEnrollmentEvent -defContinuousEnrollmentTests :: TestTree-defContinuousEnrollmentTests = testGroup "Tests of continuous enrollment template"-     ( fmap (\x -> testCase (getTestName x) -          (makeAssertion x (defContinuousEnrollment (lookback 10) 3)) )-           defContinuousEnrollmentTestCases )+buildContinuousEnrollmentTests :: TestTree+buildContinuousEnrollmentTests = testGroup+  "Tests of continuous enrollment template"+  (fmap+    (\x -> testCase+      (getTestName x)+      (makeAssertion+        x+        (buildContinuousEnrollment (makeBaselineFromIndex 10) isEnrollmentEvent 3)+      )+    )+    buildContinuousEnrollmentTestCases+  ) -defEnrollmentTests :: TestTree-defEnrollmentTests = testGroup "" [defIsEnrolledTests, defContinuousEnrollmentTests]+buildEnrollmentTests :: TestTree+buildEnrollmentTests =+  testGroup "" [buildIsEnrolledTests, buildContinuousEnrollmentTests]
+ src/Hasklepias/Templates/Features/NsatisfyP.hs view
@@ -0,0 +1,585 @@+{-|+Module      :  Features Templates +Description : Templates for Features based on satisfying a set of predicates +Copyright   : (c) NoviSci, Inc 2020+License     : BSD3+Maintainer  : bsaul@novisci.com++-}+{-# OPTIONS_HADDOCK hide #-}+{-# LANGUAGE NoImplicitPrelude #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE TupleSections #-}++module Hasklepias.Templates.Features.NsatisfyP+  ( buildNsatisfyPTests+  , buildNofX+  , buildNofXBool+  , buildNofXBinary+  , buildNofXBinaryConcurBaseline+  , buildNofConceptsBinaryConcurBaseline+  , buildNofXWithGap+  , buildNofXWithGapBool+  , buildNofXWithGapBinary+  , buildNofUniqueBegins+  ) where++import           Cohort+import qualified Control.Lens                  as Functor+import           EventData+import           Features+import           Hasklepias.FeatureEvents+import           Hasklepias.Misc                ( F )+import           Hasklepias.Reexports+import           Hasklepias.ReexportsUnsafe+import           Hasklepias.Templates.TestUtilities+import           Stype++-- | All the buildNSatisfyP tests.+buildNsatisfyPTests :: TestTree+buildNsatisfyPTests =+  testGroup "NsatisfyP" [buildNofXTests, buildNofXWithGapTests, buildNofUniqueBeginsTests]++{-|+-}+buildNofXBase+  :: ( Intervallic i0 a+     , Intervallic i1 a+     , Witherable container0+     , Witherable container1+     )+  => (container0 (Event a) -> container1 (i1 a)) -- ^ function mapping a container of events to a container of intervallic intervals (which could be events!)+  -> (container1 (i1 a) -> t) -- ^ function mapping the processed events to an intermediate type+  -> (AssessmentInterval a -> t -> outputType) -- ^ function casting intermediate type to output type with the option to use the assessment interval+  -> (Index i0 a -> AssessmentInterval a) -- ^ function which maps index interval to interval in which to assess the feature+  -> ComparativePredicateOf2 (AssessmentInterval a) (Event a) -- ^ the interval relation of the input events to the assessment interval+  -> Predicate (Event a) -- ^ The predicate to filter to Enrollment events (e.g. 'FeatureEvents.isEnrollment')+  -> Definition+       (  Feature indexName (Index i0 a)+       -> Feature eventsName (container0 (Event a))+       -> Feature varName outputType+       )+buildNofXBase runProcess runPostProcess runCast makeAssessmentInterval relation predicate+  = define+    (\index ->+      -- filter events to those satisfying both+      -- the given relation to the assessment interval+      -- AND the given predicate+      filter+          (relation (makeAssessmentInterval index) &&& getPredicate predicate)+      -- run the processing function+        .> runProcess+      -- run the post processing function+        .> runPostProcess+      -- run the casting function+        .> runCast (makeAssessmentInterval index)+    )++{-| Do N events relating to the 'AssessmentInterval' in some way the satisfy +    the given predicate? +-}+buildNofX+  :: (Intervallic i a, Witherable container)+  => (Bool -> outputType) -- ^ casting function+  -> Natural -- ^ minimum number of cases+  -> (Index i a -> AssessmentInterval a) -- ^ function to transform a 'Cohort.Index' to an 'Cohort.AssessmentInterval'+  -> ComparativePredicateOf2 (AssessmentInterval a) (Event a) -- ^ interval predicate+  -> Predicate (Event a) -- ^ a predicate on events+  -> Definition+       (  Feature indexName (Index i a)+       -> Feature eventsName (container (Event a))+       -> Feature varName outputType+       )+buildNofX f n = buildNofXBase id (\x -> length x >= naturalToInt n) (const f)++-- | 'buildNofX' specialized to return 'Bool'.+buildNofXBool+  :: (Intervallic i a, Witherable container)+  => Natural -- ^ minimum number of cases +  -> (Index i a -> AssessmentInterval a) -- ^ function to transform a 'Cohort.Index' to an 'Cohort.AssessmentInterval'+  -> ComparativePredicateOf2 (AssessmentInterval a) (Event a) -- ^ interval predicate+  -> Predicate (Event a) -- ^ a predicate on events+  -> Definition+       (  Feature indexName (Index i a)+       -> Feature eventsName (container (Event a))+       -> Feature varName Bool+       )+buildNofXBool = buildNofX id++-- | 'buildNofX' specialized to return 'Stype.Binary'.+buildNofXBinary+  :: (Intervallic i a, Witherable container)+  => Natural+  -> (Index i a -> AssessmentInterval a)+  -> ComparativePredicateOf2 (AssessmentInterval a) (Event a)+  -> Predicate (Event a)+  -> Definition+       (  Feature indexName (Index i a)+       -> Feature eventsName (container (Event a))+       -> Feature varName Binary+       )+buildNofXBinary = buildNofX fromBool++{- | +'buildNofXBinary' specialized to filter to events that 'IntervalAlgebra.concur' +with an 'Cohort.AssessmentInterval' created by 'Cohort.makeBaselineFromIndex' of+a specified duration and a provided 'Data.Functor.Contravariant.Predicate'.+-}+buildNofXBinaryConcurBaseline+  :: (Intervallic i0 a, Witherable t, IntervalSizeable a b, Baseline i0 a)+  => Natural -- ^ minimum number of events.+  -> b -- ^ duration of baseline (passed to 'Cohort.makeBaselineFromIndex')+  -> Predicate (Event a)+  -> Definition+       (  Feature indexName (Index i0 a)+       -> Feature eventsName (t (Event a))+       -> Feature varName Binary+       )+buildNofXBinaryConcurBaseline n baselineDur =+  buildNofXBinary n (makeBaselineFromIndex baselineDur) concur++{- | +'buildNofXBinary' specialized to filter to events that 'IntervalAlgebra.concur' +with an 'Cohort.AssessmentInterval' created by 'Cohort.makeBaselineFromIndex' of+a specified duration and that have a given set of 'EventData.Concepts'.+-}+buildNofConceptsBinaryConcurBaseline+  :: (Intervallic i0 a, Witherable t, IntervalSizeable a b, Baseline i0 a)+  => Natural -- ^ minimum number of events. +  -> b  -- ^ duration of baseline (passed to 'Cohort.makeBaselineFromIndex')+  -> [Text] -- ^ list of 'EventData.Concepts' passed to 'EventData.containsConcepts'+  -> Definition+       (  Feature indexName (Index i0 a)+       -> Feature eventsName (t (Event a))+       -> Feature varName Bool+       )+buildNofConceptsBinaryConcurBaseline n baselineDur cpts = buildNofXBool+  n+  (makeBaselineFromIndex baselineDur)+  concur+  (containsConcepts cpts)++--------------------------------------------------------------------------------+-- NofX examples/tests+--------------------------------------------------------------------------------++type NofXArgs+  = ( Natural+    , Index Interval Int -> AssessmentInterval Int+    , ComparativePredicateOf2 (AssessmentInterval Int) (Event Int)+    , Predicate (Event Int)+    )++makeTestInputs+  :: (Integral b, IntervalSizeable a b)+  => TestName+  -> bargs+  -> (a, a)+  -> [Event a]+  -> returnType +  -> TestCase+       (F "index" (Index Interval a), F "events" [Event a])+       returnType+       bargs+makeTestInputs name buildArgs intrvl e b = MkTestCase+  buildArgs+  name+  (pure (makeIndex (readIntervalSafe intrvl)), pure e)+  (pure b)++type NofXTestCase+  = TestCase+      (F "index" (Index Interval Int), F "events" [Event Int])+      Bool+      NofXArgs++buildNofXTestCases :: [NofXTestCase]+buildNofXTestCases =+  [ f "False if no events"+      (1, makeBaselineFromIndex 10, concur, isEnrollmentEvent)+      (0, 1)+      []+      False+  , f+    "False if 1 event after index but looking for single event concurring with baseline"+    (1, makeBaselineFromIndex 10, concur, isEnrollmentEvent)+    (0, 1)+    [g (2, 7)]+    False+  , f+    "True if 1 event before index and looking for single event concurring with baseline"+    (1, makeBaselineFromIndex 10, concur, containsConcepts ["A"])+    (0, 1)+    [h ["A", "B"] (-5, -4)]+    True+  , f+    "True if 2 events before index and looking for at least 2 events concurring with baseline"+    (2, makeBaselineFromIndex 10, concur, containsConcepts ["A"])+    (0, 1)+    [h ["A", "B"] (-5, -4), h ["A", "C"] (-3, -2)]+    True+  , f+    "True if 3 events before index and looking for at least 2 events concurring with baseline"+    (2, makeBaselineFromIndex 10, concur, containsConcepts ["A"])+    (0, 1)+    [h ["A", "B"] (-7, -6), h ["A", "B"] (-5, -4), h ["A", "C"] (-3, -2)]+    True+  , f+    "True if 2 events of same interval before index and looking for at least 2 events concurring with baseline"+    (2, makeBaselineFromIndex 10, concur, containsConcepts ["A"])+    (0, 1)+    [h ["A"] (-5, -4), h ["A", "B"] (-5, -4)]+    True+  , f+    "False if 1 event before index and looking for at least 2 events concurring with baseline"+    (2, makeBaselineFromIndex 10, concur, containsConcepts ["A"])+    (0, 1)+    [h ["A", "C"] (-3, -2)]+    False+  ] where+  f = makeTestInputs+  g = makeEnrollmentEvent+  h = makeEventWithConcepts++buildNofXTests :: TestTree+buildNofXTests = testGroup+  "Tests of NofX template"+  (fmap+    (\x -> testCase+      (getTestName x)+      (makeAssertion x (uncurryN buildNofXBool (getBuilderArgs x)))+    )+    buildNofXTestCases+  )++{-| Are there N gaps of at least the given duration between any pair of events +    that relate to the 'AssessmentInterval' by the given relation and the+    satisfy the given predicate? +-}+buildNofXWithGap+  :: ( Intervallic i a+     , IntervalSizeable a b+     , IntervalCombinable i a+     , Witherable container+     )+  => (Bool -> outputType)+  -> Natural -- ^ the minimum number of gaps+  -> b -- ^ the minimum duration of a gap+  -> (Index i a -> AssessmentInterval a)+  -> ComparativePredicateOf2 (AssessmentInterval a) (Event a)+  -> Predicate (Event a)+  -> Definition+       (  Feature indexName (Index i a)+       -> Feature eventsName (container (Event a))+       -> Feature varName outputType+       )+buildNofXWithGap cast nGaps allowableGap = buildNofXBase+  (-- just need the intervals  +     fmap getInterval+   -- pairGaps needs List input as the container type+    .> toList)+  (-- get (Maybe) durations of interval gaps between all pairs+    pairGaps+   -- throw away any non-gaps+  .> catMaybes+   -- keep only those gap durations at least the allowableGap+  .> filter (>= allowableGap)+   -- are there at least as many events as desired?+  .> \x -> length x >= naturalToInt nGaps+  )+  (const cast)++-- | 'buildNofXWithGap' specialized to return 'Bool'. +buildNofXWithGapBool+  :: ( Intervallic i a+     , IntervalSizeable a b+     , IntervalCombinable i a+     , Witherable container+     )+  => Natural -- ^ the minimum number of gaps+  -> b -- ^ the minimum duration of a gap+  -> (Index i a -> AssessmentInterval a)+  -> ComparativePredicateOf2 (AssessmentInterval a) (Event a)+  -> Predicate (Event a)+  -> Definition+       (  Feature indexName (Index i a)+       -> Feature eventsName (container (Event a))+       -> Feature varName Bool+       )+buildNofXWithGapBool = buildNofXWithGap id+++-- | 'buildNofXWithGap' specialized to return 'Stype.Binary'. +buildNofXWithGapBinary+  :: ( Intervallic i a+     , IntervalSizeable a b+     , IntervalCombinable i a+     , Witherable container+     )+  => Natural -- ^ the minimum number of gaps+  -> b -- ^ the minimum duration of a gap+  -> (Index i a -> AssessmentInterval a)+  -> ComparativePredicateOf2 (AssessmentInterval a) (Event a)+  -> Predicate (Event a)+  -> Definition+       (  Feature indexName (Index i a)+       -> Feature eventsName (container (Event a))+       -> Feature varName Binary+       )+buildNofXWithGapBinary = buildNofXWithGap fromBool++type NofXWithGapArgs+  = ( Natural+    , Int+    , Index Interval Int -> AssessmentInterval Int+    , ComparativePredicateOf2 (AssessmentInterval Int) (Event Int)+    , Predicate (Event Int)+    )++type NofXWithGapTestCase+  = TestCase+      (F "index" (Index Interval Int), F "events" [Event Int])+      Bool+      NofXWithGapArgs++buildNofXWithGapTestCases :: [NofXWithGapTestCase]+buildNofXWithGapTestCases =+  [ f "True if looking for no events and there are no events"+      (0, 3, makeBaselineFromIndex 10, concur, isEnrollmentEvent)+      (10, 11)+      []+      True+      {-+                   -          <- Index+         ----------           <- Baseline+                              <- Enrollment+        |--------------|+      -}+  , f+    "True if looking for (at least) no events and there are events satisfying gap condition"+    (0, 3, makeBaselineFromIndex 10, concur, isEnrollmentEvent)+    (10, 11)+    [g (1, 2), g (8, 9)]+    True+      {-+                   -          <- Index+         ----------           <- Baseline+         -       -            <- Enrollment+        |--------------|+      -}+  , f "False if no events and looking for 1 gap"+      (1, 3, makeBaselineFromIndex 10, concur, isEnrollmentEvent)+      (10, 11)+      []+      False+      {-+                   -          <- Index+         ----------           <- Baseline+                              <- Enrollment+        |--------------|+      -}+  , f "False if a single event and looking for gap"+      (1, 3, makeBaselineFromIndex 10, concur, isEnrollmentEvent)+      (10, 11)+      [g (8, 9)]+      False+      {-+                   -          <- Index+         ----------           <- Baseline+                 -            <- Enrollment+        |--------------|+      -}+  , f "False if 1 gap but not satisfying gap condition"+      (1, 3, makeBaselineFromIndex 10, concur, isEnrollmentEvent)+      (10, 11)+      [g (6, 7), g (8, 9)]+      False+      {-+                   -          <- Index+         ----------           <- Baseline+               - -            <- Enrollment+        |--------------|+      -}+  , f "True if 1 gap satisfy gap condition"+      (1, 3, makeBaselineFromIndex 10, concur, containsConcepts ["A"])+      (10, 11)+      [h ["C", "A"] (2, 3), h ["A", "B"] (8, 9)]+      True+      {-+                   -          <- Index+         ----------           <- Baseline+          -                   <- ["C", "A"]+                 -            <- ["A", "B"] +        |--------------|+      -}+  , f "True if 1 gap satisfy gap condition "+      (1, 3, makeBaselineFromIndex 10, concur, containsConcepts ["A"])+      (10, 11)+      [h ["C", "A"] (2, 3), h ["D", "E"] (5, 6), h ["A", "B"] (8, 9)]+      True+      {-+                   -          <- Index+         ----------           <- Baseline+          -                   <- ["C", "A"]+              -               <- ["D", "E"]+                 -            <- ["A", "B"] +        |--------------|+      -}+  , f+    "True if 1 gap satisfy gap condition"+    (1, 3, makeBaselineFromIndex 10, concur, containsConcepts ["A"])+    (10, 11)+    [ h ["A"] (1, 2)+    , h ["A"] (2, 3)+    , h ["A"] (3, 4)+    , h ["A"] (4, 5)+    , h ["A"] (5, 6)+    ]+    True+      {-+                    -          <- Index+          ----------           <- Baseline+          -                    <- ["A"]+           -                   <- ["A"]+            -                  <- ["A"]+             -                 <- ["A"]+              -                <- ["A"]+        |--------------|+      -}+  , f "False if no gap satisfy gap condition"+      (1, 3, makeBaselineFromIndex 10, concur, containsConcepts ["A"])+      (10, 11)+      [h ["A"] (1, 2), h ["A"] (2, 3), h ["A"] (3, 4), h ["A"] (4, 5)]+      False+      {-+                    -          <- Index+          ----------           <- Baseline+          -                    <- ["A"]+           -                   <- ["A"]+            -                  <- ["A"]+             -                 <- ["A"]+        |--------------|+      -}+  ] where+  f = makeTestInputs+  g = makeEnrollmentEvent+  h = makeEventWithConcepts++buildNofXWithGapTests :: TestTree+buildNofXWithGapTests = testGroup+  "Tests of NofXWithGap template"+  (fmap+    (\x -> testCase+      (getTestName x)+      (makeAssertion x (uncurryN buildNofXWithGapBool (getBuilderArgs x)))+    )+    buildNofXWithGapTestCases+  )+++{-+-}++{-| Do N events relating to the 'AssessmentInterval' in some way the satisfy +    the given predicate? +-}+buildNofUniqueBegins+  :: (Intervallic i a, IntervalSizeable a b, Witherable container)+  => (Index i a -> AssessmentInterval a) -- ^ function to transform a 'Cohort.Index' to an 'Cohort.AssessmentInterval'+  -> ComparativePredicateOf2 (AssessmentInterval a) (Event a) -- ^ interval predicate+  -> Predicate (Event a) -- ^ a predicate on events+  -> Definition+       (  Feature indexName (Index i a)+       -> Feature eventsName (container (Event a))+       -> Feature varName [(EventTime b, Count)]+       )+buildNofUniqueBegins = buildNofXBase +  ( fmap (momentize . getInterval) )+  (  fmap (, 1 :: Natural)+  .> toList+  .> mapFromList+  .> mapToList+  .> \x -> uncurry zip (fmap (scanl1 (+)) (unzip x)) +  ) +  (\window ->+    fmap (\i -> (mkEventTime $ Just (diff (begin (fst i)) (begin window)), Count (snd i)))  +  )++type NofUniqueBeginsArgs+  = ( Index Interval Int -> AssessmentInterval Int+    , ComparativePredicateOf2 (AssessmentInterval Int) (Event Int)+    , Predicate (Event Int)+    )++type NofUniqueBeginsTestCase+  = TestCase+      (F "index" (Index Interval Int), F "events" [Event Int])+      [(EventTime Int, Count)]+      NofUniqueBeginsArgs++buildNofUniqueBeginsTestCases :: [NofUniqueBeginsTestCase]+buildNofUniqueBeginsTestCases =+  [ f "empty input"+      (makeFollowupFromIndex 10, concur, isEnrollmentEvent)+      (0, 1)+      []+      [] +      {-+         -                    <- Index+         ----------           <- Baseline++        |--------------|+      -}+  , f "2 results if 2 different begins"+      (makeFollowupFromIndex 10, concur, containsConcepts ["A"])+      (0, 1)+      [h ["A"] (2, 5), h ["A"] (4, 5)]+      [(mkEventTime (Just 2), 1), (mkEventTime (Just 4), 2)] +      {-+         -                    <- Index+         ----------           <- Followup+           ---                <- "A"+             _                <- "A"+        |--------------|+      -}+  , f "2 results when multiple begins at same time"+      (makeFollowupFromIndex 10, concur, containsConcepts ["A"])+      (0, 1)+      [h ["A"] (2, 3),h ["A"] (2, 5), h ["A"] (4, 5)]+      [(mkEventTime (Just 2), 1), (mkEventTime (Just 4), 2)] +      {-+         -                    <- Index+         ----------           <- Followup +           -                  <- "A"+           ---                <- "A"+             -                <- "A"+        |--------------|+      -}+  , f "1 result based on predicate filter"+      (makeFollowupFromIndex 10, concur, containsConcepts ["A"])+      (0, 1)+      [h ["B"] (2, 3),h ["B"] (2, 5), h ["A"] (4, 5)]+      [(mkEventTime (Just 4), 1)] +      {-+         -                    <- Index+         ----------           <- Followup +           -                  <- "B"+           ---                <- "B"+             -                <- "A"+        |--------------|+      -}+  ] where+  f = makeTestInputs+  h = makeEventWithConcepts++buildNofUniqueBeginsTests :: TestTree+buildNofUniqueBeginsTests = testGroup+  "Tests ofNofUniqueBegins template"+  (fmap+    (\x -> testCase+      (getTestName x)+      (makeAssertion x (uncurryN buildNofUniqueBegins (getBuilderArgs x)))+    )+    buildNofUniqueBeginsTestCases+  )
src/Hasklepias/Templates/TestUtilities.hs view
@@ -14,33 +14,81 @@ {-# LANGUAGE FlexibleContexts #-}  module Hasklepias.Templates.TestUtilities (-    TemplateTestCase(..)+    TestCase(..)   , evalTestCase   , makeAssertion+  , readIntervalSafe+  , makeEnrollmentEvent+  , makeEventWithConcepts ) where +import Control.Applicative ( Applicative(pure) )+import Data.Bool ( Bool (True) ) import Data.Eq                          ( Eq )+import Data.Monoid ( Monoid(mempty) )+import Data.Text ( Text ) import Data.Tuple                       ( uncurry )+import           Data.Tuple.Curry+-- ( uncurryN )+import           GHC.Real                       ( Integral )+ import GHC.Show                         ( Show )+import EventData+import Cohort.Index import Features.Compose                 ( Feature                                         , Definition(..)                                         , Define(..)                                         , Eval(..) )+import Hasklepias.Misc++import IntervalAlgebra import Test.Tasty                       ( TestName )-import Test.Tasty.HUnit                 ( (@=?), Assertion )+import Test.Tasty.HUnit                 ( (@?=), Assertion ) -data TemplateTestCase a b = MkTemplateTestCase {-    getTestName :: TestName++data TestCase a b builderArgs = MkTestCase {+    getBuilderArgs :: builderArgs+  , getTestName :: TestName   , getInputs :: a   , getTruth  :: Feature "result" b   } deriving (Eq, Show) -evalTestCase :: Eval def args return => -  TemplateTestCase args b -  -> Definition def ++evalTestCase :: (Eval def defArgs return) =>+  TestCase defArgs b builderArgs+  -> Definition def   -> ( return, Feature "result" b )-evalTestCase (MkTemplateTestCase _ inputs truth) def = ( eval def inputs, truth )+evalTestCase (MkTestCase buildArgs _ inputs truth) def = ( eval def inputs, truth ) -makeAssertion :: (Eq b, Show b, Eval def args (Feature "result" b)) =>-  TemplateTestCase args b -> Definition def -> Assertion-makeAssertion x def = uncurry (@=?) (evalTestCase x def)+makeAssertion :: (Eq b, Show b, Eval def defArgs (Feature "result" b)) =>+  TestCase defArgs b  builderArgs -> Definition def -> Assertion+makeAssertion x def = uncurry (@?=) (evalTestCase x def)++readIntervalSafe :: (Integral b, IntervalSizeable a b) => (a, a) -> Interval a+readIntervalSafe (b, e) = beginerval (diff e b) b++makeEnrollmentEvent :: (Integral b, IntervalSizeable a b) => (a, a) -> Event a+makeEnrollmentEvent intrvl =+  event (readIntervalSafe intrvl) (context (Enrollment (EnrollmentFacts ())) mempty)++makeEventWithConcepts :: (Integral b, IntervalSizeable a b) => [Text] -> (a, a) -> Event a+makeEventWithConcepts cpts intrvl = event+  (readIntervalSafe intrvl)+  (context (Enrollment (EnrollmentFacts ())) (packConcepts cpts))++makeTestTemplate+  :: (Integral b, IntervalSizeable a b)+  => TestName  -- ^ name of the test+  -> builderArgs -- ^ tuple of arguments pass to the definition builder+  -> (a, a)    -- ^ index interval +  -> [Event a] -- ^ test events+  -> resultType -- ^ expected result+  -> TestCase+       (F "index" (Index Interval a), F "events" [Event a])+       resultType+       builderArgs+makeTestTemplate name buildArgs intrvl e b = MkTestCase+  buildArgs+  name+  (pure (makeIndex (readIntervalSafe intrvl) ), pure e)+  (pure b)
src/Hasklepias/Templates/Tests.hs view
@@ -9,16 +9,18 @@ -} {-# OPTIONS_HADDOCK hide #-} {-# LANGUAGE NoImplicitPrelude #-}-{-# LANGUAGE DeriveGeneric #-}-{-# LANGUAGE DataKinds #-}-{-# LANGUAGE FlexibleContexts #-}  module Hasklepias.Templates.Tests (    templateTests ) where  import Test.Tasty                               ( testGroup, TestTree )                       -import Hasklepias.Templates.Features.Enrollment ( defEnrollmentTests )+import Hasklepias.Templates.Features.Enrollment ( buildEnrollmentTests )+import Hasklepias.Templates.Features.NsatisfyP  ( buildNsatisfyPTests )  templateTests :: TestTree-templateTests = testGroup "tests of feature templates" [defEnrollmentTests]+templateTests = +   testGroup +      "tests of feature templates" +      [ buildEnrollmentTests+      , buildNsatisfyPTests ]
src/Stype.hs view
@@ -10,12 +10,12 @@ {-# OPTIONS_HADDOCK hide #-} -- {-# LANGUAGE Safe #-} -module Stype (-    module Stype.Numeric+module Stype+  ( module Stype.Numeric   , module Stype.Categorical   , module Stype.Aeson-) where +  ) where -import Stype.Numeric-import Stype.Categorical-import Stype.Aeson+import           Stype.Aeson+import           Stype.Categorical+import           Stype.Numeric
src/Stype/Numeric/Censored.hs view
@@ -30,12 +30,13 @@   Uncensored :: a -> MaybeCensored a   deriving( Eq, Show, Ord, Generic ) +-- | A type to hold a reason that interval fails to parse. newtype ParseIntervalError = ParseIntervalError Text   deriving ( Eq, Show)  -- | A class to censor data class (Ord a, Show a) => Censorable a where-+    parseIntervalCensor :: a -> a -> Either ParseIntervalError (MaybeCensored a)   parseIntervalCensor x y     | x < y = Right $ IntervalCensored x y
src/Stype/Numeric/Count.hs view
@@ -18,6 +18,8 @@ import safe GHC.Num                      ( Natural ) import safe Data.Semiring                ( Semiring(..) ) +{- | Just a type holding a 'GHC.Num.Natural' value.+-} newtype Count = Count Natural   deriving (Eq, Show, Ord, Generic)
+ test/Cohort/AssessmentIntervalsSpec.hs view
@@ -0,0 +1,41 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TypeApplications #-}+++module Cohort.AssessmentIntervalsSpec (+  spec+ ) where++import IntervalAlgebra+import IntervalAlgebra.Arbitrary+import Cohort.Index+import Cohort.AssessmentIntervals+import Test.Hspec ( describe, pending, shouldBe, it, Spec )+import Test.QuickCheck++prop_baseline :: (IntervalSizeable a b) => b -> Interval a -> Property+prop_baseline dur i = relate (baseline dur (makeIndex i)) (makeIndex i) === Meets++prop_baselineBefore :: (IntervalSizeable a b) => b -> b -> Interval a -> Property+prop_baselineBefore s d i = relate (baselineBefore s d (makeIndex i)) (makeIndex i) === Before++prop_followup :: (IntervalSizeable a b) =>  b -> Interval a -> Property+prop_followup d i = relate (followup d (makeIndex i)) (makeIndex i) === StartedBy++prop_followupMetBy :: (IntervalSizeable a b) =>  b -> Interval a -> Property+prop_followupMetBy d i = relate (followupMetBy d (makeIndex i)) (makeIndex i) === MetBy ++prop_followupAfter :: (IntervalSizeable a b) => b -> b -> Interval a -> Property+prop_followupAfter s d i = relate (followupAfter s d (makeIndex i)) (makeIndex i) === After ++spec :: Spec+spec = do++  describe "Assessment Interval properties" $+    do++      it "baseline meets index" $ property ( prop_baseline @Int @Int)+      it "baselineBefore precedes index" $ property ( prop_baseline @Int @Int)+      it "followup starts index" $ property ( prop_followup @Int @Int)+      it "followupMetBy metBy index" $ property ( prop_followupMetBy @Int @Int)+      it "followupAfter after index" $ property ( prop_followupAfter @Int @Int)
+ test/EventData/AccessorsSpec.hs view
@@ -0,0 +1,35 @@+{-# LANGUAGE OverloadedStrings #-}+module EventData.AccessorsSpec (spec) where++import IntervalAlgebra+import EventData ( Event, event )+import EventData.Accessors+import EventData.Context as HC ( context, packConcepts )+import Test.Hspec ( shouldBe, it, Spec )+import Data.Maybe (Maybe(Nothing))+import Data.Set(fromList)+import EventData.Context.Domain++-- | Toy events for unit tests+evnt1 :: Event Int+evnt1 = event ( beginerval (4 :: Int) (1 :: Int) ) +        ( HC.context (UnimplementedDomain ()) (packConcepts ["c1", "c2"] ))+evnt2 :: Event Int+evnt2 = event ( beginerval (4 :: Int) (2 :: Int) )+         ( HC.context (UnimplementedDomain ())  (packConcepts ["c3", "c4"] ))+evnts :: [Event Int]+evnts = [evnt1, evnt2]++evntGender :: Event Int+evntGender = event ( beginerval (4 :: Int) (2 :: Int) )+         ( HC.context (Demographics ( DemographicsFacts (DemographicsInfo Gender (Just "F"))))+           (packConcepts [] ))++spec :: Spec+spec = do+    it "viewGenders on empty list" $+      viewGenders [] `shouldBe` []+    it "viewGenders with no demographic events" $+      viewGenders evnts `shouldBe` []+    it "viewGenders with a demographic event" $+      viewGenders [evntGender] `shouldBe` ["F"]
test/EventDataSpec.hs view
@@ -1,61 +1,76 @@ {-# LANGUAGE OverloadedStrings #-}-module EventDataSpec (spec) where+module EventDataSpec+  ( spec+  ) where -import IntervalAlgebra-import IntervalAlgebra.IntervalUtilities-import Hasklepias.FeatureEvents -import EventData-import EventData.Context as HC-import EventData.Context.Domain ( Domain(UnimplementedDomain) )-import Data.Maybe-import Test.Hspec ( it, shouldBe, Spec )+import           Data.Maybe+import           EventData+import           EventData.Context             as HC+import           EventData.Context.Domain       ( Domain(UnimplementedDomain) )+import           Hasklepias.FeatureEvents+import           IntervalAlgebra+import           IntervalAlgebra.IntervalUtilities+import           Test.Hspec                     ( Spec+                                                , it+                                                , shouldBe+                                                )   evnt1 :: Event Int-evnt1 = event ( beginerval 4 (1 :: Int))-              (HC.context (UnimplementedDomain ()) (packConcepts ["c1", "c2"] ))+evnt1 = event+  (beginerval 4 (1 :: Int))+  (HC.context (UnimplementedDomain ()) (packConcepts ["c1", "c2"])) evnt2 :: Event Int-evnt2 = event ( beginerval 4 (2 :: Int)  )-              (HC.context (UnimplementedDomain ())  (packConcepts ["c3", "c4"] ))+evnt2 = event+  (beginerval 4 (2 :: Int))+  (HC.context (UnimplementedDomain ()) (packConcepts ["c3", "c4"])) evnts :: [Event Int] evnts = [evnt1, evnt2]  containmentInt :: Interval Int-containmentInt = beginerval 10 (0 :: Int) +containmentInt = beginerval 10 (0 :: Int)  noncontainmentInt :: Interval Int-noncontainmentInt = beginerval 6 (4 :: Int) +noncontainmentInt = beginerval 6 (4 :: Int)  anotherInt :: Interval Int-anotherInt = beginerval 5 (15 :: Int) +anotherInt = beginerval 5 (15 :: Int)  spec :: Spec spec = do-    it "hasConcept returns True when concept is in context" $-      (evnt1 `hasConcept` "c1") `shouldBe` True-    it "hasConcept returns False when concept is not in context" $-      (evnt1 `hasConcept` "c3") `shouldBe` False-    it "hasConcepts returns True when at at least one concept is in context" $-      (evnt1 `hasConcepts` ["c3", "c1"]) `shouldBe` True-    it "hasConcepts returns False when no concept is in context" $-      (evnt1 `hasConcepts` ["c3", "c4"]) `shouldBe` False+  it "hasConcept returns True when concept is in context"+    $          (evnt1 `hasConcept` "c1")+    `shouldBe` True+  it "hasConcept returns False when concept is not in context"+    $          (evnt1 `hasConcept` "c3")+    `shouldBe` False+  it "hasConcepts returns True when at at least one concept is in context"+    $          (evnt1 `hasConcepts` ["c3", "c1"])+    `shouldBe` True+  it "hasConcepts returns False when no concept is in context"+    $          (evnt1 `hasConcepts` ["c3", "c4"])+    `shouldBe` False -    it "filterEvents for evnt1" $-      filter (`hasConcept` "c1") evnts `shouldBe` [evnt1]-    it "filterEvents for evnt2" $-      filter (`hasConcept` "c3") evnts `shouldBe` [evnt2]-    it "filterEvents to no events" $-      filter (`hasConcept` "c5") evnts `shouldBe` []+  it "filterEvents for evnt1"+    $          filter (`hasConcept` "c1") evnts+    `shouldBe` [evnt1]+  it "filterEvents for evnt2"+    $          filter (`hasConcept` "c3") evnts+    `shouldBe` [evnt2]+  it "filterEvents to no events"+    $          filter (`hasConcept` "c5") evnts+    `shouldBe` [] -    it "lift2IntervalPredicate meets" $-      meets evnt1 evnt2 `shouldBe` False-    it "lift2IntervalPredicate overlaps" $-      overlaps evnt1 evnt2 `shouldBe` True-    it "lift2IntervalPredicate overlaps" $-      overlappedBy evnt2 evnt1 `shouldBe` True+  it "lift2IntervalPredicate meets" $ meets evnt1 evnt2 `shouldBe` False+  it "lift2IntervalPredicate overlaps" $ overlaps evnt1 evnt2 `shouldBe` True+  it "lift2IntervalPredicate overlaps"+    $          overlappedBy evnt2 evnt1+    `shouldBe` True -    it "filterEvents by interval containment" $-      filterContains containmentInt evnts `shouldBe` evnts-    it "filterEvents by interval containment" $-      filterContains noncontainmentInt evnts `shouldBe` []+  it "filterEvents by interval containment"+    $          filterContains containmentInt evnts+    `shouldBe` evnts+  it "filterEvents by interval containment"+    $          filterContains noncontainmentInt evnts+    `shouldBe` []
test/Features/OutputSpec.hs view
@@ -46,18 +46,22 @@     it "an Int event is parsed correctly" $        encode (index ex1)  `shouldBe` "{\"end\":10,\"begin\":0}" +    -- TODO: these are failing in CI because the `type' field is sorting to after+    --            it "dummy encodes correctly" $         encode dummy `shouldBe` -        "{\"data\":true,\"name\":\"dummy\",\"type\":\"Bool\",\+        "{\"data\":true,\"name\":\"dummy\",\         \\"attrs\":{\"getPurpose\":{\"getTags\":[],\"getRole\":[]},\         \\"getDerivation\":\"a description\",\         \\"getLongLabel\":\"longer label...\",\-        \\"getShortLabel\":\"some Label\"}}"+        \\"getShortLabel\":\"some Label\"},\+        \\"type\":\"Bool\"}"      it "dummy2 encodes correctly" $         encode dummy2 `shouldBe` -        "{\"data\":true,\"name\":\"dummy2\",\"type\":\"Bool\",\+        "{\"data\":true,\"name\":\"dummy2\",\         \\"attrs\":{\"getPurpose\":{\"getTags\":[],\"getRole\":[]},\         \\"getDerivation\":\"\",\         \\"getLongLabel\":\"\",\-        \\"getShortLabel\":\"\"}}"+        \\"getShortLabel\":\"\"},\+        \\"type\":\"Bool\"}"
test/FeaturesSpec.hs view
@@ -1,11 +1,16 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE DataKinds #-}-module FeaturesSpec (- spec-) where+module FeaturesSpec+  ( spec+  ) where -import Features-import Test.Hspec ( describe, pending, shouldBe, it, Spec )+import           Features+import           Test.Hspec                     ( Spec+                                                , describe+                                                , it+                                                , pending+                                                , shouldBe+                                                )   -----------------------------------@@ -17,22 +22,18 @@  d1 :: Definition (FeatureData Int -> FeatureData Int) d1 = defineA-  (\x ->-    if x < 0 then-      missingBecause $ Other "at least 1 < 0"-    else-      pure (x + 1)-   )+  (\x -> if x < 0 then missingBecause $ Other "at least 1 < 0" else pure (x + 1)+  )  d2 :: Definition (FeatureData Int -> FeatureData Int)-d2 = define (*2)+d2 = define (* 2)  -d3 ::  Definition (FeatureData Int -> FeatureData Int -> FeatureData Int)+d3 :: Definition (FeatureData Int -> FeatureData Int -> FeatureData Int) d3 = define (+)  f1 :: Int -> Int-f1 = (+2)+f1 = (+ 2)  f1D :: Definition (FeatureData Int -> FeatureData Int) f1D = define f1@@ -41,28 +42,33 @@ f1F = define f1  f2 :: Bool -> FeatureData Int-f2 True = pure 1+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' 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 True  1 = "this" f3 False 9 = "that"-f3 _ _ = "otherwise"+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+  :: Definition+       (  Feature "myBool" Bool+       -> Feature "someInt" Int+       -> Feature "myString" String+       ) f3F = define f3  @@ -71,13 +77,17 @@  feat1 :: Definition (Feature "someInts" [Int] -> Feature "hasMoreThan3" Bool) feat1 = defineA-  (\ints -> if null ints then makeFeature (missingBecause $ Other "no data")-           else makeFeature $ featureDataR (length ints > 3))+  (\ints -> if null ints+    then makeFeature (missingBecause $ Other "no data")+    else makeFeature $ featureDataR (length ints > 3)+  ) -feat2 :: Definition (-      Feature "hasMoreThan3" Bool-  -> Feature "someInts" [Int]-  -> Feature "sum" Int)+feat2+  :: Definition+       (  Feature "hasMoreThan3" Bool+       -> Feature "someInts" [Int]+       -> Feature "sum" Int+       ) feat2 = define (\b ints -> if b then sum ints else 0)  ex0 = featInts []@@ -88,81 +98,78 @@ ex1a = eval feat1 ex1 -- MkFeature (MkFeatureData (Right False)) ex1b = eval feat2 (ex1a, ex1) -- MkFeature (MkFeatureData (Right 0)) -ex2 = featInts [1..4]+ex2 = featInts [1 .. 4] ex2a = eval feat1 ex2 -- MkFeature (MkFeatureData (Right True)) ex2b = eval feat2 (ex2a, ex2) -- MkFeature (MkFeatureData (Right 10))  spec :: Spec spec = do -  describe "checking d1" $-    do-      it "eval of d1 on d0" $-        eval d1 (pure 5) `shouldBe` featureDataR  6-      it "eval of d1 returns correct value" $-        eval d1 (featureDataR 5 ) `shouldBe`-          featureDataR 6-      it "d1 returns correct error" $-        eval d1 (featureDataR (-1)) `shouldBe`-          missingBecause (Other "at least 1 < 0")+  describe "checking d1" $ do+    it "eval of d1 on d0" $ eval d1 (pure 5) `shouldBe` featureDataR 6+    it "eval of d1 returns correct value"+      $          eval d1 (featureDataR 5)+      `shouldBe` featureDataR 6+    it "d1 returns correct error"+      $          eval d1 (featureDataR (-1))+      `shouldBe` missingBecause (Other "at least 1 < 0") -  describe "checking d2" $-    do-      it "eval of d2 returns correct value" $-        eval d2 (featureDataR 5) `shouldBe`-          featureDataR 10-      it "eval of d2 returns correct value" $-        eval d2 (featureDataR 5) `shouldBe`-          featureDataR 10-      it "d2 returns correct error" $-        eval d2 (featureDataL (Other "at least 1 < 0") ) `shouldBe`-          featureDataL (Other "at least 1 < 0")+  describe "checking d2" $ do+    it "eval of d2 returns correct value"+      $          eval d2 (featureDataR 5)+      `shouldBe` featureDataR 10+    it "eval of d2 returns correct value"+      $          eval d2 (featureDataR 5)+      `shouldBe` featureDataR 10+    it "d2 returns correct error"+      $          eval d2 (featureDataL (Other "at least 1 < 0"))+      `shouldBe` featureDataL (Other "at least 1 < 0") -  describe "checking d3" $-    do-      it "eval of d2 returns correct values" $-        eval d3 (featureDataR 5, featureDataR 6)  `shouldBe`-          featureDataR 11-      it "eval of d3 returns correct values" $-        eval d3 (featureDataR 5, featureDataR 5) `shouldBe`-          featureDataR 10-      it "d3 returns correct error" $-        eval d3 (featureDataL (Other "at least 1 < 0"), featureDataR 6)  `shouldBe`-          featureDataL (Other "at least 1 < 0")-      it "d3 returns correct error" $-        eval d3 (featureDataR 6, featureDataL (Other "at least 1 < 0")) `shouldBe`-          featureDataL (Other "at least 1 < 0")+  describe "checking d3" $ do+    it "eval of d2 returns correct values"+      $          eval d3 (featureDataR 5, featureDataR 6)+      `shouldBe` featureDataR 11+    it "eval of d3 returns correct values"+      $          eval d3 (featureDataR 5, featureDataR 5)+      `shouldBe` featureDataR 10+    it "d3 returns correct error"+      $          eval d3 (featureDataL (Other "at least 1 < 0"), featureDataR 6)+      `shouldBe` featureDataL (Other "at least 1 < 0")+    it "d3 returns correct error"+      $          eval d3 (featureDataR 6, featureDataL (Other "at least 1 < 0"))+      `shouldBe` featureDataL (Other "at least 1 < 0") -  describe "checking f1" $-    do-      it "eval of f1F on d0 returns correct value" $-        eval f1F (pure 5) `shouldBe` pure 7+  describe "checking 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 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"+  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" -  describe "checking ex0-2" $-    do-      it "ex0b" $-        ex0b `shouldBe` makeFeature (missingBecause (Other "no data"))-      it "ex1b" $-        ex1b `shouldBe` makeFeature (featureDataR 0)-      it "ex2b" $-        ex2b `shouldBe` makeFeature (featureDataR 10)+  describe "checking ex0-2" $ do+    it "ex0b" $ ex0b `shouldBe` makeFeature (missingBecause (Other "no data"))+    it "ex1b" $ ex1b `shouldBe` makeFeature (featureDataR 0)+    it "ex2b" $ ex2b `shouldBe` makeFeature (featureDataR 10)
test/Hasklepias/FeatureEventsSpec.hs view
@@ -23,11 +23,6 @@ evnts :: [Event Int] evnts = [evnt1, evnt2] -evntGender :: Event Int-evntGender = event ( beginerval (4 :: Int) (2 :: Int) )-         ( HC.context (Demographics ( DemographicsFacts (DemographicsInfo Gender (Just "F"))))-           (packConcepts [] ))- spec :: Spec spec = do     it "find first occurrence of c1" $@@ -44,9 +39,13 @@     it "dayOfMonthFromDay" $       dayOfMonthFromDay (fromGregorian 2021 8 18) `shouldBe` 18 -    it "viewGenders on empty list" $-      viewGenders [] `shouldBe` []-    it "viewGenders with no demographic events" $-      viewGenders evnts `shouldBe` []-    it "viewGenders with a demographic event" $-      viewGenders [evntGender] `shouldBe` ["F"]+    it "pairGaps" $+      pairGaps ([] :: [Interval Int]) `shouldBe` []+    it "pairGaps" $+      pairGaps [beginerval 5 (0::Int), beginerval 5 (0::Int)] `shouldBe` [Nothing]+    it "pairGaps" $+      pairGaps [beginerval 5 (0::Int), beginerval 5 (0::Int), beginerval 1 (10::Int)] +        `shouldBe` [Nothing, Just 5, Just 5]+    it "pairGaps" $+      pairGaps [beginerval 5 (0::Int), beginerval 1 (6::Int), beginerval 1 (10::Int)] +        `shouldBe` [Just 1, Just 5, Just 3]