diff --git a/ChangeLog.md b/ChangeLog.md --- a/ChangeLog.md +++ b/ChangeLog.md @@ -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`. diff --git a/exampleApp/Main.hs b/exampleApp/Main.hs --- a/exampleApp/Main.hs +++ b/exampleApp/Main.hs @@ -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] diff --git a/examples/ExampleCohort1.hs b/examples/ExampleCohort1.hs --- a/examples/ExampleCohort1.hs +++ b/examples/ExampleCohort1.hs @@ -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 ] diff --git a/examples/ExampleEvents.hs b/examples/ExampleEvents.hs --- a/examples/ExampleEvents.hs +++ b/examples/ExampleEvents.hs @@ -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") + ] diff --git a/examples/ExampleFeatures1.hs b/examples/ExampleFeatures1.hs --- a/examples/ExampleFeatures1.hs +++ b/examples/ExampleFeatures1.hs @@ -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 + ] + ) diff --git a/examples/ExampleFeatures2.hs b/examples/ExampleFeatures2.hs --- a/examples/ExampleFeatures2.hs +++ b/examples/ExampleFeatures2.hs @@ -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] diff --git a/examples/ExampleFeatures3.hs b/examples/ExampleFeatures3.hs --- a/examples/ExampleFeatures3.hs +++ b/examples/ExampleFeatures3.hs @@ -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) diff --git a/examples/ExampleFeatures4.hs b/examples/ExampleFeatures4.hs --- a/examples/ExampleFeatures4.hs +++ b/examples/ExampleFeatures4.hs @@ -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 diff --git a/examples/Main.hs b/examples/Main.hs --- a/examples/Main.hs +++ b/examples/Main.hs @@ -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]] + ) diff --git a/hasklepias.cabal b/hasklepias.cabal --- a/hasklepias.cabal +++ b/hasklepias.cabal @@ -1,6 +1,6 @@ cabal-version: 2.2 name: hasklepias -version: 0.16.1 +version: 0.17.0 description: Please see the README on GitHub at 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 diff --git a/src/Cohort.hs b/src/Cohort.hs --- a/src/Cohort.hs +++ b/src/Cohort.hs @@ -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 diff --git a/src/Cohort/AssessmentIntervals.hs b/src/Cohort/AssessmentIntervals.hs new file mode 100644 --- /dev/null +++ b/src/Cohort/AssessmentIntervals.hs @@ -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 ) diff --git a/src/Cohort/Criteria.hs b/src/Cohort/Criteria.hs --- a/src/Cohort/Criteria.hs +++ b/src/Cohort/Criteria.hs @@ -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) diff --git a/src/Cohort/Index.hs b/src/Cohort/Index.hs --- a/src/Cohort/Index.hs +++ b/src/Cohort/Index.hs @@ -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) + diff --git a/src/Cohort/Output.hs b/src/Cohort/Output.hs --- a/src/Cohort/Output.hs +++ b/src/Cohort/Output.hs @@ -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 diff --git a/src/EventData.hs b/src/EventData.hs --- a/src/EventData.hs +++ b/src/EventData.hs @@ -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 diff --git a/src/EventData/Accessors.hs b/src/EventData/Accessors.hs new file mode 100644 --- /dev/null +++ b/src/EventData/Accessors.hs @@ -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) diff --git a/src/EventData/Aeson.hs b/src/EventData/Aeson.hs --- a/src/EventData/Aeson.hs +++ b/src/EventData/Aeson.hs @@ -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 diff --git a/src/EventData/Arbitrary.hs b/src/EventData/Arbitrary.hs --- a/src/EventData/Arbitrary.hs +++ b/src/EventData/Arbitrary.hs @@ -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) diff --git a/src/EventData/Context.hs b/src/EventData/Context.hs --- a/src/EventData/Context.hs +++ b/src/EventData/Context.hs @@ -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 diff --git a/src/EventData/Core.hs b/src/EventData/Core.hs --- a/src/EventData/Core.hs +++ b/src/EventData/Core.hs @@ -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 diff --git a/src/EventData/Predicates.hs b/src/EventData/Predicates.hs new file mode 100644 --- /dev/null +++ b/src/EventData/Predicates.hs @@ -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) diff --git a/src/Features.hs b/src/Features.hs --- a/src/Features.hs +++ b/src/Features.hs @@ -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 diff --git a/src/Features/Attributes.hs b/src/Features/Attributes.hs --- a/src/Features/Attributes.hs +++ b/src/Features/Attributes.hs @@ -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 { diff --git a/src/Features/Compose.hs b/src/Features/Compose.hs --- a/src/Features/Compose.hs +++ b/src/Features/Compose.hs @@ -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 -} diff --git a/src/Features/Featureable.hs b/src/Features/Featureable.hs --- a/src/Features/Featureable.hs +++ b/src/Features/Featureable.hs @@ -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 diff --git a/src/Features/Featureset.hs b/src/Features/Featureset.hs --- a/src/Features/Featureset.hs +++ b/src/Features/Featureset.hs @@ -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) diff --git a/src/Features/Output.hs b/src/Features/Output.hs --- a/src/Features/Output.hs +++ b/src/Features/Output.hs @@ -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 diff --git a/src/Hasklepias.hs b/src/Hasklepias.hs --- a/src/Hasklepias.hs +++ b/src/Hasklepias.hs @@ -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 diff --git a/src/Hasklepias/FeatureEvents.hs b/src/Hasklepias/FeatureEvents.hs --- a/src/Hasklepias/FeatureEvents.hs +++ b/src/Hasklepias/FeatureEvents.hs @@ -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. diff --git a/src/Hasklepias/Reexports.hs b/src/Hasklepias/Reexports.hs --- a/src/Hasklepias/Reexports.hs +++ b/src/Hasklepias/Reexports.hs @@ -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 diff --git a/src/Hasklepias/ReexportsUnsafe.hs b/src/Hasklepias/ReexportsUnsafe.hs --- a/src/Hasklepias/ReexportsUnsafe.hs +++ b/src/Hasklepias/ReexportsUnsafe.hs @@ -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 ) diff --git a/src/Hasklepias/Templates/Features.hs b/src/Hasklepias/Templates/Features.hs --- a/src/Hasklepias/Templates/Features.hs +++ b/src/Hasklepias/Templates/Features.hs @@ -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) diff --git a/src/Hasklepias/Templates/Features/Enrollment.hs b/src/Hasklepias/Templates/Features/Enrollment.hs --- a/src/Hasklepias/Templates/Features/Enrollment.hs +++ b/src/Hasklepias/Templates/Features/Enrollment.hs @@ -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] diff --git a/src/Hasklepias/Templates/Features/NsatisfyP.hs b/src/Hasklepias/Templates/Features/NsatisfyP.hs new file mode 100644 --- /dev/null +++ b/src/Hasklepias/Templates/Features/NsatisfyP.hs @@ -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 + ) diff --git a/src/Hasklepias/Templates/TestUtilities.hs b/src/Hasklepias/Templates/TestUtilities.hs --- a/src/Hasklepias/Templates/TestUtilities.hs +++ b/src/Hasklepias/Templates/TestUtilities.hs @@ -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) diff --git a/src/Hasklepias/Templates/Tests.hs b/src/Hasklepias/Templates/Tests.hs --- a/src/Hasklepias/Templates/Tests.hs +++ b/src/Hasklepias/Templates/Tests.hs @@ -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 ] diff --git a/src/Stype.hs b/src/Stype.hs --- a/src/Stype.hs +++ b/src/Stype.hs @@ -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 diff --git a/src/Stype/Numeric/Censored.hs b/src/Stype/Numeric/Censored.hs --- a/src/Stype/Numeric/Censored.hs +++ b/src/Stype/Numeric/Censored.hs @@ -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 diff --git a/src/Stype/Numeric/Count.hs b/src/Stype/Numeric/Count.hs --- a/src/Stype/Numeric/Count.hs +++ b/src/Stype/Numeric/Count.hs @@ -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) diff --git a/test/Cohort/AssessmentIntervalsSpec.hs b/test/Cohort/AssessmentIntervalsSpec.hs new file mode 100644 --- /dev/null +++ b/test/Cohort/AssessmentIntervalsSpec.hs @@ -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) diff --git a/test/EventData/AccessorsSpec.hs b/test/EventData/AccessorsSpec.hs new file mode 100644 --- /dev/null +++ b/test/EventData/AccessorsSpec.hs @@ -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"] diff --git a/test/EventDataSpec.hs b/test/EventDataSpec.hs --- a/test/EventDataSpec.hs +++ b/test/EventDataSpec.hs @@ -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` [] diff --git a/test/Features/OutputSpec.hs b/test/Features/OutputSpec.hs --- a/test/Features/OutputSpec.hs +++ b/test/Features/OutputSpec.hs @@ -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\"}" diff --git a/test/FeaturesSpec.hs b/test/FeaturesSpec.hs --- a/test/FeaturesSpec.hs +++ b/test/FeaturesSpec.hs @@ -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) diff --git a/test/Hasklepias/FeatureEventsSpec.hs b/test/Hasklepias/FeatureEventsSpec.hs --- a/test/Hasklepias/FeatureEventsSpec.hs +++ b/test/Hasklepias/FeatureEventsSpec.hs @@ -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]