diff --git a/ChangeLog.md b/ChangeLog.md --- a/ChangeLog.md +++ b/ChangeLog.md @@ -1,5 +1,11 @@ # Changelog for hasklepias +## 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. +* Adds a `"type"` field to JSON output `Feature`s, which is a string representing the type `d` in a `Feature n d`. E.g., for a `Feature "x" Bool`, the result would be : `{..., "type": "Bool", ...}`. +* Adds the `Role` and `Purpose` types, which now are included as part of the `Attributes` type. The `Role`s mostly align with `stype`'s `valid_roles`, with the exception that `"identifier"`, `"index"` and `"censoring"` are not included and `"other"` corresponds to `Unspecified`. + ## 0.13.0 * Adds a rudimentary `Attributes` type and `HasAttributes` typeclass for adding attributes to `Feature`s. This interfaces will likely change in the future, but for now users have the ability to add information like labels to a `Feature`. In fact, `Feature`s which are encoded to JSON are *required* to have attributes. diff --git a/exampleApp/Main.hs b/exampleApp/Main.hs --- a/exampleApp/Main.hs +++ b/exampleApp/Main.hs @@ -39,7 +39,7 @@ critTrue = define $ pure Include instance HasAttributes "dummy" Bool where - getAttributes _ = MkAttributes "Text" "Text" "Text" + getAttributes _ = emptyAttributes {------------------------------------------------------------------------------- Cohort Specifications and evaluation @@ -53,13 +53,15 @@ featEvs = featureEvents events -- | Define the shape of features for a cohort -type CohortFeatures = ( Feature "dummy" Bool ) +type CohortFeatures = [Featureable] + -- (Feature "dummy" Bool ) + -- | Make a function that runs the features for a calendar index makeFeatureRunner :: Events Day -> CohortFeatures -makeFeatureRunner events = eval featureDummy ef +makeFeatureRunner events = [packFeature ( eval featureDummy ef )] where ef = featureEvents events -- | Make a cohort specification for each calendar time diff --git a/examples/ExampleCohort1.hs b/examples/ExampleCohort1.hs --- a/examples/ExampleCohort1.hs +++ b/examples/ExampleCohort1.hs @@ -261,22 +261,45 @@ diabetes = twoOutOneIn ["is_diabetes_outpatient"] ["is_diabetes_inpatient"] instance HasAttributes "diabetes" Bool where - getAttributes _ = MkAttributes + getAttributes _ = basicAttributes "Has Diabetes" "Has Diabetes within baseline" - "Has at least 1 event during the baseline interval has any of the 'cpts1' concepts \ - \ OR there are at least 2 event that have 'cpts2' concepts which have at least 7 days \ - \ between them during the baseline interval" + [Covariate] + ["baseline"] + ckd :: BoolFeatDef "ckd" ckd = twoOutOneIn ["is_ckd_outpatient"] ["is_ckd_inpatient"] +instance HasAttributes "ckd" Bool where + getAttributes _ = basicAttributes + "Has ckd" + "Has CKD within baseline" + [Covariate] + ["baseline"] + ppi :: BoolFeatDef "ppi" ppi = medHx ["is_ppi"] +instance HasAttributes "ppi" Bool where + getAttributes _ = basicAttributes + "Has ppi" + "Has PPI within baseline" + [Covariate] + ["baseline"] + glucocorticoids :: BoolFeatDef "glucocorticoids" glucocorticoids = medHx ["is_glucocorticoids"] +instance HasAttributes "glucocorticoids" Bool where + getAttributes _ = basicAttributes + "Has glucocorticoids" + "Has glucocorticoids within baseline" + [Covariate] + ["baseline"] + +-- instance HasAttributes "" (*) + {------------------------------------------------------------------------------- Cohort Specifications and evaluation -------------------------------------------------------------------------------} @@ -303,38 +326,29 @@ featInd = featureIndex index featEvs = featureEvents events --- | Define the shape of features for a cohort -type ExampleFeatures = - ( Feature "calendarIndex" (Index Interval Day) - , BoolFeat "diabetes" - , BoolFeat "ckd" - , BoolFeat "ppi" - , BoolFeat "glucocorticoids" - ) - -- | Make a function that runs the features for a calendar index makeFeatureRunner :: Index Interval Day -> Events Day - -> ExampleFeatures -makeFeatureRunner index events = ( - idx - , eval diabetes (idx, ef) - , eval ckd (idx, ef) - , eval ppi (idx, ef) - , eval glucocorticoids (idx, ef) - ) + -> [Featureable] +makeFeatureRunner index events = [ + packFeature idx + , packFeature $ eval diabetes (idx, ef) + , packFeature $ eval ckd (idx, ef) + , packFeature $ eval ppi (idx, ef) + , packFeature $ eval glucocorticoids (idx, ef) + ] where idx = featureIndex index ef = featureEvents events -- | Make a cohort specification for each calendar time -cohortSpecs :: [CohortSpec (Events Day) ExampleFeatures] +cohortSpecs :: [CohortSpec (Events Day) [Featureable]] 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 ExampleFeatures] +evalCohorts :: Population (Events Day) -> [Cohort [Featureable]] evalCohorts pop = map (`evalCohort` pop) cohortSpecs {------------------------------------------------------------------------------- @@ -376,19 +390,21 @@ makeExpectedCovariate :: (KnownSymbol name) => FeatureData Bool -> Feature name Bool makeExpectedCovariate = makeFeature +instance HasAttributes "calendarIndex" (Index Interval Day) where + makeExpectedFeatures :: FeatureData (Index Interval Day) -> (FeatureData Bool, FeatureData Bool, FeatureData Bool, FeatureData Bool) - -> ExampleFeatures + -> [Featureable] makeExpectedFeatures i (b1, b2, b3, b4) = - ( makeFeature i :: Feature "calendarIndex" (Index Interval Day) - , makeExpectedCovariate b1 - , makeExpectedCovariate b2 - , makeExpectedCovariate b3 - , makeExpectedCovariate b4 - ) + [ 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 :: [ExampleFeatures] +expectedFeatures1 :: [[Featureable ]] expectedFeatures1 = map (uncurry makeExpectedFeatures) [ (pure $ makeIndex $ beginerval 1 (fromGregorian 2017 4 1), @@ -399,13 +415,13 @@ (pure True, pure False, pure True, pure False)) ] -expectedObsUnita :: [ObsUnit ExampleFeatures] +expectedObsUnita :: [ObsUnit [Featureable]] expectedObsUnita = zipWith (curry MkObsUnit) (replicate 5 "a") expectedFeatures1 -makeExpectedCohort :: AttritionInfo -> [ObsUnit ExampleFeatures] -> Cohort ExampleFeatures +makeExpectedCohort :: AttritionInfo -> [ObsUnit [Featureable]] -> Cohort [Featureable] makeExpectedCohort a x = MkCohort (Just a, x) -expectedCohorts :: [Cohort ExampleFeatures] +expectedCohorts :: [Cohort [Featureable]] expectedCohorts = zipWith (curry MkCohort) @@ -424,5 +440,7 @@ exampleCohort1tests :: TestTree exampleCohort1tests = testGroup "Unit tests for calendar cohorts" [ testCase "expected Features for testData1" $ - evalCohorts testPop @?= expectedCohorts + -- Featureable cannot be tested for equality directly, hence encoding to + -- JSON bytestring and testing that for equality + encode (evalCohorts testPop) @?= encode expectedCohorts ] 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.0 +version: 0.13.1 description: Please see the README on GitHub at homepage: https://github.com/novisci/asclepias/#readme bug-reports: https://github.com/novisci/asclepias/issues @@ -32,6 +32,7 @@ FeatureCompose FeatureCompose.Aeson FeatureCompose.Attributes + FeatureCompose.Featureable FeatureEvents Hasklepias Hasklepias.Aeson diff --git a/src/FeatureCompose.hs b/src/FeatureCompose.hs --- a/src/FeatureCompose.hs +++ b/src/FeatureCompose.hs @@ -9,9 +9,9 @@ -} {-# OPTIONS_HADDOCK hide #-} +{-# LANGUAGE Safe #-} {-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE Safe #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE DataKinds #-} @@ -21,6 +21,9 @@ {-# LANGUAGE FunctionalDependencies #-} {-# LANGUAGE AllowAmbiguousTypes #-} {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ExistentialQuantification #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE InstanceSigs #-} module FeatureCompose( -- * Features and FeatureData @@ -55,9 +58,9 @@ , (=<<), join, liftM, liftM2, liftM3) import safe Data.Either ( Either(..) ) import safe Data.Eq ( Eq(..) ) -import safe Data.Foldable ( Foldable(foldr) ) -import safe Data.Function ( ($), (.) ) -import safe Data.List ( (++) ) +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(..) ) @@ -87,7 +90,7 @@ -} {- tag::featureData[] -} -newtype FeatureData d = MkFeatureData { +newtype FeatureData d = MkFeatureData { getFeatureData :: Either MissingReason d -- ^ Unwrap FeatureData. } {- end::featureData[] -} @@ -336,7 +339,7 @@ -> args -- ^ a tuple of arguments to the @'Definition'@ -> return -instance Eval (FeatureData b -> FeatureData a) +instance Eval (FeatureData b -> FeatureData a) (FeatureData b) (FeatureData a) where eval (D1 f) x = fmap f x eval (D1A f) x = x >>= f @@ -350,7 +353,7 @@ MkFeatureData (Right r) -> r -instance Eval (FeatureData c -> FeatureData b -> FeatureData a) +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) @@ -381,8 +384,11 @@ {- | Initializes @Feature@ @Attributes@ to empty strings -} -class HasAttributes n a where - getAttributes :: Feature n a -> Attributes +-- class HasAttributes n a where +-- getAttributes :: Feature n a -> Attributes +-- getAttributes _ = MkAttributes "" "" "" --- instance HasAttributes name d where --- getAttributes x = 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 --- a/src/FeatureCompose/Aeson.hs +++ b/src/FeatureCompose/Aeson.hs @@ -25,6 +25,7 @@ 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] @@ -36,14 +37,12 @@ (Left l) -> toJSON l (Right r) -> toJSON r +instance ToJSON Role where +instance ToJSON Purpose where instance ToJSON Attributes where --- instance (KnownSymbol n, ToJSON d) => ToJSON (Feature n d) where --- toJSON x = object [ "name" .= show (symbolVal (Proxy @n)) --- -- , "attrs" .= toJSON (getAttributes x) --- , "data" .= toJSON (getFData x) ] - -instance (KnownSymbol n, ToJSON d, HasAttributes n d) => ToJSON (Feature n d) where - toJSON x = object [ "name" .= show (symbolVal (Proxy @n)) +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 --- a/src/FeatureCompose/Attributes.hs +++ b/src/FeatureCompose/Attributes.hs @@ -12,17 +12,43 @@ {-# LANGUAGE DataKinds #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE MultiParamTypeClasses #-} module FeatureCompose.Attributes( - Attributes(..) - -- , HasAttributes(..) + 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. @@ -31,9 +57,29 @@ getShortLabel :: Text , getLongLabel :: Text , getDerivation :: Text + , getPurpose :: Purpose } deriving (Eq, Show, Generic) --- class HasAttributes a where --- getAttributes :: a -> Attributes +{- | 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 new file mode 100644 --- /dev/null +++ b/src/FeatureCompose/Featureable.hs @@ -0,0 +1,37 @@ +{-| +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/Hasklepias.hs b/src/Hasklepias.hs --- a/src/Hasklepias.hs +++ b/src/Hasklepias.hs @@ -25,6 +25,8 @@ , module FeatureCompose.Attributes -- ** Writing Features to JSON , module FeatureCompose.Aeson + -- ** Exporting Features + , module FeatureCompose.Featureable -- * Utilities for defining Features from Events {- | @@ -64,6 +66,7 @@ import FeatureCompose import FeatureCompose.Aeson import FeatureCompose.Attributes +import FeatureCompose.Featureable import FeatureEvents import Hasklepias.Reexports import Hasklepias.ReexportsUnsafe diff --git a/src/Hasklepias/Cohort/Index.hs b/src/Hasklepias/Cohort/Index.hs --- a/src/Hasklepias/Cohort/Index.hs +++ b/src/Hasklepias/Cohort/Index.hs @@ -8,7 +8,8 @@ {-# OPTIONS_HADDOCK hide #-} {-# LANGUAGE NoImplicitPrelude #-} -{-# LANGUAGE Safe #-} +{-# LANGUAGE DeriveGeneric #-} +-- {-# LANGUAGE Safe #-} module Hasklepias.Cohort.Index( Index @@ -16,21 +17,23 @@ , getIndex ) where -import safe GHC.Show ( Show ) -import safe Data.Eq ( Eq ) -import safe IntervalAlgebra ( Intervallic ) +import GHC.Show ( Show ) +import GHC.Generics +import Data.Eq ( Eq ) +import IntervalAlgebra ( Intervallic ) +import Data.Aeson {-| An @Index@ is a wrapper for an @Intervallic@ used to indicate that a particular interval is considered an index interval to which other intervals will be compared. -} -newtype (Intervallic i a) => Index i a = MkIndex { +newtype Index i a = MkIndex { getIndex :: i a -- ^ Unwrap an @Index@ - } deriving (Eq, Show) + } deriving (Eq, Show, Generic) -- | Creates a new @'Index'@. makeIndex :: Intervallic i a => i a -> Index i a makeIndex = MkIndex - +instance (Intervallic i a, ToJSON (i a)) => ToJSON (Index i a) diff --git a/src/Hasklepias/ReexportsUnsafe.hs b/src/Hasklepias/ReexportsUnsafe.hs --- a/src/Hasklepias/ReexportsUnsafe.hs +++ b/src/Hasklepias/ReexportsUnsafe.hs @@ -11,11 +11,13 @@ module Hasklepias.ReexportsUnsafe ( -- * Re-exports - module GHC.IO + module Data.Aeson + , module GHC.IO , module Test.Tasty , module Test.Tasty.HUnit ) where +import Data.Aeson (encode) import GHC.IO ( IO(..) ) -- import GHC.Types ( Any ) diff --git a/test/FeatureCompose/AesonSpec.hs b/test/FeatureCompose/AesonSpec.hs --- a/test/FeatureCompose/AesonSpec.hs +++ b/test/FeatureCompose/AesonSpec.hs @@ -35,9 +35,14 @@ dummy = pure True instance HasAttributes "dummy" Bool where - getAttributes x = MkAttributes "some Label" "longer label..." "a description" + 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" $ @@ -45,9 +50,16 @@ it "dummy encodes correctly" $ encode dummy `shouldBe` - "{\"data\":true,\"name\":\"\\\"dummy\\\"\",\ - \\"attrs\":{\"getDerivation\":\"a description\",\ + "{\"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\":\"\"}}"