diff --git a/ChangeLog.md b/ChangeLog.md --- a/ChangeLog.md +++ b/ChangeLog.md @@ -1,5 +1,12 @@ # Changelog for hasklepias +## 0.5.0 + +* Changes what was the `Feature` type into `FeatureData`. The `Feature` type becomes a container for `FeatureData` with a name and attributes. +* Adds the `FeatureSpec` type which contains `FeatureDefinition`s plus a name and attributes. The name and attributes are mapped directly into the resulting `Feature` when a `FeatureSpec` is evaluated, while the `FeatureDefinition` is evaluated into `FeatureData`. The `evalEFFeature`, `evalFEFFeature`, and `evalFFFFeature` are provided for evaluating a `FeatureSpec` according the corresponding `FeatureDefinition`. +* Adds additional functions to reexports. +* Adds `witherable` dependency to use a more general `filter` function. + ## 0.4.4 * Adds the `FFF` option to `FeatureDefinition` to define `(Feature f -> Feature e -> Feature d)` along with corresponding `defineFFF` and `applyFFF`. @@ -14,7 +21,7 @@ ## 0.4.2 -* Updates `interval-algebra` to 0.8.0 +* Updates `interval-algebra` to 0.8.0. ## 0.4.1 diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -20,7 +20,7 @@ At this time, `hasklepias` can be used for experimenting with `Feature` definitions. A `Feature d` is currently a wrapper of an [`Either`](https://hackage.haskell.org/package/base-4.15.0.0/docs/Data-Either.html) type: ```haskell -type Feature d = Feature { getFeature :: Either MissingReason d } +type Feature d = Feature { getFeatureData :: Either MissingReason d } ``` The `Either` type means there are two possibilities for the type of a `Feature`. The `Left` can be a `MissingReason`, which is a sum type enumerating the reasons that the data is missing: diff --git a/examples/ExampleFeatures1.hs b/examples/ExampleFeatures1.hs --- a/examples/ExampleFeatures1.hs +++ b/examples/ExampleFeatures1.hs @@ -7,8 +7,6 @@ -} {-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE AllowAmbiguousTypes #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE MonoLocalBinds #-} {-# LANGUAGE NoImplicitPrelude #-} @@ -35,22 +33,22 @@ {- The baseline interval is the interval (b - 60, b), where b is the begin of index. Here, baseline is defined as function that takes a filtration function -as an argument, so that the baseline feature can be used to filter events +as an argument, so that the baseline FeatureData can be used to filter events based on different predicate functions. -} baseline :: (Intervallic Interval a, IntervalSizeable a b) => - Feature (Interval a) -- ^ pass the result of index to get a baseline filter - -> Feature (Interval a) + FeatureData (Interval a) -- ^ pass the result of index to get a baseline filter + -> FeatureData (Interval a) baseline = fmap (enderval 60 . begin) bline :: (Intervallic Interval a, IntervalSizeable a b) => Events a - -> Feature (Interval a) + -> FeatureData (Interval a) bline = baseline . applyEF indexDef flwup :: (Intervallic Interval a, IntervalSizeable a b) => Events a - -> Feature (Interval a) + -> FeatureData (Interval a) flwup = fmap (beginerval 30 . begin) . applyEF indexDef {- @@ -154,14 +152,14 @@ getUnitFeatures :: Events Int - -> (Feature (Interval Int) - , Feature Bool - , Feature (Bool, Maybe (Interval Int)) - , Feature (Bool, Maybe (Interval Int)) - , Feature Bool - , Feature (Maybe Int) - , Feature (Int, Maybe Int) - , Feature (Maybe (Int, Int)) + -> (FeatureData (Interval Int) + , FeatureData Bool + , FeatureData (Bool, Maybe (Interval Int)) + , FeatureData (Bool, Maybe (Interval Int)) + , FeatureData Bool + , FeatureData (Maybe Int) + , FeatureData (Int, Maybe Int) + , FeatureData (Maybe (Int, Int)) ) getUnitFeatures x = ( applyEF indexDef x diff --git a/examples/ExampleFeatures2.hs b/examples/ExampleFeatures2.hs --- a/examples/ExampleFeatures2.hs +++ b/examples/ExampleFeatures2.hs @@ -7,8 +7,6 @@ -} {-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE AllowAmbiguousTypes #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE MonoLocalBinds #-} {-# LANGUAGE NoImplicitPrelude #-} @@ -24,7 +22,7 @@ , Intervallic Interval a , IntervalSizeable a b) => Events a - -> Feature [b] + -> FeatureData [b] durationOfHospitalizedAntibiotics es | null y = featureL $ Other "no cases" | otherwise = featureR $ durations y diff --git a/examples/ExampleFeatures3.hs b/examples/ExampleFeatures3.hs --- a/examples/ExampleFeatures3.hs +++ b/examples/ExampleFeatures3.hs @@ -7,8 +7,6 @@ -} {-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE AllowAmbiguousTypes #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE MonoLocalBinds #-} {-# LANGUAGE NoImplicitPrelude #-} @@ -43,7 +41,7 @@ ) -flwup :: Feature (Interval Int) +flwup :: FeatureData (Interval Int) flwup = featureR $ beginerval 50 0 exampleFeatures3Spec :: Spec 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.4.4 +version: 0.5.0 description: Please see the README on GitHub at homepage: https://github.com/novisci/asclepias/#readme bug-reports: https://github.com/novisci/asclepias/issues @@ -52,6 +52,7 @@ , safe >= 0.3 , vector >=0.12 , QuickCheck + , witherable >= 0.4 default-language: Haskell2010 test-suite hasklepias-test diff --git a/src/Hasklepias/Reexports.hs b/src/Hasklepias/Reexports.hs --- a/src/Hasklepias/Reexports.hs +++ b/src/Hasklepias/Reexports.hs @@ -16,17 +16,20 @@ , module Control.Monad , module Control.Applicative , module Data.Bool - , module Data.Time.Calendar + , module Data.Either + , module Data.Eq , module Data.Int , module Data.Maybe , module Data.Function , module Data.Functor , module Data.List , module Data.Ord + , module Data.Time.Calendar , module Data.Text , module Data.Tuple , module Safe , module Flow + , module Witherable ) where import safe GHC.Num ( Integer ) @@ -36,11 +39,18 @@ , (&&), not, (||) , bool , otherwise ) +import safe Data.Either ( Either(..)) +import safe Data.Eq ( Eq, (==)) import safe Data.Function ( (.), ($), const, id ) import safe Data.Functor ( fmap ) import safe Data.Int ( Int ) -import safe Data.List ( all, map, filter, length, null - , zipWith ) +import safe Data.List ( all + , any + , map + , length + , null + , zipWith + , (++) ) import safe Data.Maybe ( Maybe(..), maybe, isJust, @@ -58,5 +68,6 @@ , diffDays ) import safe Data.Text ( pack, Text ) import safe Data.Tuple ( fst, snd, uncurry, curry ) +import safe Witherable ( Filterable(filter) ) import safe Flow ( (!>), (.>), () ) import Safe ( headMay, lastMay ) diff --git a/src/Hasklepias/Types/Context.hs b/src/Hasklepias/Types/Context.hs --- a/src/Hasklepias/Types/Context.hs +++ b/src/Hasklepias/Types/Context.hs @@ -29,14 +29,14 @@ import GHC.Show ( Show(show) ) import Data.Bool ( Bool ) import Data.Eq ( Eq ) -import Data.Function ((.), ($)) +import Data.Function ( (.), ($) ) import Data.List ( all, any, map ) import Data.Maybe ( Maybe(Nothing) ) import Data.Monoid ( (<>), Monoid(mempty) ) import Data.Ord ( Ord ) import Data.Semigroup ( Semigroup((<>)) ) -import Data.Text (Text) -import Data.Set (Set +import Data.Text ( Text ) +import Data.Set ( Set , fromList, union, empty, map, toList, member) -- | A @Context@ consists of three parts: @concepts@, @facts@, and @source@. diff --git a/src/Hasklepias/Types/Feature.hs b/src/Hasklepias/Types/Feature.hs --- a/src/Hasklepias/Types/Feature.hs +++ b/src/Hasklepias/Types/Feature.hs @@ -15,7 +15,9 @@ module Hasklepias.Types.Feature( -- * Types - Feature(..) + FeatureSpec(..) + , Feature(..) + , FeatureData(..) , MissingReason(..) , FeatureDefinition(..) , defineEF @@ -27,52 +29,79 @@ , applyFFF , featureR , featureL - + , evalEFFeature + , evalFEFFeature + , evalFFFFeature ) where import GHC.Read ( Read ) import GHC.Show ( Show ) -import GHC.Generics ( Generic ) +import GHC.Generics ( Generic, D ) import Data.Either ( Either(..) ) import Data.Eq ( Eq ) import Data.Functor ( Functor(fmap) ) import Data.Function ( ($), (.) ) import Data.Maybe ( Maybe(..) ) -import Data.String ( String ) +import Data.Text ( Text ) import Hasklepias.Types.Event ( Events ) import IntervalAlgebra ( Interval, Intervallic ) +-- import safe Test.QuickCheck ( Property ) -{- | A 'Feature' is a @'Either' 'MissingReason' d@, where @d@ can be any type +{- | A 'FeatureSpec' contains all the information needed to derive a 'Feature': + * its name + * its attributes + * the function needed to derive a feature (i.e. the 'FeatureDefinition') +-} +data (Show b) => FeatureSpec b f e a d = FeatureSpec { + getSpecName :: Text + , getSpecAttr :: b + , getDefn :: FeatureDefinition f e a d + -- To add in future: an optional list of properties to check + -- , getProp :: Maybe [Feature d -> Events a -> Property] + } + +{- | A 'Feature' contains the following: + * a name + * its attributes + * 'FeatureData' +-} +data (Show b) => Feature b d = Feature { + getName :: Text + , getAttr :: b + , getData :: FeatureData d + } + +{- | 'FeatureData' is @'Either' 'MissingReason' d@, where @d@ can be any type of data derivable from 'Hasklepias.Event.Events'. -} -newtype Feature d = Feature { getFeature :: Either MissingReason d } +newtype FeatureData d = FeatureData { getFeatureData :: Either MissingReason d } deriving (Generic, Show, Eq) -instance Functor Feature where - fmap f (Feature x) = Feature (fmap f x) +instance Functor FeatureData where + fmap f (FeatureData x) = FeatureData (fmap f x) -- | Create the 'Right' side of a 'Feature'. -featureR :: d -> Feature d -featureR = Feature . Right +featureR :: d -> FeatureData d +featureR = FeatureData . Right -- | Create the 'Left' side of a 'Feature'. -featureL :: MissingReason -> Feature d -featureL = Feature . Left +featureL :: MissingReason -> FeatureData d +featureL = FeatureData . Left -- | A 'Feature' may be missing for any number of reasons. data MissingReason = InsufficientData | Excluded - | Other String + | Other Text | Unknown deriving (Eq, Read, Show, Generic) --- | A type to hold common feature definitions; i.e. functions that return +-- | A type to hold common FeatureData definitions; i.e. functions that return -- features. data FeatureDefinition f e a d = - EF (Events a -> Feature d) - | FEF (Feature e -> Events a -> Feature d) - | FFF (Feature f -> Feature e -> Feature d) + EF (Events a -> FeatureData d) + | FEF (FeatureData e -> Events a -> FeatureData d) + | FFF (FeatureData f -> FeatureData e -> FeatureData d) -- | Define an 'EF' FeatureDefinition defineEF :: (Intervallic Interval a) => @@ -81,7 +110,7 @@ -> (Events a -> Maybe c) -- ^ A function that maps events to an some intermediary Maybe type. -- In the case that this function returns 'Nothing', you get a - -- @Left@ feature with the provided @MissingReason@. Otherwise, + -- @Left@ FeatureData with the provided @MissingReason@. Otherwise, -- the 'Just' result is passed to the next function for final -- transformation to the desired @Feature@ type. -> (c -> d) @@ -95,7 +124,7 @@ ) -- | Extract an 'EF' FeatureDefinition. -applyEF :: FeatureDefinition * * a d -> Events a -> Feature d +applyEF :: FeatureDefinition * * a d -> Events a -> FeatureData d applyEF (EF f) = f -- | TODO @@ -106,7 +135,7 @@ -- ^ A function that tranforms the data of a 'Right' input 'Feature' -- and a collection of events into the desired type. -> FeatureDefinition * e a d -defineFEF r g = FEF (\(Feature feat) es -> +defineFEF r g = FEF (\(FeatureData feat) es -> case feat of (Left _) -> featureL r (Right x) -> featureR (g x es) @@ -116,18 +145,18 @@ defineFEF2 :: (Intervallic Interval a) => MissingReason -- ^ The reason if the input 'Feature' is a 'Left'. - -> (e -> Events a -> Feature d) + -> (e -> Events a -> FeatureData d) -- ^ A function that tranforms the data of a 'Right' input 'Feature' -- and a collection of events into the desired type. -> FeatureDefinition * e a d -defineFEF2 r g = FEF (\(Feature feat) es -> +defineFEF2 r g = FEF (\(FeatureData feat) es -> case feat of (Left _) -> featureL r (Right x) -> g x es ) -- | Extract a 'FEF' FeatureDefinition -applyFEF :: FeatureDefinition * e a d -> Feature e -> Events a -> Feature d +applyFEF :: FeatureDefinition * e a d -> FeatureData e -> Events a -> FeatureData d applyFEF (FEF f) = f -- | TODO @@ -136,7 +165,7 @@ -> MissingReason -> (f -> e -> d) -> FeatureDefinition f e * d -defineFFF r1 r2 g = FFF (\(Feature feat1) (Feature feat2) -> +defineFFF r1 r2 g = FFF (\(FeatureData feat1) (FeatureData feat2) -> case ( feat1, feat2 ) of ( Left _ , Left _ ) -> featureL r1 ( Left _ , _ ) -> featureL r1 @@ -145,5 +174,25 @@ ) -- | Extract a 'FFF' FeatureDefinition -applyFFF :: FeatureDefinition f e * d -> Feature f -> Feature e -> Feature d +applyFFF :: FeatureDefinition f e * d -> FeatureData f -> FeatureData e -> FeatureData d applyFFF (FFF f) = f + +-- | TODO +makeFeatureSpec :: Show b => Text -> b -> FeatureDefinition f e a d -> + FeatureSpec b f e a d +makeFeatureSpec = FeatureSpec + +-- | TODO +evalEFFeature :: Show b => FeatureSpec b * * a d -> Events a -> Feature b d +evalEFFeature (FeatureSpec n atr def) es = + Feature n atr (applyEF def es) + +-- | TODO +evalFEFFeature :: Show b => FeatureSpec b * e a d -> Feature b e -> Events a -> Feature b d +evalFEFFeature (FeatureSpec n atr def) feat es = + Feature n atr (applyFEF def (getData feat) es) + +-- | TODO +evalFFFFeature :: Show b => FeatureSpec b f e * d -> Feature b f -> Feature b e -> Feature b d +evalFFFFeature (FeatureSpec n atr def) feat1 feat2 = + Feature n atr (applyFFF def (getData feat1) (getData feat2)) diff --git a/src/Hasklepias/Types/Feature/Aeson.hs b/src/Hasklepias/Types/Feature/Aeson.hs --- a/src/Hasklepias/Types/Feature/Aeson.hs +++ b/src/Hasklepias/Types/Feature/Aeson.hs @@ -11,18 +11,23 @@ module Hasklepias.Types.Feature.Aeson( ) where -import IntervalAlgebra -import GHC.Generics -import Hasklepias.Types.Feature ( MissingReason, Feature(..) ) -import Data.Aeson --- ( ToJSON, toJSON ) +import IntervalAlgebra ( Interval, Intervallic(end, begin) ) +import Hasklepias.Types.Feature ( Feature(..) + , MissingReason + , FeatureData(..) ) +import Data.Aeson ( object, KeyValue((.=)), ToJSON(toJSON) ) instance (ToJSON a, Ord a, Show a)=> ToJSON (Interval a) where - toJSON x = - object ["begin" .= begin x, "end" .= end x] + toJSON x = object ["begin" .= begin x, "end" .= end x] + instance ToJSON MissingReason -instance (ToJSON d)=> ToJSON (Feature d) where - toJSON x = case getFeature x of + +instance (ToJSON d)=> ToJSON (FeatureData d) where + toJSON x = case getFeatureData x of (Left l) -> toJSON l (Right r) -> toJSON r +instance (Show b, ToJSON b, ToJSON d) => ToJSON (Feature b d) where + toJSON x = object [ "name" .= getName x + , "attrs" .= toJSON (getAttr x) + , "data" .= toJSON (getData x) ] diff --git a/test/Hasklepias/Types/Feature/AesonSpec.hs b/test/Hasklepias/Types/Feature/AesonSpec.hs --- a/test/Hasklepias/Types/Feature/AesonSpec.hs +++ b/test/Hasklepias/Types/Feature/AesonSpec.hs @@ -19,7 +19,7 @@ index:: (Intervallic Interval a) => Events a - -> Feature (Interval a) + -> FeatureData (Interval a) index es = case firstConceptOccurrence ["enrollment"] es of Nothing -> featureL (Other "No Enrollment")