hasklepias 0.18.0 → 0.20.0
raw patch · 27 files changed
+1748/−839 lines, 27 filesdep +amazonkadep +amazonka-s3dep +conduitdep ~bytestringnew-component:exe:collector
Dependencies added: amazonka, amazonka-s3, conduit, conduit-extra, optparse-applicative, tasty-silver
Dependency ranges changed: bytestring
Files
- ChangeLog.md +37/−0
- collector-test/Main.hs +46/−0
- collector/Main.hs +72/−0
- exampleApp/Main.hs +15/−9
- examples/ExampleCohort1.hs +86/−29
- examples/ExampleFeatures1.hs +4/−6
- hasklepias.cabal +31/−2
- src/Cohort/AssessmentIntervals.hs +59/−55
- src/Cohort/Core.hs +198/−74
- src/Cohort/Criteria.hs +82/−53
- src/Cohort/Index.hs +14/−13
- src/Cohort/Input.hs +88/−59
- src/Cohort/Output.hs +199/−79
- src/Features/Compose.hs +8/−1
- src/Hasklepias.hs +39/−1
- src/Hasklepias/CohortCollection.hs +84/−0
- src/Hasklepias/FeatureEvents.hs +217/−176
- src/Hasklepias/MakeApp.hs +117/−92
- src/Hasklepias/Misc.hs +32/−32
- src/Hasklepias/Reexports.hs +181/−133
- src/Hasklepias/ReexportsUnsafe.hs +13/−10
- src/Hasklepias/Templates.hs +4/−5
- src/Hasklepias/Templates/Features/Enrollment.hs +0/−1
- src/Hasklepias/Templates/Features/NsatisfyP.hs +2/−3
- src/Hasklepias/Templates/TestUtilities.hs +2/−1
- test/Cohort/CoreSpec.hs +25/−5
- test/Cohort/OutputSpec.hs +93/−0
ChangeLog.md view
@@ -1,5 +1,42 @@ # Changelog for hasklepias +## 0.20.0++* Adds the `Hasklepias.CohortCollection` module which is exposed as the `collector` application. This application can be used to combine cohorts that were derived from different input data (e.g. different partitions of data). However, cohorts must be derived from the same specification using the same shape (e.g. `rowWise` or `colWise`). The application can be installed from the asclepias repository using `cabal install`. It is also available to download from `download.novisci.com/hasklepias/collector-0.20.0-linux.tar.gz` (currently only available for linux (not sure of architecture)). The following gives an example of using the application on local files:++```sh+$ cat collector-test/tests/manifestrw.txt +testrw1.json+testrw2.json+testrw3.json+$ collector -f collector-test/tests/manifestrw.txt -d collector-test/tests+{"example":[{"totalProcessed":7,"attritionInfo":[{"attritionCount":2,"attritionLevel":{"contents":[1,"dummy"],"tag":"ExcludedBy"}},{"attritionCount":5,"attritionLevel":{"tag":"Included"}}]},{"contents":{"rowAttributes":[{"name":"myVar1","attrs":{"getPurpose":{"getTags":[],"getRole":["Outcome"]},"getDerivation":"","getLongLabel":"another label","getShortLabel":"somelabel"},"type":"Count"},{"name":"myVar2","attrs":{"getPurpose":{"getTags":[],"getRole":[]},"getDerivation":"","getLongLabel":"","getShortLabel":""},"type":"Bool"}],"rowData":[["a",[5,true]],["b",[5,true]],["c",[10,false]],["d",[99,true]],["f",[86,true]]]},"tag":"RW"}]}+```++## 0.19.0++* Overhauls the way that cohorts are written to JSON, mostly in the `Cohort.Output` module. The important bit is that intermediate types were added that can hold both row-wise and column-wise cohort data as list of `Value`s (`Data.Aeson` internal representation of JSON). These intermediate types were made `Semigroup` instances, which means that cohorts can be *combined*. Note that you should only combine cohorts (and set of cohorts) evaluated from the same set of cohort specifications. Since all types of the the underlying data are masked by `Value`, you technically can combine any values of these intermediate types, but the results would be generally be nonsensical. Use this feature of combining cohorts to (e.g.) collect the same cohort data processed on different partitions of population data. While users should not need to worry about these details, here is the semigroup behavior for two cohorts (i.e. `cohort1 <> cohort2`):+ * In both row-wise and column-wise formats, attrition information is added as one would expect.+ * In both row-wise and column-wise formats, feature attributes are kept from the first cohort (again, you should only combine two compatible cohorts).+ * In row-wise format, row data is stacked.+ * In column-wise format, data is stacked by column.+ * If you try to combine a row-wise cohort with a column-wise cohort, the cohort in the second position is dropped altogether.+* Adds a `CohortSet` type (which is technically not a `Set` but a `Map`) as a container for `Cohort`s, in this way each cohort can be named. Correspondingly, adds a `CohortSetSpec` type which is a `Map` of `CohortSpec`s.+* Adds the constructor function `makeCohortSpecs` for easily making a `CohortSetSpec` from a list.+* Adds the `evalCohortSet` function which evaluates a `CohortSetSpec` from `Population` into a `CohortSet`.+* Moves the `F` type synonym for `Feature` to the `Feature` module.+* Removes any the usage of `Data.List.NonEmpty.fromList` in `Cohort.Output` which was throwing an error when the input data is empty.+* Adds the empty file `exampleData/emptyData.jsonl` for testing the app on empty data.++## 0.18.2++* Mostly internal work to clean up `AttributionInfo` values. Now counts for all the criteria are included in the information, including 0 counts. Also added a total processed field. Adds a `Semigroup` instance for `AttributionInfo` so that attrition information can be later combined -- this will be useful, for example, when combining the same cohort across partitions.+* Adds `FromJSON` instance for `AttributionInfo` (and its components), so that attrition info can be read back into a Haskell program.++## 0.18.1++* Fixes incorrect type on `buildNofConceptsBinaryConcurBaseline` which returned `Bool` instead of `Binary`.+ ## 0.18.0 * Refactors the `Features.Compose` module a bit. Adds constructors for composing `Definition`. For example, `D1C :: (a2 -> a1 -> a) -> Definition (F n1 b -> F n02 a2) -> Definition (F n1 b -> F n01 a1) -> Definition (F n1 b -> F n0 a )`. Such constructors allow one to build definitions from other definitions, provided the input types are the same. Note: there is *not* a single interface to these constructors like is provided by the `define` and `defineA` functions. The poorly designed `Eval` typeclass is now replaced with a single `eval` function which simply pattern matches on the various shapes of `Definition`s. I fully expect this module to get another refactor in the future, but it is shaping up OK.
+ collector-test/Main.hs view
@@ -0,0 +1,46 @@+{-| Tests of the collector application+-}++module Main + ( main+ ) where++-- import Main (tests)+import Hasklepias (runCollectionApp, Location(..))+import Test.Tasty (defaultMain, TestTree, testGroup)+import Test.Tasty.Silver+import qualified Data.ByteString.Lazy as B++appTestRw :: IO ()+appTestRw = do+ r <- runCollectionApp+ [ Local "collector-test/tests/testrw1.json"+ , Local "collector-test/tests/testrw2.json"+ , Local "collector-test/tests/testrw3.json"+ ]+ B.writeFile "collector-test/tests/testrw.json" r++appTestCw :: IO ()+appTestCw = do+ r <- runCollectionApp+ [ Local "collector-test/tests/testcw1.json"+ , Local "collector-test/tests/testcw2.json"+ , Local "collector-test/tests/testcw3.json"+ ]+ B.writeFile "collector-test/tests/testcw.json" r++tests :: TestTree+tests = testGroup+ "Tests of cohort collection"+ [ goldenVsFile "Collection of row-wise cohorts"+ "collector-test/tests/testrw.golden"+ "collector-test/tests/testrw.json"+ appTestRw+ , goldenVsFile "Collection of column-wise cohorts"+ "collector-test/tests/testcw.golden"+ "collector-test/tests/testcw.json"+ appTestCw+ ]++main :: IO ()+main = defaultMain tests
+ collector/Main.hs view
@@ -0,0 +1,72 @@+{-| An application for collecting cohorts run on different partitions of data+-}++module Main+ ( main+ ) where++import qualified Data.ByteString.Lazy.Char8 as C+ ( lines+ , putStrLn+ , toStrict+ )+import Hasklepias ( runCollectionApp, getLocations, Input(..) )+import Options.Applicative+++fileInput :: Parser Input+fileInput =+ FileInput+ <$> optional+ (strOption $ long "dir" <> short 'd' <> metavar "DIRECTORY" <> help+ "optional directory"+ )+ <*> strOption+ (long "file" <> short 'f' <> metavar "INPUT" <> help "Input file")++s3input :: Parser Input+s3input =+ S3Input+ <$> strOption+ (long "bucket" <> short 'b' <> metavar "Bucket" <> help "S3 bucket")+ <*> strOption+ (long "manifest" <> short 'm' <> metavar "KEY" <> help+ "S3 manifest file"+ )++data CollectorApp = CollectorApp+ { input :: Input+ , ouput :: FilePath+ }++collector :: Parser CollectorApp+collector = CollectorApp <$> (fileInput <|> s3input) <*> strOption+ (long "output" <> short 'o' <> metavar "FILE" <> value "output.json" <> help+ "Output location"+ )++desc = + "Collects cohorts run on different input data. The cohorts must be derived \+ \from the same cohort specification or results my be weird. Supports reading \+ \data from a local directory or from S3. In either case the input is a path \+ \to a file containing paths (or S3 keys) to each cohort part, where One line \+ \= one file.\+ \\n\n\+ \S3 capabilities are currently limited (e.g. AWS region is set \+ \to N. Virginia)."+++opts :: ParserInfo CollectorApp+opts = Options.Applicative.info+ (collector <**> helper)+ (fullDesc <> progDesc desc <> header "cohort collector")++main :: IO ()+main = do+ options <- execParser opts++ let files = input options+ fs <- getLocations files++ r <- runCollectionApp fs+ C.putStrLn r
exampleApp/Main.hs view
@@ -31,13 +31,13 @@ -- | Lift a subject's events in a feature featureDummy- :: Definition (Feature "allEvents" (Events Day) -> Feature "dummy" Count)+ :: Definition (Feature "allEvents" (Events Day) -> Feature "myVar1" Count) featureDummy = define $ pure 5 -- | Lift a subject's events in a feature anotherDummy :: Bool- -> Definition (Feature "allEvents" (Events Day) -> Feature "another" Bool)+ -> Definition (Feature "allEvents" (Events Day) -> Feature "myVar2" Bool) anotherDummy x = define $ const x -- | Include the subject if she has an enrollment interval concurring with index.@@ -45,10 +45,15 @@ :: Definition (Feature "allEvents" (Events Day) -> Feature "dummy" Status) critTrue = define $ pure Include -instance HasAttributes "dummy" Count where- getAttributes _ = emptyAttributes+instance HasAttributes "myVar1" Count where+ getAttributes _ = + MkAttributes {+ getShortLabel = "somelabel"+ , getLongLabel = "another label"+ , getDerivation = ""+ , getPurpose = MkPurpose (setFromList [Outcome]) (setFromList [])} -instance HasAttributes "another" Bool where+instance HasAttributes "myVar2" Bool where getAttributes _ = emptyAttributes {------------------------------------------------------------------------------- Cohort Specifications and evaluation@@ -69,9 +74,10 @@ ) where ef = featureEvents events --- | Make a cohort specification for each calendar time-cohortSpecs :: [CohortSpec (Events Day) Featureset]-cohortSpecs = [specifyCohort makeCriteriaRunner makeFeatureRunner]+-- | Make a cohort specification set+cohortSpecs :: CohortSetSpec (Events Day) Featureset+cohortSpecs = + makeCohortSpecs [("example", makeCriteriaRunner, makeFeatureRunner)] main :: IO ()-main = makeCohortApp "testCohort" "v0.1.0" colWise cohortSpecs+main = makeCohortApp "testCohort" "v0.1.0" rowWise cohortSpecs
examples/ExampleCohort1.hs view
@@ -17,6 +17,7 @@ ( exampleCohort1tests ) where import Hasklepias+import Prelude ( uncurry ) {------------------------------------------------------------------------------- Constants -------------------------------------------------------------------------------}@@ -302,14 +303,23 @@ ef = featureEvents events -- | Make a cohort specification for each calendar time-cohortSpecs :: [CohortSpec (Events Day) Featureset]+-- cohortSpecs :: [CohortSpec (Events Day) Featureset]+-- cohortSpecs =+-- map (\x -> specifyCohort (makeCriteriaRunner x) (makeFeatureRunner x)) indices++cohortSpecs :: CohortSetSpec (Events Day) Featureset cohortSpecs =- map (\x -> specifyCohort (makeCriteriaRunner x) (makeFeatureRunner x)) indices+ makeCohortSpecs $+ map (\x -> (pack $ show x, makeCriteriaRunner x, makeFeatureRunner x)) indices + -- | A function that evaluates all the calendar cohorts for a population-evalCohorts :: Population (Events Day) -> [Cohort Featureset]-evalCohorts pop = map (`evalCohort` pop) cohortSpecs+-- evalCohorts :: Population (Events Day) -> [Cohort Featureset]+-- evalCohorts pop = map (`evalCohort` pop) cohortSpecs +evalCohorts :: Population (Events Day) -> CohortSet Featureset+evalCohorts = evalCohortSet cohortSpecs+ {------------------------------------------------------------------------------- Testing This would generally be in a separate file@@ -412,37 +422,84 @@ makeExpectedCohort :: AttritionInfo -> [ObsUnit Featureset] -> Cohort Featureset-makeExpectedCohort a x = MkCohort (Just a, MkCohortData x)+makeExpectedCohort a x = MkCohort (a, MkCohortData x) +mkAl :: (CohortStatus, Natural) -> AttritionLevel+mkAl = uncurry MkAttritionLevel+ expectedCohorts :: [Cohort Featureset] expectedCohorts = zipWith (curry MkCohort)- [ Just- $ MkAttritionInfo- $ (ExcludedBy (2, "isOver50"), 1)- :| [(ExcludedBy (4, "isContinuousEnrolled"), 1)]- , Just $ MkAttritionInfo $ (ExcludedBy (2, "isOver50"), 1) :| [(Included, 1)]- , Just $ MkAttritionInfo $ (ExcludedBy (2, "isOver50"), 1) :| [(Included, 1)]- , Just $ MkAttritionInfo $ (ExcludedBy (2, "isOver50"), 1) :| [(Included, 1)]- , Just- $ MkAttritionInfo- $ (ExcludedBy (2, "isOver50"), 1)- :| [(ExcludedBy (4, "isContinuousEnrolled"), 1)]- , Just- $ MkAttritionInfo- $ (ExcludedBy (2, "isOver50"), 1)- :| [(ExcludedBy (3, "isEnrolled"), 1)]- , Just- $ MkAttritionInfo- $ (ExcludedBy (2, "isOver50"), 1)- :| [(ExcludedBy (3, "isEnrolled"), 1)]- , Just- $ MkAttritionInfo- $ (ExcludedBy (2, "isOver50"), 1)- :| [(ExcludedBy (3, "isEnrolled"), 1)]+ [ MkAttritionInfo 2 $ setFromList+ [ mkAl (ExcludedBy (1, "isFemale"), 0)+ , mkAl (ExcludedBy (2, "isOver50"), 1)+ , mkAl (ExcludedBy (3, "isEnrolled"), 0)+ , mkAl (ExcludedBy (4, "isContinuousEnrolled"), 1)+ , mkAl (ExcludedBy (5, "isDead"), 0)+ , mkAl (Included, 0)+ ]+ , MkAttritionInfo 2 $ setFromList+ [ mkAl (ExcludedBy (1, "isFemale"), 0)+ , mkAl (ExcludedBy (2, "isOver50"), 1)+ , mkAl (ExcludedBy (3, "isEnrolled"), 0)+ , mkAl (ExcludedBy (4, "isContinuousEnrolled"), 0)+ , mkAl (ExcludedBy (5, "isDead"), 0)+ , mkAl (Included, 1)+ ]+ , MkAttritionInfo 2 $ setFromList+ [ mkAl (ExcludedBy (1, "isFemale"), 0)+ , mkAl (ExcludedBy (2, "isOver50"), 1)+ , mkAl (ExcludedBy (3, "isEnrolled"), 0)+ , mkAl (ExcludedBy (4, "isContinuousEnrolled"), 0)+ , mkAl (ExcludedBy (5, "isDead"), 0)+ , mkAl (Included, 1)+ ]+ , MkAttritionInfo 2 $ setFromList+ [ mkAl (ExcludedBy (1, "isFemale"), 0)+ , mkAl (ExcludedBy (2, "isOver50"), 1)+ , mkAl (ExcludedBy (3, "isEnrolled"), 0)+ , mkAl (ExcludedBy (4, "isContinuousEnrolled"), 0)+ , mkAl (ExcludedBy (5, "isDead"), 0)+ , mkAl (Included, 1)+ ]+ , MkAttritionInfo 2 $ setFromList+ [ mkAl (ExcludedBy (1, "isFemale"), 0)+ , mkAl (ExcludedBy (2, "isOver50"), 1)+ , mkAl (ExcludedBy (3, "isEnrolled"), 0)+ , mkAl (ExcludedBy (4, "isContinuousEnrolled"), 1)+ , mkAl (ExcludedBy (5, "isDead"), 0)+ , mkAl (Included, 0)+ ]+ , MkAttritionInfo 2 $ setFromList+ [ mkAl (ExcludedBy (1, "isFemale"), 0)+ , mkAl (ExcludedBy (2, "isOver50"), 1)+ , mkAl (ExcludedBy (3, "isEnrolled"), 1)+ , mkAl (ExcludedBy (4, "isContinuousEnrolled"), 0)+ , mkAl (ExcludedBy (5, "isDead"), 0)+ , mkAl (Included, 0)+ ]+ , MkAttritionInfo 2 $ setFromList+ [ mkAl (ExcludedBy (1, "isFemale"), 0)+ , mkAl (ExcludedBy (2, "isOver50"), 1)+ , mkAl (ExcludedBy (3, "isEnrolled"), 1)+ , mkAl (ExcludedBy (4, "isContinuousEnrolled"), 0)+ , mkAl (ExcludedBy (5, "isDead"), 0)+ , mkAl (Included, 0)+ ]+ , MkAttritionInfo 2 $ setFromList+ [ mkAl (ExcludedBy (1, "isFemale"), 0)+ , mkAl (ExcludedBy (2, "isOver50"), 1)+ , mkAl (ExcludedBy (3, "isEnrolled"), 1)+ , mkAl (ExcludedBy (4, "isContinuousEnrolled"), 0)+ , mkAl (ExcludedBy (5, "isDead"), 0)+ , mkAl (Included, 0)+ ] ] (fmap MkCohortData ([[]] ++ transpose [expectedObsUnita] ++ [[], [], [], []])) +expectedCohortSet :: CohortSet Featureset+expectedCohortSet = MkCohortSet $ mapFromList $ zip (fmap (pack.show) indices) expectedCohorts+ exampleCohort1tests :: TestTree exampleCohort1tests = testGroup "Unit tests for calendar cohorts"@@ -451,5 +508,5 @@ -- Featureable cannot be tested for equality directly, hence encoding to -- JSON bytestring and testing that for equality encode (evalCohorts testPop)- @?= encode expectedCohorts+ @?= encode expectedCohortSet ]
examples/ExampleFeatures1.hs view
@@ -16,13 +16,8 @@ ( exampleFeatures1Spec ) where -import Cohort ( AssessmentInterval )-import Control.Monad import ExampleEvents-import Features ( HasAttributes ) import Hasklepias-import Hasklepias ( IntervalSizeable )-import Hasklepias.ReexportsUnsafe ( ToJSON ) import Test.Hspec {-@@ -271,7 +266,10 @@ $ evalCohort testCohortSpec (MkPopulation [exampleSubject1, exampleSubject2]) `shouldBe` MkCohort- ( Just $ MkAttritionInfo $ pure (Included, 2)+ ( MkAttritionInfo 2 $ setFromList+ [ uncurry MkAttritionLevel (ExcludedBy (1, "includeAll"), 0)+ , uncurry MkAttritionLevel (Included , 2)+ ] , MkCohortData [ MkObsUnit "a" example1results , MkObsUnit "b" example2results
hasklepias.cabal view
@@ -1,6 +1,6 @@ cabal-version: 2.2 name: hasklepias-version: 0.18.0+version: 0.20.0 description: Please see the README on GitHub at <https://github.com/novisci/asclepias#readme> homepage: https://github.com/novisci/asclepias/#readme bug-reports: https://github.com/novisci/asclepias/issues@@ -49,6 +49,7 @@ Hasklepias Hasklepias.FeatureEvents Hasklepias.MakeApp+ Hasklepias.CohortCollection Hasklepias.Misc Hasklepias.Reexports Hasklepias.ReexportsUnsafe@@ -75,12 +76,16 @@ src build-depends: aeson >=1.4.0.0 && <2+ , amazonka+ , amazonka-s3 , base >=4.14 && <4.15 , bytestring == 0.10.12.0 , cmdargs == 0.10.21 , containers == 0.6.5.1 , contravariant >= 1.4 , co-log == 0.4.0.1+ , conduit+ , conduit-extra , flow == 1.0.22 , ghc-prim == 0.6.1 , interval-algebra == 0.10.2@@ -118,6 +123,7 @@ Cohort.CoreSpec Cohort.AssessmentIntervalsSpec Cohort.CriteriaSpec+ Cohort.OutputSpec Hasklepias.FeatureEventsSpec Stype.AesonSpec Stype.Numeric.CensoredSpec@@ -179,10 +185,33 @@ default-language: Haskell2010 executable exampleApp- -- type: exitcode-stdio-1.0 main-is: Main.hs hs-source-dirs: exampleApp build-depends: hasklepias+ default-language: Haskell2010++executable collector+ main-is: Main.hs+ hs-source-dirs:+ collector+ build-depends:+ base >=4.14 && <4.15+ , hasklepias+ , bytestring+ , optparse-applicative+ default-language: Haskell2010++test-suite collector-test+ type: exitcode-stdio-1.0+ main-is: Main.hs+ hs-source-dirs:+ collector-test+ build-depends:+ hasklepias+ , base >=4.14 && <4.15+ , tasty == 1.4.1+ , tasty-silver + , bytestring default-language: Haskell2010
src/Cohort/AssessmentIntervals.hs view
@@ -13,7 +13,8 @@ {-# LANGUAGE MultiParamTypeClasses #-} -- {-# LANGUAGE Safe #-} -module Cohort.AssessmentIntervals(+module Cohort.AssessmentIntervals+ ( {- | The assessment intervals provided are: @@ -75,24 +76,27 @@ , makeFollowupFromIndex , makeFollowupMeetingIndex , makeFollowupAfterIndex-) where+ ) 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 )+import Cohort.Index ( Index )+import Data.Eq ( Eq )+import Data.Function ( ($) )+import Data.Functor ( Functor(fmap) )+import Data.Ord ( (<=)+ , Ord+ )+import GHC.Generics ( Generic )+import GHC.Num ( Num((+)) )+import GHC.Show ( Show )+import IntervalAlgebra ( Interval+ , IntervalSizeable(..)+ , Intervallic(..)+ , begin+ , beginerval+ , duration+ , end+ , enderval+ ) {-| A type to contain baseline intervals. See the 'Baseline' typeclass for methods to create values of this type.@@ -104,7 +108,7 @@ fmap f (MkBaselineInterval x) = MkBaselineInterval (fmap f x) instance (Ord a) => Intervallic BaselineInterval a where- getInterval (MkBaselineInterval x) = getInterval x+ getInterval (MkBaselineInterval x) = getInterval x setInterval (MkBaselineInterval x) y = MkBaselineInterval (setInterval x y) {-| @@ -142,8 +146,8 @@ 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) => + baseline ::+ ( IntervalSizeable a b) => b -- ^ duration of baseline -> Index i a -- ^ the 'Index' event -> BaselineInterval a@@ -151,13 +155,13 @@ -- | Creates a 'BaselineInterval' of the given duration that 'IntervalAlgebra.precedes' -- the 'Index' interval. - baselineBefore :: - ( IntervalSizeable a b) => + 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 = + baselineBefore shiftBy dur index = MkBaselineInterval $ enderval dur (begin (enderval shiftBy (begin index))) instance (Ord a) => Baseline Interval a@@ -172,7 +176,7 @@ fmap f (MkFollowupInterval x) = MkFollowupInterval (fmap f x) instance (Ord a) => Intervallic FollowupInterval a where- getInterval (MkFollowupInterval x) = getInterval x+ getInterval (MkFollowupInterval x) = getInterval x setInterval (MkFollowupInterval x) y = MkFollowupInterval (setInterval x y) {-| @@ -236,9 +240,9 @@ After -} class Intervallic i a => Followup i a where- followup :: + followup :: ( IntervalSizeable a b- , Intervallic i a) => + , Intervallic i a) => b -- ^ duration of followup -> Index i a -- ^ the 'Index' event -> FollowupInterval a@@ -247,22 +251,22 @@ then duration index + moment' index else dur - followupMetBy :: + followupMetBy :: ( IntervalSizeable a b- , Intervallic i a) => + , Intervallic i a) => b -- ^ duration of followup -> Index i a -- ^ the 'Index' event -> FollowupInterval a followupMetBy dur index = MkFollowupInterval (beginerval dur (end index)) - followupAfter :: + 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 = + followupAfter shiftBy dur index = MkFollowupInterval $ beginerval dur (end (beginerval shiftBy (end index))) instance (Ord a) => Followup Interval a@@ -275,8 +279,8 @@ deriving (Eq, Show, Generic) instance (Ord a) => Intervallic AssessmentInterval a where- getInterval (Bl x) = getInterval x- getInterval (Fl x) = getInterval x+ 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)@@ -292,12 +296,12 @@ -- >>> makeBaselineFromIndex 10 x -- Bl (MkBaselineInterval (0, 10)) ---makeBaselineFromIndex :: - (Baseline i a, IntervalSizeable a b) => - b +makeBaselineFromIndex+ :: (Baseline i a, IntervalSizeable a b)+ => b -> Index i a -> AssessmentInterval a-makeBaselineFromIndex dur index = Bl ( baseline dur index )+makeBaselineFromIndex dur index = Bl (baseline dur index) -- | Creates an 'AssessmentInterval' using the 'baselineBefore' function. -- @@ -306,14 +310,14 @@ -- >>> makeBaselineBeforeIndex 2 10 x -- Bl (MkBaselineInterval (-2, 8)) ---makeBaselineBeforeIndex :: - (Baseline i a, IntervalSizeable a b) => - b- -> b +makeBaselineBeforeIndex+ :: (Baseline i a, IntervalSizeable a b)+ => b+ -> b -> Index i a -> AssessmentInterval a-makeBaselineBeforeIndex shiftBy dur index = - Bl ( baselineBefore shiftBy dur index )+makeBaselineBeforeIndex shiftBy dur index =+ Bl (baselineBefore shiftBy dur index) -- | Creates an 'AssessmentInterval' using the 'followup' function. -- @@ -322,12 +326,12 @@ -- >>> makeFollowupFromIndex 10 x -- Fl (MkFollowupInterval (10, 20)) ---makeFollowupFromIndex :: - (Followup i a, IntervalSizeable a b) => - b+makeFollowupFromIndex+ :: (Followup i a, IntervalSizeable a b)+ => b -> Index i a -> AssessmentInterval a-makeFollowupFromIndex dur index = Fl ( followup dur index )+makeFollowupFromIndex dur index = Fl (followup dur index) -- | Creates an 'AssessmentInterval' using the 'followupMetBy' function. -- @@ -336,12 +340,12 @@ -- >>> makeFollowupMeetingIndex 10 x -- Fl (MkFollowupInterval (11, 21)) ---makeFollowupMeetingIndex :: - (Followup i a, IntervalSizeable a b) => - b+makeFollowupMeetingIndex+ :: (Followup i a, IntervalSizeable a b)+ => b -> Index i a -> AssessmentInterval a-makeFollowupMeetingIndex dur index = Fl ( followupMetBy dur index )+makeFollowupMeetingIndex dur index = Fl (followupMetBy dur index) -- | Creates an 'AssessmentInterval' using the 'followupAfter' function. -- @@ -350,10 +354,10 @@ -- >>> makeFollowupAfterIndex 10 10 x -- Fl (MkFollowupInterval (21, 31)) ---makeFollowupAfterIndex :: - (Followup i a, IntervalSizeable a b) => - b+makeFollowupAfterIndex+ :: (Followup i a, IntervalSizeable a b)+ => b -> b -> Index i a -> AssessmentInterval a-makeFollowupAfterIndex shiftBy dur index = Fl ( followupAfter shiftBy dur index )+makeFollowupAfterIndex shiftBy dur index = Fl (followupAfter shiftBy dur index)
src/Cohort/Core.hs view
@@ -8,44 +8,88 @@ {-# OPTIONS_HADDOCK hide #-} {-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE DeriveGeneric #-}-{-# LANGUAGE TupleSections #-}-{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE OverloadedStrings #-} -- {-# LANGUAGE Safe #-} -module Cohort.Core(- Subject(..)- , ID- , Population(..)- , ObsUnit(..)- , CohortData(..)- , Cohort(..)- , CohortSpec- , AttritionInfo(..)- , specifyCohort- , makeObsUnitFeatures- , evalCohort- , getCohortIDs- , getCohortData- , getAttritionInfo-) where--import GHC.Num ( Num((+)), Natural )-import Data.Aeson ( FromJSON, ToJSON, ToJSONKey )-import Data.Bool ( Bool )-import Data.Eq ( Eq )-import Data.Foldable ( Foldable(length) )-import Data.Function ( ($) )-import Data.Functor ( Functor(fmap) )-import Data.Maybe ( Maybe(..), catMaybes )-import Data.List ( zipWith, replicate )-import Data.List.NonEmpty ( NonEmpty(..), zip, fromList, nonEmpty )-import Data.Map.Strict as Map ( toList, fromListWith )-import Data.Text ( Text )-import GHC.Generics ( Generic )-import GHC.Show ( Show(..) )-import Cohort.Index ( makeIndex, Index(..) )-import Cohort.Criteria+module Cohort.Core+ ( Subject(..)+ , ID+ , Population(..)+ , ObsUnit(..)+ , CohortData(..)+ , Cohort(..)+ , CohortSpec+ , CohortSetSpec+ , CohortSet(..)+ , AttritionInfo(..)+ , AttritionLevel(..)+ , specifyCohort+ , makeObsUnitFeatures+ , evalCohort+ , getCohortIDs+ , getCohortDataIDs+ , getCohortData+ , getCohortDataData+ , getAttritionInfo+ , makeCohortSpecs+ , evalCohortSet+ , getCohortSet+ ) where +import Cohort.Criteria ( CohortStatus(..)+ , Criteria(getCriteria)+ , checkCohortStatus+ , initStatusInfo+ )+import Cohort.Index ( Index(..)+ , makeIndex+ )+import Data.Aeson ( FromJSON+ , ToJSON(..)+ )+import Data.Bool ( Bool )+import Data.Eq ( Eq )+import Data.Foldable ( Foldable(length) )+import Data.Function ( ($) )+import Data.Functor ( (<$>)+ , Functor(fmap)+ )+import Data.List ( replicate+ , zip+ , zipWith+ )+import qualified Data.List.NonEmpty as NEL+ ( NonEmpty(..)+ , toList+ )+import Data.Map.Strict as Map+ ( Map+ , fromList+ , fromListWith+ , toList+ , unionsWith+ )+import Data.Maybe ( Maybe(..)+ , maybe+ , catMaybes+ )+import Data.Monoid ( mempty )+import Data.Ord ( Ord(..) )+import Data.Semigroup ( Semigroup((<>)) )+import qualified Data.Set as Set+ ( Set+ , fromList+ , toList+ )+import Data.Text ( Text )+import Data.Tuple ( uncurry )+import GHC.Generics ( Generic )+import GHC.Int ( Int )+import GHC.Num ( Natural+ , Num((+))+ )+import GHC.Show ( Show(..) )+import Safe ( headMay ) -- | A subject identifier. Currently, simply @Text@. type ID = Text @@ -54,24 +98,25 @@ deriving (Eq, Show, Generic) instance Functor Subject where- fmap f (MkSubject (id, x)) = MkSubject (id, f x)+ fmap f (MkSubject (id, x)) = MkSubject (id, f x) instance (FromJSON d) => FromJSON (Subject d) where -- | A population is a list of @'Subject'@s-newtype Population d = MkPopulation [Subject d] +newtype Population d = MkPopulation [Subject d] deriving (Eq, Show, Generic) instance Functor Population where- fmap f (MkPopulation x) = MkPopulation (fmap (fmap f) x)+ fmap f (MkPopulation x) = MkPopulation (fmap (fmap f) x) instance (FromJSON d) => FromJSON (Population d) where -- | An observational unit is what a subject may be transformed into.-data ObsUnit d = MkObsUnit {- obsID :: ID- , obsData :: d }- deriving (Eq, Show, Generic)+data ObsUnit d = MkObsUnit+ { obsID :: ID+ , obsData :: d+ }+ deriving (Eq, Show, Generic) -- | A container for CohortData newtype CohortData d = MkCohortData { getObsData :: [ObsUnit d] }@@ -79,11 +124,11 @@ -- | A cohort is a list of observational units along with @'AttritionInfo'@ -- regarding the number of subjects excluded by the @'Criteria'@. -newtype Cohort d = MkCohort (Maybe AttritionInfo, CohortData d)+newtype Cohort d = MkCohort (AttritionInfo, CohortData d) deriving (Eq, Show, Generic) -- | Gets the attrition info from a cohort-getAttritionInfo :: Cohort d -> Maybe AttritionInfo+getAttritionInfo :: Cohort d -> AttritionInfo getAttritionInfo (MkCohort (x, _)) = x -- | Unpacks a @'Population'@ to a list of subjects.@@ -102,18 +147,20 @@ -- input data into a @'Criteria'@ and another that transforms a subject's input data -- into the desired return type. data CohortSpec d1 d0 = MkCohortSpec- { runCriteria:: d1 -> Criteria+ { runCriteria :: d1 -> Criteria -- (Feature (Index i a))- , runFeatures:: d1 -> d0 }+ , runFeatures :: d1 -> d0+ } -- | Creates a @'CohortSpec'@.-specifyCohort :: (d1 -> Criteria) -> (d1 -> d0) -> CohortSpec d1 d0+specifyCohort :: (d1 -> Criteria) -> (d1 -> d0) -> CohortSpec d1 d0 specifyCohort = MkCohortSpec -- | Evaluates the @'runCriteria'@ of a @'CohortSpec'@ on a @'Population'@ to -- return a list of @Subject Criteria@ (one per subject in the population). evalCriteria :: CohortSpec d1 d0 -> Population d1 -> [Subject Criteria]-evalCriteria (MkCohortSpec runCrit _) (MkPopulation pop) = fmap (fmap runCrit) pop+evalCriteria (MkCohortSpec runCrit _) (MkPopulation pop) =+ fmap (fmap runCrit) pop -- | Convert a list of @Subject Criteria@ into a list of @Subject CohortStatus@ evalCohortStatus :: [Subject Criteria] -> [Subject CohortStatus]@@ -122,46 +169,123 @@ -- | Runs the input function which transforms a subject into an observational unit. -- If the subeject is excluded, the result is @Nothing@; otherwise it is @Just@ -- an observational unit.-evalSubjectCohort :: (d1 -> d0) -> Subject CohortStatus -> Subject d1 -> Maybe (ObsUnit d0)-evalSubjectCohort f (MkSubject (id, status)) subjData =- case status of- Included -> Just $ makeObsUnitFeatures f subjData- ExcludedBy _ -> Nothing+evalSubjectCohort+ :: (d1 -> d0) -> Subject CohortStatus -> Subject d1 -> Maybe (ObsUnit d0)+evalSubjectCohort f (MkSubject (id, status)) subjData = case status of+ Included -> Just $ makeObsUnitFeatures f subjData+ ExcludedBy _ -> Nothing +-- | A type which collects counts of a 'CohortStatus'+data AttritionLevel = MkAttritionLevel+ { attritionLevel :: CohortStatus+ , attritionCount :: Natural+ }+ deriving (Eq, Show, Generic)++-- | Ordering of @AttritionLevel@ is based on the value of its 'attritionLevel'. +instance Ord AttritionLevel where+ compare (MkAttritionLevel l1 _) (MkAttritionLevel l2 _) = compare l1 l2++-- | NOTE: the @Semigroup@ instance prefers the 'attritionLevel' from the left,+-- so be sure that you're combining +instance Semigroup AttritionLevel where+ (<>) (MkAttritionLevel l1 c1) (MkAttritionLevel _ c2) =+ MkAttritionLevel l1 (c1 + c2)+ -- | A type which collects the counts of subjects included or excluded.-newtype AttritionInfo = MkAttritionInfo (NonEmpty (CohortStatus, Natural))- deriving (Eq, Show, Generic)+data AttritionInfo = MkAttritionInfo+ { totalProcessed :: Int+ , attritionInfo :: Set.Set AttritionLevel+ }+ deriving (Eq, Show, Generic) --- | Initializes @AttritionInfo@ from a @'Criteria'@.-initAttritionInfo :: Criteria -> AttritionInfo-initAttritionInfo x =- MkAttritionInfo $ zip (initStatusInfo x) - (0 :| replicate (length (getCriteria x)) 0)+setAttrLevlToMap :: Set.Set AttritionLevel -> Map.Map CohortStatus Natural+setAttrLevlToMap x =+ Map.fromList $ (\(MkAttritionLevel l c) -> (l, c)) <$> Set.toList x --- | Creates an @'AttritionInfo'@ from a list of @Subject CohortStatus@. The result--- is @Nothing@ if the input list is empty.-measureAttrition :: [Subject CohortStatus] -> Maybe AttritionInfo-measureAttrition l = fmap MkAttritionInfo $ nonEmpty $ Map.toList $- Map.fromListWith (+) $ fmap (\x -> (getSubjectData x, 1)) l+mapToSetAttrLevel :: Map.Map CohortStatus Natural -> Set.Set AttritionLevel+mapToSetAttrLevel x = Set.fromList $ uncurry MkAttritionLevel <$> Map.toList x +-- | Two @AttritionInfo@ values can be combined, but this meant for combining+-- attrition info from the same set of @Criteria@.+instance Semigroup AttritionInfo where+ (<>) (MkAttritionInfo t1 i1) (MkAttritionInfo t2 i2) = MkAttritionInfo+ (t1 + t2)+ ( mapToSetAttrLevel+ $ unionsWith (+) [setAttrLevlToMap i1, setAttrLevlToMap i2]+ )++-- Initializes @AttritionInfo@ from a @'Criteria'@.+initAttritionInfo :: Criteria -> Map.Map CohortStatus Natural+initAttritionInfo x = Map.fromList+ $ zip (NEL.toList (initStatusInfo x)) (replicate (length (getCriteria x)) 0)++-- An internal function used to measure attrition for a cohort.+measureAttrition+ :: Maybe Criteria -> [Subject CohortStatus] -> AttritionInfo+measureAttrition c l =+ MkAttritionInfo (length l) $ mapToSetAttrLevel $ unionsWith+ (+)+ [ maybe mempty initAttritionInfo c+ , Map.fromListWith (+) $ fmap (\x -> (getSubjectData x, 1)) l+ , Map.fromList [(Included, 0)]+ -- including Included in the case that none of the evaluated criteria+ -- have status Include+ ]+ -- | The internal function to evaluate a @'CohortSpec'@ on a @'Population'@. -evalUnits :: CohortSpec d1 d0 -> Population d1 -> (Maybe AttritionInfo, CohortData d0)+evalUnits+ :: CohortSpec d1 d0 -> Population d1 -> (AttritionInfo, CohortData d0) evalUnits spec pop =- ( measureAttrition statuses- , MkCohortData $ catMaybes $ zipWith (evalSubjectCohort (runFeatures spec))- statuses- (getPopulation pop))- where crits = evalCriteria spec pop- statuses = evalCohortStatus crits+ ( measureAttrition fcrit statuses+ , MkCohortData $ catMaybes $ zipWith (evalSubjectCohort (runFeatures spec))+ statuses+ (getPopulation pop)+ )+ where+ crits = evalCriteria spec pop+ fcrit = fmap getSubjectData (headMay crits)+ statuses = evalCohortStatus crits -- | Evaluates a @'CohortSpec'@ on a @'Population'@. evalCohort :: CohortSpec d1 d0 -> Population d1 -> Cohort d0 evalCohort s p = MkCohort $ evalUnits s p +-- | Get IDs from 'CohortData'.+getCohortDataIDs :: CohortData d -> [ID]+getCohortDataIDs (MkCohortData x) = fmap obsID x+ -- | Get IDs from a cohort. getCohortIDs :: Cohort d -> [ID]-getCohortIDs (MkCohort (_, dat)) = fmap obsID ( getObsData dat )+getCohortIDs (MkCohort (_, dat)) = getCohortDataIDs dat -- | Get data from a cohort.+getCohortDataData :: CohortData d -> [d]+getCohortDataData (MkCohortData x) = fmap obsData x++-- | Get data from a cohort. getCohortData :: Cohort d -> [d]-getCohortData (MkCohort (_, dat)) = fmap obsData ( getObsData dat )+getCohortData (MkCohort (_, dat)) = getCohortDataData dat++{-| A container hold multiple cohorts of the same type. The key is the name of + the cohort; value is a cohort.+-}+newtype CohortSet d = MkCohortSet (Map Text (Cohort d))+ deriving (Eq, Show, Generic)++-- | Unwraps a 'CohortSet'.+getCohortSet :: CohortSet d -> Map Text (Cohort d)+getCohortSet (MkCohortSet x) = x++{-| Key/value pairs of 'CohortSpec's. The keys are the names of the cohorts.+-}+newtype CohortSetSpec i d = MkCohortSetSpec (Map Text (CohortSpec i d))++-- | Make a set of 'CohortSpec's from list input.+makeCohortSpecs :: [(Text, d1 -> Criteria, d1 -> d0)] -> CohortSetSpec d1 d0+makeCohortSpecs l =+ MkCohortSetSpec $ fromList (fmap (\(n, c, f) -> (n, specifyCohort c f)) l)++-- | Evaluates a @'CohortSetSpec'@ on a @'Population'@.+evalCohortSet :: CohortSetSpec d1 d0 -> Population d1 -> CohortSet d0+evalCohortSet (MkCohortSetSpec s) p = MkCohortSet $ fmap (`evalCohort` p) s
src/Cohort/Criteria.hs view
@@ -6,48 +6,79 @@ Maintainer : bsaul@novisci.com -} {-# OPTIONS_HADDOCK hide #-}-{-# LANGUAGE Safe #-}+-- {-# LANGUAGE Safe #-} {-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE TupleSections #-} -module Cohort.Criteria(- Criterion- , Criteria(..)- , Status(..)- , CohortStatus(..)- , criterion- , criteria- , excludeIf- , includeIf- , initStatusInfo- , checkCohortStatus-) where -import safe GHC.Generics ( Generic )-import safe GHC.Num ( Num((+)), Natural )-import safe GHC.Show ( Show(show) )-import safe GHC.TypeLits ( KnownSymbol, symbolVal )-import safe Control.Applicative ( Applicative(pure) )-import safe Control.Monad ( Functor(..) )-import safe Data.Bifunctor ( Bifunctor(second) )-import safe Data.Bool ( Bool(..), otherwise, not, (&&) )-import safe Data.Either ( either )-import safe Data.Eq ( Eq(..) )-import safe Data.Function ( ($), (.), const, id )-import safe qualified Data.List.NonEmpty as NE- ( NonEmpty, zip, fromList, toList, map )-import safe Data.List ( find, (++) )-import safe Data.Maybe ( Maybe(..), maybe )-import safe Data.Ord ( Ord(..), Ordering(..) )-import safe Data.Semigroup ( Semigroup((<>)) )-import safe Data.Tuple ( fst, snd )-import safe Data.Text ( Text, pack )-import safe Features.Compose ( getFeatureData- , Feature- , nameFeature- , FeatureN(..) )+module Cohort.Criteria+ ( Criterion+ , Criteria(..)+ , Status(..)+ , CohortStatus(..)+ , criterion+ , criteria+ , excludeIf+ , includeIf+ , initStatusInfo+ , checkCohortStatus+ ) where +import Control.Applicative ( Applicative(pure) )+import Control.Monad ( Functor(..) )+import Data.Aeson ( (.=)+ , ToJSON(..)+ , object+ )+import Data.Bifunctor ( Bifunctor(second) )+import Data.Bool ( (&&)+ , Bool(..)+ , not+ , otherwise+ )+import Data.Either ( either )+import Data.Eq ( Eq(..) )+import Data.Function ( ($)+ , (.)+ , const+ , id+ )+import Data.List ( (++)+ , find+ )+import qualified Data.List.NonEmpty as NE+ ( NonEmpty+ , fromList+ , zip+ )+import Data.Maybe ( Maybe(..)+ , maybe+ )+import Data.Ord ( Ord(..)+ , Ordering(..)+ )+import Data.Semigroup ( Semigroup((<>)) )+import Data.Text ( Text+ , pack+ )+import Data.Tuple ( fst+ , snd+ )+import Features.Compose ( Feature+ , FeatureN(..)+ , getFeatureData+ , nameFeature+ )+import GHC.Generics ( Generic )+import GHC.Num ( Natural+ , Num((+))+ )+import GHC.Show ( Show(show) )+import GHC.TypeLits ( KnownSymbol+ , symbolVal+ )+ -- | Defines the return type for @'Criterion'@ indicating whether to include or -- exclude a subject. data Status = Include | Exclude deriving (Eq, Show, Generic)@@ -62,9 +93,9 @@ -- Defines an ordering to put @Included@ last in a container of @'CohortStatus'@. -- The @'ExcludedBy'@ are ordered by their number value. instance Ord CohortStatus where- compare Included Included = EQ- compare Included (ExcludedBy _) = GT- compare (ExcludedBy _) Included = LT+ compare Included Included = EQ+ compare Included (ExcludedBy _) = GT+ compare (ExcludedBy _ ) Included = LT compare (ExcludedBy (i, _)) (ExcludedBy (j, _)) = compare i j -- | Helper to convert a @Bool@ to a @'Status'@@@ -102,36 +133,34 @@ -- | Constructs a @'Criteria'@ from a @'NE.NonEmpty'@ collection of @'Criterion'@. criteria :: NE.NonEmpty Criterion -> Criteria-criteria l = MkCriteria $ NE.zip (NE.fromList [1..]) l+criteria l = MkCriteria $ NE.zip (NE.fromList [1 ..]) l -- | Unpacks a @'Criterion'@ into a (Text, Status) pair where the text is the -- name of the criterion and its @Status@ is the value of the status in the -- @'Criterion'@. In the case, that the value of the @'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)- where nm = getNameN x+getStatus (MkCriterion x) = either (const (nm, Exclude))+ (nm, )+ ((getFeatureData . getDataN) x)+ where nm = getNameN x -- | Converts a subject's @'Criteria'@ into a @'NE.NonEmpty'@ triple of -- (order of criterion, name of criterion, status)-getStatuses ::- Criteria -> NE.NonEmpty (Natural, Text, Status)+getStatuses :: Criteria -> NE.NonEmpty (Natural, Text, Status) getStatuses (MkCriteria x) =- fmap (\c -> (fst c, (fst.getStatus.snd) c, (snd.getStatus.snd) c)) x+ fmap (\c -> (fst c, (fst . getStatus . snd) c, (snd . getStatus . snd) c)) x -- | An internal function used to @'Data.List.find'@ excluded statuses. Used in -- 'checkCohortStatus'.-findExclude ::- Criteria -> Maybe (Natural, Text, Status)-findExclude x = find (\(_, _, z) -> z == Exclude) (getStatuses x)+findExclude :: Criteria -> Maybe (Natural, Text, Status)+findExclude x = find (\(_, _, z) -> z == Exclude) (getStatuses x) -- | Converts a subject's @'Criteria'@ to a @'CohortStatus'@. The status is set -- to @'Included'@ if none of the @'Criterion'@ have a status of @'Exclude'@.-checkCohortStatus ::- Criteria -> CohortStatus+checkCohortStatus :: Criteria -> CohortStatus checkCohortStatus x =- maybe Included (\(i, n, _) -> ExcludedBy (i, n)) (findExclude x)+ maybe Included (\(i, n, _) -> ExcludedBy (i, n)) (findExclude x) -- | Utility to get the name of a @'Criterion'@. getCriterionName :: Criterion -> Text@@ -141,4 +170,4 @@ -- to collect generate all the possible Exclusion/Inclusion reasons. initStatusInfo :: Criteria -> NE.NonEmpty CohortStatus initStatusInfo (MkCriteria z) =- NE.map (ExcludedBy . Data.Bifunctor.second getCriterionName) z <> pure Included+ fmap (ExcludedBy . Data.Bifunctor.second getCriterionName) z <> pure Included
src/Cohort/Index.hs view
@@ -13,7 +13,8 @@ {-# LANGUAGE MultiParamTypeClasses #-} -- {-# LANGUAGE Safe #-} -module Cohort.Index(+module Cohort.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@@ -21,23 +22,23 @@ -} Index , makeIndex-) where+ ) where -import GHC.Show ( Show )-import GHC.Generics ( Generic )-import Data.Eq ( Eq )-import Data.Functor ( Functor(fmap) )-import Data.Ord ( Ord )-import IntervalAlgebra ( Interval- , Intervallic(..)- )-import Data.Aeson ( ToJSON )+import Data.Aeson ( ToJSON )+import Data.Eq ( Eq )+import Data.Functor ( Functor(fmap) )+import Data.Ord ( Ord )+import GHC.Generics ( Generic )+import GHC.Show ( Show )+import IntervalAlgebra ( Interval+ , Intervallic(..)+ ) {-| An @Index@ is a wrapper for an @Intervallic@ used to indicate that a particular interval is considered an index interval to which other intervals will be compared. -}-newtype Index i a = MkIndex { +newtype Index i a = MkIndex { getIndex :: i a -- ^ Unwrap an @Index@ } deriving (Eq, Show, Generic) @@ -52,5 +53,5 @@ getInterval (MkIndex x) = getInterval x setInterval (MkIndex x) y = MkIndex (setInterval x y) -instance (Intervallic i a, ToJSON (i a)) => ToJSON (Index i a) +instance (Intervallic i a, ToJSON (i a)) => ToJSON (Index i a)
src/Cohort/Input.hs view
@@ -10,45 +10,65 @@ {-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE TupleSections #-} -module Cohort.Input(- parsePopulationLines- , parsePopulationIntLines- , parsePopulationDayLines- , ParseError(..)-) where+module Cohort.Input+ ( parsePopulationLines+ , parsePopulationIntLines+ , parsePopulationDayLines+ , ParseError(..)+ ) where -import Control.Applicative ( Applicative((<*>)), (<$>) )-import Data.Aeson ( FromJSON(..)- , ToJSON(..)- , eitherDecode- , Value(Array))-import qualified Data.ByteString.Lazy as B ( fromStrict- , toStrict- , ByteString)-import qualified Data.ByteString.Char8 as C ( lines )-import Prelude (- String)-import Data.Bifunctor ( Bifunctor(first) )-import Data.Either ( Either(..)- , partitionEithers )-import Data.Eq ( Eq )-import Data.Function ( ($), id ) -import Data.Functor ( Functor(fmap) )-import Data.List ( sort, (++), zipWith )-import qualified Data.Map.Strict as M ( toList, fromListWith)-import Data.Ord ( Ord )-import Data.Text (Text, pack)-import Data.Time.Calendar ( Day )-import Data.Vector ( (!) )-import EventData ( Events, event, Event )-import EventData.Aeson ()-import Cohort.Core ( Population(..)- , ID- , Subject(MkSubject) )-import GHC.Int ( Int )-import GHC.Num ( Natural )-import GHC.Show ( Show )-import IntervalAlgebra ( IntervalSizeable )+import Cohort.Core ( ID+ , Population(..)+ , Subject(MkSubject)+ )+import Control.Applicative ( (<$>)+ , Applicative((<*>))+ )+import Data.Aeson ( FromJSON(..)+ , ToJSON(..)+ , Value(Array)+ , eitherDecode+ )+import Data.Bifunctor ( Bifunctor(first) )+import qualified Data.ByteString.Char8 as C+ ( lines )+import qualified Data.ByteString.Lazy as B+ ( ByteString+ , fromStrict+ , toStrict+ )+import Data.Either ( Either(..)+ , partitionEithers+ )+import Data.Eq ( Eq )+import Data.Function ( ($)+ , id+ )+import Data.Functor ( Functor(fmap) )+import Data.List ( (++)+ , sort+ , zipWith+ )+import qualified Data.Map.Strict as M+ ( fromListWith+ , toList+ )+import Data.Ord ( Ord )+import Data.Text ( Text+ , pack+ )+import Data.Time.Calendar ( Day )+import Data.Vector ( (!) )+import EventData ( Event+ , Events+ , event+ )+import EventData.Aeson ( )+import GHC.Int ( Int )+import GHC.Num ( Natural )+import GHC.Show ( Show )+import IntervalAlgebra ( IntervalSizeable )+import Prelude ( String ) newtype SubjectEvent a = MkSubjectEvent (ID, Event a)@@ -57,41 +77,50 @@ subjectEvent x y = MkSubjectEvent (x, y) instance (FromJSON a, Show a, IntervalSizeable a b) => FromJSON (SubjectEvent a) where- parseJSON (Array v) = subjectEvent <$>- parseJSON (v ! 0) <*> (event <$> parseJSON (v ! 5) <*> parseJSON (Array v))+ parseJSON (Array v) =+ subjectEvent+ <$> parseJSON (v ! 0)+ <*> (event <$> parseJSON (v ! 5) <*> parseJSON (Array v)) mapIntoPop :: (Ord a) => [SubjectEvent a] -> Population (Events a)-mapIntoPop l = MkPopulation $- fmap (\(id, es) -> MkSubject (id, sort es)) -- TODO: is there a way to avoid the sort?- (M.toList $ M.fromListWith (++) - (fmap (\(MkSubjectEvent (id, e)) -> (id, [e])) l ))+mapIntoPop l = MkPopulation $ fmap+ (\(id, es) -> MkSubject (id, sort es)) -- TODO: is there a way to avoid the sort?+ ( M.toList+ $ M.fromListWith (++) (fmap (\(MkSubjectEvent (id, e)) -> (id, [e])) l)+ ) -decodeIntoSubj :: (FromJSON a, Show a, IntervalSizeable a b) => - B.ByteString -> Either Text (SubjectEvent a)-decodeIntoSubj x = first pack $ eitherDecode x +decodeIntoSubj+ :: (FromJSON a, Show a, IntervalSizeable a b)+ => B.ByteString+ -> Either Text (SubjectEvent a)+decodeIntoSubj x = first pack $ eitherDecode x -- | Contains the line number and error message. newtype ParseError = MkParseError (Natural, Text) deriving (Eq, Show) -- | Parse @Event Int@ from json lines.-parseSubjectLines ::- (FromJSON a, Show a, IntervalSizeable a b) =>- B.ByteString -> ( [ParseError], [SubjectEvent a] )-parseSubjectLines l =- partitionEithers $ zipWith- (\x i -> first (\t -> MkParseError (i,t)) (decodeIntoSubj $ B.fromStrict x) )- (C.lines $ B.toStrict l)- [1..]+parseSubjectLines+ :: (FromJSON a, Show a, IntervalSizeable a b)+ => B.ByteString+ -> ([ParseError], [SubjectEvent a])+parseSubjectLines l = partitionEithers $ zipWith+ (\x i -> first (\t -> MkParseError (i, t)) (decodeIntoSubj $ B.fromStrict x))+ (C.lines $ B.toStrict l)+ [1 ..] -- | Parse @Event Int@ from json lines.-parsePopulationLines :: (FromJSON a, Show a, IntervalSizeable a b) => - B.ByteString -> ([ParseError], Population (Events a))+parsePopulationLines+ :: (FromJSON a, Show a, IntervalSizeable a b)+ => B.ByteString+ -> ([ParseError], Population (Events a)) parsePopulationLines x = fmap mapIntoPop (parseSubjectLines x) -- | Parse @Event Int@ from json lines.-parsePopulationIntLines :: B.ByteString -> ([ParseError], Population (Events Int))+parsePopulationIntLines+ :: B.ByteString -> ([ParseError], Population (Events Int)) parsePopulationIntLines x = fmap mapIntoPop (parseSubjectLines x) -- | Parse @Event Day@ from json lines.-parsePopulationDayLines :: B.ByteString -> ([ParseError], Population (Events Day))+parsePopulationDayLines+ :: B.ByteString -> ([ParseError], Population (Events Day)) parsePopulationDayLines x = fmap mapIntoPop (parseSubjectLines x)
src/Cohort/Output.hs view
@@ -1,6 +1,6 @@ {-|-Module : Hasklepias Cohorts-Description : Defines the options for outputting a cohort+Module : Cohort output (and some input)+Description : Methods for outputting a cohort Copyright : (c) NoviSci, Inc 2020 License : BSD3 Maintainer : bsaul@novisci.com@@ -13,109 +13,229 @@ {-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE DeriveAnyClass #-}+{-# LANGUAGE MultiParamTypeClasses #-} -module Cohort.Output(- CohortShape+module Cohort.Output+ ( CohortJSON+ , CohortSetJSON(..)+ , CohortDataShape+ , CohortDataShapeJSON(..)+ , ColumnWiseJSON(..)+ , RowWiseJSON(..) , ShapeCohort(..)- , toJSONCohortShape-) where+ , toJSONCohortDataShape+ ) where -import Data.Aeson ( ToJSON(..)- , Value- , object- , (.=) )-import Data.Function ( (.) )-import Data.Functor ( Functor(fmap) )-import Data.List.NonEmpty as NE ( NonEmpty(..)- , head- , fromList- , zip )-import Data.Tuple ( uncurry )-import GHC.Generics ( Generic )-import GHC.Types ( Type )-import GHC.Show ( Show )-import Cohort.Core ( AttritionInfo,- Cohort,- ObsUnit,- ID,- CohortData,- getCohortData,- getCohortIDs )-import Cohort.Criteria ( CohortStatus )-import Features.Featureset ( FeaturesetList(MkFeaturesetList)- , Featureset- , getFeatureset- , getFeaturesetList- , tpose )-import Features.Output ( ShapeOutput(dataOnly, nameAttr)- , OutputShape )+import Control.Applicative ( (<$>) )+import Cohort.Core ( AttritionInfo+ , AttritionLevel+ , Cohort(..)+ , CohortData+ , CohortSet(..)+ , ID+ , ObsUnit+ , getCohortData+ , getCohortDataData+ , getCohortDataIDs+ , getCohortIDs+ )+import Cohort.Criteria ( CohortStatus )+import Data.Aeson ( (.=)+ , FromJSON+ , ToJSON(..)+ , Value+ , object+ )+import Data.Aeson.Types ( FromJSON )+import Data.Eq ( Eq )+import Data.Function ( ($)+ , (.)+ )+import Data.Functor ( Functor(fmap) )+import Data.List ( zip, zipWith, head )+import Data.List.NonEmpty as NE+ ( NonEmpty(..)+ , nonEmpty+ , head+ , toList+ )+import Data.Map.Strict as Data.Map+ ( Map+ , unionWith )+import Data.Maybe ( maybe, maybeToList+ , fromMaybe+ , Maybe(..) )+import Data.Semigroup ( Semigroup(..) )+import Data.Text ( Text )+import Data.Tuple ( uncurry )+import Features.Featureset ( Featureset+ , FeaturesetList+ ( MkFeaturesetList+ )+ , getFeatureset+ , getFeaturesetList+ , tpose+ )+import Features.Output ( OutputShape+ , ShapeOutput+ ( dataOnly+ , nameAttr+ )+ )+import GHC.Generics ( Generic )+import GHC.Show ( Show )+import GHC.Types ( Type )+import Safe ( headMay ) instance (ToJSON d) => ToJSON (ObsUnit d) where instance (ToJSON d) => ToJSON (CohortData d) where instance (ToJSON d) => ToJSON (Cohort d) where+instance (ToJSON d) => ToJSON (CohortSet d)++-- NOTE: The following purposefully use default encodings to make roundtrip easier+-- They can be changed from the default, but be sure that one can go to/from+-- JSON. instance ToJSON CohortStatus where+instance FromJSON CohortStatus where+instance ToJSON AttritionLevel where+instance FromJSON AttritionLevel where instance ToJSON AttritionInfo where+instance FromJSON AttritionInfo where -- | A type used to determine the output shape of a Cohort.-data CohortShape d where- ColumnWise :: (Show a, ToJSON a) => a -> CohortShape ColumnWise- RowWise :: (Show a, ToJSON a) => a -> CohortShape RowWise+data CohortDataShape d where+ ColumnWise :: (Show a, ToJSON a) => a -> CohortDataShape ColumnWise+ RowWise :: (Show a, ToJSON a) => a -> CohortDataShape RowWise -deriving instance Show d => Show (CohortShape d)+deriving instance Show d => Show (CohortDataShape d) --- | Maps CohortShape into an Aeson Value. --- TODO: implement Generic and ToJSON instance of CohortShape directly.-toJSONCohortShape :: CohortShape shape -> Value-toJSONCohortShape (ColumnWise x) = toJSON x-toJSONCohortShape (RowWise x) = toJSON x+-- TODO: implement Generic and ToJSON instance of CohortDataShape directly.+-- | Maps CohortDataShape into an Aeson Value. +toJSONCohortDataShape :: CohortDataShape shape -> Value+toJSONCohortDataShape (ColumnWise x) = toJSON x+toJSONCohortDataShape (RowWise x) = toJSON x --- | Provides methods for reshaping a 'Cohort.Cohort' to a 'CohortShape'.+{- | +A type containing all the information of a 'Cohort' but where the 'CohortData'+has been reshaped to a 'CohortDataShapeJSON'.+-}+newtype CohortJSON = MkCohortJSON (AttritionInfo, CohortDataShapeJSON)+ deriving (Eq, Show, Generic)++instance ToJSON CohortJSON+instance FromJSON CohortJSON++instance Semigroup CohortJSON where+ (<>) (MkCohortJSON x) (MkCohortJSON y) = MkCohortJSON (x <> y)++{- | +Similar to 'CohortSet', but where the 'Cohort's have been mapped to a 'CohortJSON'.+-}+newtype CohortSetJSON = MkCohortSetJSON (Map Text CohortJSON)+ deriving (Eq, Show, Generic)++instance ToJSON CohortSetJSON+instance FromJSON CohortSetJSON++instance Semigroup CohortSetJSON where+ (<>) (MkCohortSetJSON x) (MkCohortSetJSON y) = + MkCohortSetJSON (unionWith (<>) x y)++-- | A type used to represent JSON formats for each shape+data CohortDataShapeJSON =+ CW ColumnWiseJSON+ | RW RowWiseJSON+ deriving (Eq, Show, Generic)++instance ToJSON CohortDataShapeJSON+instance FromJSON CohortDataShapeJSON+instance Semigroup CohortDataShapeJSON where+ (<>) (CW x) (CW y) = CW (x <> y)+ (<>) (RW x) (RW y) = RW (x <> y)+ (<>) (RW x) (CW y) = RW x+ (<>) (CW x) (RW y) = CW x++-- | Provides methods for reshaping a 'Cohort.Cohort' to a 'CohortDataShapeJSON'. class ShapeCohort d where- colWise :: Cohort d -> CohortShape ColumnWise- rowWise :: Cohort d -> CohortShape RowWise+ colWise :: Cohort d -> CohortJSON+ rowWise :: Cohort d -> CohortJSON -instance ShapeCohort Featureset where- colWise x = ColumnWise (shapeColumnWise x)- rowWise x = RowWise (shapeRowWise x)+instance ShapeCohort Featureset where+ colWise (MkCohort (a, d)) = MkCohortJSON (a, CW $ colWiseJson (shapeColumnWise d))+ rowWise (MkCohort (a, d)) = MkCohortJSON (a, RW $ rowWiseJson (shapeRowWise d)) -data ColumnWise = MkColumnWise {- colAttributes :: NonEmpty (OutputShape Type)- , ids :: [ID]- , colData :: NonEmpty (NonEmpty (OutputShape Type))- } deriving ( Show, Generic )+---- ColumnWise ---- +data ColumnWise = MkColumnWise [OutputShape Type] -- attributes+ [ID] -- ids+ [[OutputShape Type]] -- data+ deriving (Show, Generic)+ instance ToJSON ColumnWise where- toJSON x = object [ "attributes" .= colAttributes x- , "ids" .= ids x- , "data" .= colData x ] -newtype IDRow = MkIDRow (ID, NonEmpty (OutputShape Type))+-- | A type to hold 'Cohort' information in a column-wise manner.+data ColumnWiseJSON = MkColumnWiseJSON+ { colAttributes :: [Value]+ , ids :: [Value]+ , colData :: [[Value]]+ }+ deriving (Eq, Show, Generic)++instance ToJSON ColumnWiseJSON+instance FromJSON ColumnWiseJSON++instance Semigroup ColumnWiseJSON where+ (<>) (MkColumnWiseJSON a1 i1 d1) (MkColumnWiseJSON _ i2 d2) =+ MkColumnWiseJSON a1 (i1 <> i2) (zipWith (<>) d1 d2)++colWiseJson :: ColumnWise -> ColumnWiseJSON+colWiseJson (MkColumnWise a ids cd) =+ MkColumnWiseJSON (fmap toJSON a) (fmap toJSON ids) (fmap (fmap toJSON) cd)++shapeColumnWise :: CohortData Featureset -> ColumnWise+shapeColumnWise x = MkColumnWise+ (fromMaybe [] attr)+ (getCohortDataIDs x)+ (fromMaybe [[]] dat)+ where+ feat = fmap (getFeaturesetList . (tpose . MkFeaturesetList)) (nonEmpty (getCohortDataData x))+ attr = fmap (toList . fmap (nameAttr . NE.head . getFeatureset)) feat+ dat = fmap (toList . fmap (toList . (fmap dataOnly . getFeatureset))) feat++---- Rowwise ---- ++newtype IDRow = MkIDRow (ID, [OutputShape Type]) deriving ( Show, Generic ) instance ToJSON IDRow where- toJSON (MkIDRow x) = object [ uncurry (.=) x]+ -- toJSON (MkIDRow x) = object [uncurry (.=) x] -data RowWise = MkRowWise {- attributes :: NonEmpty (OutputShape Type)- , rowData :: NonEmpty IDRow- } deriving ( Show, Generic )+data RowWise = MkRowWise [OutputShape Type] -- attributes+ [IDRow] -- data+ deriving (Show, Generic) instance ToJSON RowWise where- toJSON x = object [ "attributes" .= attributes x- , "data" .= rowData x ] -shapeColumnWise :: Cohort Featureset -> ColumnWise-shapeColumnWise x = MkColumnWise- (fmap (nameAttr . NE.head . getFeatureset) z)- (getCohortIDs x)- (fmap (fmap dataOnly . getFeatureset) z)- -- TODO: don't use fromList; do something more principled- where z = getFeaturesetList (tpose (MkFeaturesetList (NE.fromList (getCohortData x))))+-- | A type to hold 'Cohort' information in a row-wise manner.+data RowWiseJSON = MkRowWiseJSON+ { rowAttributes :: [Value]+ , rowData :: [Value]+ }+ deriving (Eq, Show, Generic) -shapeRowWise :: Cohort Featureset -> RowWise+instance ToJSON RowWiseJSON+instance FromJSON RowWiseJSON+instance Semigroup RowWiseJSON where+ (<>) (MkRowWiseJSON a1 d1) (MkRowWiseJSON _ d2) =+ MkRowWiseJSON a1 (d1 <> d2)++rowWiseJson :: RowWise -> RowWiseJSON+rowWiseJson (MkRowWise a rd) = MkRowWiseJSON (fmap toJSON a) (fmap toJSON rd)++shapeRowWise :: CohortData Featureset -> RowWise shapeRowWise x = MkRowWise- (fmap (nameAttr . NE.head . getFeatureset) z)- (fmap MkIDRow (zip ids (fmap (fmap dataOnly . getFeatureset) z)))- -- TODO: don't use fromList; do something more principled- where z = NE.fromList (getCohortData x)- ids = fromList (getCohortIDs x)+ ( maybe [] (fmap nameAttr . toList . getFeatureset) ( headMay cd ) )+ (fmap MkIDRow (zip ids (fmap (toList . (fmap dataOnly . getFeatureset)) cd)))+ where+ cd = getCohortDataData x+ ids = getCohortDataIDs x
src/Features/Compose.hs view
@@ -24,6 +24,7 @@ FeatureData , MissingReason(..) , Feature+ , F , FeatureN , featureDataL , featureDataR@@ -40,6 +41,7 @@ , Definition(..) , Define(..) , DefineA(..)+ , Def --- *** Evalution of Definitions , eval@@ -84,6 +86,12 @@ , symbolVal ) +-- | Type synonym for 'Feature'.+type F n a = Feature n a++-- | Type synonym for 'Definition'.+type Def d = Definition d+ {- | 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@@ -271,7 +279,6 @@ -} -type F n d = Feature n d data Definition d where Pure :: a -> Definition (F n0 a ) D1 :: (b -> a) -> Definition (F n1 b -> F n0 a)
src/Hasklepias.hs view
@@ -47,6 +47,9 @@ -- ** Creating an executable cohort application , module Hasklepias.MakeApp + -- ** Collecting cohorts run on different partitions+ , module Hasklepias.CohortCollection+ -- * Statistical Types , module Stype @@ -64,11 +67,46 @@ import Cohort +import Hasklepias.CohortCollection import Hasklepias.FeatureEvents import Hasklepias.MakeApp import Hasklepias.Misc import Hasklepias.Reexports-import Hasklepias.ReexportsUnsafe+import Hasklepias.ReexportsUnsafe+ ( IO(..),+ encode,+ ToJSON(..),+ HasCallStack,+ adjustOption,+ askOption,+ defaultIngredients,+ defaultMain,+ localOption,+ withResource,+ defaultMainWithIngredients,+ after_,+ testGroup,+ includingOptions,+ mkTimeout,+ testCase,+ testCaseInfo,+ (@=?),+ (@?),+ (@?=),+ assertBool,+ assertEqual,+ assertFailure,+ assertString,+ testCaseSteps,+ DependencyType(..),+ TestName,+ TestTree,+ Timeout(..),+ Assertable(..),+ Assertion,+ AssertionPredicable(..),+ AssertionPredicate,+ HUnitFailure(..) ) import Hasklepias.Templates import Stype
+ src/Hasklepias/CohortCollection.hs view
@@ -0,0 +1,84 @@+{-|+-}++{-# LANGUAGE GADTs #-}++module Hasklepias.CohortCollection + ( runCollectionApp+ , getLocations+ , Location(..)+ , Input(..)+ ) where++import Conduit ( (.|)+ , foldMapMC+ , runConduit+ , runResourceT+ , yieldMany+ )+import Control.Lens ( (<&>)+ , (^.)+ , set+ )+import Data.Aeson ( decode+ , encode+ )+import qualified Data.ByteString.Char8 as CH+import qualified Data.ByteString.Lazy as B+import qualified Data.ByteString.Lazy.Char8 as C+ ( lines+ , putStrLn+ , toStrict+ )+import Data.Conduit.Binary ( sinkLbs )+import qualified Data.Conduit.List as CL+import Data.Maybe ( fromMaybe )+import qualified Data.Text as T+ ( pack )+import Cohort.Output ( CohortSetJSON )+import Network.AWS+import Network.AWS.S3+import System.IO ( stderr )+++data Location where+ Local ::FilePath -> Location+ S3 ::BucketName -> ObjectKey -> Location++getData :: Location -> IO (Maybe CohortSetJSON)+getData (Local x) = decode <$> B.readFile x+getData (S3 b k ) = decode <$> doGetObject b k++doGetObject :: BucketName -> ObjectKey -> IO B.ByteString+doGetObject b k = do+ lgr <- newLogger Debug stderr+ env <- newEnv Discover <&> set envLogger lgr . set envRegion NorthVirginia+ runResourceT . runAWS env $ do+ result <- send $ getObject b k+ (result ^. gorsBody) `sinkBody` sinkLbs++getLocations :: Input -> IO [Location]+getLocations (FileInput d f) = fmap (fmap Local)+ (fmap pre . lines <$> readFile f)+ where+ pre = case d of+ Nothing -> (<>) ""+ Just s -> (<>) (s <> "/")+getLocations (S3Input b k) =+ fmap (\x -> S3 b (ObjectKey $ T.pack $ CH.unpack $ C.toStrict x))+ . C.lines+ <$> doGetObject b k++-- | +data Input =+ FileInput (Maybe FilePath) FilePath+ | S3Input BucketName ObjectKey+ deriving (Show)++-- | Run collection on a list of 'Location's+runCollectionApp :: [Location] -> IO B.ByteString+runCollectionApp fs = do+ r <- runConduit $ yieldMany fs .| foldMapMC getData+ let x = fmap encode r+ let z = fromMaybe B.empty x+ return z
src/Hasklepias/FeatureEvents.hs view
@@ -12,231 +12,269 @@ {-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE TupleSections #-} -module Hasklepias.FeatureEvents(+module Hasklepias.FeatureEvents+ ( -- ** Container predicates- isNotEmpty- , atleastNofX- , anyGapsWithinAtLeastDuration- , allGapsWithinLessThanDuration+ isNotEmpty+ , atleastNofX+ , anyGapsWithinAtLeastDuration+ , allGapsWithinLessThanDuration -- ** Finding occurrences of concepts- , nthConceptOccurrence- , firstConceptOccurrence+ , nthConceptOccurrence+ , firstConceptOccurrence -- ** Reshaping containers- , allPairs- , pairs- , splitByConcepts+ , allPairs+ , pairs+ , splitByConcepts -- ** Create filters- , makeConceptsFilter- , makePairedFilter+ , makeConceptsFilter+ , makePairedFilter -- ** Manipulating Dates- , yearFromDay- , monthFromDay- , dayOfMonthFromDay+ , yearFromDay+ , monthFromDay+ , dayOfMonthFromDay -- ** Functions for manipulating intervals- , lookback- , lookahead+ , lookback+ , lookahead -- ** Misc functions- , computeAgeAt- , pairGaps-) where+ , computeAgeAt+ , pairGaps+ ) where -import IntervalAlgebra ( Intervallic- , IntervalSizeable(..)- , ComparativePredicateOf1- , ComparativePredicateOf2- , Interval- , IntervalCombinable(..)- , begin- , end- , beginerval- , enderval )-import IntervalAlgebra.PairedInterval ( PairedInterval, getPairData )-import IntervalAlgebra.IntervalUtilities ( durations, gapsWithin )-import EventData ( Events- , Event- , ConceptEvent- , ctxt- , context- , Domain (Demographics) )-import EventData.Context ( Concept- , Concepts- , Context- , HasConcept( hasConcepts )- , facts- , _facts )-import EventData.Context.Domain ( Domain(..)- , DemographicsFacts(..)- , DemographicsInfo(..)- , DemographicsField(..)- , demo- , info- , _Demographics )-import Safe ( headMay, lastMay )-import Control.Applicative ( Applicative(liftA2) )-import Control.Monad ( Functor(fmap), (=<<) )-import Data.Bool ( Bool(..), (&&), not, (||), otherwise )-import Data.Either ( either )-import Data.Eq ( Eq )-import Data.Foldable ( Foldable(length, null)- , all- , any- , toList )-import Data.Function ( (.), ($), const )-import Data.Functor ( Functor(fmap) )-import Data.Int ( Int )-import Data.Maybe ( Maybe(..), maybe, mapMaybe )-import Data.Monoid ( Monoid(..), (<>) )-import Data.Ord ( Ord(..) )-import Data.Time.Calendar ( Day- , Year- , MonthOfYear- , DayOfMonth- , diffDays- , toGregorian )-import Data.Text ( Text )-import Data.Tuple ( fst, uncurry )-import Witherable ( filter, Filterable, Witherable )-import GHC.Num ( Integer, fromInteger )-import GHC.Real ( RealFrac(floor), (/) )+import Control.Applicative ( Applicative(liftA2) )+import Control.Monad ( (=<<)+ , Functor(fmap)+ )+import Data.Bool ( (&&)+ , Bool(..)+ , not+ , otherwise+ , (||)+ )+import Data.Either ( either )+import Data.Eq ( Eq )+import Data.Foldable ( Foldable(length, null)+ , all+ , any+ , toList+ )+import Data.Function ( ($)+ , (.)+ , const+ )+import Data.Functor ( Functor(fmap) )+import Data.Int ( Int )+import Data.Maybe ( Maybe(..)+ , mapMaybe+ , maybe+ )+import Data.Monoid ( (<>)+ , Monoid(..)+ )+import Data.Ord ( Ord(..) )+import Data.Text ( Text )+import Data.Time.Calendar ( Day+ , DayOfMonth+ , MonthOfYear+ , Year+ , diffDays+ , toGregorian+ )+import Data.Tuple ( fst+ , uncurry+ )+import EventData ( ConceptEvent+ , Domain(Demographics)+ , Event+ , Events+ , context+ , ctxt+ )+import EventData.Context ( Concept+ , Concepts+ , Context+ , HasConcept(hasConcepts)+ , _facts+ , facts+ )+import EventData.Context.Domain ( DemographicsFacts(..)+ , DemographicsField(..)+ , DemographicsInfo(..)+ , Domain(..)+ , _Demographics+ , demo+ , info+ )+import GHC.Num ( Integer+ , fromInteger+ )+import GHC.Real ( (/)+ , RealFrac(floor)+ )+import IntervalAlgebra ( ComparativePredicateOf1+ , ComparativePredicateOf2+ , Interval+ , IntervalCombinable(..)+ , IntervalSizeable(..)+ , Intervallic+ , begin+ , beginerval+ , end+ , enderval+ )+import IntervalAlgebra.IntervalUtilities+ ( durations+ , gapsWithin+ )+import IntervalAlgebra.PairedInterval ( PairedInterval+ , getPairData+ )+import Safe ( headMay+ , lastMay+ )+import Witherable ( Filterable+ , Witherable+ , filter+ ) -- | Is the input list empty? isNotEmpty :: [a] -> Bool-isNotEmpty = not.null+isNotEmpty = not . null -- | Filter 'Events' to those that have any of the provided concepts.-makeConceptsFilter ::- ( Filterable f ) =>- [Text] -- ^ the list of concepts by which to filter - -> f (Event a)- -> f (Event a)+makeConceptsFilter+ :: (Filterable f)+ => [Text] -- ^ the list of concepts by which to filter + -> f (Event a)+ -> f (Event a) makeConceptsFilter cpts = filter (`hasConcepts` cpts) -- | Filter 'Events' to a single @'Maybe' 'Event'@, based on a provided function, -- with the provided concepts. For example, see 'firstConceptOccurrence' and -- 'lastConceptOccurrence'.-nthConceptOccurrence ::- ( Filterable f ) =>- (f (Event a) -> Maybe (Event a)) -- ^ function used to select a single event- -> [Text]- -> f (Event a)- -> Maybe (Event a)-nthConceptOccurrence f c = f.makeConceptsFilter c+nthConceptOccurrence+ :: (Filterable f)+ => (f (Event a) -> Maybe (Event a)) -- ^ function used to select a single event+ -> [Text]+ -> f (Event a)+ -> Maybe (Event a)+nthConceptOccurrence f c = f . makeConceptsFilter c -- | Finds the *first* occurrence of an 'Event' with at least one of the concepts. -- Assumes the input 'Events' list is appropriately sorted.-firstConceptOccurrence ::- ( Witherable f ) =>- [Text]- -> f (Event a)- -> Maybe (Event a)+firstConceptOccurrence+ :: (Witherable f) => [Text] -> f (Event a) -> Maybe (Event a) firstConceptOccurrence = nthConceptOccurrence (headMay . toList) -- | Finds the *last* occurrence of an 'Event' with at least one of the concepts. -- Assumes the input 'Events' list is appropriately sorted.-lastConceptOccurrence ::- ( Witherable f ) =>- [Text]- -> f (Event a)- -> Maybe (Event a)+lastConceptOccurrence+ :: (Witherable f) => [Text] -> f (Event a) -> Maybe (Event a) lastConceptOccurrence = nthConceptOccurrence (lastMay . toList) -- | Does 'Events' have at least @n@ events with any of the Concept in @x@.-atleastNofX ::- Int -- ^ n- -> [Text] -- ^ x- -> Events a -> Bool+atleastNofX+ :: Int -- ^ n+ -> [Text] -- ^ x+ -> Events a+ -> Bool atleastNofX n x es = length (makeConceptsFilter x es) >= n -- | Takes a predicate of intervals and a predicate on the data part of a -- paired interval to create a single predicate such that both input -- predicates should hold.-makePairPredicate :: Ord a =>- ComparativePredicateOf2 (i0 a) ((PairedInterval b) a)- -> i0 a- -> (b -> Bool)- -> (PairedInterval b a -> Bool)-makePairPredicate pi i pd x = pi i x && pd (getPairData x)+makePairPredicate+ :: Ord a+ => ComparativePredicateOf2 (i0 a) ((PairedInterval b) a)+ -> i0 a+ -> (b -> Bool)+ -> (PairedInterval b a -> Bool)+makePairPredicate pi i pd x = pi i x && pd (getPairData x) -- | -makePairedFilter :: Ord a =>- ComparativePredicateOf2 (i0 a) ((PairedInterval b) a)- -> i0 a- -> (b -> Bool)- -> [PairedInterval b a]- -> [PairedInterval b a]+makePairedFilter+ :: Ord a+ => ComparativePredicateOf2 (i0 a) ((PairedInterval b) a)+ -> i0 a+ -> (b -> Bool)+ -> [PairedInterval b a]+ -> [PairedInterval b a] makePairedFilter fi i fc = filter (makePairPredicate fi i fc) -- | Generate all pair-wise combinations from two lists.-allPairs :: Applicative f => f a -> f b -> f (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)]+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+ 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 ::- ( Filterable f ) =>- [Text]- -> [Text]- -> f (Event a)- -> (f (Event a), f (Event a))-splitByConcepts c1 c2 es = ( filter (`hasConcepts` c1) es- , filter (`hasConcepts` c2) es)+splitByConcepts+ :: (Filterable f)+ => [Text]+ -> [Text]+ -> f (Event a)+ -> (f (Event a), f (Event a))+splitByConcepts c1 c2 es =+ (filter (`hasConcepts` c1) es, filter (`hasConcepts` c2) es) -- | 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]+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?-makeGapsWithinPredicate ::- ( Monoid (t (Interval a))- , Monoid (t (Maybe (Interval a)))- , Applicative t- , Witherable t- , IntervalSizeable a b- , Intervallic i0 a- , IntervalCombinable i1 a) =>- ((b -> Bool) -> t b -> Bool)- -> (b -> b -> Bool)- -> (b -> i0 a -> t (i1 a) -> Bool)+makeGapsWithinPredicate+ :: ( Monoid (t (Interval a))+ , Monoid (t (Maybe (Interval a)))+ , Applicative t+ , Witherable t+ , IntervalSizeable a b+ , Intervallic i0 a+ , IntervalCombinable i1 a+ )+ => ((b -> Bool) -> t b -> Bool)+ -> (b -> b -> Bool)+ -> (b -> i0 a -> t (i1 a) -> Bool) makeGapsWithinPredicate f op gapDuration interval l =- maybe False (f (`op` gapDuration) . durations) (gapsWithin interval l)+ maybe False (f (`op` gapDuration) . durations) (gapsWithin interval l) -- | Within a provided spanning interval, are there any gaps of at least the -- specified duration among the input intervals?-anyGapsWithinAtLeastDuration ::- ( IntervalSizeable a b- , Intervallic i0 a- , IntervalCombinable i1 a- , Monoid (t (Interval a))- , Monoid (t (Maybe (Interval a)))- , Applicative t- , Witherable t) =>- b -- ^ duration of gap- -> i0 a -- ^ within this interval- -> t (i1 a)- -> Bool+anyGapsWithinAtLeastDuration+ :: ( IntervalSizeable a b+ , Intervallic i0 a+ , IntervalCombinable i1 a+ , Monoid (t (Interval a))+ , Monoid (t (Maybe (Interval a)))+ , Applicative t+ , Witherable t+ )+ => b -- ^ duration of gap+ -> i0 a -- ^ within this interval+ -> t (i1 a)+ -> Bool anyGapsWithinAtLeastDuration = makeGapsWithinPredicate any (>=) -- | Within a provided spanning interval, are all gaps less than the specified@@ -244,18 +282,19 @@ -- -- >>> allGapsWithinLessThanDuration 30 (beginerval 100 (0::Int)) [beginerval 5 (-1), beginerval 99 10] -- True-allGapsWithinLessThanDuration ::- ( IntervalSizeable a b- , Intervallic i0 a- , IntervalCombinable i1 a- , Monoid (t (Interval a))- , Monoid (t (Maybe (Interval a)))- , Applicative t- , Witherable t) =>- b -- ^ duration of gap- -> i0 a -- ^ within this interval- -> t (i1 a)- -> Bool+allGapsWithinLessThanDuration+ :: ( IntervalSizeable a b+ , Intervallic i0 a+ , IntervalCombinable i1 a+ , Monoid (t (Interval a))+ , Monoid (t (Maybe (Interval a)))+ , Applicative t+ , Witherable t+ )+ => b -- ^ duration of gap+ -> i0 a -- ^ within this interval+ -> t (i1 a)+ -> Bool allGapsWithinLessThanDuration = makeGapsWithinPredicate all (<) -- | Compute the "age" in years between two calendar days. The difference between@@ -280,10 +319,11 @@ -- -- >>> lookback 4 (beginerval 10 (1 :: Int)) -- (-3, 1)-lookback :: (Intervallic i a, IntervalSizeable a b) =>- b -- ^ lookback duration- -> i a- -> Interval a+lookback+ :: (Intervallic i a, IntervalSizeable a b)+ => b -- ^ lookback duration+ -> i a+ -> Interval a lookback d x = enderval d (begin x) -- | Creates a new @Interval@ of a provided lookahead duration beginning at the @@ -291,9 +331,10 @@ -- -- >>> lookahead 4 (beginerval 1 (1 :: Int)) -- (2, 6)-lookahead :: (Intervallic i a, IntervalSizeable a b) =>- b -- ^ lookahead duration- -> i a- -> Interval a+lookahead+ :: (Intervallic i a, IntervalSizeable a b)+ => b -- ^ lookahead duration+ -> i a+ -> Interval a lookahead d x = beginerval d (end x)
src/Hasklepias/MakeApp.hs view
@@ -1,4 +1,3 @@-{-# LANGUAGE BlockArguments #-} {-| Module : Hasklepias.MakeApp Description : Functions for creating a cohort application@@ -8,87 +7,114 @@ -} {-# OPTIONS_HADDOCK hide #-} {-# LANGUAGE NoImplicitPrelude #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE DerivingStrategies #-}-{-# LANGUAGE GeneralizedNewtypeDeriving #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE DeriveDataTypeable #-}-module Hasklepias.MakeApp (- makeCohortApp-) where -import Control.Monad ( Monad(return), Functor(fmap) )-import Control.Applicative ( Applicative )-import Data.Aeson ( encode, FromJSON, ToJSON(..) )-import Data.Bifunctor ( Bifunctor(second) )-import qualified Data.ByteString.Lazy as B-import Data.ByteString.Lazy.Char8 as C ( putStrLn )-import Data.Function ( ($), (.) )-import Data.List ( (++) )-import Data.Maybe ( Maybe )-import Data.Monoid ( Monoid(mconcat) )-import Data.String ( String )-import Data.Text ( pack, Text )-import Data.Tuple ( fst, snd )-import GHC.Show ( Show(show) )-import GHC.IO ( IO )+module Hasklepias.MakeApp+ ( makeCohortApp+ ) where -import EventData ( Events )-import Cohort-import IntervalAlgebra ( IntervalSizeable )+import Control.Applicative ( Applicative )+import Control.Monad ( Functor(fmap)+ , Monad(return)+ )+import Data.Aeson ( FromJSON+ , ToJSON(..)+ , encode+ )+import Data.Bifunctor ( Bifunctor(second) )+import qualified Data.ByteString.Lazy as B+import Data.ByteString.Lazy.Char8 as C+ ( putStrLn )+import Data.Function ( ($)+ , (.)+ )+import Data.List ( (++) )+import Data.Map.Strict ( fromList+ , toList+ )+import Data.Maybe ( Maybe )+import Data.Monoid ( Monoid(mconcat) )+import Data.String ( String )+import Data.Text ( Text+ , pack+ )+import Data.Tuple ( fst+ , snd+ )+import GHC.IO ( IO )+import GHC.Show ( Show(show) ) -import Control.Monad.IO.Class (MonadIO, liftIO)-import Control.Monad.Reader (MonadReader (..), ReaderT (..))-import Colog ( Message- , HasLog(..)- , WithLog- , LogAction(..)- , richMessageAction- , logInfo- , logError- , logStringStdout- , logStringStderr- , logText- , withLog- , logPrint- , logPrintStderr- , (<&)- , (>$)- , log )-import System.Console.CmdArgs ( Data, Typeable- , cmdArgs, summary, help, (&=) )-import System.Environment (getArgs)+import Cohort+import EventData ( Events )+import IntervalAlgebra ( IntervalSizeable ) +import Colog ( (<&)+ , (>$)+ , HasLog(..)+ , LogAction(..)+ , Message+ , WithLog+ , log+ , logError+ , logInfo+ , logPrint+ , logPrintStderr+ , logStringStderr+ , logStringStdout+ , logText+ , richMessageAction+ , withLog+ )+import Control.Monad.IO.Class ( MonadIO+ , liftIO+ )+import Control.Monad.Reader ( MonadReader(..)+ , ReaderT(..)+ )+import System.Console.CmdArgs ( (&=)+ , Data+ , Typeable+ , cmdArgs+ , help+ , summary+ )+import System.Environment ( getArgs )+ -- a stub to add more arguments to later-data MakeCohort = MakeCohort deriving (Show, Data, Typeable)+data MakeCohort = MakeCohort+ deriving (Show, Data, Typeable) -makeAppArgs ::- String -- ^ name of the application+makeAppArgs+ :: String -- ^ name of the application -> String -- ^ version of the application -> MakeCohort-makeAppArgs name version = MakeCohort- {- } &= help "Pass event data via stdin."- &= summary (name ++ " " ++ version)+makeAppArgs name version =+ MakeCohort{} &= help "Pass event data via stdin." &= summary+ (name ++ " " ++ version) -makeCohortBuilder :: (FromJSON a, Show a, IntervalSizeable a b, ToJSON d0, ShapeCohort d0, Monad m) =>- [CohortSpec (Events a) d0]- -> m (B.ByteString -> m ([ParseError], [Cohort d0]))+makeCohortBuilder+ :: ( FromJSON a+ , Show a+ , IntervalSizeable a b+ , ToJSON d0+ , ShapeCohort d0+ , Monad m+ )+ => CohortSetSpec (Events a) d0+ -> m (B.ByteString -> m ([ParseError], CohortSet d0)) makeCohortBuilder specs =- return (return . second (\pop -> fmap (`evalCohort` pop) specs) . parsePopulationLines)+ return (return . second (evalCohortSet specs) . parsePopulationLines) -reshapeWith :: (Cohort d -> CohortShape shape) - -> Cohort d - -> (Maybe AttritionInfo, CohortShape shape)-reshapeWith s x = (getAttritionInfo x, s x)+reshapeCohortSet :: (Cohort d0 -> CohortJSON) -> CohortSet d0 -> CohortSetJSON+reshapeCohortSet g x =+ MkCohortSetJSON $ fromList $ fmap (fmap g) (toList $ getCohortSet x) -shapeOutput :: (Monad m, ShapeCohort d0) => (Cohort d0 -> CohortShape shape) - -> m ([ParseError], [Cohort d0]) - -> m ([ParseError], [(Maybe AttritionInfo, CohortShape shape)]) -shapeOutput shape = fmap (fmap (fmap (reshapeWith shape)))- -- fmap (fmap (fmap shape))+shapeOutput+ :: (Monad m, ShapeCohort d0)+ => (Cohort d0 -> CohortJSON)+ -> m ([ParseError], CohortSet d0)+ -> m ([ParseError], CohortSetJSON)+shapeOutput shape = fmap (fmap (reshapeCohortSet shape)) -- logging based on example here: -- https://github.com/kowainik/co-log/blob/main/co-log/tutorials/Main.hs@@ -99,33 +125,32 @@ logParseErrors x = mconcat $ fmap (parseErrorL <&) x -- | Make a command line cohort building application.-makeCohortApp :: (FromJSON a, Show a, IntervalSizeable a b- , ToJSON d0,- ShapeCohort d0) =>- String -- ^ cohort name- -> String -- ^ app version- -> (Cohort d0 -> CohortShape shape) -- ^ a function which specifies the output shape- -> [CohortSpec (Events a) d0] -- ^ a list of cohort specifications- -> IO ()-makeCohortApp name version shape spec =- do- args <- cmdArgs ( makeAppArgs name version )- let logger = logStringStdout+makeCohortApp+ :: (FromJSON a, Show a, IntervalSizeable a b, ToJSON d0, ShapeCohort d0)+ => String -- ^ cohort name+ -> String -- ^ app version+ -> (Cohort d0 -> CohortJSON) -- ^ a function which specifies the output shape+ -> CohortSetSpec (Events a) d0 -- ^ a list of cohort specifications+ -> IO ()+makeCohortApp name version shape spec = do+ args <- cmdArgs (makeAppArgs name version)+ -- let logger = logStringStdout+ let errLog = logStringStderr - logger <& "Creating cohort builder..."- app <- makeCohortBuilder spec+ errLog <& "Creating cohort builder..."+ app <- makeCohortBuilder spec - logger <& "Reading data from stdin..."- -- TODO: give error if no contents within some amount of time- dat <- B.getContents+ errLog <& "Reading data from stdin..."+ -- TODO: give error if no contents within some amount of time+ dat <- B.getContents - logger <& "Bulding cohort..."- res <- shapeOutput shape (app dat)+ errLog <& "Bulding cohort..."+ res <- shapeOutput shape (app dat) - logParseErrors (fst res)+ logParseErrors (fst res) - logger <& "Encoding cohort(s) output and writing to stdout..."- C.putStrLn (encode (fmap (second toJSONCohortShape) (snd res) ))+ errLog <& "Encoding cohort(s) output and writing to stdout..."+ C.putStrLn (encode (toJSON (snd res))) - logger <& "Cohort build complete!"+ errLog <& "Cohort build complete!"
src/Hasklepias/Misc.hs view
@@ -11,10 +11,8 @@ {-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE DeriveGeneric #-} -module Hasklepias.Misc (- F- , Def- , Occurrence(..)+module Hasklepias.Misc+ ( Occurrence(..) , makeOccurrence , getOccurrenceReason , getOccurrenceTime@@ -22,25 +20,26 @@ , OccurrenceReason(..) , CensoredOccurrence(..) , adminCensor+ ) where -) where+import Data.Bool ( (&&)+ , otherwise+ )+import Data.Eq ( Eq(..) )+import Data.Ord ( Ord(..)+ , Ordering(..)+ )+import Data.Semigroup ( Semigroup((<>)) )+import Features.Compose ( Definition+ , Feature+ )+import GHC.Generics ( Generic )+import GHC.Show ( Show(..) )+import Stype.Numeric.Censored ( MaybeCensored(..) )+import Stype.Numeric.Continuous ( EventTime ) -import Features.Compose ( Feature, Definition )-import Data.Bool ( otherwise, (&&) )-import Data.Eq ( Eq(..) )-import Data.Ord ( Ord(..), Ordering(..) )-import Data.Semigroup ( Semigroup((<>)) )-import GHC.Generics ( Generic )-import GHC.Show ( Show(..) )-import Stype.Numeric.Censored ( MaybeCensored(..) )-import Stype.Numeric.Continuous ( EventTime ) --- | Type synonym for 'Feature'.-type F n a = Feature n a --- | Type synonym for 'Definition'.-type Def d = Definition d- -- | A simple typeclass for making a type a "reason" for an event. class (Ord a, Show a) => OccurrenceReason a where @@ -49,25 +48,25 @@ deriving (Eq, Show, Generic) -- | Create an 'Occurrence'-makeOccurrence :: (OccurrenceReason what) => - what -> EventTime b -> Occurrence what b-makeOccurrence r t = MkOccurrence (r , t)+makeOccurrence+ :: (OccurrenceReason what) => what -> EventTime b -> Occurrence what b+makeOccurrence r t = MkOccurrence (r, t) -- | Get the reason for an 'Occurrence'.-getOccurrenceReason :: Occurrence what b -> what +getOccurrenceReason :: Occurrence what b -> what getOccurrenceReason (MkOccurrence (r, t)) = r -- | Get the time of an 'Occurrence'.-getOccurrenceTime :: Occurrence what b -> EventTime b +getOccurrenceTime :: Occurrence what b -> EventTime b getOccurrenceTime (MkOccurrence (r, t)) = t -- Define a custom ordering based on times and then reasons. instance (OccurrenceReason r, Ord b) => Ord (Occurrence r b) where compare (MkOccurrence (r1, t1)) (MkOccurrence (r2, t2))- | t1 < t2 = LT- | t1 == t2 && r1 < r2 = LT+ | t1 < t2 = LT+ | t1 == t2 && r1 < r2 = LT | t1 == t2 && r1 == r2 = EQ- | otherwise = GT+ | otherwise = GT -- | Sum type for possible censoring and outcome reasons, including administrative -- censoring.@@ -75,15 +74,16 @@ deriving (Eq, Show, Generic) -- | A type to represent censored 'Occurrence'.-data CensoredOccurrence censors outcomes b = MkCensoredOccurrence {- reason :: CensoringReason censors outcomes- , time :: MaybeCensored ( EventTime b )}+data CensoredOccurrence censors outcomes b = MkCensoredOccurrence+ { reason :: CensoringReason censors outcomes+ , time :: MaybeCensored (EventTime b)+ } deriving (Eq, Generic) -instance (OccurrenceReason c, OccurrenceReason o, Show b) => +instance (OccurrenceReason c, OccurrenceReason o, Show b) => Show ( CensoredOccurrence c o b ) where show (MkCensoredOccurrence r t) = "(" <> show t <> ", " <> show r <> ")" -- | Creates an administratively censored occurrence. adminCensor :: EventTime b -> CensoredOccurrence c o b-adminCensor t = MkCensoredOccurrence AdminCensor ( RightCensored t )+adminCensor t = MkCensoredOccurrence AdminCensor (RightCensored t)
src/Hasklepias/Reexports.hs view
@@ -9,149 +9,197 @@ {-# LANGUAGE Safe #-} -module Hasklepias.Reexports (+module Hasklepias.Reexports+ ( -- * Re-exports- module GHC.Num- , module GHC.Real- , module GHC.Generics- , module GHC.Show- , module GHC.TypeLits- , module Control.Monad- , module Control.Applicative- , module Data.Bifunctor- , module Data.Bool- , module Data.Either- , module Data.Eq- , module Data.Int- , module Data.Maybe- , module Data.Monoid- , module Data.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- , module IntervalAlgebra.PairedInterval-- , module Safe- , module Flow- , module Witherable- , setFromList - , mapFromList- , mapToList-) where+ module GHC.Num+ , module GHC.Real+ , module GHC.Generics+ , module GHC.Show+ , module GHC.TypeLits+ , module Control.Monad+ , module Control.Applicative+ , module Data.Bifunctor+ , module Data.Bool+ , module Data.Either+ , module Data.Eq+ , module Data.Int+ , module Data.Maybe+ , module Data.Monoid+ , module Data.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+ , module IntervalAlgebra.PairedInterval+ , module Safe+ , module Flow+ , module Witherable+ , setFromList+ , mapFromList+ , mapToList+ ) where -import safe GHC.Num ( Integer(..)- , Num(..)- , Natural(..)- , naturalToInt )-import safe GHC.Real ( Integral(..)- , toInteger )-import safe GHC.Generics ( Generic )-import safe GHC.Show ( Show(..) )-import safe GHC.TypeLits ( KnownSymbol(..)- , symbolVal )-import safe Control.Applicative ( (<$>), Applicative(..) )-import safe Control.Monad ( Functor(..)- , Monad(..)- , join- , (>>=)- , (=<<) )-import safe Data.Bifunctor ( Bifunctor(..) )-import safe Data.Bool ( Bool(..)- , (&&), not, (||)- , bool- , otherwise )-import safe Data.Either ( Either(..))-import safe Data.Eq ( Eq, (==))-import safe Data.Foldable ( Foldable(..)- , minimum- , 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- , any- , 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,- catMaybes,- fromJust,- fromMaybe,- isNothing,- listToMaybe,- mapMaybe,- maybeToList )-import safe Data.Monoid ( Monoid(..), (<>) )-import safe Data.Ord ( Ord(..)- , Ordering(..)- , max, min )-import safe Data.Proxy ( Proxy(..) )-import safe qualified Data.Set as Set ( Set(..), member, fromList )-import safe Data.Traversable ( Traversable(..) )-import safe Data.Time.Calendar ( Day- , DayOfWeek- , DayOfMonth- , MonthOfYear- , Year- , CalendarDiffDays(..)- , addGregorianDurationClip- , fromGregorian- , toGregorian- , gregorianMonthLength- , diffDays )-import safe Data.Time.Calendar.Quarter ( QuarterOfYear - , Quarter- , dayQuarter )-import safe Data.Text ( pack, Text )-import safe Data.Tuple ( fst, snd, uncurry, curry )-import safe Data.Tuple.Curry ( curryN, uncurryN )+import safe Control.Applicative ( (<$>)+ , Applicative(..)+ )+import safe Control.Monad ( (=<<)+ , (>>=)+ , Functor(..)+ , Monad(..)+ , join+ )+import safe Data.Bifunctor ( Bifunctor(..) )+import safe Data.Bool ( (&&)+ , Bool(..)+ , bool+ , not+ , otherwise+ , (||)+ )+import safe Data.Either ( Either(..) )+import safe Data.Eq ( (==)+ , Eq+ )+import safe Data.Foldable ( Foldable(..)+ , maximum+ , minimum+ )+import safe Data.Function ( ($)+ , (.)+ , const+ , flip+ , id+ )+import safe Data.Functor.Contravariant ( Contravariant(contramap)+ , Predicate(..)+ )+import safe Data.Int ( Int(..) )+import safe Data.List ( (++)+ , all+ , any+ , length+ , map+ , null+ , replicate+ , scanl'+ , scanl1+ , sort+ , transpose+ , unzip+ , zip+ , zipWith+ )+import safe Data.List.NonEmpty ( NonEmpty(..) )+import safe qualified Data.Map.Strict as M+ ( Map(..)+ , fromList+ , fromListWith+ , toList+ )+import safe Data.Maybe ( Maybe(..)+ , catMaybes+ , fromJust+ , fromMaybe+ , isJust+ , isNothing+ , listToMaybe+ , mapMaybe+ , maybe+ , maybeToList+ )+import safe Data.Monoid ( (<>)+ , Monoid(..)+ )+import safe Data.Ord ( Ord(..)+ , Ordering(..)+ , max+ , min+ )+import safe Data.Proxy ( Proxy(..) )+import safe qualified Data.Set as Set+ ( Set(..)+ , fromList+ , member+ )+import safe Data.Text ( Text+ , pack+ )+import safe Data.Time.Calendar ( CalendarDiffDays(..)+ , Day+ , DayOfMonth+ , DayOfWeek+ , MonthOfYear+ , Year+ , addGregorianDurationClip+ , diffDays+ , fromGregorian+ , gregorianMonthLength+ , toGregorian+ )+import safe Data.Time.Calendar.Quarter ( Quarter+ , QuarterOfYear+ , dayQuarter+ )+import safe Data.Traversable ( Traversable(..) )+import safe Data.Tuple ( curry+ , fst+ , snd+ , uncurry+ )+import safe Data.Tuple.Curry ( curryN+ , uncurryN+ )+import safe GHC.Generics ( Generic )+import safe GHC.Num ( Integer(..)+ , Natural(..)+ , Num(..)+ , naturalToInt+ )+import safe GHC.Real ( Integral(..)+ , toInteger+ )+import safe GHC.Show ( Show(..) )+import safe GHC.TypeLits ( KnownSymbol(..)+ , symbolVal+ ) -import safe Witherable ( Filterable(filter), Witherable(..) )-import safe Flow ( (!>), (.>), (<!), (<.), (<|), (|>) )-import Safe ( headMay, lastMay )+import safe Flow ( (!>)+ , (.>)+ , (<!)+ , (<.)+ , (<|)+ , (|>)+ )+import Safe ( headMay+ , lastMay+ )+import safe Witherable ( Filterable(filter)+ , Witherable(..)+ ) -import safe IntervalAlgebra-import safe IntervalAlgebra.IntervalUtilities-import safe IntervalAlgebra.PairedInterval+import safe IntervalAlgebra+import safe IntervalAlgebra.IntervalUtilities+import safe IntervalAlgebra.PairedInterval -setFromList :: (Ord a) => [a] -> Set.Set a+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 :: (Ord k) => M.Map k a -> [(k, a)] mapToList = M.toList
src/Hasklepias/ReexportsUnsafe.hs view
@@ -8,18 +8,21 @@ -} -module Hasklepias.ReexportsUnsafe (+module Hasklepias.ReexportsUnsafe+ ( -- * Re-exports- module Data.Aeson- , module GHC.IO- , module Test.Tasty- , module Test.Tasty.HUnit-) where+ module Data.Aeson+ , module GHC.IO+ , module Test.Tasty+ , module Test.Tasty.HUnit+ ) where -import Data.Aeson ( encode, ToJSON(..))-import GHC.IO ( IO(..) )+import Data.Aeson ( ToJSON(..)+ , encode+ )+import GHC.IO ( IO(..) ) -- import GHC.Types ( Any )-import Test.Tasty hiding (after)-import Test.Tasty.HUnit +import Test.Tasty hiding ( after )+import Test.Tasty.HUnit
src/Hasklepias/Templates.hs view
@@ -8,9 +8,8 @@ {-# OPTIONS_HADDOCK hide #-} {-# LANGUAGE NoImplicitPrelude #-} -module Hasklepias.Templates (- module Hasklepias.Templates.Features--) where+module Hasklepias.Templates+ ( module Hasklepias.Templates.Features+ ) where -import Hasklepias.Templates.Features+import Hasklepias.Templates.Features
src/Hasklepias/Templates/Features/Enrollment.hs view
@@ -22,7 +22,6 @@ import Cohort import EventData import Features-import Hasklepias.Misc ( F ) import Hasklepias.FeatureEvents import Hasklepias.Templates.TestUtilities import Hasklepias.Reexports
src/Hasklepias/Templates/Features/NsatisfyP.hs view
@@ -33,7 +33,6 @@ import EventData import Features import Hasklepias.FeatureEvents-import Hasklepias.Misc ( F ) import Hasklepias.Reexports import Hasklepias.ReexportsUnsafe import Hasklepias.Templates.TestUtilities@@ -159,9 +158,9 @@ -> Definition ( Feature indexName (Index i0 a) -> Feature eventsName (t (Event a))- -> Feature varName Bool+ -> Feature varName Binary )-buildNofConceptsBinaryConcurBaseline n baselineDur cpts = buildNofXBool+buildNofConceptsBinaryConcurBaseline n baselineDur cpts = buildNofXBinary n (makeBaselineFromIndex baselineDur) concur
src/Hasklepias/Templates/TestUtilities.hs view
@@ -35,7 +35,8 @@ import GHC.Show ( Show ) import EventData import Cohort.Index-import Features.Compose ( Feature+import Features.Compose ( F+ , Feature , Definition(..) , Define(..) , eval )
test/Cohort/CoreSpec.hs view
@@ -7,7 +7,7 @@ import Features import Cohort-import Data.List.NonEmpty+import Data.Set (fromList) import Test.Hspec ( describe, pending, shouldBe, it, Spec ) -- data Feat1@@ -55,18 +55,38 @@ testOut :: Cohort Features testOut = MkCohort- ( Just $ MkAttritionInfo $ (ExcludedBy (1, "feat2"), 1) :| [ (Included, 1) ]+ ( MkAttritionInfo 2 $+ fromList [ uncurry MkAttritionLevel (ExcludedBy (1, "feat2"), 1)+ , uncurry MkAttritionLevel (Included, 1) ] , MkCohortData [MkObsUnit "2" ( makeFeature (featureDataR False) , makeFeature (featureDataR 56)) ]) +testAttr1 :: AttritionInfo+testAttr1 = MkAttritionInfo 2 $+ fromList [ uncurry MkAttritionLevel (ExcludedBy (1, "feat2"), 1)+ , uncurry MkAttritionLevel (Included, 1) ] ++testAttr2 :: AttritionInfo+testAttr2 = MkAttritionInfo 5 $+ fromList [ uncurry MkAttritionLevel (ExcludedBy (1, "feat2"), 3)+ , uncurry MkAttritionLevel (Included, 2) ] ++testAttr1p2 :: AttritionInfo+testAttr1p2 = MkAttritionInfo 7 $+ fromList [ uncurry MkAttritionLevel (ExcludedBy (1, "feat2"), 4)+ , uncurry MkAttritionLevel (Included, 3) ]+ -- evalCohort testCohort testPopulation spec :: Spec spec = do - describe "checking d1" $+ describe "checking evaluation of a cohort" $ do-- it "include f1" $+ it "testCohort evaluates to testOut" $ evalCohort testCohort testPopulation `shouldBe` testOut + describe "checking semigroup of attrition" $+ do+ it "testAttr1 <> testAttr2" $+ testAttr1 <> testAttr2 `shouldBe` testAttr1p2
+ test/Cohort/OutputSpec.hs view
@@ -0,0 +1,93 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE DataKinds #-}++module Cohort.OutputSpec (+ spec+ ) where++import Cohort+import Data.Aeson+import Data.HashMap.Internal as H+import Data.Vector as V (fromList)+import qualified Data.Set as Set (fromList)+import Test.Hspec ( describe, pending, shouldBe, it, Spec )+import qualified Data.ByteString.Lazy as B+ ( ByteString )+import Features (emptyAttributes)++attr1 :: Maybe AttritionInfo+attr1 = + Just $ MkAttritionInfo 2 $+ Set.fromList [ uncurry MkAttritionLevel (ExcludedBy (1, "feat2"), 1)+ , uncurry MkAttritionLevel (Included, 1)]++cw1 :: B.ByteString+cw1 = "{\"contents\":{\"ids\":[\"a\",\"b\"],\"colData\":[[5,5],[true,true]],\"colAttributes\":[{\"name\":\"dummy\",\"attrs\":{\"getPurpose\":{\"getTags\":[],\"getRole\":[]},\"getDerivation\":\"\",\"getLongLabel\":\"\",\"getShortLabel\":\"\"},\"type\":\"Count\"},{\"name\":\"another\",\"attrs\":{\"getPurpose\":{\"getTags\":[],\"getRole\":[]},\"getDerivation\":\"\",\"getLongLabel\":\"\",\"getShortLabel\":\"\"},\"type\":\"Bool\"}]},\"tag\":\"CW\"}"++cw2 :: B.ByteString+cw2 = "{\"contents\":{\"ids\":[\"c\",\"d\"],\"colData\":[[6,8],[false,true]],\"colAttributes\":[{\"name\":\"dummy\",\"attrs\":{\"getPurpose\":{\"getTags\":[],\"getRole\":[]},\"getDerivation\":\"\",\"getLongLabel\":\"\",\"getShortLabel\":\"\"},\"type\":\"Count\"},{\"name\":\"another\",\"attrs\":{\"getPurpose\":{\"getTags\":[],\"getRole\":[]},\"getDerivation\":\"\",\"getLongLabel\":\"\",\"getShortLabel\":\"\"},\"type\":\"Bool\"}]},\"tag\":\"CW\"}"++rw1 :: B.ByteString+rw1 = "{\"contents\":{\"rowAttributes\":[{\"name\":\"dummy\",\"attrs\":{\"getPurpose\":{\"getTags\":[],\"getRole\":[]},\"getDerivation\":\"\",\"getLongLabel\":\"\",\"getShortLabel\":\"\"},\"type\":\"Count\"},{\"name\":\"another\",\"attrs\":{\"getPurpose\":{\"getTags\":[],\"getRole\":[]},\"getDerivation\":\"\",\"getLongLabel\":\"\",\"getShortLabel\":\"\"},\"type\":\"Bool\"}],\"rowData\":[[\"a\",[5,true]],[\"b\",[5,true]]]},\"tag\":\"RW\"}"++rw2 :: B.ByteString+rw2 = "{\"contents\":{\"rowAttributes\":[{\"name\":\"dummy\",\"attrs\":{\"getPurpose\":{\"getTags\":[],\"getRole\":[]},\"getDerivation\":\"\",\"getLongLabel\":\"\",\"getShortLabel\":\"\"},\"type\":\"Count\"},{\"name\":\"another\",\"attrs\":{\"getPurpose\":{\"getTags\":[],\"getRole\":[]},\"getDerivation\":\"\",\"getLongLabel\":\"\",\"getShortLabel\":\"\"},\"type\":\"Bool\"}],\"rowData\":[[\"c\",[6,false]],[\"d\",[8,true]]]},\"tag\":\"RW\"}"++ep :: Value+ep = toJSON emptyAttributes++cwt :: CohortDataShapeJSON +cwt = CW $ MkColumnWiseJSON + [ Object $ H.fromList [("name", String "dummy")+ , ("attrs", ep)+ , ("type", String "Count")]+ , Object $ H.fromList [("name", String "another")+ , ("attrs", ep)+ , ("type", String "Bool")]+ ]+ [String "a", String "b", String "c", String "d"] + [ [Number 5, Number 5, Number 6, Number 8]+ , [Bool True, Bool True, Bool False, Bool True]+ ]++rwt :: CohortDataShapeJSON +rwt = RW $ MkRowWiseJSON + [ Object $ H.fromList [("name", String "dummy")+ , ("attrs", ep)+ , ("type", String "Count")]+ , Object $ H.fromList [("name", String "another")+ , ("attrs", ep)+ , ("type", String "Bool")]+ ]+ [ Array $ V.fromList [String "a", Array $ V.fromList [ Number 5, Bool True]]+ , Array $ V.fromList [String "b", Array $ V.fromList [ Number 5, Bool True]]+ , Array $ V.fromList [String "c", Array $ V.fromList [ Number 6, Bool False]]+ , Array $ V.fromList [String "d", Array $ V.fromList [ Number 8, Bool True]]+ ]++cw1p2 :: B.ByteString +cw1p2 = "{\"contents\":{\"ids\":[\"a\",\"b\",\"c\",\"d\"],\"colData\":[[5,5,6,8],[true,true,false,true]],\"colAttributes\":[{\"name\":\"dummy\",\"attrs\":{\"getPurpose\":{\"getTags\":[],\"getRole\":[]},\"getDerivation\":\"\",\"getLongLabel\":\"\",\"getShortLabel\":\"\"},\"type\":\"Count\"},{\"name\":\"another\",\"attrs\":{\"getPurpose\":{\"getTags\":[],\"getRole\":[]},\"getDerivation\":\"\",\"getLongLabel\":\"\",\"getShortLabel\":\"\"},\"type\":\"Bool\"}]},\"tag\":\"CW\"}"++rw1p2 :: B.ByteString+rw1p2 = "{\"contents\":{\"rowAttributes\":[{\"name\":\"dummy\",\"attrs\":{\"getPurpose\":{\"getTags\":[],\"getRole\":[]},\"getDerivation\":\"\",\"getLongLabel\":\"\",\"getShortLabel\":\"\"},\"type\":\"Count\"},{\"name\":\"another\",\"attrs\":{\"getPurpose\":{\"getTags\":[],\"getRole\":[]},\"getDerivation\":\"\",\"getLongLabel\":\"\",\"getShortLabel\":\"\"},\"type\":\"Bool\"}],\"rowData\":[[\"a\",[5,true]],[\"b\",[5,true]],[\"c\",[6,false]],[\"d\",[8,true]]]},\"tag\":\"RW\"}"+ ++spec :: Spec+spec = do++ describe "Cohort I/O" $+ do++ it "AttritionInfo can roundtrip via JSON" $+ decode (encode attr1) `shouldBe` attr1+ describe "Cohort to/fromJSON" $+ do++ it "columnwise cohort data can be combined" $+ (decode cw1 <> decode cw2) `shouldBe` Just cwt+ it "columnwise cohort data can be combined and serialized" $+ encode (decode cw1 <> decode cw2 :: Maybe CohortDataShapeJSON) `shouldBe` cw1p2+ it "rowwise cohort data can be combined" $+ (decode rw1 <> decode rw2) `shouldBe` Just rwt+ it "rowwise cohort data can be combined and serialized" $+ encode (decode rw1 <> decode rw2 :: Maybe CohortDataShapeJSON) `shouldBe` rw1p2