packages feed

hasklepias 0.13.0 → 0.13.1

raw patch · 12 files changed

+208/−73 lines, 12 files

Files

ChangeLog.md view
@@ -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.
exampleApp/Main.hs view
@@ -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
examples/ExampleCohort1.hs view
@@ -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   ]
hasklepias.cabal view
@@ -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 <https://github.com/novisci/asclepias#readme> 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
src/FeatureCompose.hs view
@@ -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 "" "" ""+
src/FeatureCompose/Aeson.hs view
@@ -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) ]
src/FeatureCompose/Attributes.hs view
@@ -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
+ src/FeatureCompose/Featureable.hs view
@@ -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+
src/Hasklepias.hs view
@@ -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
src/Hasklepias/Cohort/Index.hs view
@@ -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)
src/Hasklepias/ReexportsUnsafe.hs view
@@ -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 )
test/FeatureCompose/AesonSpec.hs view
@@ -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\":\"\"}}"