diff --git a/ChangeLog.md b/ChangeLog.md --- a/ChangeLog.md +++ b/ChangeLog.md @@ -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. diff --git a/exampleApp/Main.hs b/exampleApp/Main.hs --- a/exampleApp/Main.hs +++ b/exampleApp/Main.hs @@ -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 diff --git a/examples/ExampleCohort1.hs b/examples/ExampleCohort1.hs --- a/examples/ExampleCohort1.hs +++ b/examples/ExampleCohort1.hs @@ -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" diff --git a/examples/ExampleFeatures1.hs b/examples/ExampleFeatures1.hs --- a/examples/ExampleFeatures1.hs +++ b/examples/ExampleFeatures1.hs @@ -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]) diff --git a/hasklepias.cabal b/hasklepias.cabal --- a/hasklepias.cabal +++ b/hasklepias.cabal @@ -1,6 +1,6 @@ cabal-version: 2.2 name: hasklepias -version: 0.13.1 +version: 0.14.0 description: Please see the README on GitHub at 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 diff --git a/src/EventData.hs b/src/EventData.hs --- a/src/EventData.hs +++ b/src/EventData.hs @@ -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] diff --git a/src/EventData/Aeson.hs b/src/EventData/Aeson.hs --- a/src/EventData/Aeson.hs +++ b/src/EventData/Aeson.hs @@ -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 diff --git a/src/EventData/Arbitrary.hs b/src/EventData/Arbitrary.hs --- a/src/EventData/Arbitrary.hs +++ b/src/EventData/Arbitrary.hs @@ -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 diff --git a/src/EventData/Core.hs b/src/EventData/Core.hs new file mode 100644 --- /dev/null +++ b/src/EventData/Core.hs @@ -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] diff --git a/src/FeatureCompose.hs b/src/FeatureCompose.hs deleted file mode 100644 --- a/src/FeatureCompose.hs +++ /dev/null @@ -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 "" "" "" - diff --git a/src/FeatureCompose/Aeson.hs b/src/FeatureCompose/Aeson.hs deleted file mode 100644 --- a/src/FeatureCompose/Aeson.hs +++ /dev/null @@ -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) ] diff --git a/src/FeatureCompose/Attributes.hs b/src/FeatureCompose/Attributes.hs deleted file mode 100644 --- a/src/FeatureCompose/Attributes.hs +++ /dev/null @@ -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 diff --git a/src/FeatureCompose/Featureable.hs b/src/FeatureCompose/Featureable.hs deleted file mode 100644 --- a/src/FeatureCompose/Featureable.hs +++ /dev/null @@ -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 - diff --git a/src/FeatureEvents.hs b/src/FeatureEvents.hs --- a/src/FeatureEvents.hs +++ b/src/FeatureEvents.hs @@ -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) => diff --git a/src/Features.hs b/src/Features.hs new file mode 100644 --- /dev/null +++ b/src/Features.hs @@ -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 diff --git a/src/Features/Attributes.hs b/src/Features/Attributes.hs new file mode 100644 --- /dev/null +++ b/src/Features/Attributes.hs @@ -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 diff --git a/src/Features/Compose.hs b/src/Features/Compose.hs new file mode 100644 --- /dev/null +++ b/src/Features/Compose.hs @@ -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 "" "" "" + diff --git a/src/Features/Featureable.hs b/src/Features/Featureable.hs new file mode 100644 --- /dev/null +++ b/src/Features/Featureable.hs @@ -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 + diff --git a/src/Features/Featureset.hs b/src/Features/Featureset.hs new file mode 100644 --- /dev/null +++ b/src/Features/Featureset.hs @@ -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))) diff --git a/src/Features/Output.hs b/src/Features/Output.hs new file mode 100644 --- /dev/null +++ b/src/Features/Output.hs @@ -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 diff --git a/src/Hasklepias.hs b/src/Hasklepias.hs --- a/src/Hasklepias.hs +++ b/src/Hasklepias.hs @@ -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 diff --git a/src/Hasklepias/Aeson.hs b/src/Hasklepias/Aeson.hs deleted file mode 100644 --- a/src/Hasklepias/Aeson.hs +++ /dev/null @@ -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) diff --git a/src/Hasklepias/Cohort.hs b/src/Hasklepias/Cohort.hs --- a/src/Hasklepias/Cohort.hs +++ b/src/Hasklepias/Cohort.hs @@ -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 diff --git a/src/Hasklepias/Cohort/Core.hs b/src/Hasklepias/Cohort/Core.hs new file mode 100644 --- /dev/null +++ b/src/Hasklepias/Cohort/Core.hs @@ -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 ) diff --git a/src/Hasklepias/Cohort/Criteria.hs b/src/Hasklepias/Cohort/Criteria.hs --- a/src/Hasklepias/Cohort/Criteria.hs +++ b/src/Hasklepias/Cohort/Criteria.hs @@ -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(..) ) diff --git a/src/Hasklepias/Cohort/Input.hs b/src/Hasklepias/Cohort/Input.hs new file mode 100644 --- /dev/null +++ b/src/Hasklepias/Cohort/Input.hs @@ -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) diff --git a/src/Hasklepias/Cohort/Output.hs b/src/Hasklepias/Cohort/Output.hs new file mode 100644 --- /dev/null +++ b/src/Hasklepias/Cohort/Output.hs @@ -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) diff --git a/src/Hasklepias/MakeApp.hs b/src/Hasklepias/MakeApp.hs --- a/src/Hasklepias/MakeApp.hs +++ b/src/Hasklepias/MakeApp.hs @@ -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!" diff --git a/src/Hasklepias/Reexports.hs b/src/Hasklepias/Reexports.hs --- a/src/Hasklepias/Reexports.hs +++ b/src/Hasklepias/Reexports.hs @@ -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 diff --git a/src/Stype.hs b/src/Stype.hs --- a/src/Stype.hs +++ b/src/Stype.hs @@ -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 diff --git a/src/Stype/Aeson.hs b/src/Stype/Aeson.hs new file mode 100644 --- /dev/null +++ b/src/Stype/Aeson.hs @@ -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) diff --git a/src/Stype/Categorical.hs b/src/Stype/Categorical.hs --- a/src/Stype/Categorical.hs +++ b/src/Stype/Categorical.hs @@ -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 diff --git a/src/Stype/Categorical/Binary.hs b/src/Stype/Categorical/Binary.hs new file mode 100644 --- /dev/null +++ b/src/Stype/Categorical/Binary.hs @@ -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 diff --git a/src/Stype/Categorical/Nominal.hs b/src/Stype/Categorical/Nominal.hs --- a/src/Stype/Categorical/Nominal.hs +++ b/src/Stype/Categorical/Nominal.hs @@ -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 ) diff --git a/src/Stype/Numeric.hs b/src/Stype/Numeric.hs --- a/src/Stype/Numeric.hs +++ b/src/Stype/Numeric.hs @@ -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 diff --git a/src/Stype/Numeric/Censored.hs b/src/Stype/Numeric/Censored.hs --- a/src/Stype/Numeric/Censored.hs +++ b/src/Stype/Numeric/Censored.hs @@ -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 diff --git a/src/Stype/Numeric/Continuous.hs b/src/Stype/Numeric/Continuous.hs --- a/src/Stype/Numeric/Continuous.hs +++ b/src/Stype/Numeric/Continuous.hs @@ -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 diff --git a/src/Stype/Numeric/Count.hs b/src/Stype/Numeric/Count.hs --- a/src/Stype/Numeric/Count.hs +++ b/src/Stype/Numeric/Count.hs @@ -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) diff --git a/test/FeatureCompose/AesonSpec.hs b/test/FeatureCompose/AesonSpec.hs deleted file mode 100644 --- a/test/FeatureCompose/AesonSpec.hs +++ /dev/null @@ -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\":\"\"}}" diff --git a/test/FeatureComposeSpec.hs b/test/FeatureComposeSpec.hs deleted file mode 100644 --- a/test/FeatureComposeSpec.hs +++ /dev/null @@ -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) diff --git a/test/Features/FeaturesetSpec.hs b/test/Features/FeaturesetSpec.hs new file mode 100644 --- /dev/null +++ b/test/Features/FeaturesetSpec.hs @@ -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\":\"\"}}]}" diff --git a/test/Features/OutputSpec.hs b/test/Features/OutputSpec.hs new file mode 100644 --- /dev/null +++ b/test/Features/OutputSpec.hs @@ -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\":\"\"}}" diff --git a/test/FeaturesSpec.hs b/test/FeaturesSpec.hs new file mode 100644 --- /dev/null +++ b/test/FeaturesSpec.hs @@ -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) diff --git a/test/Hasklepias/AesonSpec.hs b/test/Hasklepias/AesonSpec.hs deleted file mode 100644 --- a/test/Hasklepias/AesonSpec.hs +++ /dev/null @@ -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) diff --git a/test/Hasklepias/Cohort/CoreSpec.hs b/test/Hasklepias/Cohort/CoreSpec.hs new file mode 100644 --- /dev/null +++ b/test/Hasklepias/Cohort/CoreSpec.hs @@ -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 + diff --git a/test/Hasklepias/Cohort/CriteriaSpec.hs b/test/Hasklepias/Cohort/CriteriaSpec.hs --- a/test/Hasklepias/Cohort/CriteriaSpec.hs +++ b/test/Hasklepias/Cohort/CriteriaSpec.hs @@ -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 diff --git a/test/Hasklepias/Cohort/InputSpec.hs b/test/Hasklepias/Cohort/InputSpec.hs new file mode 100644 --- /dev/null +++ b/test/Hasklepias/Cohort/InputSpec.hs @@ -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) diff --git a/test/Hasklepias/CohortSpec.hs b/test/Hasklepias/CohortSpec.hs deleted file mode 100644 --- a/test/Hasklepias/CohortSpec.hs +++ /dev/null @@ -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 - diff --git a/test/Stype/AesonSpec.hs b/test/Stype/AesonSpec.hs new file mode 100644 --- /dev/null +++ b/test/Stype/AesonSpec.hs @@ -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 diff --git a/test/Stype/Numeric/CensoredSpec.hs b/test/Stype/Numeric/CensoredSpec.hs new file mode 100644 --- /dev/null +++ b/test/Stype/Numeric/CensoredSpec.hs @@ -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)))