hasklepias 0.13.1 → 0.14.0
raw patch · 50 files changed
+2013/−1379 lines, 50 filesdep ~interval-algebra
Dependency ranges changed: interval-algebra
Files
- ChangeLog.md +12/−0
- exampleApp/Main.hs +23/−14
- examples/ExampleCohort1.hs +34/−32
- examples/ExampleFeatures1.hs +1/−1
- hasklepias.cabal +22/−13
- src/EventData.hs +16/−69
- src/EventData/Aeson.hs +1/−1
- src/EventData/Arbitrary.hs +1/−2
- src/EventData/Core.hs +86/−0
- src/FeatureCompose.hs +0/−394
- src/FeatureCompose/Aeson.hs +0/−48
- src/FeatureCompose/Attributes.hs +0/−85
- src/FeatureCompose/Featureable.hs +0/−37
- src/FeatureEvents.hs +9/−7
- src/Features.hs +30/−0
- src/Features/Attributes.hs +86/−0
- src/Features/Compose.hs +394/−0
- src/Features/Featureable.hs +55/−0
- src/Features/Featureset.hs +65/−0
- src/Features/Output.hs +106/−0
- src/Hasklepias.hs +5/−27
- src/Hasklepias/Aeson.hs +0/−97
- src/Hasklepias/Cohort.hs +16/−139
- src/Hasklepias/Cohort/Core.hs +167/−0
- src/Hasklepias/Cohort/Criteria.hs +1/−1
- src/Hasklepias/Cohort/Input.hs +97/−0
- src/Hasklepias/Cohort/Output.hs +120/−0
- src/Hasklepias/MakeApp.hs +23/−8
- src/Hasklepias/Reexports.hs +2/−0
- src/Stype.hs +2/−0
- src/Stype/Aeson.hs +47/−0
- src/Stype/Categorical.hs +7/−3
- src/Stype/Categorical/Binary.hs +44/−0
- src/Stype/Categorical/Nominal.hs +7/−4
- src/Stype/Numeric.hs +1/−4
- src/Stype/Numeric/Censored.hs +16/−7
- src/Stype/Numeric/Continuous.hs +21/−7
- src/Stype/Numeric/Count.hs +3/−1
- test/FeatureCompose/AesonSpec.hs +0/−65
- test/FeatureComposeSpec.hs +0/−168
- test/Features/FeaturesetSpec.hs +58/−0
- test/Features/OutputSpec.hs +63/−0
- test/FeaturesSpec.hs +168/−0
- test/Hasklepias/AesonSpec.hs +0/−73
- test/Hasklepias/Cohort/CoreSpec.hs +72/−0
- test/Hasklepias/Cohort/CriteriaSpec.hs +1/−1
- test/Hasklepias/Cohort/InputSpec.hs +73/−0
- test/Hasklepias/CohortSpec.hs +0/−71
- test/Stype/AesonSpec.hs +41/−0
- test/Stype/Numeric/CensoredSpec.hs +17/−0
ChangeLog.md view
@@ -1,5 +1,17 @@ # Changelog for hasklepias +## 0.14.0++* Adds the ability to modify the output shape of cohorts. The `makeCohortApp` now takes a "`shape`" function as an argument of type `Cohort d -> CohortShape shape`. Currently, two functions of this type are provided: `rowWise` and `colWise`. The `rowWise` functions presents the output feature data in a row-wise format where each subject's data is its own array; whereas `colWise` presents the feature data where all the data of a given feature are in a single array.+* Updates `interval-algebra` dependency to 0.9.0. Updates code accordingly.+* Reorganizes modules to simplify imports.++## 0.13.2++* Adds `Binary` Stype data type.+* Adds `ToJSON` instance for most Stype types.+* Adds `Featureset` module and type, which is simply a list of `Featureable`s. This is just a step towards being able to define the shape of JSON output.+ ## 0.13.1 * Adds the `Featureable` type, which allows users to put features into a heterogenous list. A drawback of `Featureable` is that two `Featurable` values cannot be tested for equality, so testing will need to occur before a `Feature n d` is packed into a `Featureable` (by the `packFeature` function) or after the `Featureable` is encoded to JSON. See `examples/ExampleCohort1.hs` for example usage.
exampleApp/Main.hs view
@@ -4,6 +4,9 @@ Copyright : (c) NoviSci, Inc 2020 License : BSD3 Maintainer : bsaul@novisci.com++To run as an example: +cat exampleApp/exampleData.jsonl| cabal exec exampleApp -} {-# LANGUAGE OverloadedStrings #-}@@ -29,18 +32,27 @@ -- | Lift a subject's events in a feature featureDummy :: Definition ( Feature "allEvents" (Events Day)- -> Feature "dummy" Bool)-featureDummy = define $ pure True+ -> Feature "dummy" Count)+featureDummy = define $ pure 5 +-- | Lift a subject's events in a feature+anotherDummy :: Bool + -> Definition+ ( Feature "allEvents" (Events Day)+ -> Feature "another" Bool)+anotherDummy x = define $ const x+ -- | Include the subject if she has an enrollment interval concurring with index. critTrue :: Definition ( Feature "allEvents" (Events Day) -> Feature "dummy" Status)-critTrue = define $ pure Include +critTrue = define $ pure Include -instance HasAttributes "dummy" Bool where- getAttributes _ = emptyAttributes +instance HasAttributes "dummy" Count where+ getAttributes _ = emptyAttributes +instance HasAttributes "another" Bool where+ getAttributes _ = emptyAttributes {------------------------------------------------------------------------------- Cohort Specifications and evaluation -------------------------------------------------------------------------------}@@ -52,21 +64,18 @@ where crit1 = eval critTrue featEvs featEvs = featureEvents events --- | Define the shape of features for a cohort-type CohortFeatures = [Featureable]- -- (Feature "dummy" Bool )-- -- | Make a function that runs the features for a calendar index makeFeatureRunner :: Events Day- -> CohortFeatures-makeFeatureRunner events = [packFeature ( eval featureDummy ef )]+ -> Featureset+makeFeatureRunner events = featureset + ( packFeature ( eval featureDummy ef ) :|+ [packFeature ( eval (anotherDummy True ) ef)]) where ef = featureEvents events -- | Make a cohort specification for each calendar time-cohortSpecs :: [CohortSpec (Events Day) CohortFeatures]+cohortSpecs :: [CohortSpec (Events Day) Featureset] cohortSpecs = [specifyCohort makeCriteriaRunner makeFeatureRunner] main :: IO ()-main = makeCohortApp "testCohort" "v0.1.0" cohortSpecs+main = makeCohortApp "testCohort" "v0.1.0" colWise cohortSpecs
examples/ExampleCohort1.hs view
@@ -76,16 +76,16 @@ ( Feature "calendarIndex" (Index Interval Day) -> Feature "allEvents" (Events Day) -> Feature name Bool )-twoOutOneIn cpts1 cpts2 = +twoOutOneIn cpts1 cpts2 = define (\index events ->- atleastNofX 1 cpts1 (getBaselineConcur index events) - || ( - events - |> makeConceptsFilter cpts2 + atleastNofX 1 cpts1 (getBaselineConcur index events)+ || (+ events+ |> makeConceptsFilter cpts2 |> map toConceptEvent- |> anyGapsWithinAtLeastDuration 7 (baselineInterval index)) - + |> anyGapsWithinAtLeastDuration 7 (baselineInterval index))+ ) -- | Defines a feature that returns 'True' ('False' otherwise) if either:@@ -108,9 +108,9 @@ || ( events |> getBaselineConcur index- |> relations+ |> relationsL |> filter (== Equals)- |> not . null) + |> not . null) ) @@ -261,7 +261,7 @@ diabetes = twoOutOneIn ["is_diabetes_outpatient"] ["is_diabetes_inpatient"] instance HasAttributes "diabetes" Bool where- getAttributes _ = basicAttributes + getAttributes _ = basicAttributes "Has Diabetes" "Has Diabetes within baseline" [Covariate]@@ -282,7 +282,7 @@ ppi = medHx ["is_ppi"] instance HasAttributes "ppi" Bool where- getAttributes _ = basicAttributes + getAttributes _ = basicAttributes "Has ppi" "Has PPI within baseline" [Covariate]@@ -292,7 +292,7 @@ glucocorticoids = medHx ["is_glucocorticoids"] instance HasAttributes "glucocorticoids" Bool where- getAttributes _ = basicAttributes + getAttributes _ = basicAttributes "Has glucocorticoids" "Has glucocorticoids within baseline" [Covariate]@@ -304,8 +304,6 @@ Cohort Specifications and evaluation -------------------------------------------------------------------------------} -- -- | Make a function that runs the criteria for a calendar index makeCriteriaRunner :: Index Interval Day -> Events Day -> Criteria makeCriteriaRunner index events =@@ -330,25 +328,25 @@ makeFeatureRunner :: Index Interval Day -> Events Day- -> [Featureable] -makeFeatureRunner index events = [- packFeature idx- , packFeature $ eval diabetes (idx, ef)+ -> Featureset+makeFeatureRunner index events = featureset+ (packFeature idx :|+ [ packFeature $ eval diabetes (idx, ef) , packFeature $ eval ckd (idx, ef) , packFeature $ eval ppi (idx, ef) , packFeature $ eval glucocorticoids (idx, ef)- ] + ]) where idx = featureIndex index ef = featureEvents events -- | Make a cohort specification for each calendar time-cohortSpecs :: [CohortSpec (Events Day) [Featureable]]+cohortSpecs :: [CohortSpec (Events Day) Featureset] cohortSpecs = map (\x -> specifyCohort (makeCriteriaRunner x) (makeFeatureRunner x)) indices -- | A function that evaluates all the calendar cohorts for a population-evalCohorts :: Population (Events Day) -> [Cohort [Featureable]]+evalCohorts :: Population (Events Day) -> [Cohort Featureset] evalCohorts pop = map (`evalCohort` pop) cohortSpecs {-------------------------------------------------------------------------------@@ -395,16 +393,17 @@ makeExpectedFeatures :: FeatureData (Index Interval Day) -> (FeatureData Bool, FeatureData Bool, FeatureData Bool, FeatureData Bool)- -> [Featureable]+ -> Featureset makeExpectedFeatures i (b1, b2, b3, b4) =- [ packFeature (makeFeature i :: Feature "calendarIndex" (Index Interval Day))- , packFeature ( makeExpectedCovariate b1 :: Feature "diabetes" Bool )+ featureset+ ( packFeature (makeFeature i :: Feature "calendarIndex" (Index Interval Day)) :|+ [ packFeature ( makeExpectedCovariate b1 :: Feature "diabetes" Bool ) , packFeature ( makeExpectedCovariate b2 :: Feature "ckd" Bool ) , packFeature ( makeExpectedCovariate b3 :: Feature "ppi" Bool ) , packFeature ( makeExpectedCovariate b4 :: Feature "glucocorticoids" Bool )- ]+ ]) -expectedFeatures1 :: [[Featureable ]]+expectedFeatures1 :: [Featureset] expectedFeatures1 = map (uncurry makeExpectedFeatures) [ (pure $ makeIndex $ beginerval 1 (fromGregorian 2017 4 1),@@ -415,13 +414,13 @@ (pure True, pure False, pure True, pure False)) ] -expectedObsUnita :: [ObsUnit [Featureable]]-expectedObsUnita = zipWith (curry MkObsUnit) (replicate 5 "a") expectedFeatures1+expectedObsUnita :: [ObsUnit Featureset]+expectedObsUnita = zipWith MkObsUnit (replicate 5 "a") expectedFeatures1 -makeExpectedCohort :: AttritionInfo -> [ObsUnit [Featureable]] -> Cohort [Featureable]-makeExpectedCohort a x = MkCohort (Just a, x)+makeExpectedCohort :: AttritionInfo -> [ObsUnit Featureset] -> Cohort Featureset+makeExpectedCohort a x = MkCohort (Just a, MkCohortData x) -expectedCohorts :: [Cohort [Featureable]]+expectedCohorts :: [Cohort Featureset] expectedCohorts = zipWith (curry MkCohort)@@ -435,7 +434,10 @@ , Just $ MkAttritionInfo $ (ExcludedBy (2, "isOver50"), 1) :| [(ExcludedBy (3, "isEnrolled"), 1)] , Just $ MkAttritionInfo $ (ExcludedBy (2, "isOver50"), 1) :| [(ExcludedBy (3, "isEnrolled"), 1)] ]- ([[]] ++ transpose [expectedObsUnita] ++ [[], [], [], []])+ ( fmap MkCohortData (+ [[]] + ++ transpose [expectedObsUnita]+ ++ [[], [], [], []] )) exampleCohort1tests :: TestTree exampleCohort1tests = testGroup "Unit tests for calendar cohorts"
examples/ExampleFeatures1.hs view
@@ -223,5 +223,5 @@ it "mapping a population to cohort" $ evalCohort testCohortSpec (MkPopulation [exampleSubject1, exampleSubject2 ]) `shouldBe` MkCohort (Just $ MkAttritionInfo $ pure (Included, 2),- [MkObsUnit ("a", example1results), MkObsUnit ("b", example2results)])+ MkCohortData [MkObsUnit "a" example1results, MkObsUnit "b" example2results])
hasklepias.cabal view
@@ -1,6 +1,6 @@ cabal-version: 2.2 name: hasklepias-version: 0.13.1+version: 0.14.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@@ -23,31 +23,38 @@ library exposed-modules: EventData+ EventData.Core EventData.Arbitrary EventData.Aeson EventData.Context EventData.Context.Arbitrary EventData.Context.Domain EventData.Context.Domain.Demographics- FeatureCompose- FeatureCompose.Aeson- FeatureCompose.Attributes- FeatureCompose.Featureable+ Features+ Features.Attributes+ Features.Compose+ Features.Featureable+ Features.Output+ Features.Featureset FeatureEvents Hasklepias- Hasklepias.Aeson Hasklepias.MakeApp Hasklepias.Reexports Hasklepias.ReexportsUnsafe Hasklepias.Cohort+ Hasklepias.Cohort.Core+ Hasklepias.Cohort.Input+ Hasklepias.Cohort.Output Hasklepias.Cohort.Criteria Hasklepias.Cohort.Index Stype+ Stype.Aeson Stype.Numeric Stype.Numeric.Count Stype.Numeric.Continuous Stype.Numeric.Censored Stype.Categorical+ Stype.Categorical.Binary Stype.Categorical.Nominal other-modules: Paths_hasklepias@@ -64,7 +71,7 @@ , co-log == 0.4.0.1 , flow == 1.0.22 , ghc-prim == 0.6.1- , interval-algebra == 0.8.2+ , interval-algebra == 0.9.0 , lens == 5.0.1 , lens-aeson == 1.1.1 , mtl == 2.2.2@@ -91,12 +98,15 @@ EventData.ContextSpec EventData.Context.DomainSpec EventData.Context.Domain.DemographicsSpec- FeatureComposeSpec- FeatureCompose.AesonSpec- Hasklepias.AesonSpec- Hasklepias.CohortSpec+ FeaturesSpec+ Features.OutputSpec+ Features.FeaturesetSpec+ Hasklepias.Cohort.InputSpec+ Hasklepias.Cohort.CoreSpec Hasklepias.Cohort.CriteriaSpec FeatureEventsSpec+ Stype.AesonSpec+ Stype.Numeric.CensoredSpec Paths_hasklepias autogen-modules: Paths_hasklepias @@ -111,7 +121,7 @@ , flow == 1.0.22 , hasklepias , hspec- , interval-algebra == 0.8.2+ , interval-algebra == 0.9.0 , lens == 5.0.1 , text >=1.2.3 , time >=1.11@@ -139,7 +149,6 @@ , tasty-hunit == 0.10.0.3 , tasty-hspec == 1.2 default-language: Haskell2010- executable exampleApp -- type: exitcode-stdio-1.0
src/EventData.hs view
@@ -8,79 +8,26 @@ -} {-# OPTIONS_HADDOCK hide #-} {-# LANGUAGE NoImplicitPrelude #-}-{-# LANGUAGE TypeSynonymInstances #-}-{-# LANGUAGE FlexibleInstances #-}--- {-# LANGUAGE Safe #-} module EventData( - -- * Events- Event- , Events- , ConceptEvent- , event- , ctxt- , toConceptEvent- , toConceptEventOf- , mkConceptEvent-) where--import GHC.Show ( Show(show) )-import Data.Function ( ($) )-import Data.Set ( member, fromList, intersection )-import Data.Ord ( Ord )-import IntervalAlgebra ( Interval- , Intervallic- , Intervallic (getInterval) )-import IntervalAlgebra.PairedInterval ( PairedInterval- , makePairedInterval- , getPairData )-import EventData.Context ( HasConcept(..)- , Concepts- , Concept- , packConcept- , Context(..)- , getConcepts- , toConcepts )+ -- * Events+ module EventData.Core+ -- ** Event Contexts+ , module EventData.Context+ -- ** Event Domains+ , module EventData.Context.Domain+ -- ** Parsing Events+ , module EventData.Aeson+ -- ** Generating arbitrary events+ , module EventData.Arbitrary --- | An Event @a@ is simply a pair @(Interval a, Context)@.-type Event a = PairedInterval Context a--instance HasConcept (Event a) where- hasConcept x y = ctxt x `hasConcept` y---- | A smart constructor for 'Event a's.-event :: Interval a -> Context -> Event a-event i c = makePairedInterval c i---- | Get the 'Context' of an 'Event a'.-ctxt :: Event a -> Context-ctxt = getPairData---- | An event containing only concepts and an interval-type ConceptEvent a = PairedInterval Concepts a--instance HasConcept (ConceptEvent a) where- hasConcept e concept = member (packConcept concept) (getConcepts $ getPairData e)---- | Drops an @Event@ to a @ConceptEvent@ by moving the concepts in the data--- position in the paired interval and throwing out the facts and source.-toConceptEvent :: (Show a, Ord a) => Event a -> ConceptEvent a-toConceptEvent e = makePairedInterval (_concepts $ ctxt e) (getInterval e)---- | Creates a new @'ConceptEvent'@ from an @'Event'@ by taking the intersection--- of the list of Concepts in the first argument and any Concepts in the @'Event'@.--- This is a way to keep only the concepts you want in an event.-toConceptEventOf :: (Show a, Ord a) => [Concept] -> Event a -> ConceptEvent a-toConceptEventOf cpts e =- makePairedInterval- (toConcepts $ intersection (fromList cpts) (getConcepts $ _concepts $ ctxt e))- (getInterval e)+) where --- | Create a new @'ConceptEvent'@.-mkConceptEvent :: (Show a, Ord a) => Interval a -> Concepts -> ConceptEvent a-mkConceptEvent i c = makePairedInterval c i+import EventData.Core+import EventData.Context+import EventData.Context.Domain+import EventData.Arbitrary+import EventData.Aeson --- | A @List@ of @Event a@-type Events a = [Event a]
src/EventData/Aeson.hs view
@@ -27,7 +27,7 @@ , context , packConcept , toConcepts )-import EventData ( Event, event )+import EventData.Core ( Event, event ) import EventData.Context.Domain import Prelude ( (<$>), (<*>), ($) , fmap, pure, id
src/EventData/Arbitrary.hs view
@@ -33,8 +33,7 @@ import Data.List(length) import IntervalAlgebra ( Interval ) import IntervalAlgebra.Arbitrary ()-import EventData- ( event, Event, ConceptEvent, toConceptEvent )+import EventData.Core ( event, Event, ConceptEvent, toConceptEvent ) import EventData.Context.Arbitrary () instance (Arbitrary (Interval a)) => Arbitrary (Event a) where
+ src/EventData/Core.hs view
@@ -0,0 +1,86 @@+{-|+Module : Hasklepias Event Type+Description : Defines the Event type and its component types, constructors, + and class instance+Copyright : (c) NoviSci, Inc 2020+License : BSD3+Maintainer : bsaul@novisci.com+-}+{-# OPTIONS_HADDOCK hide #-}+{-# LANGUAGE NoImplicitPrelude #-}+{-# LANGUAGE TypeSynonymInstances #-}+{-# LANGUAGE FlexibleInstances #-}+-- {-# LANGUAGE Safe #-}++module EventData.Core(++ -- * Events+ Event+ , Events+ , ConceptEvent+ , event+ , ctxt+ , toConceptEvent+ , toConceptEventOf+ , mkConceptEvent+) where++import GHC.Show ( Show(show) )+import Data.Function ( ($) )+import Data.Set ( member, fromList, intersection )+import Data.Ord ( Ord )+import IntervalAlgebra ( Interval+ , Intervallic+ , Intervallic (getInterval) )+import IntervalAlgebra.PairedInterval ( PairedInterval+ , makePairedInterval+ , getPairData )+import EventData.Context ( HasConcept(..)+ , Concepts+ , Concept+ , packConcept+ , Context(..)+ , getConcepts+ , toConcepts )+++-- | An Event @a@ is simply a pair @(Interval a, Context)@.+type Event a = PairedInterval Context a++instance HasConcept (Event a) where+ hasConcept x y = ctxt x `hasConcept` y++-- | A smart constructor for 'Event a's.+event :: Interval a -> Context -> Event a+event i c = makePairedInterval c i++-- | Get the 'Context' of an 'Event a'.+ctxt :: Event a -> Context+ctxt = getPairData++-- | An event containing only concepts and an interval+type ConceptEvent a = PairedInterval Concepts a++instance HasConcept (ConceptEvent a) where+ hasConcept e concept = member (packConcept concept) (getConcepts $ getPairData e)++-- | Drops an @Event@ to a @ConceptEvent@ by moving the concepts in the data+-- position in the paired interval and throwing out the facts and source.+toConceptEvent :: (Show a, Ord a) => Event a -> ConceptEvent a+toConceptEvent e = makePairedInterval (_concepts $ ctxt e) (getInterval e)++-- | Creates a new @'ConceptEvent'@ from an @'Event'@ by taking the intersection+-- of the list of Concepts in the first argument and any Concepts in the @'Event'@.+-- This is a way to keep only the concepts you want in an event.+toConceptEventOf :: (Show a, Ord a) => [Concept] -> Event a -> ConceptEvent a+toConceptEventOf cpts e =+ makePairedInterval+ (toConcepts $ intersection (fromList cpts) (getConcepts $ _concepts $ ctxt e))+ (getInterval e)++-- | Create a new @'ConceptEvent'@.+mkConceptEvent :: (Show a, Ord a) => Interval a -> Concepts -> ConceptEvent a+mkConceptEvent i c = makePairedInterval c i++-- | A @List@ of @Event a@+type Events a = [Event a]
− src/FeatureCompose.hs
@@ -1,394 +0,0 @@-{-|-Module : Define and evaluate Features -Description : Defines the Feature type and its component types, constructors, - and class instances-Copyright : (c) NoviSci, Inc 2020-License : BSD3-Maintainer : bsaul@novisci.com---}-{-# OPTIONS_HADDOCK hide #-}--{-# LANGUAGE Safe #-}-{-# LANGUAGE NoImplicitPrelude #-}-{-# LANGUAGE DeriveGeneric #-}-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE DataKinds #-}-{-# LANGUAGE TypeApplications #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE GADTs #-}-{-# LANGUAGE FunctionalDependencies #-}-{-# LANGUAGE AllowAmbiguousTypes #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE ExistentialQuantification #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE InstanceSigs #-}--module FeatureCompose(- -- * Features and FeatureData- FeatureData- , MissingReason(..)- , Feature- , FeatureN- , featureDataL- , featureDataR- , missingBecause- , makeFeature- , getFeatureData- , getFData- , getData- , getDataN- , getNameN- , nameFeature-- -- * Defining and evaluating Features- , Definition(..)- , Define(..)- , DefineA(..)- , Eval- , eval-- , HasAttributes(..)-) where--import safe Control.Applicative ( Applicative(..)- , liftA3, (<$>) )-import safe Control.Monad ( Functor(..), Monad(..)- , (=<<), join, liftM, liftM2, liftM3)-import safe Data.Either ( Either(..) )-import safe Data.Eq ( Eq(..) )-import safe Data.Foldable ( Foldable(foldr), fold )-import safe Data.Function ( ($), (.), id )-import safe Data.List ( (++), transpose, concat )-import safe Data.Proxy ( Proxy(..) )-import safe Data.Text ( Text, pack )-import safe Data.Traversable ( Traversable(..) )-import safe GHC.Generics ( Generic )-import safe GHC.Show ( Show(show) )-import safe GHC.TypeLits ( KnownSymbol, Symbol, symbolVal )-import safe FeatureCompose.Attributes-{- | -Defines the reasons that a @'FeatureData'@ value may be missing. Can be used to-indicate the reason that a @'Feature'@'s data was unable to be derived or does-not need to be derived. --}-{- tag::missingReason[] -}-data MissingReason =- InsufficientData -- ^ Insufficient information available to derive data.- | Other Text -- ^ User provided reason for missingness-{- end::missingReason[] -}- deriving (Eq, Show, Generic)--{- | -The @FeatureData@ type is a container for an (almost) arbitrary type @d@ that can-have a "failed" or "missing" state. The failure is represented by the @'Left'@ of -an @'Either'@, while the data @d@ is contained in the @'Either'@'s @'Right'@.--To construct a successful value, use @'featureDataR'@. A missing value can be -constructed with @'featureDataL'@ or its synonym @'missingBecause'@.---}-{- tag::featureData[] -}-newtype FeatureData d = MkFeatureData {- getFeatureData :: Either MissingReason d -- ^ Unwrap FeatureData.- }-{- end::featureData[] -}- deriving (Eq, Show, Generic)---- | Creates a non-missing 'FeatureData'. Since @'FeatureData'@ is an instance of--- @'Applicative'@, @'pure'@ is also a synonym of for @'featureDataR'@.--- --- >>> featureDataR "aString"--- MkFeatureData (Right "aString")--- >>> featureDataR (1 :: P.Int)--- MkFeatureData (Right 1)--- --- >>> featureDataR ("aString", (1 :: P.Int))--- MkFeatureData (Right ("aString",1))----featureDataR :: d -> FeatureData d-featureDataR = MkFeatureData . Right---- | Creates a missing 'FeatureData'.--- --- >>> featureDataL (Other "no good reason") :: FeatureData P.Int--- MkFeatureData (Left (Other "no good reason"))------ >>> featureDataL (Other "no good reason") :: FeatureData Text--- MkFeatureData (Left (Other "no good reason"))----featureDataL :: MissingReason -> FeatureData d-featureDataL = MkFeatureData . Left---- | A synonym for 'featureDataL'.-missingBecause :: MissingReason -> FeatureData d-missingBecause = featureDataL--{- FeatureData instances -}---- | Transform ('fmap') @'FeatureData'@ of one type to another.------ >>> x = featureDataR (1 :: P.Int)--- >>> :type x--- >>> :type ( fmap show x )--- x :: FeatureData Int--- ( fmap show x ) :: FeatureData String--- --- Note that 'Left' values are carried along while the type changes:------ >>> x = ( featureDataL InsufficientData ) :: FeatureData P.Int--- >>> :type x--- >>> x--- >>> :type ( fmap show x )--- >>> fmap show x --- x :: FeatureData Int--- MkFeatureData {getFeatureData = Left InsufficientData}--- ( fmap show x ) :: FeatureData String--- MkFeatureData {getFeatureData = Left InsufficientData}----instance Functor FeatureData where- fmap f (MkFeatureData x) = MkFeatureData (fmap f x)--instance Applicative FeatureData where- pure = featureDataR- liftA2 f (MkFeatureData x) (MkFeatureData y) = MkFeatureData (liftA2 f x y)--instance Monad FeatureData where- (MkFeatureData x) >>= f =- case fmap f x of- Left l -> MkFeatureData $ Left l- Right v -> v--instance Foldable FeatureData where- foldr f x (MkFeatureData z) = foldr f x z--instance Traversable FeatureData where- traverse f (MkFeatureData z) = MkFeatureData <$> traverse f z--{- | -The @'Feature'@ is an abstraction for @name@d @d@ata, where the @name@ is a-*type*. Essentially, it is a container for @'FeatureData'@ that assigns a @name@-to the data.--Except when using @'pure'@ to lift data into a @Feature@, @Feature@s can only be-derived from other @Feature@ via a @'Definition'@.--}-{- tag::feature[] -}-newtype (KnownSymbol name) => Feature name d =- MkFeature { getFData :: FeatureData d }-{- end::feature[] -}- deriving (Eq)---- | A utility for constructing a @'Feature'@ from @'FeatureData'@.--- Since @name@ is a type, you may need to annotate the type when using this--- function.------ >>> makeFeature (pure "test") :: Feature "dummy" Text--- "dummy": MkFeatureData {getFeatureData = Right "test"}----makeFeature :: (KnownSymbol name) => FeatureData d -> Feature name d-makeFeature = MkFeature---- | A utility for getting the (inner) @'FeatureData'@ content of a @'Feature'@.-getData :: Feature n d -> Either MissingReason d-getData (MkFeature x) = getFeatureData x--{- Feature instances -}-instance (KnownSymbol name, Show a) => Show (Feature name a) where- show (MkFeature x) = show (symbolVal (Proxy @name)) ++ ": " ++ show x--instance Functor (Feature name) where- fmap f (MkFeature x) = MkFeature (fmap f x)--instance Applicative (Feature name) where- pure x = MkFeature (pure x)- liftA2 f (MkFeature x) (MkFeature y) = MkFeature (liftA2 f x y)--instance Foldable (Feature name) where- foldr f x (MkFeature t) = foldr f x t--instance Traversable (Feature name) where- traverse f (MkFeature x) = MkFeature <$> traverse f x--instance Monad (Feature name) where- (MkFeature x) >>= f =- case fmap f x of- MkFeatureData (Left l) -> MkFeature $ MkFeatureData (Left l)- MkFeatureData (Right r) -> r--{- |-The @'FeatureN'@ type is similar to @'Feature'@ where the @name@ is included-as a @Text@ field. This type is mainly for internal purposes in order to collect-@Feature@s of the same type @d@ into a homogeneous container like a @'Data.List'@.--}-data FeatureN d = MkFeatureN {- getNameN :: Text -- ^ Get the name of a @FeatureN@.- , getDataN :: FeatureData d -- ^ Get the data of a @FeatureN@- } deriving (Eq, Show)---- | A utility for converting a @'Feature'@ to @'FeatureN'@.-nameFeature :: forall name d . (KnownSymbol name) => Feature name d -> FeatureN d-nameFeature (MkFeature d) = MkFeatureN (pack $ symbolVal (Proxy @name)) d--{- | A @Definition@ can be thought of as a lifted function. Specifically, the-@'define'@ function takes an arbitrary function (currently up to three arguments)-and returns a @Defintion@ where the arguments have been lifted to a new domain.--For example, here we take @f@ and lift to to a function of @Feature@s.--@-f :: Int -> String -> Bool-f i s - | 1 "yes" = True- | otherwise = FALSE--myFeature :: Definition (Feature "A" Int -> Feature "B" String -> Feature "C" Bool )-myFeature = define f-@--See @'eval'@ for evaluating @Defintions@. ---}--data Definition d where- D1 :: (b -> a) -> Definition (f1 b -> f0 a)- D1A :: (b -> f0 a) -> Definition (f1 b -> f0 a)- D2 :: (c -> b -> a) -> Definition (f2 c -> f1 b -> f0 a)- D2A :: (c -> b -> f0 a) -> Definition (f2 c -> f1 b -> f0 a)- D3 :: (d -> c -> b -> a) -> Definition (f3 d -> f2 c -> f1 b -> f0 a)- D3A :: (d -> c -> b -> f0 a) -> Definition (f3 d -> f2 c -> f1 b -> f0 a)--{- | Define (and @'DefineA@) provide a means to create new @'Definition'@s via -@'define'@ (@'defineA'@). The @'define'@ function takes a single function input -and returns a lifted function. For example,--@-f :: Int -> String -> Bool-f i s - | 1 "yes" = True- | otherwise = FALSE--myFeature :: Definition (Feature "A" Int -> Feature "B" String -> Feature "C" Bool )-myFeature = define f-@--The @'defineA'@ function is similar, except that the return type of the input-function is already lifted. In the example below, an input of @Nothing@ is -considered a missing state: --@-f :: Int -> Maybe String -> Feature "C" Bool-f i s - | 1 (Just "yes") = pure True- | _ (Just _ ) = pure False -- False for any Int and any (Just String)- | otherwise = pure $ missingBecause InsufficientData -- missing if no string--myFeature :: Definition (Feature "A" Int -> Feature "B" String -> Feature "C" Bool )-myFeature = defineA f-@---}-class Define inputs def | def -> inputs where- define :: inputs -> Definition def---- | See @'Define'@.-class DefineA inputs def | def -> inputs where- defineA :: inputs -> Definition def--instance Define (b -> a) (FeatureData b -> FeatureData a) where define = D1-instance Define (c -> b -> a) (FeatureData c -> FeatureData b -> FeatureData a) where define = D2-instance Define (d -> c -> b -> a) (FeatureData d -> FeatureData c -> FeatureData b -> FeatureData a) where define = D3--instance DefineA (b -> FeatureData a) (FeatureData b -> FeatureData a) where defineA = D1A-instance DefineA (c -> b -> FeatureData a) (FeatureData c -> FeatureData b -> FeatureData a) where defineA = D2A-instance DefineA (d -> c -> b -> FeatureData a) (FeatureData d -> FeatureData c -> FeatureData b -> FeatureData a) where defineA = D3A--instance Define (b -> a) (Feature n1 b -> Feature n0 a) where define = D1-instance Define (c -> b -> a) (Feature n2 c -> Feature n1 b -> Feature n0 a) where define = D2-instance Define (d -> c -> b -> a) (Feature n3 d -> Feature n2 c -> Feature n1 b -> Feature n0 a) where define = D3--instance DefineA (b -> Feature n0 a) (Feature n1 b -> Feature n0 a) where defineA = D1A-instance DefineA (c -> b -> Feature n0 a) (Feature n2 c -> Feature n1 b -> Feature n0 a) where defineA = D2A-instance DefineA (d -> c -> b -> Feature n0 a) (Feature n3 d -> Feature n2 c -> Feature n1 b -> Feature n0 a) where defineA = D3A--{- | Evaluate a @Definition@. Note that (currently), the second argument of 'eval'-is a *tuple* of inputs. For example,--@-f :: Int -> String -> Bool-f i s - | 1 "yes" = True- | otherwise = FALSE--myFeature :: Definition (Feature "A" Int -> Feature "B" String -> Feature "C" Bool )-myFeature = define f--a :: Feature "A" Int-a = pure 1--b :: Feature "B" String-b = pure "yes"--c = eval myFeature (a, b)-@---}-class Eval def args return | def -> args return where- eval :: Definition def -- ^ a @'Definition'@- -> args -- ^ a tuple of arguments to the @'Definition'@- -> return--instance Eval (FeatureData b -> FeatureData a)- (FeatureData b) (FeatureData a) where- eval (D1 f) x = fmap f x- eval (D1A f) x = x >>= f--instance Eval (Feature n1 b -> Feature n0 a)- (Feature n1 b) (Feature n0 a) where- eval (D1 f) (MkFeature x) = MkFeature $ fmap f x- eval (D1A f) (MkFeature x) =- case fmap f x of- MkFeatureData (Left l) -> MkFeature $ MkFeatureData (Left l)- MkFeatureData (Right r) -> r---instance Eval (FeatureData c -> FeatureData b -> FeatureData a)- (FeatureData c, FeatureData b) (FeatureData a) where- eval (D2 f) (x, y) = liftA2 f x y- eval (D2A f) (x, y) = join (liftA2 f x y)--instance Eval (Feature n2 c -> Feature n1 b -> Feature n0 a)- (Feature n2 c, Feature n1 b) (Feature n0 a)- where- eval (D2 f) (MkFeature x, MkFeature y) = MkFeature $ liftA2 f x y- eval (D2A f) (MkFeature x, MkFeature y) =- case liftA2 f x y of- MkFeatureData (Left l) -> MkFeature $ MkFeatureData (Left l)- MkFeatureData (Right r) -> r--instance Eval (FeatureData d -> FeatureData c -> FeatureData b -> FeatureData a)- (FeatureData d, FeatureData c, FeatureData b) (FeatureData a)- where- eval (D3 f) (x, y, z) = liftA3 f x y z- eval (D3A f) (x, y, z) = join (liftA3 f x y z)--instance Eval (Feature n3 d -> Feature n2 c -> Feature n1 b -> Feature n0 a)- (Feature n3 d, Feature n2 c, Feature n1 b) (Feature n0 a)- where- eval (D3 f) (MkFeature x, MkFeature y, MkFeature z) = MkFeature $ liftA3 f x y z- eval (D3A f) (MkFeature x, MkFeature y, MkFeature z) =- case liftA3 f x y z of- MkFeatureData (Left l) -> MkFeature $ MkFeatureData (Left l)- MkFeatureData (Right r) -> r--{- | Initializes @Feature@ @Attributes@ to empty strings -}---- class HasAttributes n a where--- getAttributes :: Feature n a -> Attributes--- getAttributes _ = MkAttributes "" "" ""---- instance (KnownSymbol n) => HasAttributes n a where- -- getAttributes :: Feature n a -> Attributes- -- getAttributes _ = MkAttributes "" "" ""-
− src/FeatureCompose/Aeson.hs
@@ -1,48 +0,0 @@-{-|-Module : Functions for encoding Feature data-Description : Defines ToJSON instances for Features.-Copyright : (c) NoviSci, Inc 2020-License : BSD3-Maintainer : bsaul@novisci.com--}-{-# OPTIONS_HADDOCK hide #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE TypeApplications #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE FlexibleContexts #-}--module FeatureCompose.Aeson(-) where--import GHC.TypeLits ( KnownSymbol, symbolVal )-import IntervalAlgebra ( Interval, Intervallic(end, begin) )-import FeatureCompose ( Feature- , MissingReason- , FeatureData- , getFeatureData- , getFData- , HasAttributes(..) )-import FeatureCompose.Attributes-import Data.Aeson ( object, KeyValue((.=)), ToJSON(toJSON) )-import Data.Proxy ( Proxy(Proxy) )-import Data.Typeable (typeRep, Typeable)--instance (ToJSON a, Ord a, Show a)=> ToJSON (Interval a) where- toJSON x = object ["begin" .= begin x, "end" .= end x]--instance ToJSON MissingReason--instance (ToJSON d) => ToJSON (FeatureData d) where- toJSON x = case getFeatureData x of- (Left l) -> toJSON l- (Right r) -> toJSON r--instance ToJSON Role where-instance ToJSON Purpose where-instance ToJSON Attributes where--instance (Typeable d, KnownSymbol n, ToJSON d, HasAttributes n d) => ToJSON (Feature n d) where- toJSON x = object [ "name" .= symbolVal (Proxy @n)- , "attrs" .= toJSON (getAttributes x)- , "type" .= toJSON (show $ typeRep (Proxy @d))- , "data" .= toJSON (getFData x) ]
− src/FeatureCompose/Attributes.hs
@@ -1,85 +0,0 @@-{-|-Module : Functions for defining attributes Feature data-Description : Defines attributes instances for Features.-Copyright : (c) NoviSci, Inc 2020-License : BSD3-Maintainer : bsaul@novisci.com--}-{-# OPTIONS_HADDOCK hide #-}-{-# LANGUAGE Safe #-}-{-# LANGUAGE NoImplicitPrelude #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE DataKinds #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE DeriveGeneric #-}-{-# LANGUAGE MultiParamTypeClasses #-}--module FeatureCompose.Attributes(- Attributes(..)- , Role(..)- , Purpose(..)- , HasAttributes(..)- , emptyAttributes- , basicAttributes- , emptyPurpose-) where--import safe Data.Eq ( Eq )-import safe Data.Ord ( Ord )-import safe Data.Set ( Set, empty, fromList )-import safe Data.Text ( Text )-import safe GHC.Show ( Show )-import safe GHC.Generics ( Generic )-import safe GHC.TypeLits ( KnownSymbol )--{- | A type to identify a feature's role -}-data Role =- Outcome- | Covariate- | Exposure- | Competing- | Weight- | Intermediate- | Unspecified- deriving (Eq, Ord, Show, Generic)--{- | A type to identify a feature's purpose -}-data Purpose = MkPurpose {- getRole :: Set Role - , getTags :: Set Text- } deriving (Eq, Show, Generic)--{- |-A data type for holding attritbutes of Features. This type and the @HasAttributes@-are likely to change in future versions.--}-data Attributes = MkAttributes { - getShortLabel :: Text- , getLongLabel :: Text- , getDerivation :: Text- , getPurpose :: Purpose- } deriving (Eq, Show, Generic)--{- | Just empty purpose -}-emptyPurpose :: Purpose-emptyPurpose = MkPurpose empty empty--{- | Just empty attributes -}-emptyAttributes :: Attributes-emptyAttributes = MkAttributes "" "" "" emptyPurpose--{- | Create attributes with just short label, long label, roles, and tags. -}-basicAttributes :: - Text -- ^ short label- -> Text -- ^ long label- -> [Role] -- ^ purpose roles- -> [Text] -- ^ purpose tags- -> Attributes-basicAttributes sl ll rls tgs = - MkAttributes sl ll "" - (MkPurpose (fromList rls) (fromList tgs))---class (KnownSymbol n) => HasAttributes n a where- getAttributes :: f n a -> Attributes- getAttributes _ = emptyAttributes
− src/FeatureCompose/Featureable.hs
@@ -1,37 +0,0 @@-{-|-Module : Functions for defining attributes Feature data-Description : Defines attributes instances for Features.-Copyright : (c) NoviSci, Inc 2020-License : BSD3-Maintainer : bsaul@novisci.com--}--{-# LANGUAGE ExistentialQuantification #-}--module FeatureCompose.Featureable (- Featureable(..)- , packFeature-) where--import FeatureCompose ( HasAttributes, Feature )-import FeatureCompose.Aeson ()-import FeatureCompose.Attributes ()-import GHC.TypeLits ( KnownSymbol )-import Data.Aeson ( ToJSON(toJSON) )-import Data.Typeable ( Typeable )--{- | Existential type to hold features -}-data Featureable = forall d . (Show d, ToJSON d) => MkFeatureable d--{- | Pack a feature into a Featurable -}-packFeature ::- (KnownSymbol n, Show d, ToJSON d, Typeable d, HasAttributes n d) =>- Feature n d -> Featureable-packFeature = MkFeatureable--instance Show Featureable where- show (MkFeatureable x) = show x--instance ToJSON Featureable where- toJSON (MkFeatureable x) = toJSON x-
src/FeatureEvents.hs view
@@ -5,7 +5,7 @@ License : BSD3 Maintainer : bsaul@novisci.com -Provides functions used in defining @'FeatureCompose.Feature'@ from +Provides functions used in defining @'Features.Feature'@ from @'EventData.Event'@s. -} {-# OPTIONS_HADDOCK hide #-}@@ -43,16 +43,18 @@ ) where -import IntervalAlgebra ( Intervallic(..)+import IntervalAlgebra ( Intervallic , IntervalSizeable(..) , ComparativePredicateOf1 , ComparativePredicateOf2 , Interval , IntervalCombinable+ , begin+ , end , beginerval , enderval ) import IntervalAlgebra.PairedInterval ( PairedInterval, getPairData )-import IntervalAlgebra.IntervalUtilities ( durations, gapsWithin, gaps' )+import IntervalAlgebra.IntervalUtilities ( durations, gapsWithin ) import EventData ( Events , Event , ConceptEvent@@ -84,7 +86,7 @@ import Data.Text ( Text ) import Data.Text.Read ( rational ) import Data.Tuple ( fst )-import Witherable ( filter, Filterable )+import Witherable ( filter, Filterable, Witherable ) import GHC.Num ( Integer, fromInteger ) import GHC.Real ( RealFrac(floor), (/) ) @@ -170,10 +172,10 @@ -- interval, are there (e.g. any, all) gaps of (e.g. <, <=, >=, >) a specified -- duration among the input intervals? makeGapsWithinPredicate ::- ( Foldable t- , Monoid (t (Interval a))+ ( Monoid (t (Interval a))+ , Monoid (t (Maybe (Interval a))) , Applicative t- , Filterable t+ , Witherable t , IntervalSizeable a b , IntervalCombinable i0 a , IntervalCombinable i1 a) =>
+ src/Features.hs view
@@ -0,0 +1,30 @@+{-|+Module : Features+Description : Defines the Feature type and its component types, constructors, + and class instances+Copyright : (c) NoviSci, Inc 2020+License : BSD3+Maintainer : bsaul@novisci.com++-}+{-# OPTIONS_HADDOCK hide #-}++module Features(++ -- ** Defining and evaluating Features+ module Features.Compose++ -- ** Adding Attributes to Features+ , module Features.Attributes++ -- ** Exporting Features+ , module Features.Featureable+ , module Features.Featureset+ , module Features.Output+) where++import Features.Compose+import Features.Attributes+import Features.Featureable+import Features.Featureset+import Features.Output
+ src/Features/Attributes.hs view
@@ -0,0 +1,86 @@+{-|+Module : Functions for defining attributes Feature data+Description : Defines attributes instances for Features.+Copyright : (c) NoviSci, Inc 2020+License : BSD3+Maintainer : bsaul@novisci.com+-}+{-# OPTIONS_HADDOCK hide #-}+{-# LANGUAGE Safe #-}+{-# LANGUAGE NoImplicitPrelude #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE MultiParamTypeClasses #-}++module Features.Attributes(+ Attributes(..)+ , Role(..)+ , Purpose(..)+ , HasAttributes(..)+ , emptyAttributes+ , basicAttributes+ , emptyPurpose+) where++import safe Data.Eq ( Eq )+import safe Data.Ord ( Ord )+import safe Data.Set ( Set, empty, fromList )+import safe Data.Text ( Text )+import safe GHC.Show ( Show )+import safe GHC.Generics ( Generic )+import safe GHC.TypeLits ( KnownSymbol )++-- | A type to identify a feature's role in a research study.+data Role =+ Outcome+ | Covariate+ | Exposure+ | Competing+ | Weight+ | Intermediate+ | Unspecified+ deriving (Eq, Ord, Show, Generic)++-- | A type to identify a feature's purpose+data Purpose = MkPurpose {+ getRole :: Set Role + , getTags :: Set Text+ } deriving (Eq, Show, Generic)++{- |+A data type for holding attritbutes of Features. This type and the @HasAttributes@+are likely to change in future versions.+-}+data Attributes = MkAttributes { + getShortLabel :: Text+ , getLongLabel :: Text+ , getDerivation :: Text+ , getPurpose :: Purpose+ } deriving (Eq, Show, Generic)++-- | An empty purpose value. +emptyPurpose :: Purpose+emptyPurpose = MkPurpose empty empty++-- | An empty attributes value.+emptyAttributes :: Attributes+emptyAttributes = MkAttributes "" "" "" emptyPurpose++-- | Create attributes with just short label, long label, roles, and tags.+basicAttributes :: + Text -- ^ short label+ -> Text -- ^ long label+ -> [Role] -- ^ purpose roles+ -> [Text] -- ^ purpose tags+ -> Attributes+basicAttributes sl ll rls tgs = + MkAttributes sl ll "" + (MkPurpose (fromList rls) (fromList tgs))++{-| A typeclass providing a single method for defining @Attributes@ for a+@Feature@. -}+class (KnownSymbol name) => HasAttributes name d where+ getAttributes :: f name d -> Attributes+ getAttributes _ = emptyAttributes
+ src/Features/Compose.hs view
@@ -0,0 +1,394 @@+{-|+Module : Define and evaluate Features +Description : Defines the Feature type and its component types, constructors, + and class instances+Copyright : (c) NoviSci, Inc 2020+License : BSD3+Maintainer : bsaul@novisci.com++-}+{-# OPTIONS_HADDOCK hide #-}++{-# LANGUAGE Safe #-}+{-# LANGUAGE NoImplicitPrelude #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE FunctionalDependencies #-}+{-# LANGUAGE AllowAmbiguousTypes #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE ExistentialQuantification #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE InstanceSigs #-}++module Features.Compose(+ -- * Features and FeatureData+ FeatureData+ , MissingReason(..)+ , Feature+ , FeatureN+ , featureDataL+ , featureDataR+ , missingBecause+ , makeFeature+ , getFeatureData+ , getFData+ , getData+ , getDataN+ , getNameN+ , nameFeature++ -- * Defining and evaluating Features+ , Definition(..)+ , Define(..)+ , DefineA(..)+ , Eval+ , eval++ -- , HasAttributes(..)+) where++import safe Control.Applicative ( Applicative(..)+ , liftA3, (<$>) )+import safe Control.Monad ( Functor(..), Monad(..)+ , (=<<), join, liftM, liftM2, liftM3)+import safe Data.Either ( Either(..) )+import safe Data.Eq ( Eq(..) )+import safe Data.Foldable ( Foldable(foldr), fold )+import safe Data.Function ( ($), (.), id )+import safe Data.List ( (++), transpose, concat )+import safe Data.Proxy ( Proxy(..) )+import safe Data.Text ( Text, pack )+import safe Data.Traversable ( Traversable(..) )+import safe GHC.Generics ( Generic )+import safe GHC.Show ( Show(show) )+import safe GHC.TypeLits ( KnownSymbol, Symbol, symbolVal )++{- | +Defines the reasons that a @'FeatureData'@ value may be missing. Can be used to+indicate the reason that a @'Feature'@'s data was unable to be derived or does+not need to be derived. +-}+{- tag::missingReason[] -}+data MissingReason =+ InsufficientData -- ^ Insufficient information available to derive data.+ | Other Text -- ^ User provided reason for missingness+{- end::missingReason[] -}+ deriving (Eq, Show, Generic)++{- | +The @FeatureData@ type is a container for an (almost) arbitrary type @d@ that can+have a "failed" or "missing" state. The failure is represented by the @'Left'@ of +an @'Either'@, while the data @d@ is contained in the @'Either'@'s @'Right'@.++To construct a successful value, use @'featureDataR'@. A missing value can be +constructed with @'featureDataL'@ or its synonym @'missingBecause'@.++-}+{- tag::featureData[] -}+newtype FeatureData d = MkFeatureData {+ getFeatureData :: Either MissingReason d -- ^ Unwrap FeatureData.+ }+{- end::featureData[] -}+ deriving (Eq, Show, Generic)++-- | Creates a non-missing 'FeatureData'. Since @'FeatureData'@ is an instance of+-- @'Applicative'@, @'pure'@ is also a synonym of for @'featureDataR'@.+-- +-- >>> featureDataR "aString"+-- MkFeatureData (Right "aString")+-- >>> featureDataR (1 :: P.Int)+-- MkFeatureData (Right 1)+-- +-- >>> featureDataR ("aString", (1 :: P.Int))+-- MkFeatureData (Right ("aString",1))+--+featureDataR :: d -> FeatureData d+featureDataR = MkFeatureData . Right++-- | Creates a missing 'FeatureData'.+-- +-- >>> featureDataL (Other "no good reason") :: FeatureData P.Int+-- MkFeatureData (Left (Other "no good reason"))+--+-- >>> featureDataL (Other "no good reason") :: FeatureData Text+-- MkFeatureData (Left (Other "no good reason"))+--+featureDataL :: MissingReason -> FeatureData d+featureDataL = MkFeatureData . Left++-- | A synonym for 'featureDataL'.+missingBecause :: MissingReason -> FeatureData d+missingBecause = featureDataL++{- FeatureData instances -}++-- | Transform ('fmap') @'FeatureData'@ of one type to another.+--+-- >>> x = featureDataR (1 :: P.Int)+-- >>> :type x+-- >>> :type ( fmap show x )+-- x :: FeatureData Int+-- ( fmap show x ) :: FeatureData String+-- +-- Note that 'Left' values are carried along while the type changes:+--+-- >>> x = ( featureDataL InsufficientData ) :: FeatureData P.Int+-- >>> :type x+-- >>> x+-- >>> :type ( fmap show x )+-- >>> fmap show x +-- x :: FeatureData Int+-- MkFeatureData {getFeatureData = Left InsufficientData}+-- ( fmap show x ) :: FeatureData String+-- MkFeatureData {getFeatureData = Left InsufficientData}+--+instance Functor FeatureData where+ fmap f (MkFeatureData x) = MkFeatureData (fmap f x)++instance Applicative FeatureData where+ pure = featureDataR+ liftA2 f (MkFeatureData x) (MkFeatureData y) = MkFeatureData (liftA2 f x y)++instance Monad FeatureData where+ (MkFeatureData x) >>= f =+ case fmap f x of+ Left l -> MkFeatureData $ Left l+ Right v -> v++instance Foldable FeatureData where+ foldr f x (MkFeatureData z) = foldr f x z++instance Traversable FeatureData where+ traverse f (MkFeatureData z) = MkFeatureData <$> traverse f z++{- | +The @'Feature'@ is an abstraction for @name@d @d@ata, where the @name@ is a+*type*. Essentially, it is a container for @'FeatureData'@ that assigns a @name@+to the data.++Except when using @'pure'@ to lift data into a @Feature@, @Feature@s can only be+derived from other @Feature@ via a @'Definition'@.+-}+{- tag::feature[] -}+newtype (KnownSymbol name) => Feature name d =+ MkFeature { getFData :: FeatureData d }+{- end::feature[] -}+ deriving (Eq)++-- | A utility for constructing a @'Feature'@ from @'FeatureData'@.+-- Since @name@ is a type, you may need to annotate the type when using this+-- function.+--+-- >>> makeFeature (pure "test") :: Feature "dummy" Text+-- "dummy": MkFeatureData {getFeatureData = Right "test"}+--+makeFeature :: (KnownSymbol name) => FeatureData d -> Feature name d+makeFeature = MkFeature++-- | A utility for getting the (inner) @'FeatureData'@ content of a @'Feature'@.+getData :: Feature n d -> Either MissingReason d+getData (MkFeature x) = getFeatureData x++{- Feature instances -}+instance (KnownSymbol name, Show a) => Show (Feature name a) where+ show (MkFeature x) = show (symbolVal (Proxy @name)) ++ ": " ++ show x++instance Functor (Feature name) where+ fmap f (MkFeature x) = MkFeature (fmap f x)++instance Applicative (Feature name) where+ pure x = MkFeature (pure x)+ liftA2 f (MkFeature x) (MkFeature y) = MkFeature (liftA2 f x y)++instance Foldable (Feature name) where+ foldr f x (MkFeature t) = foldr f x t++instance Traversable (Feature name) where+ traverse f (MkFeature x) = MkFeature <$> traverse f x++instance Monad (Feature name) where+ (MkFeature x) >>= f =+ case fmap f x of+ MkFeatureData (Left l) -> MkFeature $ MkFeatureData (Left l)+ MkFeatureData (Right r) -> r++{- |+The @'FeatureN'@ type is similar to @'Feature'@ where the @name@ is included+as a @Text@ field. This type is mainly for internal purposes in order to collect+@Feature@s of the same type @d@ into a homogeneous container like a @'Data.List'@.+-}+data FeatureN d = MkFeatureN {+ getNameN :: Text -- ^ Get the name of a @FeatureN@.+ , getDataN :: FeatureData d -- ^ Get the data of a @FeatureN@+ } deriving (Eq, Show)++-- | A utility for converting a @'Feature'@ to @'FeatureN'@.+nameFeature :: forall name d . (KnownSymbol name) => Feature name d -> FeatureN d+nameFeature (MkFeature d) = MkFeatureN (pack $ symbolVal (Proxy @name)) d++{- | A @Definition@ can be thought of as a lifted function. Specifically, the+@'define'@ function takes an arbitrary function (currently up to three arguments)+and returns a @Defintion@ where the arguments have been lifted to a new domain.++For example, here we take @f@ and lift to to a function of @Feature@s.++@+f :: Int -> String -> Bool+f i s + | 1 "yes" = True+ | otherwise = FALSE++myFeature :: Definition (Feature "A" Int -> Feature "B" String -> Feature "C" Bool )+myFeature = define f+@++See @'eval'@ for evaluating @Defintions@. ++-}++data Definition d where+ D1 :: (b -> a) -> Definition (f1 b -> f0 a)+ D1A :: (b -> f0 a) -> Definition (f1 b -> f0 a)+ D2 :: (c -> b -> a) -> Definition (f2 c -> f1 b -> f0 a)+ D2A :: (c -> b -> f0 a) -> Definition (f2 c -> f1 b -> f0 a)+ D3 :: (d -> c -> b -> a) -> Definition (f3 d -> f2 c -> f1 b -> f0 a)+ D3A :: (d -> c -> b -> f0 a) -> Definition (f3 d -> f2 c -> f1 b -> f0 a)++{- | Define (and @'DefineA@) provide a means to create new @'Definition'@s via +@'define'@ (@'defineA'@). The @'define'@ function takes a single function input +and returns a lifted function. For example,++@+f :: Int -> String -> Bool+f i s + | 1 "yes" = True+ | otherwise = FALSE++myFeature :: Definition (Feature "A" Int -> Feature "B" String -> Feature "C" Bool )+myFeature = define f+@++The @'defineA'@ function is similar, except that the return type of the input+function is already lifted. In the example below, an input of @Nothing@ is +considered a missing state: ++@+f :: Int -> Maybe String -> Feature "C" Bool+f i s + | 1 (Just "yes") = pure True+ | _ (Just _ ) = pure False -- False for any Int and any (Just String)+ | otherwise = pure $ missingBecause InsufficientData -- missing if no string++myFeature :: Definition (Feature "A" Int -> Feature "B" String -> Feature "C" Bool )+myFeature = defineA f+@++-}+class Define inputs def | def -> inputs where+ define :: inputs -> Definition def++-- | See @'Define'@.+class DefineA inputs def | def -> inputs where+ defineA :: inputs -> Definition def++instance Define (b -> a) (FeatureData b -> FeatureData a) where define = D1+instance Define (c -> b -> a) (FeatureData c -> FeatureData b -> FeatureData a) where define = D2+instance Define (d -> c -> b -> a) (FeatureData d -> FeatureData c -> FeatureData b -> FeatureData a) where define = D3++instance DefineA (b -> FeatureData a) (FeatureData b -> FeatureData a) where defineA = D1A+instance DefineA (c -> b -> FeatureData a) (FeatureData c -> FeatureData b -> FeatureData a) where defineA = D2A+instance DefineA (d -> c -> b -> FeatureData a) (FeatureData d -> FeatureData c -> FeatureData b -> FeatureData a) where defineA = D3A++instance Define (b -> a) (Feature n1 b -> Feature n0 a) where define = D1+instance Define (c -> b -> a) (Feature n2 c -> Feature n1 b -> Feature n0 a) where define = D2+instance Define (d -> c -> b -> a) (Feature n3 d -> Feature n2 c -> Feature n1 b -> Feature n0 a) where define = D3++instance DefineA (b -> Feature n0 a) (Feature n1 b -> Feature n0 a) where defineA = D1A+instance DefineA (c -> b -> Feature n0 a) (Feature n2 c -> Feature n1 b -> Feature n0 a) where defineA = D2A+instance DefineA (d -> c -> b -> Feature n0 a) (Feature n3 d -> Feature n2 c -> Feature n1 b -> Feature n0 a) where defineA = D3A++{- | Evaluate a @Definition@. Note that (currently), the second argument of 'eval'+is a *tuple* of inputs. For example,++@+f :: Int -> String -> Bool+f i s + | 1 "yes" = True+ | otherwise = FALSE++myFeature :: Definition (Feature "A" Int -> Feature "B" String -> Feature "C" Bool )+myFeature = define f++a :: Feature "A" Int+a = pure 1++b :: Feature "B" String+b = pure "yes"++c = eval myFeature (a, b)+@++-}+class Eval def args return | def -> args return where+ eval :: Definition def -- ^ a @'Definition'@+ -> args -- ^ a tuple of arguments to the @'Definition'@+ -> return++instance Eval (FeatureData b -> FeatureData a)+ (FeatureData b) (FeatureData a) where+ eval (D1 f) x = fmap f x+ eval (D1A f) x = x >>= f++instance Eval (Feature n1 b -> Feature n0 a)+ (Feature n1 b) (Feature n0 a) where+ eval (D1 f) (MkFeature x) = MkFeature $ fmap f x+ eval (D1A f) (MkFeature x) =+ case fmap f x of+ MkFeatureData (Left l) -> MkFeature $ MkFeatureData (Left l)+ MkFeatureData (Right r) -> r+++instance Eval (FeatureData c -> FeatureData b -> FeatureData a)+ (FeatureData c, FeatureData b) (FeatureData a) where+ eval (D2 f) (x, y) = liftA2 f x y+ eval (D2A f) (x, y) = join (liftA2 f x y)++instance Eval (Feature n2 c -> Feature n1 b -> Feature n0 a)+ (Feature n2 c, Feature n1 b) (Feature n0 a)+ where+ eval (D2 f) (MkFeature x, MkFeature y) = MkFeature $ liftA2 f x y+ eval (D2A f) (MkFeature x, MkFeature y) =+ case liftA2 f x y of+ MkFeatureData (Left l) -> MkFeature $ MkFeatureData (Left l)+ MkFeatureData (Right r) -> r++instance Eval (FeatureData d -> FeatureData c -> FeatureData b -> FeatureData a)+ (FeatureData d, FeatureData c, FeatureData b) (FeatureData a)+ where+ eval (D3 f) (x, y, z) = liftA3 f x y z+ eval (D3A f) (x, y, z) = join (liftA3 f x y z)++instance Eval (Feature n3 d -> Feature n2 c -> Feature n1 b -> Feature n0 a)+ (Feature n3 d, Feature n2 c, Feature n1 b) (Feature n0 a)+ where+ eval (D3 f) (MkFeature x, MkFeature y, MkFeature z) = MkFeature $ liftA3 f x y z+ eval (D3A f) (MkFeature x, MkFeature y, MkFeature z) =+ case liftA3 f x y z of+ MkFeatureData (Left l) -> MkFeature $ MkFeatureData (Left l)+ MkFeatureData (Right r) -> r++{- | Initializes @Feature@ @Attributes@ to empty strings -}++-- class HasAttributes n a where+-- getAttributes :: Feature n a -> Attributes+-- getAttributes _ = MkAttributes "" "" ""++-- instance (KnownSymbol n) => HasAttributes n a where+ -- getAttributes :: Feature n a -> Attributes+ -- getAttributes _ = MkAttributes "" "" ""+
+ src/Features/Featureable.hs view
@@ -0,0 +1,55 @@+{-|+Module : Featureable+Description : Defines an existential type to with which to collect Features.+Copyright : (c) NoviSci, Inc 2020+License : BSD3+Maintainer : bsaul@novisci.com+-}+{-# OPTIONS_HADDOCK hide #-}+{-# LANGUAGE ExistentialQuantification #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}++module Features.Featureable (+ Featureable(..)+ , packFeature+ , getFeatureableAttrs+) where++import Features.Compose ( Feature+ , makeFeature+ )+import Features.Output ( ShapeOutput(..), OutputShape )+import Features.Attributes ( HasAttributes(..), Attributes )+import GHC.TypeLits ( KnownSymbol )+import Data.Aeson ( ToJSON(toJSON) )+import Data.Typeable ( Typeable )++{- | Existential type to hold features, which allows for Features to be put+into a heterogeneous list.+-}+data Featureable = forall d . (Show d, ToJSON d, ShapeOutput d) => MkFeatureable d Attributes ++{- | Pack a feature into a @Featurable@. -}+packFeature ::+ ( KnownSymbol n, Show d, ToJSON d, Typeable d, HasAttributes n d) =>+ Feature n d -> Featureable+packFeature x = MkFeatureable x (getAttributes x)++instance Show Featureable where+ show (MkFeatureable x _ ) = show x++instance ToJSON Featureable where+ toJSON (MkFeatureable x _ ) = toJSON x++instance ShapeOutput Featureable where+ dataOnly (MkFeatureable x _ ) = dataOnly x+ nameOnly (MkFeatureable x _ ) = nameOnly x + attrOnly (MkFeatureable x _ ) = attrOnly x + nameData (MkFeatureable x _ ) = nameData x + nameAttr (MkFeatureable x _ ) = nameAttr x ++-- | Get the @Attributes@ from a @Featureable@.+getFeatureableAttrs :: Featureable -> Attributes +getFeatureableAttrs (MkFeatureable _ a) = a+
+ src/Features/Featureset.hs view
@@ -0,0 +1,65 @@+{-|+Module : Featureset+Description : Defines a collection of Featureables.+Copyright : (c) NoviSci, Inc 2020+License : BSD3+Maintainer : bsaul@novisci.com+-}+{-# OPTIONS_HADDOCK hide #-}+{-# LANGUAGE NoImplicitPrelude #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE OverloadedStrings #-}++module Features.Featureset (+ Featureset+ , FeaturesetList(..)+ , featureset+ , getFeatureset+ , getFeaturesetAttrs+ , getFeaturesetList+ , tpose+) where++import Features.Featureable ( Featureable+ , getFeatureableAttrs+ )+import Features.Attributes ( Attributes )+import Data.Aeson ( ToJSON(toJSON), object, (.=) )+import Data.List.NonEmpty as NE ( NonEmpty(..), transpose, head )+import Data.Functor ( Functor(fmap) )+import Data.Function ( (.) )+import GHC.Generics ( Generic )+import GHC.Show ( Show )++-- | A Featureset is a (non-empty) list of @Featureable@.+newtype Featureset = MkFeatureset (NE.NonEmpty Featureable)+ deriving (Show)++-- | Constructor of a @Featureset@.+featureset :: NE.NonEmpty Featureable -> Featureset+featureset = MkFeatureset++-- | Constructor of a @Featureset@.+getFeatureset :: Featureset -> NE.NonEmpty Featureable+getFeatureset (MkFeatureset x) = x++-- | Gets a list of @Attributes@ from a @Featureset@, one @Attributes@ per @Featureable@.+getFeaturesetAttrs :: Featureset -> NE.NonEmpty Attributes+getFeaturesetAttrs (MkFeatureset l) = fmap getFeatureableAttrs l++instance ToJSON Featureset where+ toJSON (MkFeatureset x) = toJSON x++newtype FeaturesetList = MkFeaturesetList (NE.NonEmpty Featureset) + deriving (Show)++-- | Constructor of a @Featureset@.+getFeaturesetList :: FeaturesetList -> NE.NonEmpty Featureset+getFeaturesetList (MkFeaturesetList x) = x++-- | Transpose a FeaturesetList+tpose :: FeaturesetList -> FeaturesetList+tpose (MkFeaturesetList x) = MkFeaturesetList + (fmap featureset ( transpose (fmap getFeatureset x)))
+ src/Features/Output.hs view
@@ -0,0 +1,106 @@+{-|+Module : Functions for encoding Feature data+Description : Defines ToJSON instances for Features.+Copyright : (c) NoviSci, Inc 2020+License : BSD3+Maintainer : bsaul@novisci.com+-}+{-# OPTIONS_HADDOCK hide #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE GADTs #-}++module Features.Output(+ ShapeOutput(..)+ , OutputShape+) where++import GHC.Generics ( Generic )+import GHC.TypeLits ( KnownSymbol, symbolVal )+import IntervalAlgebra ( Interval, begin, end )+import Features.Compose ( Feature+ , MissingReason+ , FeatureData+ , getFeatureData+ , getFData )+import Features.Attributes ( Attributes, Purpose, Role, HasAttributes(..) )+import Data.Aeson ( object+ , KeyValue((.=))+ , ToJSON(toJSON)+ , Value )+import Data.Proxy ( Proxy(Proxy) )+import Data.Typeable ( typeRep, Typeable )++instance (ToJSON a, Ord a, Show a)=> ToJSON (Interval a) where+ toJSON x = object ["begin" .= begin x, "end" .= end x]++instance ToJSON MissingReason++instance (ToJSON d) => ToJSON (FeatureData d) where+ toJSON x = case getFeatureData x of+ (Left l) -> toJSON l+ (Right r) -> toJSON r++instance ToJSON Role where+instance ToJSON Purpose where+instance ToJSON Attributes where++instance (Typeable d, KnownSymbol n, ToJSON d, HasAttributes n d) =>+ ToJSON (Feature n d) where+ toJSON x = object [ "name" .= symbolVal (Proxy @n)+ , "attrs" .= toJSON (getAttributes x)+ , "type" .= toJSON (show $ typeRep (Proxy @d))+ , "data" .= toJSON (getFData x) ]++-- | A type used to determine the output shape of a Feature.+data OutputShape d where+ DataOnly :: (ToJSON a, Show a) => a -> OutputShape b+ NameOnly :: (ToJSON a, Show a) => a -> OutputShape b+ AttrOnly :: (ToJSON a, Show a) => a -> OutputShape b+ NameData :: (ToJSON a, Show a) => a -> OutputShape b+ NameAttr :: (ToJSON a, Show a) => a -> OutputShape b ++class (ToJSON a) => ShapeOutput a where+ dataOnly :: a -> OutputShape b+ nameOnly :: a -> OutputShape b+ attrOnly :: a -> OutputShape b+ nameData :: a -> OutputShape b+ nameAttr :: a -> OutputShape b++-- | A container for name and attributes.+data NameTypeAttr = NameTypeAttr { + getName :: String+ , getType :: String+ , getAttr :: Attributes }+ deriving (Generic, Show)++instance ToJSON NameTypeAttr where+ toJSON x = object [ "name" .= getName x+ , "type" .= getType x+ , "attrs" .= getAttr x] ++instance (KnownSymbol n, Show d, ToJSON d, Typeable d, HasAttributes n d) => + ShapeOutput (Feature n d) where+ dataOnly x = DataOnly (getFData x)+ nameOnly x = NameOnly (symbolVal (Proxy @n))+ attrOnly x = AttrOnly (getAttributes x)+ nameData x = NameData (symbolVal (Proxy @n), getFData x)+ nameAttr x = NameAttr (NameTypeAttr (symbolVal (Proxy @n)) (show $ typeRep (Proxy @d)) (getAttributes x))++instance ToJSON (OutputShape a) where+ toJSON (DataOnly x) = toJSON x+ toJSON (NameOnly x) = toJSON x+ toJSON (AttrOnly x) = toJSON x+ toJSON (NameData x) = toJSON x+ toJSON (NameAttr x) = toJSON x++instance Show (OutputShape a) where+ show (DataOnly x) = show x+ show (NameOnly x) = show x+ show (AttrOnly x) = show x+ show (NameData x) = show x+ show (NameAttr x) = show x
src/Hasklepias.hs view
@@ -11,22 +11,9 @@ module Hasklepias ( module EventData- -- ** Event Contexts- , module EventData.Context- -- ** Event Domains- , module EventData.Context.Domain- -- ** Parsing Events- , module EventData.Aeson- -- ** Generating arbitrary events- , module EventData.Arbitrary - , module FeatureCompose- -- ** Adding Attributes to Features- , module FeatureCompose.Attributes- -- ** Writing Features to JSON- , module FeatureCompose.Aeson- -- ** Exporting Features- , module FeatureCompose.Featureable+ -- * Working with Features+ , module Features -- * Utilities for defining Features from Events {- |@@ -40,8 +27,7 @@ -- * Specifying and building cohorts , module Hasklepias.Cohort- -- ** Writing Cohorts to JSON- , module Hasklepias.Aeson+ -- ** Creating an executable cohort application , module Hasklepias.MakeApp @@ -54,25 +40,17 @@ ) where import EventData-import EventData.Aeson-import EventData.Arbitrary-import EventData.Context-import EventData.Context.Domain import IntervalAlgebra import IntervalAlgebra.IntervalUtilities import IntervalAlgebra.PairedInterval -import FeatureCompose-import FeatureCompose.Aeson-import FeatureCompose.Attributes-import FeatureCompose.Featureable+import Features+ import FeatureEvents import Hasklepias.Reexports import Hasklepias.ReexportsUnsafe import Hasklepias.Cohort-import Hasklepias.Cohort.Criteria-import Hasklepias.Aeson import Hasklepias.MakeApp import Stype
− src/Hasklepias/Aeson.hs
@@ -1,97 +0,0 @@-{-|-Module : Functions for Parsing Hasklepias populations -Description : Defines FromJSON instances for Hasklepias populations .-Copyright : (c) NoviSci, Inc 2020-License : BSD3-Maintainer : bsaul@novisci.com--}-{-# OPTIONS_HADDOCK hide #-}-{-# LANGUAGE NoImplicitPrelude #-}-{-# LANGUAGE UndecidableInstances #-}-{-# LANGUAGE TupleSections #-}--module Hasklepias.Aeson(- parsePopulationLines- , parsePopulationIntLines- , parsePopulationDayLines- , ParseError(..)-) where--import Control.Applicative ( Applicative((<*>)), (<$>) )-import Data.Aeson ( FromJSON(..)- , ToJSON(..)- , eitherDecode- , Value(Array))-import qualified Data.ByteString.Lazy as B ( fromStrict- , toStrict- , ByteString)-import qualified Data.ByteString.Char8 as C ( lines )-import Prelude (- String)-import Data.Bifunctor ( Bifunctor(first) )-import Data.Either ( Either(..)- , partitionEithers )-import Data.Eq ( Eq )-import Data.Function ( ($), id ) -import Data.Functor ( Functor(fmap) )-import Data.List ( sort, (++), zipWith )-import qualified Data.Map.Strict as M ( toList, fromListWith)-import Data.Ord ( Ord )-import Data.Text (Text, pack)-import Data.Time.Calendar ( Day )-import Data.Vector ( (!) )-import EventData ( Events, event, Event )-import EventData.Aeson ()-import Hasklepias.Cohort ( Population(..)- , ID- , Subject(MkSubject) )-import GHC.Int ( Int )-import GHC.Num ( Natural )-import GHC.Show ( Show )-import IntervalAlgebra ( IntervalSizeable )---newtype SubjectEvent a = MkSubjectEvent (ID, Event a)--subjectEvent :: ID -> Event a -> SubjectEvent a-subjectEvent x y = MkSubjectEvent (x, y)--instance (FromJSON a, Show a, IntervalSizeable a b) => FromJSON (SubjectEvent a) where- parseJSON (Array v) = subjectEvent <$>- parseJSON (v ! 0) <*> (event <$> parseJSON (v ! 5) <*> parseJSON (Array v))--mapIntoPop :: (Ord a) => [SubjectEvent a] -> Population (Events a)-mapIntoPop l = MkPopulation $- fmap (\(id, es) -> MkSubject (id, sort es)) -- TODO: is there a way to avoid the sort?- (M.toList $ M.fromListWith (++) - (fmap (\(MkSubjectEvent (id, e)) -> (id, [e])) l ))--decodeIntoSubj :: (FromJSON a, Show a, IntervalSizeable a b) => - B.ByteString -> Either Text (SubjectEvent a)-decodeIntoSubj x = first pack $ eitherDecode x ---- | Contains the line number and error message.-newtype ParseError = MkParseError (Natural, Text) deriving (Eq, Show)---- | Parse @Event Int@ from json lines.-parseSubjectLines ::- (FromJSON a, Show a, IntervalSizeable a b) =>- B.ByteString -> ( [ParseError], [SubjectEvent a] )-parseSubjectLines l =- partitionEithers $ zipWith- (\x i -> first (\t -> MkParseError (i,t)) (decodeIntoSubj $ B.fromStrict x) )- (C.lines $ B.toStrict l)- [1..]---- | Parse @Event Int@ from json lines.-parsePopulationLines :: (FromJSON a, Show a, IntervalSizeable a b) => - B.ByteString -> ([ParseError], Population (Events a))-parsePopulationLines x = fmap mapIntoPop (parseSubjectLines x)---- | Parse @Event Int@ from json lines.-parsePopulationIntLines :: B.ByteString -> ([ParseError], Population (Events Int))-parsePopulationIntLines x = fmap mapIntoPop (parseSubjectLines x)---- | Parse @Event Day@ from json lines.-parsePopulationDayLines :: B.ByteString -> ([ParseError], Population (Events Day))-parsePopulationDayLines x = fmap mapIntoPop (parseSubjectLines x)
src/Hasklepias/Cohort.hs view
@@ -1,158 +1,35 @@ {-|-Module : Hasklepias Subject Type-Description : Defines the Subject type+Module : Hasklepias Cohorts+Description : Defines the Cohort type and associated methods Copyright : (c) NoviSci, Inc 2020 License : BSD3 Maintainer : bsaul@novisci.com -} {-# OPTIONS_HADDOCK hide #-} {-# LANGUAGE NoImplicitPrelude #-}-{-# LANGUAGE DeriveGeneric #-}-{-# LANGUAGE TupleSections #-}-{-# LANGUAGE LambdaCase #-}--- {-# LANGUAGE Safe #-} module Hasklepias.Cohort(- Subject(..)- , ID- , Population(..)- , ObsUnit(..)- , Cohort(..)- , CohortSpec- , AttritionInfo(..)- , specifyCohort- , makeObsUnitFeatures- , evalCohort + -- * Defining Cohorts+ module Hasklepias.Cohort.Core+ -- ** Criteria , module Hasklepias.Cohort.Criteria- -- ** Index , module Hasklepias.Cohort.Index-) where -import GHC.Num ( Num((+)), Natural )-import Data.Aeson ( FromJSON, ToJSON, ToJSONKey )-import Data.Bool ( Bool )-import Data.Eq ( Eq )-import Data.Foldable ( Foldable(length) )-import Data.Function ( ($) )-import Data.Functor ( Functor(fmap) )-import Data.Maybe ( Maybe(..), catMaybes )-import Data.List ( zipWith, replicate )-import Data.List.NonEmpty ( NonEmpty(..), zip, fromList, nonEmpty )-import Data.Map.Strict as Map ( toList, fromListWith )-import Data.Text ( Text )-import GHC.Generics ( Generic )-import GHC.Show ( Show )-import Hasklepias.Cohort.Index ( makeIndex, Index(..) )-import Hasklepias.Cohort.Criteria+ -- * Cohort I/O+ -- ** Input+ , module Hasklepias.Cohort.Input + -- ** Output+ , module Hasklepias.Cohort.Output --- | A subject identifier. Currently, simply @Text@.-type ID = Text --- | A subject is just a pair of @ID@ and data.-newtype Subject d = MkSubject (ID, d)- deriving (Eq, Show, Generic)+) where -instance Functor Subject where- fmap f (MkSubject (id, x)) = MkSubject (id, f x) -instance (FromJSON d) => FromJSON (Subject d) where---- | A population is a list of @'Subject'@s-newtype Population d = MkPopulation [Subject d] - deriving (Eq, Show, Generic)--instance Functor Population where- fmap f (MkPopulation x) = MkPopulation (fmap (fmap f) x)--instance (FromJSON d) => FromJSON (Population d) where---- | An observational unit is what a subject may be transformed into.-newtype ObsUnit d = MkObsUnit (ID, d)- deriving (Eq, Show, Generic)--instance (ToJSON d) => ToJSON (ObsUnit d) where---- | A cohort is a list of observational units along with @'AttritionInfo'@ --- regarding the number of subjects excluded by the @'Criteria'@. -newtype Cohort d = MkCohort (Maybe AttritionInfo, [ObsUnit d])- deriving (Eq, Show, Generic)--instance (ToJSON d) => ToJSON (Cohort d) where---- | Unpacks a @'Population'@ to a list of subjects.-getPopulation :: Population d -> [Subject d]-getPopulation (MkPopulation x) = x---- | Gets the data out of a @'Subject'@.-getSubjectData :: Subject d -> d-getSubjectData (MkSubject (_, x)) = x---- | Tranforms a @'Subject'@ into a @'ObsUnit'@.-makeObsUnitFeatures :: (d1 -> d0) -> Subject d1 -> ObsUnit d0-makeObsUnitFeatures f (MkSubject (id, dat)) = MkObsUnit (id, f dat)---- | A cohort specification consist of two functions: one that transforms a subject's--- input data into a @'Criteria'@ and another that transforms a subject's input data--- into the desired return type.-data CohortSpec d1 d0 = MkCohortSpec- { runCriteria:: d1 -> Criteria- -- (Feature b (Index i a))- , runFeatures:: d1 -> d0 }---- | Creates a @'CohortSpec'@.-specifyCohort :: (d1 -> Criteria) -> (d1 -> d0) -> CohortSpec d1 d0-specifyCohort = MkCohortSpec---- | Evaluates the @'runCriteria'@ of a @'CohortSpec'@ on a @'Population'@ to --- return a list of @Subject Criteria@ (one per subject in the population). -evalCriteria :: CohortSpec d1 d0 -> Population d1 -> [Subject Criteria]-evalCriteria (MkCohortSpec runCrit _) (MkPopulation pop) = fmap (fmap runCrit) pop---- | Convert a list of @Subject Criteria@ into a list of @Subject CohortStatus@-evalCohortStatus :: [Subject Criteria] -> [Subject CohortStatus]-evalCohortStatus = fmap (fmap checkCohortStatus)---- | Runs the input function which transforms a subject into an observational unit. --- If the subeject is excluded, the result is @Nothing@; otherwise it is @Just@ --- an observational unit.-evalSubjectCohort :: (d1 -> d0) -> Subject CohortStatus -> Subject d1 -> Maybe (ObsUnit d0)-evalSubjectCohort f (MkSubject (id, status)) subjData =- case status of- Included -> Just $ makeObsUnitFeatures f subjData- ExcludedBy _ -> Nothing---- | A type which collects the counts of subjects included or excluded.-newtype AttritionInfo = MkAttritionInfo (NonEmpty (CohortStatus, Natural))- deriving (Eq, Show, Generic)---- | Initializes @AttritionInfo@ from a @'Criteria'@.-initAttritionInfo :: Criteria -> AttritionInfo-initAttritionInfo x =- MkAttritionInfo $ zip (initStatusInfo x) - (0 :| replicate (length (getCriteria x)) 0)--instance ToJSON CohortStatus where-instance ToJSON AttritionInfo where---- | Creates an @'AttritionInfo'@ from a list of @Subject CohortStatus@. The result--- is @Nothing@ if the input list is empty.-measureAttrition :: [Subject CohortStatus] -> Maybe AttritionInfo-measureAttrition l = fmap MkAttritionInfo $ nonEmpty $ Map.toList $- Map.fromListWith (+) $ fmap (\x -> (getSubjectData x, 1)) l---- | The internal function to evaluate a @'CohortSpec'@ on a @'Population'@. -evalUnits :: CohortSpec d1 d0 -> Population d1 -> (Maybe AttritionInfo, [ObsUnit d0])-evalUnits spec pop =- ( measureAttrition statuses- , catMaybes $ zipWith (evalSubjectCohort (runFeatures spec))- statuses- (getPopulation pop))- where crits = evalCriteria spec pop- statuses = evalCohortStatus crits---- | Evaluates a @'CohortSpec'@ on a @'Population'@.-evalCohort :: CohortSpec d1 d0 -> Population d1 -> Cohort d0-evalCohort s p = MkCohort $ evalUnits s p+import Hasklepias.Cohort.Core+import Hasklepias.Cohort.Index+import Hasklepias.Cohort.Criteria+import Hasklepias.Cohort.Input+import Hasklepias.Cohort.Output
+ src/Hasklepias/Cohort/Core.hs view
@@ -0,0 +1,167 @@+{-|+Module : Hasklepias Cohorts+Description : Defines the Cohort type and associated methods+Copyright : (c) NoviSci, Inc 2020+License : BSD3+Maintainer : bsaul@novisci.com+-}+{-# OPTIONS_HADDOCK hide #-}+{-# LANGUAGE NoImplicitPrelude #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE TupleSections #-}+{-# LANGUAGE LambdaCase #-}+-- {-# LANGUAGE Safe #-}++module Hasklepias.Cohort.Core(+ Subject(..)+ , ID+ , Population(..)+ , ObsUnit(..)+ , CohortData(..)+ , Cohort(..)+ , CohortSpec+ , AttritionInfo(..)+ , specifyCohort+ , makeObsUnitFeatures+ , evalCohort+ , getCohortIDs+ , getCohortData+ , getAttritionInfo+) where++import GHC.Num ( Num((+)), Natural )+import Data.Aeson ( FromJSON, ToJSON, ToJSONKey )+import Data.Bool ( Bool )+import Data.Eq ( Eq )+import Data.Foldable ( Foldable(length) )+import Data.Function ( ($) )+import Data.Functor ( Functor(fmap) )+import Data.Maybe ( Maybe(..), catMaybes )+import Data.List ( zipWith, replicate )+import Data.List.NonEmpty ( NonEmpty(..), zip, fromList, nonEmpty )+import Data.Map.Strict as Map ( toList, fromListWith )+import Data.Text ( Text )+import GHC.Generics ( Generic )+import GHC.Show ( Show(..) )+import Hasklepias.Cohort.Index ( makeIndex, Index(..) )+import Hasklepias.Cohort.Criteria++-- | A subject identifier. Currently, simply @Text@.+type ID = Text++-- | A subject is just a pair of @ID@ and data.+newtype Subject d = MkSubject (ID, d)+ deriving (Eq, Show, Generic)++instance Functor Subject where+ fmap f (MkSubject (id, x)) = MkSubject (id, f x)++instance (FromJSON d) => FromJSON (Subject d) where++-- | A population is a list of @'Subject'@s+newtype Population d = MkPopulation [Subject d] + deriving (Eq, Show, Generic)++instance Functor Population where+ fmap f (MkPopulation x) = MkPopulation (fmap (fmap f) x)++instance (FromJSON d) => FromJSON (Population d) where++-- | An observational unit is what a subject may be transformed into.+data ObsUnit d = MkObsUnit {+ obsID :: ID+ , obsData :: d }+ deriving (Eq, Show, Generic)++-- | A container for CohortData+newtype CohortData d = MkCohortData { getObsData :: [ObsUnit d] }+ deriving (Eq, Show, Generic)++-- | A cohort is a list of observational units along with @'AttritionInfo'@ +-- regarding the number of subjects excluded by the @'Criteria'@. +newtype Cohort d = MkCohort (Maybe AttritionInfo, CohortData d)+ deriving (Eq, Show, Generic)++-- | Gets the attrition info from a cohort+getAttritionInfo :: Cohort d -> Maybe AttritionInfo+getAttritionInfo (MkCohort (x, _)) = x++-- | Unpacks a @'Population'@ to a list of subjects.+getPopulation :: Population d -> [Subject d]+getPopulation (MkPopulation x) = x++-- | Gets the data out of a @'Subject'@.+getSubjectData :: Subject d -> d+getSubjectData (MkSubject (_, x)) = x++-- | Tranforms a @'Subject'@ into a @'ObsUnit'@.+makeObsUnitFeatures :: (d1 -> d0) -> Subject d1 -> ObsUnit d0+makeObsUnitFeatures f (MkSubject (id, dat)) = MkObsUnit id (f dat)++-- | A cohort specification consist of two functions: one that transforms a subject's+-- input data into a @'Criteria'@ and another that transforms a subject's input data+-- into the desired return type.+data CohortSpec d1 d0 = MkCohortSpec+ { runCriteria:: d1 -> Criteria+ -- (Feature (Index i a))+ , runFeatures:: d1 -> d0 }++-- | Creates a @'CohortSpec'@.+specifyCohort :: (d1 -> Criteria) -> (d1 -> d0) -> CohortSpec d1 d0+specifyCohort = MkCohortSpec++-- | Evaluates the @'runCriteria'@ of a @'CohortSpec'@ on a @'Population'@ to +-- return a list of @Subject Criteria@ (one per subject in the population). +evalCriteria :: CohortSpec d1 d0 -> Population d1 -> [Subject Criteria]+evalCriteria (MkCohortSpec runCrit _) (MkPopulation pop) = fmap (fmap runCrit) pop++-- | Convert a list of @Subject Criteria@ into a list of @Subject CohortStatus@+evalCohortStatus :: [Subject Criteria] -> [Subject CohortStatus]+evalCohortStatus = fmap (fmap checkCohortStatus)++-- | Runs the input function which transforms a subject into an observational unit. +-- If the subeject is excluded, the result is @Nothing@; otherwise it is @Just@ +-- an observational unit.+evalSubjectCohort :: (d1 -> d0) -> Subject CohortStatus -> Subject d1 -> Maybe (ObsUnit d0)+evalSubjectCohort f (MkSubject (id, status)) subjData =+ case status of+ Included -> Just $ makeObsUnitFeatures f subjData+ ExcludedBy _ -> Nothing++-- | A type which collects the counts of subjects included or excluded.+newtype AttritionInfo = MkAttritionInfo (NonEmpty (CohortStatus, Natural))+ deriving (Eq, Show, Generic)++-- | Initializes @AttritionInfo@ from a @'Criteria'@.+initAttritionInfo :: Criteria -> AttritionInfo+initAttritionInfo x =+ MkAttritionInfo $ zip (initStatusInfo x) + (0 :| replicate (length (getCriteria x)) 0)++-- | Creates an @'AttritionInfo'@ from a list of @Subject CohortStatus@. The result+-- is @Nothing@ if the input list is empty.+measureAttrition :: [Subject CohortStatus] -> Maybe AttritionInfo+measureAttrition l = fmap MkAttritionInfo $ nonEmpty $ Map.toList $+ Map.fromListWith (+) $ fmap (\x -> (getSubjectData x, 1)) l++-- | The internal function to evaluate a @'CohortSpec'@ on a @'Population'@. +evalUnits :: CohortSpec d1 d0 -> Population d1 -> (Maybe AttritionInfo, CohortData d0)+evalUnits spec pop =+ ( measureAttrition statuses+ , MkCohortData $ catMaybes $ zipWith (evalSubjectCohort (runFeatures spec))+ statuses+ (getPopulation pop))+ where crits = evalCriteria spec pop+ statuses = evalCohortStatus crits++-- | Evaluates a @'CohortSpec'@ on a @'Population'@.+evalCohort :: CohortSpec d1 d0 -> Population d1 -> Cohort d0+evalCohort s p = MkCohort $ evalUnits s p++-- | Get IDs from a cohort.+getCohortIDs :: Cohort d -> [ID]+getCohortIDs (MkCohort (_, dat)) = fmap obsID ( getObsData dat )++-- | Get data from a cohort.+getCohortData :: Cohort d -> [d]+getCohortData (MkCohort (_, dat)) = fmap obsData ( getObsData dat )
src/Hasklepias/Cohort/Criteria.hs view
@@ -43,7 +43,7 @@ import safe Data.Semigroup ( Semigroup((<>)) ) import safe Data.Tuple ( fst, snd ) import safe Data.Text ( Text, pack )-import safe FeatureCompose ( getFeatureData+import safe Features.Compose ( getFeatureData , Feature , nameFeature , FeatureN(..) )
+ src/Hasklepias/Cohort/Input.hs view
@@ -0,0 +1,97 @@+{-|+Module : Functions for Parsing Hasklepias populations +Description : Defines FromJSON instances for Hasklepias populations .+Copyright : (c) NoviSci, Inc 2020+License : BSD3+Maintainer : bsaul@novisci.com+-}+{-# OPTIONS_HADDOCK hide #-}+{-# LANGUAGE NoImplicitPrelude #-}+{-# LANGUAGE UndecidableInstances #-}+{-# LANGUAGE TupleSections #-}++module Hasklepias.Cohort.Input(+ parsePopulationLines+ , parsePopulationIntLines+ , parsePopulationDayLines+ , ParseError(..)+) where++import Control.Applicative ( Applicative((<*>)), (<$>) )+import Data.Aeson ( FromJSON(..)+ , ToJSON(..)+ , eitherDecode+ , Value(Array))+import qualified Data.ByteString.Lazy as B ( fromStrict+ , toStrict+ , ByteString)+import qualified Data.ByteString.Char8 as C ( lines )+import Prelude (+ String)+import Data.Bifunctor ( Bifunctor(first) )+import Data.Either ( Either(..)+ , partitionEithers )+import Data.Eq ( Eq )+import Data.Function ( ($), id ) +import Data.Functor ( Functor(fmap) )+import Data.List ( sort, (++), zipWith )+import qualified Data.Map.Strict as M ( toList, fromListWith)+import Data.Ord ( Ord )+import Data.Text (Text, pack)+import Data.Time.Calendar ( Day )+import Data.Vector ( (!) )+import EventData ( Events, event, Event )+import EventData.Aeson ()+import Hasklepias.Cohort.Core ( Population(..)+ , ID+ , Subject(MkSubject) )+import GHC.Int ( Int )+import GHC.Num ( Natural )+import GHC.Show ( Show )+import IntervalAlgebra ( IntervalSizeable )+++newtype SubjectEvent a = MkSubjectEvent (ID, Event a)++subjectEvent :: ID -> Event a -> SubjectEvent a+subjectEvent x y = MkSubjectEvent (x, y)++instance (FromJSON a, Show a, IntervalSizeable a b) => FromJSON (SubjectEvent a) where+ parseJSON (Array v) = subjectEvent <$>+ parseJSON (v ! 0) <*> (event <$> parseJSON (v ! 5) <*> parseJSON (Array v))++mapIntoPop :: (Ord a) => [SubjectEvent a] -> Population (Events a)+mapIntoPop l = MkPopulation $+ fmap (\(id, es) -> MkSubject (id, sort es)) -- TODO: is there a way to avoid the sort?+ (M.toList $ M.fromListWith (++) + (fmap (\(MkSubjectEvent (id, e)) -> (id, [e])) l ))++decodeIntoSubj :: (FromJSON a, Show a, IntervalSizeable a b) => + B.ByteString -> Either Text (SubjectEvent a)+decodeIntoSubj x = first pack $ eitherDecode x ++-- | Contains the line number and error message.+newtype ParseError = MkParseError (Natural, Text) deriving (Eq, Show)++-- | Parse @Event Int@ from json lines.+parseSubjectLines ::+ (FromJSON a, Show a, IntervalSizeable a b) =>+ B.ByteString -> ( [ParseError], [SubjectEvent a] )+parseSubjectLines l =+ partitionEithers $ zipWith+ (\x i -> first (\t -> MkParseError (i,t)) (decodeIntoSubj $ B.fromStrict x) )+ (C.lines $ B.toStrict l)+ [1..]++-- | Parse @Event Int@ from json lines.+parsePopulationLines :: (FromJSON a, Show a, IntervalSizeable a b) => + B.ByteString -> ([ParseError], Population (Events a))+parsePopulationLines x = fmap mapIntoPop (parseSubjectLines x)++-- | Parse @Event Int@ from json lines.+parsePopulationIntLines :: B.ByteString -> ([ParseError], Population (Events Int))+parsePopulationIntLines x = fmap mapIntoPop (parseSubjectLines x)++-- | Parse @Event Day@ from json lines.+parsePopulationDayLines :: B.ByteString -> ([ParseError], Population (Events Day))+parsePopulationDayLines x = fmap mapIntoPop (parseSubjectLines x)
+ src/Hasklepias/Cohort/Output.hs view
@@ -0,0 +1,120 @@+{-|+Module : Hasklepias Cohorts+Description : Defines the options for outputting a cohort+Copyright : (c) NoviSci, Inc 2020+License : BSD3+Maintainer : bsaul@novisci.com+-}+{-# OPTIONS_HADDOCK hide #-}+{-# LANGUAGE NoImplicitPrelude #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE DeriveAnyClass #-}++module Hasklepias.Cohort.Output(+ CohortShape+ , ShapeCohort(..)+ , toJSONCohortShape+) where++import Data.Aeson ( ToJSON(..)+ , Value+ , object+ , (.=) )+import Data.Function ( (.) )+import Data.Functor ( Functor(fmap) )+import Data.List.NonEmpty as NE ( NonEmpty(..)+ , head+ , fromList+ , zip )+import Data.Tuple ( uncurry )+import GHC.Generics ( Generic )+import GHC.Types ( Type )+import GHC.Show ( Show )+import Hasklepias.Cohort.Core ( AttritionInfo,+ Cohort,+ ObsUnit,+ ID,+ CohortData,+ getCohortData,+ getCohortIDs )+import Hasklepias.Cohort.Criteria ( CohortStatus )+import Features.Featureset ( FeaturesetList(MkFeaturesetList)+ , Featureset+ , getFeatureset+ , getFeaturesetList+ , tpose )+import Features.Output ( ShapeOutput(dataOnly, nameAttr)+ , OutputShape )++instance (ToJSON d) => ToJSON (ObsUnit d) where+instance (ToJSON d) => ToJSON (CohortData d) where+instance (ToJSON d) => ToJSON (Cohort d) where+instance ToJSON CohortStatus where+instance ToJSON AttritionInfo where++-- | A type used to determine the output shape of a Cohort.+data CohortShape d where+ ColumnWise :: (Show a, ToJSON a) => a -> CohortShape ColumnWise+ RowWise :: (Show a, ToJSON a) => a -> CohortShape RowWise++deriving instance Show d => Show (CohortShape d)++-- | Maps CohortShape into an Aeson Value. +-- TODO: implement Generic and ToJSON instance of CohortShape directly.+toJSONCohortShape :: CohortShape shape -> Value+toJSONCohortShape (ColumnWise x) = toJSON x+toJSONCohortShape (RowWise x) = toJSON x++class ShapeCohort d where+ colWise :: Cohort d -> CohortShape ColumnWise+ rowWise :: Cohort d -> CohortShape RowWise++instance ShapeCohort Featureset where+ colWise x = ColumnWise (shapeColumnWise x)+ rowWise x = RowWise (shapeRowWise x)++data ColumnWise = MkColumnWise {+ colAttributes :: NonEmpty (OutputShape Type)+ , ids :: [ID]+ , colData :: NonEmpty (NonEmpty (OutputShape Type))+ } deriving ( Show, Generic )++instance ToJSON ColumnWise where+ toJSON x = object [ "attributes" .= colAttributes x+ , "ids" .= ids x+ , "data" .= colData x ]++newtype IDRow = MkIDRow (ID, NonEmpty (OutputShape Type))+ deriving ( Show, Generic )++instance ToJSON IDRow where+ toJSON (MkIDRow x) = object [ uncurry (.=) x]++data RowWise = MkRowWise {+ attributes :: NonEmpty (OutputShape Type)+ , rowData :: NonEmpty IDRow+ } deriving ( Show, Generic )++instance ToJSON RowWise where+ toJSON x = object [ "attributes" .= attributes x+ , "data" .= rowData x ]++shapeColumnWise :: Cohort Featureset -> ColumnWise+shapeColumnWise x = MkColumnWise+ (fmap (nameAttr . NE.head . getFeatureset) z)+ (getCohortIDs x)+ (fmap (fmap dataOnly . getFeatureset) z)+ -- TODO: don't use fromList; do something more principled+ where z = getFeaturesetList (tpose (MkFeaturesetList (NE.fromList (getCohortData x))))++shapeRowWise :: Cohort Featureset -> RowWise+shapeRowWise x = MkRowWise+ (fmap (nameAttr . NE.head . getFeatureset) z)+ (fmap MkIDRow (zip ids (fmap (fmap dataOnly . getFeatureset) z)))+ -- TODO: don't use fromList; do something more principled+ where z = NE.fromList (getCohortData x)+ ids = fromList (getCohortIDs x)
src/Hasklepias/MakeApp.hs view
@@ -27,6 +27,7 @@ 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 )@@ -35,8 +36,7 @@ import GHC.IO ( IO ) import EventData ( Events )-import Hasklepias.Aeson ( parsePopulationLines, ParseError )-import Hasklepias.Cohort ( evalCohort, Cohort, CohortSpec )+import Hasklepias.Cohort import IntervalAlgebra ( IntervalSizeable ) import Control.Monad.IO.Class (MonadIO, liftIO)@@ -53,7 +53,7 @@ , logText , withLog , logPrint- , logPrintStderr + , logPrintStderr , (<&) , (>$) , log )@@ -73,12 +73,23 @@ } &= help "Pass event data via stdin." &= summary (name ++ " " ++ version) -makeCohortBuilder :: (FromJSON a, Show a, IntervalSizeable a b, ToJSON d0, Monad m) =>+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 specs = return (return . second (\pop -> fmap (`evalCohort` pop) specs) . parsePopulationLines) +reshapeWith :: (Cohort d -> CohortShape shape) + -> Cohort d + -> (Maybe AttritionInfo, CohortShape shape)+reshapeWith s x = (getAttritionInfo x, s 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))+ -- logging based on example here: -- https://github.com/kowainik/co-log/blob/main/co-log/tutorials/Main.hs parseErrorL :: LogAction IO ParseError@@ -88,12 +99,15 @@ logParseErrors x = mconcat $ fmap (parseErrorL <&) x -- | Make a command line cohort building application.-makeCohortApp :: (FromJSON a, Show a, IntervalSizeable a b, ToJSON d0) =>+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 spec =+makeCohortApp name version shape spec = do args <- cmdArgs ( makeAppArgs name version ) let logger = logStringStdout@@ -102,15 +116,16 @@ app <- makeCohortBuilder spec logger <& "Reading data from stdin..."+ -- TODO: give error if no contents within some amount of time dat <- B.getContents logger <& "Bulding cohort..."- res <- app dat+ res <- shapeOutput shape (app dat) logParseErrors (fst res) logger <& "Encoding cohort(s) output and writing to stdout..."- C.putStrLn (encode ( toJSON (snd res) ))+ C.putStrLn (encode (fmap (second toJSONCohortShape) (snd res) )) logger <& "Cohort build complete!"
src/Hasklepias/Reexports.hs view
@@ -23,6 +23,7 @@ , module Data.Eq , module Data.Int , module Data.Maybe+ , module Data.Monoid , module Data.Function , module Data.Functor , module Data.List@@ -77,6 +78,7 @@ listToMaybe, mapMaybe, maybeToList )+import safe Data.Monoid ( Monoid(..), (<>) ) import safe Data.Ord ( Ord((>=), (<), (>), (<=)) , max, min ) import safe Data.Time.Calendar ( Day, MonthOfYear, Year
src/Stype.hs view
@@ -13,7 +13,9 @@ module Stype ( module Stype.Numeric , module Stype.Categorical+ , module Stype.Aeson ) where import Stype.Numeric import Stype.Categorical+import Stype.Aeson
+ src/Stype/Aeson.hs view
@@ -0,0 +1,47 @@+{-|+Module : Stype aeson instances+Description : Statistical types+Copyright : (c) NoviSci, Inc 2020+License : BSD3+Maintainer : bsaul@novisci.com++-}++{-# LANGUAGE NoImplicitPrelude #-}+{-# LANGUAGE OverloadedStrings #-}++module Stype.Aeson (+) where++import Data.Aeson +-- ( ToJSON(..)) +import Stype.Numeric ( Count+ , Continuous(..)+ , NonnegContinuous(..)+ , EventTime(..)+ , MaybeCensored )+import Stype.Categorical ( Nominal+ , Binary+ , toBool )+import Data.Text++instance ToJSON Count where++instance ToJSON a => ToJSON (Continuous a) where+ toJSON (Cont x) = toJSON x+ toJSON NegContInf = "-Inf"+ toJSON ContInf = "Inf"++instance ToJSON a => ToJSON (NonnegContinuous a) where+ toJSON (NonNegCont x) = toJSON x+ toJSON NonNegContInf = "Inf"++instance ToJSON a => ToJSON (EventTime a) where+ toJSON (EventTime x) = toJSON x++instance ToJSON a => ToJSON (MaybeCensored a) where++instance ToJSON a => ToJSON (Nominal a) where++instance ToJSON Binary where+ toJSON x = toJSON (toBool x)
src/Stype/Categorical.hs view
@@ -6,9 +6,13 @@ Maintainer : bsaul@novisci.com -}--- {-# LANGUAGE Safe #-}++{-# LANGUAGE Safe #-}+ module Stype.Categorical (- module Stype.Categorical.Nominal + module Stype.Categorical.Nominal + , module Stype.Categorical.Binary ) where -import Stype.Categorical.Nominal+import safe Stype.Categorical.Nominal+import safe Stype.Categorical.Binary
+ src/Stype/Categorical/Binary.hs view
@@ -0,0 +1,44 @@+{-|+Module : Stype binary +Description : Statistical types+Copyright : (c) NoviSci, Inc 2020+License : BSD3+Maintainer : bsaul@novisci.com++-}++{-# LANGUAGE Safe #-}+{-# LANGUAGE DeriveGeneric #-}++module Stype.Categorical.Binary (+ Binary(..)+ , toBool+ , toInt+ , fromBool+) where++import GHC.Generics ( Generic )++{- | Binary Type -}+data Binary = Zero | One deriving ( Eq, Ord, Generic )++instance Show Binary where + show x = + case x of+ Zero -> "0"+ One -> "1"++-- | Convert a @Binary@ to @Bool@.+toBool :: Binary -> Bool +toBool Zero = False +toBool One = True ++-- | Convert @Binary@ to @Int@.+toInt :: Binary -> Int +toInt Zero = 0+toInt One = 1++-- | Create a @Binary@ from a @Bool@. +fromBool :: Bool -> Binary+fromBool True = One+fromBool False = Zero
src/Stype/Categorical/Nominal.hs view
@@ -6,12 +6,15 @@ Maintainer : bsaul@novisci.com -}--- {-# LANGUAGE Safe #-}++{-# LANGUAGE Safe #-}+{-# LANGUAGE DeriveGeneric #-}+ module Stype.Categorical.Nominal (- Nomimal(..)+ Nominal(..) ) where --- import qualified Data.Set.NonEmpty as NES+import GHC.Generics ( Generic ) {- | a placeholder for a future nominal type -}-newtype Nomimal a = Nomimal a deriving ( Eq, Show, Ord )+newtype Nominal a = Nominal a deriving ( Eq, Show, Ord, Generic )
src/Stype/Numeric.hs view
@@ -7,9 +7,6 @@ -} -{-# LANGUAGE GADTs #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE Safe #-} module Stype.Numeric (@@ -23,4 +20,4 @@ import safe Stype.Numeric.Censored instance Censorable Double where-instance (Ord a) => Censorable (EventTime a) where+instance (Ord a, Show a) => Censorable (EventTime a) where
src/Stype/Numeric/Censored.hs view
@@ -10,31 +10,40 @@ {-# LANGUAGE Safe #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE DeriveGeneric #-} module Stype.Numeric.Censored ( Censorable(..) , MaybeCensored(..)+ , ParseIntervalError(..) ) where -import safe Data.Text (Text)+import safe Data.Text + -- ( Text, pack, unpack )+import safe GHC.Generics ( Generic ) +-- | Data for censored data data MaybeCensored a where IntervalCensored :: a -> a -> MaybeCensored a RightCensored :: a -> MaybeCensored a LeftCensored :: a -> MaybeCensored a Uncensored :: a -> MaybeCensored a- deriving( Eq, Show, Ord )+ deriving( Eq, Show, Ord, Generic ) -class (Ord a) => Censorable a where+newtype ParseIntervalError = ParseIntervalError Text+ deriving ( Eq, Show) - parseIntervalCensor :: a -> a -> Either Text (MaybeCensored a)- parseIntervalCensor x y +-- | A class to censor data+class (Ord a, Show a) => Censorable a where++ parseIntervalCensor :: a -> a -> Either ParseIntervalError (MaybeCensored a)+ parseIntervalCensor x y | x < y = Right $ IntervalCensored x y- | otherwise = Left "y >= x"+ | otherwise = Left $ ParseIntervalError ( pack (show y ++ " < " ++ show x) ) rightCensor :: a -> a -> MaybeCensored a rightCensor c t- | c < t = RightCensored c + | c < t = RightCensored c | otherwise = Uncensored t leftCensor :: a -> a -> MaybeCensored a
src/Stype/Numeric/Continuous.hs view
@@ -8,6 +8,8 @@ -} {-# LANGUAGE Safe #-}+{-# LANGUAGE DeriveGeneric #-}+ module Stype.Numeric.Continuous ( Continuous(..) , NonnegContinuous(..)@@ -16,10 +18,11 @@ ) where import safe Control.Applicative ( Applicative(liftA2) )-+import safe GHC.Generics ( Generic ) +-- | Data type for continuous numbers. data Continuous a = NegContInf | Cont a | ContInf- deriving (Eq, Show, Ord)+ deriving (Eq, Show, Ord, Generic) instance Functor Continuous where fmap f (Cont x) = Cont (f x)@@ -42,12 +45,23 @@ signum = fmap signum negate = fmap negate -data NonnegContinuous a = NonNeg a | NonNegInf- deriving (Eq, Show, Ord)+-- | Data type for nonnegative continuous numbers.+data NonnegContinuous a = NonNegCont a | NonNegContInf+ deriving (Eq, Show, Ord, Generic) +data ParseErrorNegative = ParseErrorNegative deriving (Eq, Show)++-- | Parse a number into a Nonnegative continuous number.+parseNonnegCont :: (Num a, Ord a) => a -> Either ParseErrorNegative (NonnegContinuous a)+parseNonnegCont x + | x < 0 = Left ParseErrorNegative+ | otherwise = Right (NonNegCont x)++-- | Data type for event times. newtype EventTime a = EventTime { getEventTime :: NonnegContinuous a }- deriving (Eq, Show, Ord)+ deriving (Eq, Show, Ord, Generic) +-- | Create an event time from a @Maybe@. mkEventTime :: Maybe a -> EventTime a-mkEventTime (Just x) = EventTime $ NonNeg x-mkEventTime Nothing = EventTime NonNegInf+mkEventTime (Just x) = EventTime $ NonNegCont x+mkEventTime Nothing = EventTime NonNegContInf
src/Stype/Numeric/Count.hs view
@@ -8,16 +8,18 @@ -} {-# LANGUAGE Safe #-}+{-# LANGUAGE DeriveGeneric #-} module Stype.Numeric.Count ( Count(..) ) where +import safe GHC.Generics ( Generic ) import safe GHC.Num ( Natural ) import safe Data.Semiring ( Semiring(..) ) newtype Count = Count Natural- deriving (Eq, Show, Ord)+ deriving (Eq, Show, Ord, Generic) instance Num Count where (+) (Count x) (Count y) = Count (x + y)
− test/FeatureCompose/AesonSpec.hs
@@ -1,65 +0,0 @@-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE DataKinds #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE MultiParamTypeClasses #-}-module FeatureCompose.AesonSpec (spec) where--import IntervalAlgebra-import EventData-import EventData.Context-import FeatureEvents-import FeatureCompose-import FeatureCompose.Aeson-import FeatureCompose.Attributes-import Data.Aeson (encode)-import Data.Maybe-import Data.Time as DT-import Test.Hspec ( shouldBe, it, Spec )-import qualified Data.ByteString.Lazy as B-import EventData.Context.Domain---ex1 :: Events Int-ex1 = [event (beginerval 10 0) (context (UnimplementedDomain ()) (packConcepts ["enrollment"]))]--index:: (Ord a) =>- Events a- -> FeatureData (Interval a)-index es =- case firstConceptOccurrence ["enrollment"] es of- Nothing -> featureDataL (Other "No Enrollment")- Just x -> pure (getInterval x)--dummy :: Feature "dummy" Bool-dummy = pure True--instance HasAttributes "dummy" Bool where- getAttributes x = MkAttributes "some Label" "longer label..." "a description" emptyPurpose--dummy2 :: Feature "dummy2" Bool-dummy2 = pure True--instance HasAttributes "dummy2" Bool where- getAttributes x = emptyAttributes --spec :: Spec-spec = do- it "an Int event is parsed correctly" $- encode (index ex1) `shouldBe` "{\"end\":10,\"begin\":0}"-- it "dummy encodes correctly" $- encode dummy `shouldBe` - "{\"data\":true,\"name\":\"dummy\",\"type\":\"Bool\",\- \\"attrs\":{\"getPurpose\":{\"getTags\":[],\"getRole\":[]},\- \\"getDerivation\":\"a description\",\- \\"getLongLabel\":\"longer label...\",\- \\"getShortLabel\":\"some Label\"}}"-- it "dummy2 encodes correctly" $- encode dummy2 `shouldBe` - "{\"data\":true,\"name\":\"dummy2\",\"type\":\"Bool\",\- \\"attrs\":{\"getPurpose\":{\"getTags\":[],\"getRole\":[]},\- \\"getDerivation\":\"\",\- \\"getLongLabel\":\"\",\- \\"getShortLabel\":\"\"}}"
− test/FeatureComposeSpec.hs
@@ -1,168 +0,0 @@-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE DataKinds #-}-module FeatureComposeSpec (- spec-) where--import FeatureCompose-import Test.Hspec ( describe, pending, shouldBe, it, Spec )----------------------------------------- example :: Feature "test" ()--- example = MkFeature $ pure ()---- d0 :: Definition (FeatureData Int)--- d0 = define 5--d1 :: Definition (FeatureData Int -> FeatureData Int)-d1 = defineA- (\x ->- if x < 0 then- missingBecause $ Other "at least 1 < 0"- else- pure (x + 1)- )--d2 :: Definition (FeatureData Int -> FeatureData Int)-d2 = define (*2)---d3 :: Definition (FeatureData Int -> FeatureData Int -> FeatureData Int)-d3 = define (+)--f1 :: Int -> Int-f1 = (+2)--f1D :: Definition (FeatureData Int -> FeatureData Int)-f1D = define f1--f1F :: Definition (Feature "someInt" Int -> Feature "anotherInt" Int)-f1F = define f1--f2 :: Bool -> FeatureData Int-f2 True = pure 1-f2 False = missingBecause $ Other "test"--f2D :: Definition (FeatureData Bool -> FeatureData Int)-f2D = defineA f2--f2' :: Bool -> Feature "someInt" Int-f2' True = pure 1-f2' False = makeFeature $ missingBecause $ Other "test"--f2F :: Definition (Feature "someBool" Bool -> Feature "someInt" Int)-f2F = defineA f2'--f3 :: Bool -> Int -> String-f3 True 1 = "this"-f3 False 9 = "that"-f3 _ _ = "otherwise"--f3D :: Definition (FeatureData Bool -> FeatureData Int -> FeatureData String)-f3D = define f3--f3F :: Definition (Feature "myBool" Bool -> Feature "someInt" Int -> Feature "myString" String)-f3F = define f3---featInts :: [Int] -> Feature "someInts" [Int]-featInts = pure--feat1 :: Definition (Feature "someInts" [Int] -> Feature "hasMoreThan3" Bool)-feat1 = defineA- (\ints -> if null ints then makeFeature (missingBecause $ Other "no data")- else makeFeature $ featureDataR (length ints > 3))--feat2 :: Definition (- Feature "hasMoreThan3" Bool- -> Feature "someInts" [Int]- -> Feature "sum" Int)-feat2 = define (\b ints -> if b then sum ints else 0)--ex0 = featInts []-ex0a = eval feat1 ex0 -- MkFeature (MkFeatureData (Left (Other "no data")))-ex0b = eval feat2 (ex0a, ex0) -- MkFeature (MkFeatureData (Left (Other "no data")))--ex1 = featInts [3, 8]-ex1a = eval feat1 ex1 -- MkFeature (MkFeatureData (Right False))-ex1b = eval feat2 (ex1a, ex1) -- MkFeature (MkFeatureData (Right 0))--ex2 = featInts [1..4]-ex2a = eval feat1 ex2 -- MkFeature (MkFeatureData (Right True))-ex2b = eval feat2 (ex2a, ex2) -- MkFeature (MkFeatureData (Right 10))--spec :: Spec-spec = do-- describe "checking d1" $- do- it "eval of d1 on d0" $- eval d1 (pure 5) `shouldBe` featureDataR 6- it "eval of d1 returns correct value" $- eval d1 (featureDataR 5 ) `shouldBe`- featureDataR 6- it "d1 returns correct error" $- eval d1 (featureDataR (-1)) `shouldBe`- missingBecause (Other "at least 1 < 0")-- describe "checking d2" $- do- it "eval of d2 returns correct value" $- eval d2 (featureDataR 5) `shouldBe`- featureDataR 10- it "eval of d2 returns correct value" $- eval d2 (featureDataR 5) `shouldBe`- featureDataR 10- it "d2 returns correct error" $- eval d2 (featureDataL (Other "at least 1 < 0") ) `shouldBe`- featureDataL (Other "at least 1 < 0")-- describe "checking d3" $- do- it "eval of d2 returns correct values" $- eval d3 (featureDataR 5, featureDataR 6) `shouldBe`- featureDataR 11- it "eval of d3 returns correct values" $- eval d3 (featureDataR 5, featureDataR 5) `shouldBe`- featureDataR 10- it "d3 returns correct error" $- eval d3 (featureDataL (Other "at least 1 < 0"), featureDataR 6) `shouldBe`- featureDataL (Other "at least 1 < 0")- it "d3 returns correct error" $- eval d3 (featureDataR 6, featureDataL (Other "at least 1 < 0")) `shouldBe`- featureDataL (Other "at least 1 < 0")-- describe "checking f1" $- do- it "eval of f1F on d0 returns correct value" $- eval f1F (pure 5) `shouldBe` pure 7-- describe "checking f2" $- do- it "eval of f2D on d0 returns correct value" $- eval f2D (pure True) `shouldBe` pure 1- it "eval of f1F on d0 returns correct value" $- eval f2D (pure False) `shouldBe` missingBecause (Other "test")- it "eval of f1F on d0 returns correct value" $- eval f2F (pure False) `shouldBe` makeFeature (missingBecause (Other "test"))-- describe "checking f3" $- do- it "eval of f3D returns correct value" $- eval f3D (pure True, pure 1) `shouldBe` pure "this"- it "eval of f3D returns correct value" $- eval f3D (pure True, pure 9) `shouldBe` pure "otherwise"- it "eval of f3F returns correct value" $- eval f3F (pure True, eval f2F (pure False)) `shouldBe` makeFeature (missingBecause (Other "test"))- it "eval of f3F returns correct value" $- eval f3F (pure True, eval f2F (pure True)) `shouldBe` pure "this"-- describe "checking ex0-2" $- do- it "ex0b" $- ex0b `shouldBe` makeFeature (missingBecause (Other "no data"))- it "ex1b" $- ex1b `shouldBe` makeFeature (featureDataR 0)- it "ex2b" $- ex2b `shouldBe` makeFeature (featureDataR 10)
+ test/Features/FeaturesetSpec.hs view
@@ -0,0 +1,58 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}+module Features.FeaturesetSpec (spec) where++import Features+import Data.Aeson (encode)+import Data.List+import Data.List.NonEmpty as NE+-- import Data.Maybe+-- import Data.Time as DT+import Data.Text ( Text )+import Test.Hspec ( shouldBe, it, Spec, pending )+import qualified Data.ByteString.Lazy as B+++s1f1 :: Feature "a" Bool+s1f1 = pure True++s2f1 :: Feature "a" Bool+s2f1 = pure False++instance HasAttributes "a" Bool where+ getAttributes x = MkAttributes "some Label" "longer label..." "a description" emptyPurpose++s1f2 :: Feature "b" (Maybe Text)+s1f2 = pure Nothing++s2f2 :: Feature "b" (Maybe Text)+s2f2 = pure (Just "bye")++instance HasAttributes "b" (Maybe Text) where+ getAttributes x = emptyAttributes++s1 :: Featureset +s1 = featureset ((packFeature s1f1) :| [packFeature s1f2])++s2 :: Featureset +s2 = featureset ((packFeature s2f1) :| [packFeature s2f2])++dt :: FeaturesetList+dt = MkFeaturesetList (s1 :| [s2])++-- tdt :: DataFrameShape+-- tdt = makeDataFrameReady dt+++spec :: Spec+spec = do ++ it "tdt encodes correctly" $ pending + -- encode tdt `shouldBe`+ -- "{\"data\":[[true,false],[null,\"bye\"]],\+ -- \\"attributes\":[{\"name\":\"a\",\+ -- \\"type\":\"Bool\",\"attrs\":{\"getPurpose\":{\"getTags\":[],\"getRole\":[]},\"getDerivation\":\"a description\",\"getLongLabel\":\"longer label...\",\"getShortLabel\":\"some Label\"}},\+ -- \{\"name\":\"b\",\"type\":\"Maybe Text\",\"attrs\":{\"getPurpose\":{\"getTags\":[],\"getRole\":[]},\"getDerivation\":\"\",\"getLongLabel\":\"\",\"getShortLabel\":\"\"}}]}"
+ test/Features/OutputSpec.hs view
@@ -0,0 +1,63 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}+module Features.OutputSpec (spec) where++import IntervalAlgebra+import EventData+import EventData.Context+import FeatureEvents+import Features+import Data.Aeson (encode)+import Data.Maybe+import Data.Time as DT+import Test.Hspec ( shouldBe, it, Spec )+import qualified Data.ByteString.Lazy as B+import EventData.Context.Domain+++ex1 :: Events Int+ex1 = [event (beginerval 10 0) (context (UnimplementedDomain ()) (packConcepts ["enrollment"]))]++index:: (Ord a) =>+ Events a+ -> FeatureData (Interval a)+index es =+ case firstConceptOccurrence ["enrollment"] es of+ Nothing -> featureDataL (Other "No Enrollment")+ Just x -> pure (getInterval x)++dummy :: Feature "dummy" Bool+dummy = pure True++instance HasAttributes "dummy" Bool where+ getAttributes x = MkAttributes "some Label" "longer label..." "a description" emptyPurpose++dummy2 :: Feature "dummy2" Bool+dummy2 = pure True++instance HasAttributes "dummy2" Bool where+ getAttributes x = emptyAttributes ++spec :: Spec+spec = do+ it "an Int event is parsed correctly" $+ encode (index ex1) `shouldBe` "{\"end\":10,\"begin\":0}"++ it "dummy encodes correctly" $+ encode dummy `shouldBe` + "{\"data\":true,\"name\":\"dummy\",\"type\":\"Bool\",\+ \\"attrs\":{\"getPurpose\":{\"getTags\":[],\"getRole\":[]},\+ \\"getDerivation\":\"a description\",\+ \\"getLongLabel\":\"longer label...\",\+ \\"getShortLabel\":\"some Label\"}}"++ it "dummy2 encodes correctly" $+ encode dummy2 `shouldBe` + "{\"data\":true,\"name\":\"dummy2\",\"type\":\"Bool\",\+ \\"attrs\":{\"getPurpose\":{\"getTags\":[],\"getRole\":[]},\+ \\"getDerivation\":\"\",\+ \\"getLongLabel\":\"\",\+ \\"getShortLabel\":\"\"}}"
+ test/FeaturesSpec.hs view
@@ -0,0 +1,168 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE DataKinds #-}+module FeaturesSpec (+ spec+) where++import Features+import Test.Hspec ( describe, pending, shouldBe, it, Spec )+++-----------------------------------+-- example :: Feature "test" ()+-- example = MkFeature $ pure ()++-- d0 :: Definition (FeatureData Int)+-- d0 = define 5++d1 :: Definition (FeatureData Int -> FeatureData Int)+d1 = defineA+ (\x ->+ if x < 0 then+ missingBecause $ Other "at least 1 < 0"+ else+ pure (x + 1)+ )++d2 :: Definition (FeatureData Int -> FeatureData Int)+d2 = define (*2)+++d3 :: Definition (FeatureData Int -> FeatureData Int -> FeatureData Int)+d3 = define (+)++f1 :: Int -> Int+f1 = (+2)++f1D :: Definition (FeatureData Int -> FeatureData Int)+f1D = define f1++f1F :: Definition (Feature "someInt" Int -> Feature "anotherInt" Int)+f1F = define f1++f2 :: Bool -> FeatureData Int+f2 True = pure 1+f2 False = missingBecause $ Other "test"++f2D :: Definition (FeatureData Bool -> FeatureData Int)+f2D = defineA f2++f2' :: Bool -> Feature "someInt" Int+f2' True = pure 1+f2' False = makeFeature $ missingBecause $ Other "test"++f2F :: Definition (Feature "someBool" Bool -> Feature "someInt" Int)+f2F = defineA f2'++f3 :: Bool -> Int -> String+f3 True 1 = "this"+f3 False 9 = "that"+f3 _ _ = "otherwise"++f3D :: Definition (FeatureData Bool -> FeatureData Int -> FeatureData String)+f3D = define f3++f3F :: Definition (Feature "myBool" Bool -> Feature "someInt" Int -> Feature "myString" String)+f3F = define f3+++featInts :: [Int] -> Feature "someInts" [Int]+featInts = pure++feat1 :: Definition (Feature "someInts" [Int] -> Feature "hasMoreThan3" Bool)+feat1 = defineA+ (\ints -> if null ints then makeFeature (missingBecause $ Other "no data")+ else makeFeature $ featureDataR (length ints > 3))++feat2 :: Definition (+ Feature "hasMoreThan3" Bool+ -> Feature "someInts" [Int]+ -> Feature "sum" Int)+feat2 = define (\b ints -> if b then sum ints else 0)++ex0 = featInts []+ex0a = eval feat1 ex0 -- MkFeature (MkFeatureData (Left (Other "no data")))+ex0b = eval feat2 (ex0a, ex0) -- MkFeature (MkFeatureData (Left (Other "no data")))++ex1 = featInts [3, 8]+ex1a = eval feat1 ex1 -- MkFeature (MkFeatureData (Right False))+ex1b = eval feat2 (ex1a, ex1) -- MkFeature (MkFeatureData (Right 0))++ex2 = featInts [1..4]+ex2a = eval feat1 ex2 -- MkFeature (MkFeatureData (Right True))+ex2b = eval feat2 (ex2a, ex2) -- MkFeature (MkFeatureData (Right 10))++spec :: Spec+spec = do++ describe "checking d1" $+ do+ it "eval of d1 on d0" $+ eval d1 (pure 5) `shouldBe` featureDataR 6+ it "eval of d1 returns correct value" $+ eval d1 (featureDataR 5 ) `shouldBe`+ featureDataR 6+ it "d1 returns correct error" $+ eval d1 (featureDataR (-1)) `shouldBe`+ missingBecause (Other "at least 1 < 0")++ describe "checking d2" $+ do+ it "eval of d2 returns correct value" $+ eval d2 (featureDataR 5) `shouldBe`+ featureDataR 10+ it "eval of d2 returns correct value" $+ eval d2 (featureDataR 5) `shouldBe`+ featureDataR 10+ it "d2 returns correct error" $+ eval d2 (featureDataL (Other "at least 1 < 0") ) `shouldBe`+ featureDataL (Other "at least 1 < 0")++ describe "checking d3" $+ do+ it "eval of d2 returns correct values" $+ eval d3 (featureDataR 5, featureDataR 6) `shouldBe`+ featureDataR 11+ it "eval of d3 returns correct values" $+ eval d3 (featureDataR 5, featureDataR 5) `shouldBe`+ featureDataR 10+ it "d3 returns correct error" $+ eval d3 (featureDataL (Other "at least 1 < 0"), featureDataR 6) `shouldBe`+ featureDataL (Other "at least 1 < 0")+ it "d3 returns correct error" $+ eval d3 (featureDataR 6, featureDataL (Other "at least 1 < 0")) `shouldBe`+ featureDataL (Other "at least 1 < 0")++ describe "checking f1" $+ do+ it "eval of f1F on d0 returns correct value" $+ eval f1F (pure 5) `shouldBe` pure 7++ describe "checking f2" $+ do+ it "eval of f2D on d0 returns correct value" $+ eval f2D (pure True) `shouldBe` pure 1+ it "eval of f1F on d0 returns correct value" $+ eval f2D (pure False) `shouldBe` missingBecause (Other "test")+ it "eval of f1F on d0 returns correct value" $+ eval f2F (pure False) `shouldBe` makeFeature (missingBecause (Other "test"))++ describe "checking f3" $+ do+ it "eval of f3D returns correct value" $+ eval f3D (pure True, pure 1) `shouldBe` pure "this"+ it "eval of f3D returns correct value" $+ eval f3D (pure True, pure 9) `shouldBe` pure "otherwise"+ it "eval of f3F returns correct value" $+ eval f3F (pure True, eval f2F (pure False)) `shouldBe` makeFeature (missingBecause (Other "test"))+ it "eval of f3F returns correct value" $+ eval f3F (pure True, eval f2F (pure True)) `shouldBe` pure "this"++ describe "checking ex0-2" $+ do+ it "ex0b" $+ ex0b `shouldBe` makeFeature (missingBecause (Other "no data"))+ it "ex1b" $+ ex1b `shouldBe` makeFeature (featureDataR 0)+ it "ex2b" $+ ex2b `shouldBe` makeFeature (featureDataR 10)
− test/Hasklepias/AesonSpec.hs
@@ -1,73 +0,0 @@-{-# LANGUAGE OverloadedStrings #-}-module Hasklepias.AesonSpec (spec) where--import IntervalAlgebra-import EventData-import Hasklepias.Aeson-import Hasklepias.Cohort-import EventData.Context as HC-import EventData.Context.Domain-import Data.Aeson-import Data.Maybe-import Data.Time as DT-import Test.Hspec-import qualified Data.ByteString.Lazy as B----testInputsDay1 :: B.ByteString-testInputsDay1 =- "[\"abc\", \"2020-01-01\", \"2020-01-02\", \"Diagnosis\",\- \[\"someThing\"],\- \{\"domain\":\"Diagnosis\",\- \ \"time\":{\"begin\":\"2020-01-01\",\"end\":\"2020-01-02\"}}]\n\- \[\"abc\", \"2020-01-05\", \"2020-01-06\", \"Diagnosis\",\- \[\"someThing\"],\- \{\"domain\":\"Diagnosis\",\- \ \"time\":{\"begin\":\"2020-01-05\",\"end\":\"2020-01-06\"}}]"---testInputsDay2 :: B.ByteString-testInputsDay2 =- "[\"def\", \"2020-01-01\", null, \"Diagnosis\",\- \[\"someThing\"],\- \{\"domain\":\"Diagnosis\",\- \ \"time\":{\"begin\":\"2020-01-01\",\"end\":\"2020-01-02\"}}]\n\- \[\"def\", \"2020-01-05\", null, \"Diagnosis\",\- \[\"someThing\"],\- \{\"domain\":\"Diagnosis\",\- \ \"time\":{\"begin\":\"2020-01-05\",\"end\":\"2020-01-06\"}}]"--testInputsDayBad :: B.ByteString-testInputsDayBad =- "[\"ghi\", \"2020-01-01\", null, \"Diagnosis\",\- \[\"someThing\"],\- \{\"time\":{\"begin\":\"2020-01-01\",\"end\":\"2020-01-02\"}}]\n\- \[\"ghi\", \"2020-01-05\", null, \"Diagnosis\",\- \[\"someThing\"],\- \{\"domain\":\"Diagnosis\",\- \ \"time\":{\"begin\":\"2020-01-05\",\"end\":\"2020-01-04\"}}]"--testInput = testInputsDay1 <> "\n" <> testInputsDay2---testOutDay1 = event (beginerval 1 (fromGregorian 2020 1 1))- (HC.context ( UnimplementedDomain () ) (packConcepts ["someThing"]))-testOutDay2 = event (beginerval 1 (fromGregorian 2020 1 5))- (HC.context ( UnimplementedDomain () ) (packConcepts [ "someThing"]))---testOutPop = MkPopulation [- MkSubject ("abc", [testOutDay1, testOutDay2])- , MkSubject ("def", [testOutDay1, testOutDay2])- ]--spec :: Spec-spec = do- it "a population is parsed" $- parsePopulationDayLines testInput `shouldBe` ([], testOutPop)-- it "a population is parsed" $- parsePopulationDayLines (testInput <> "\n" <> testInputsDayBad)`shouldBe`- ([MkParseError (5, "Error in $: key \"domain\" not found")- , MkParseError (6, "Error in $: 2020-01-04<2020-01-05")], testOutPop)
+ test/Hasklepias/Cohort/CoreSpec.hs view
@@ -0,0 +1,72 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE DataKinds #-}++module Hasklepias.Cohort.CoreSpec (+ spec+ ) where++import Features+import Hasklepias.Cohort+import Data.List.NonEmpty+import Test.Hspec ( describe, pending, shouldBe, it, Spec )++-- data Feat1++d1 :: Definition (Feature "feat" Int -> Feature "feat1" Bool)+d1 =+ defineA+ (\x ->+ if x < 0 then+ makeFeature $ featureDataL $ Other "at least 1 < 0"+ else+ pure ((x + 1) == 5)+ )+++d2 :: Definition (Feature "feat" Int -> Feature "feat2" Status)+d2 = define (\x -> includeIf (x*2 > 4))++d3 :: Definition (Feature "feat" Int -> Feature "feat3" Int)+d3 = define (+ 2)+++testSubject1 :: Subject Int+testSubject1 = MkSubject ("1", 0)+testSubject2 :: Subject Int+testSubject2 = MkSubject ("2", 54)++testPopulation :: Population Int+testPopulation = MkPopulation [testSubject1, testSubject2]++buildCriteria :: Int -> Criteria+buildCriteria dat = criteria $ pure ( criterion feat1 )+ where feat1 = eval d2 $ pure dat++type Features = (Feature "feat1" Bool, Feature "feat3" Int)+buildFeatures :: Int -> Features+buildFeatures dat =+ ( eval d1 input+ , eval d3 input+ )+ where input = pure dat++testCohort :: CohortSpec Int Features+testCohort = specifyCohort buildCriteria buildFeatures++testOut :: Cohort Features+testOut = MkCohort+ ( Just $ MkAttritionInfo $ (ExcludedBy (1, "feat2"), 1) :| [ (Included, 1) ]+ , MkCohortData [MkObsUnit "2" + ( makeFeature (featureDataR False)+ , makeFeature (featureDataR 56)) ])++-- evalCohort testCohort testPopulation+spec :: Spec+spec = do++ describe "checking d1" $+ do++ it "include f1" $+ evalCohort testCohort testPopulation `shouldBe` testOut+
test/Hasklepias/Cohort/CriteriaSpec.hs view
@@ -4,7 +4,7 @@ spec ) where -import FeatureCompose+import Features import Hasklepias.Cohort.Criteria import Test.Hspec ( describe, pending, shouldBe, it, Spec ) import Data.List.NonEmpty
+ test/Hasklepias/Cohort/InputSpec.hs view
@@ -0,0 +1,73 @@+{-# LANGUAGE OverloadedStrings #-}+module Hasklepias.Cohort.InputSpec (spec) where++import IntervalAlgebra+import EventData+-- import Hasklepias.Cohort.Aeson+import Hasklepias.Cohort+import EventData.Context as HC+import EventData.Context.Domain+import Data.Aeson+import Data.Maybe+import Data.Time as DT+import Test.Hspec+import qualified Data.ByteString.Lazy as B++++testInputsDay1 :: B.ByteString+testInputsDay1 =+ "[\"abc\", \"2020-01-01\", \"2020-01-02\", \"Diagnosis\",\+ \[\"someThing\"],\+ \{\"domain\":\"Diagnosis\",\+ \ \"time\":{\"begin\":\"2020-01-01\",\"end\":\"2020-01-02\"}}]\n\+ \[\"abc\", \"2020-01-05\", \"2020-01-06\", \"Diagnosis\",\+ \[\"someThing\"],\+ \{\"domain\":\"Diagnosis\",\+ \ \"time\":{\"begin\":\"2020-01-05\",\"end\":\"2020-01-06\"}}]"+++testInputsDay2 :: B.ByteString+testInputsDay2 =+ "[\"def\", \"2020-01-01\", null, \"Diagnosis\",\+ \[\"someThing\"],\+ \{\"domain\":\"Diagnosis\",\+ \ \"time\":{\"begin\":\"2020-01-01\",\"end\":\"2020-01-02\"}}]\n\+ \[\"def\", \"2020-01-05\", null, \"Diagnosis\",\+ \[\"someThing\"],\+ \{\"domain\":\"Diagnosis\",\+ \ \"time\":{\"begin\":\"2020-01-05\",\"end\":\"2020-01-06\"}}]"++testInputsDayBad :: B.ByteString+testInputsDayBad =+ "[\"ghi\", \"2020-01-01\", null, \"Diagnosis\",\+ \[\"someThing\"],\+ \{\"time\":{\"begin\":\"2020-01-01\",\"end\":\"2020-01-02\"}}]\n\+ \[\"ghi\", \"2020-01-05\", null, \"Diagnosis\",\+ \[\"someThing\"],\+ \{\"domain\":\"Diagnosis\",\+ \ \"time\":{\"begin\":\"2020-01-05\",\"end\":\"2020-01-04\"}}]"++testInput = testInputsDay1 <> "\n" <> testInputsDay2+++testOutDay1 = event (beginerval 1 (fromGregorian 2020 1 1))+ (HC.context ( UnimplementedDomain () ) (packConcepts ["someThing"]))+testOutDay2 = event (beginerval 1 (fromGregorian 2020 1 5))+ (HC.context ( UnimplementedDomain () ) (packConcepts [ "someThing"]))+++testOutPop = MkPopulation [+ MkSubject ("abc", [testOutDay1, testOutDay2])+ , MkSubject ("def", [testOutDay1, testOutDay2])+ ]++spec :: Spec+spec = do+ it "a population is parsed" $+ parsePopulationDayLines testInput `shouldBe` ([], testOutPop)++ it "a population is parsed" $+ parsePopulationDayLines (testInput <> "\n" <> testInputsDayBad)`shouldBe`+ ([MkParseError (5, "Error in $: key \"domain\" not found")+ , MkParseError (6, "Error in $: 2020-01-04<2020-01-05")], testOutPop)
− test/Hasklepias/CohortSpec.hs
@@ -1,71 +0,0 @@-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE DataKinds #-}--module Hasklepias.CohortSpec (- spec- ) where--import FeatureCompose-import Hasklepias.Cohort-import Data.List.NonEmpty-import Test.Hspec ( describe, pending, shouldBe, it, Spec )---- data Feat1--d1 :: Definition (Feature "feat" Int -> Feature "feat1" Bool)-d1 =- defineA- (\x ->- if x < 0 then- makeFeature $ featureDataL $ Other "at least 1 < 0"- else- pure ((x + 1) == 5)- )---d2 :: Definition (Feature "feat" Int -> Feature "feat2" Status)-d2 = define (\x -> includeIf (x*2 > 4))--d3 :: Definition (Feature "feat" Int -> Feature "feat3" Int)-d3 = define (+ 2)---testSubject1 :: Subject Int-testSubject1 = MkSubject ("1", 0)-testSubject2 :: Subject Int-testSubject2 = MkSubject ("2", 54)--testPopulation :: Population Int-testPopulation = MkPopulation [testSubject1, testSubject2]--buildCriteria :: Int -> Criteria-buildCriteria dat = criteria $ pure ( criterion feat1 )- where feat1 = eval d2 $ pure dat--type Features = (Feature "feat1" Bool, Feature "feat3" Int)-buildFeatures :: Int -> Features-buildFeatures dat =- ( eval d1 input- , eval d3 input- )- where input = pure dat--testCohort :: CohortSpec Int Features-testCohort = specifyCohort buildCriteria buildFeatures--testOut :: Cohort Features-testOut = MkCohort- ( Just $ MkAttritionInfo $ (ExcludedBy (1, "feat2"), 1) :| [ (Included, 1) ]- , [MkObsUnit ("2", ( makeFeature (featureDataR False)- , makeFeature (featureDataR 56))) ])---- evalCohort testCohort testPopulation-spec :: Spec-spec = do-- describe "checking d1" $- do-- it "include f1" $- evalCohort testCohort testPopulation `shouldBe` testOut-
+ test/Stype/AesonSpec.hs view
@@ -0,0 +1,41 @@+{-# LANGUAGE OverloadedStrings #-}+module Stype.AesonSpec (spec) where++import Stype+import Data.Aeson+import Test.Hspec++spec :: Spec+spec = do+ describe "encoding Continuous" $+ do+ it "Inf encodes" $ toJSON (ContInf :: Continuous Double) `shouldBe` "Inf"+ it "Negative Inf encodes" $ toJSON (NegContInf :: Continuous Double) `shouldBe` "-Inf" + it "Continuous encodes" $ toJSON (Cont 7.5 :: Continuous Double) `shouldBe` Number 7.5++ describe "encoding Nonnegative Continuous" $+ do+ it "NonNegative Inf encodes" $ toJSON (NonNegContInf :: NonnegContinuous Double) `shouldBe` "Inf" + it "Continuous encodes" $ toJSON (NonNegCont 7.5 :: NonnegContinuous Double) `shouldBe` Number 7.5++ describe "encoding EventTime" $+ do+ it "EventTime Inf encodes" $ toJSON (EventTime NonNegContInf :: EventTime Double) `shouldBe` "Inf" + it "EventTime encodes" $ toJSON (EventTime (NonNegCont 7.5) :: EventTime Double) `shouldBe` Number 7.5 ++ describe "encoding Count" $+ do+ it "count encodes" $ toJSON (8 :: Count) `shouldBe` Number 8++ describe "encoding Binary" $+ do+ it "zero encodes" $ toJSON Zero `shouldBe` Bool False+ it "one encodes" $ toJSON One `shouldBe` Bool True++ describe "encoding Nominal" $ + do + it "nominal encodes" pending++ describe "encoding MaybeCensored" $ + do + it "MaybeCensored encodes" pending
+ test/Stype/Numeric/CensoredSpec.hs view
@@ -0,0 +1,17 @@+{-# LANGUAGE OverloadedStrings #-}+module Stype.Numeric.CensoredSpec (spec) where++import Stype+import Test.Hspec++spec :: Spec+spec = do+ describe "basic censored tests" $+ do+ it "parseIntervalCensor returns error on invalid interval" $ + parseIntervalCensor (mkEventTime (Just 5)) (mkEventTime (Just 1)) + `shouldBe` Left ( ParseIntervalError "EventTime {getEventTime = NonNegCont 1} < EventTime {getEventTime = NonNegCont 5}" )++ it "parseIntervalCensor returns right on valid interval" $ + parseIntervalCensor (mkEventTime (Just 5.0)) (mkEventTime (Just 9.0)) + `shouldBe` Right ( IntervalCensored (EventTime (NonNegCont 5.0)) (EventTime (NonNegCont 9.0)))