{-|
Module      : Functions for composing features from events  
Description : Functions for composing features. 
Copyright   : (c) NoviSci, Inc 2020
License     : BSD3
Maintainer  : bsaul@novisci.com

Provides functions used in defining @'Features.Feature'@ from 
@'EventData.Event'@s.
-}
{-# OPTIONS_HADDOCK hide #-}
{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE TupleSections #-}

module Hasklepias.FeatureEvents(
    -- ** Container predicates
      isNotEmpty
    , atleastNofX
    , anyGapsWithinAtLeastDuration
    , allGapsWithinLessThanDuration

    -- **  Finding occurrences of concepts
    , nthConceptOccurrence
    , firstConceptOccurrence

    -- ** Reshaping containers
    , allPairs
    , pairs
    , splitByConcepts

    -- ** Create filters
    , makeConceptsFilter
    , makePairedFilter

    -- ** Manipulating Dates
    , yearFromDay
    , monthFromDay
    , dayOfMonthFromDay

    -- ** Functions for manipulating intervals
    , lookback
    , lookahead

    -- ** Misc functions
    , computeAgeAt
    , pairGaps
) where


import IntervalAlgebra                      ( Intervallic
                                            , IntervalSizeable(..)
                                            , ComparativePredicateOf1
                                            , ComparativePredicateOf2
                                            , Interval
                                            , IntervalCombinable(..)
                                            , begin
                                            , end
                                            , beginerval
                                            , enderval )
import IntervalAlgebra.PairedInterval       ( PairedInterval, getPairData )
import IntervalAlgebra.IntervalUtilities    ( durations, gapsWithin )
import EventData                            ( Events
                                            , Event
                                            , ConceptEvent
                                            , ctxt
                                            , context
                                            , Domain (Demographics) )
import EventData.Context                    ( Concept
                                            , Concepts
                                            , Context
                                            , HasConcept( hasConcepts )
                                            , facts
                                            , _facts )
import EventData.Context.Domain             ( Domain(..)
                                            , DemographicsFacts(..)
                                            , DemographicsInfo(..)
                                            , DemographicsField(..)
                                            , demo
                                            , info
                                            , _Demographics )
import Safe                                 ( headMay, lastMay )
import Control.Applicative                  ( Applicative(liftA2) )
import Control.Monad                        ( Functor(fmap), (=<<) )
import Data.Bool                            ( Bool(..), (&&), not, (||), otherwise )
import Data.Either                          ( either )
import Data.Eq                              ( Eq )
import Data.Foldable                        ( Foldable(length, null)
                                            , all
                                            , any
                                            , toList )
import Data.Function                        ( (.), ($), const )
import Data.Functor                         ( Functor(fmap) )
import Data.Int                             ( Int )
import Data.Maybe                           ( Maybe(..), maybe, mapMaybe )
import Data.Monoid                          ( Monoid(..), (<>) )
import Data.Ord                             ( Ord(..) )
import Data.Time.Calendar                   ( Day
                                            , Year
                                            , MonthOfYear
                                            , DayOfMonth
                                            , diffDays
                                            , toGregorian )
import Data.Text                            ( Text )
import Data.Tuple                           ( fst, uncurry )
import Witherable                           ( filter, Filterable, Witherable )
import           GHC.Num                        ( Integer, fromInteger )
import           GHC.Real                       ( RealFrac(floor), (/) )

-- | Is the input list empty? 
isNotEmpty :: [a] -> Bool
isNotEmpty :: [a] -> Bool
isNotEmpty = Bool -> Bool
not(Bool -> Bool) -> ([a] -> Bool) -> [a] -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
.[a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null

-- | Filter 'Events' to those that have any of the provided concepts.
makeConceptsFilter ::
    ( Filterable f ) =>
       [Text]    -- ^ the list of concepts by which to filter 
    -> f (Event a)
    -> f (Event a)
makeConceptsFilter :: [Text] -> f (Event a) -> f (Event a)
makeConceptsFilter [Text]
cpts = (Event a -> Bool) -> f (Event a) -> f (Event a)
forall (f :: * -> *) a. Filterable f => (a -> Bool) -> f a -> f a
filter (Event a -> [Text] -> Bool
forall a. HasConcept a => a -> [Text] -> Bool
`hasConcepts` [Text]
cpts)

-- | Filter 'Events' to a single @'Maybe' 'Event'@, based on a provided function,
--   with the provided concepts. For example, see 'firstConceptOccurrence' and
--  'lastConceptOccurrence'.
nthConceptOccurrence ::
    ( Filterable f ) =>
       (f (Event a) -> Maybe (Event a)) -- ^ function used to select a single event
    -> [Text]
    -> f (Event a)
    -> Maybe (Event a)
nthConceptOccurrence :: (f (Event a) -> Maybe (Event a))
-> [Text] -> f (Event a) -> Maybe (Event a)
nthConceptOccurrence f (Event a) -> Maybe (Event a)
f [Text]
c = f (Event a) -> Maybe (Event a)
f(f (Event a) -> Maybe (Event a))
-> (f (Event a) -> f (Event a)) -> f (Event a) -> Maybe (Event a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
.[Text] -> f (Event a) -> f (Event a)
forall (f :: * -> *) a.
Filterable f =>
[Text] -> f (Event a) -> f (Event a)
makeConceptsFilter [Text]
c

-- | Finds the *first* occurrence of an 'Event' with at least one of the concepts.
--   Assumes the input 'Events' list is appropriately sorted.
firstConceptOccurrence ::
    ( Witherable f ) =>
      [Text]
    -> f (Event a)
    -> Maybe (Event a)
firstConceptOccurrence :: [Text] -> f (Event a) -> Maybe (Event a)
firstConceptOccurrence = (f (Event a) -> Maybe (Event a))
-> [Text] -> f (Event a) -> Maybe (Event a)
forall (f :: * -> *) a.
Filterable f =>
(f (Event a) -> Maybe (Event a))
-> [Text] -> f (Event a) -> Maybe (Event a)
nthConceptOccurrence ([Event a] -> Maybe (Event a)
forall a. [a] -> Maybe a
headMay ([Event a] -> Maybe (Event a))
-> (f (Event a) -> [Event a]) -> f (Event a) -> Maybe (Event a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. f (Event a) -> [Event a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList)

-- | Finds the *last* occurrence of an 'Event' with at least one of the concepts.
--   Assumes the input 'Events' list is appropriately sorted.
lastConceptOccurrence ::
    ( Witherable f ) =>
      [Text]
    -> f (Event a)
    -> Maybe (Event a)
lastConceptOccurrence :: [Text] -> f (Event a) -> Maybe (Event a)
lastConceptOccurrence = (f (Event a) -> Maybe (Event a))
-> [Text] -> f (Event a) -> Maybe (Event a)
forall (f :: * -> *) a.
Filterable f =>
(f (Event a) -> Maybe (Event a))
-> [Text] -> f (Event a) -> Maybe (Event a)
nthConceptOccurrence ([Event a] -> Maybe (Event a)
forall a. [a] -> Maybe a
lastMay ([Event a] -> Maybe (Event a))
-> (f (Event a) -> [Event a]) -> f (Event a) -> Maybe (Event a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. f (Event a) -> [Event a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList)

-- | Does 'Events' have at least @n@ events with any of the Concept in @x@.
atleastNofX ::
      Int -- ^ n
   -> [Text] -- ^ x
   -> Events a -> Bool
atleastNofX :: Int -> [Text] -> Events a -> Bool
atleastNofX Int
n [Text]
x Events a
es = Events a -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length ([Text] -> Events a -> Events a
forall (f :: * -> *) a.
Filterable f =>
[Text] -> f (Event a) -> f (Event a)
makeConceptsFilter [Text]
x Events a
es) Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
n

-- | Takes a predicate of intervals and a predicate on the data part of a 
--   paired interval to create a single predicate such that both input
--   predicates should hold.
makePairPredicate ::  Ord a =>
       ComparativePredicateOf2 (i0 a) ((PairedInterval b) a)
    -> i0 a
    -> (b -> Bool)
    -> (PairedInterval b a -> Bool)
makePairPredicate :: ComparativePredicateOf2 (i0 a) (PairedInterval b a)
-> i0 a -> (b -> Bool) -> PairedInterval b a -> Bool
makePairPredicate ComparativePredicateOf2 (i0 a) (PairedInterval b a)
pi i0 a
i b -> Bool
pd PairedInterval b a
x =  ComparativePredicateOf2 (i0 a) (PairedInterval b a)
pi i0 a
i PairedInterval b a
x Bool -> Bool -> Bool
&& b -> Bool
pd (PairedInterval b a -> b
forall b a. PairedInterval b a -> b
getPairData PairedInterval b a
x)

-- | 
makePairedFilter :: Ord a =>
       ComparativePredicateOf2 (i0 a) ((PairedInterval b) a)
    -> i0 a
    -> (b -> Bool)
    -> [PairedInterval b a]
    -> [PairedInterval b a]
makePairedFilter :: ComparativePredicateOf2 (i0 a) (PairedInterval b a)
-> i0 a
-> (b -> Bool)
-> [PairedInterval b a]
-> [PairedInterval b a]
makePairedFilter ComparativePredicateOf2 (i0 a) (PairedInterval b a)
fi i0 a
i b -> Bool
fc = (PairedInterval b a -> Bool)
-> [PairedInterval b a] -> [PairedInterval b a]
forall (f :: * -> *) a. Filterable f => (a -> Bool) -> f a -> f a
filter (ComparativePredicateOf2 (i0 a) (PairedInterval b a)
-> i0 a -> (b -> Bool) -> PairedInterval b a -> Bool
forall a (i0 :: * -> *) b.
Ord a =>
ComparativePredicateOf2 (i0 a) (PairedInterval b a)
-> i0 a -> (b -> Bool) -> PairedInterval b a -> Bool
makePairPredicate ComparativePredicateOf2 (i0 a) (PairedInterval b a)
fi i0 a
i b -> Bool
fc)

-- | Generate all pair-wise combinations from two lists.
allPairs :: Applicative f => f a  -> f b -> f (a, b)
allPairs :: f a -> f b -> f (a, b)
allPairs = (a -> b -> (a, b)) -> f a -> f b -> f (a, b)
forall (f :: * -> *) a b c.
Applicative f =>
(a -> b -> c) -> f a -> f b -> f c
liftA2 (,)

-- | Generate all pair-wise combinations of a single list.
pairs :: [a]  -> [(a,a)]
-- copied from the hgeometry library (https://hackage.haskell.org/package/hgeometry-0.12.0.4/docs/src/Data.Geometry.Arrangement.Internal.html#allPairs)
-- TODO: better naming differences between pairs and allPairs?
-- TODO: generalize this function over more containers?
pairs :: [a] -> [(a, a)]
pairs = [a] -> [(a, a)]
forall t. [t] -> [(t, t)]
go
  where
    go :: [t] -> [(t, t)]
go []     = []
    go (t
x:[t]
xs) = (t -> (t, t)) -> [t] -> [(t, t)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (t
x,) [t]
xs [(t, t)] -> [(t, t)] -> [(t, t)]
forall a. Semigroup a => a -> a -> a
<> [t] -> [(t, t)]
go [t]
xs

-- | Split an @Events a@ into a pair of @Events a@. The first element contains
--   events have any of the concepts in the first argument, similarly for the
--   second element.
splitByConcepts ::
    ( Filterable f ) =>
       [Text]
    -> [Text]
    -> f (Event a)
    -> (f (Event a), f (Event a))
splitByConcepts :: [Text] -> [Text] -> f (Event a) -> (f (Event a), f (Event a))
splitByConcepts [Text]
c1 [Text]
c2 f (Event a)
es = ( (Event a -> Bool) -> f (Event a) -> f (Event a)
forall (f :: * -> *) a. Filterable f => (a -> Bool) -> f a -> f a
filter (Event a -> [Text] -> Bool
forall a. HasConcept a => a -> [Text] -> Bool
`hasConcepts` [Text]
c1) f (Event a)
es
                           , (Event a -> Bool) -> f (Event a) -> f (Event a)
forall (f :: * -> *) a. Filterable f => (a -> Bool) -> f a -> f a
filter (Event a -> [Text] -> Bool
forall a. HasConcept a => a -> [Text] -> Bool
`hasConcepts` [Text]
c2) f (Event a)
es)

-- | Gets the durations of gaps (via 'IntervalAlgebra.(><)') between all pairs 
--   of the input. 
pairGaps :: (Intervallic i a, IntervalSizeable a b, IntervalCombinable i a) =>
     [i a]
  -> [Maybe b]
pairGaps :: [i a] -> [Maybe b]
pairGaps [i a]
es = ((i a, i a) -> Maybe b) -> [(i a, i a)] -> [Maybe b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((i a -> b) -> Maybe (i a) -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap i a -> b
forall a b (i :: * -> *).
(IntervalSizeable a b, Intervallic i a) =>
i a -> b
duration (Maybe (i a) -> Maybe b)
-> ((i a, i a) -> Maybe (i a)) -> (i a, i a) -> Maybe b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (i a -> i a -> Maybe (i a)) -> (i a, i a) -> Maybe (i a)
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry i a -> i a -> Maybe (i a)
forall (i :: * -> *) a.
IntervalCombinable i a =>
i a -> i a -> Maybe (i a)
(><)) ([i a] -> [(i a, i a)]
forall t. [t] -> [(t, t)]
pairs [i a]
es)

-- | Create a predicate function that checks whether within a provided spanning
--   interval, are there (e.g. any, all) gaps of (e.g. <, <=, >=, >) a specified
--   duration among  the input intervals?
makeGapsWithinPredicate ::
       ( Monoid (t (Interval a))
       , Monoid (t (Maybe (Interval a)))
       , Applicative t
       , Witherable t
       , IntervalSizeable a b
       , Intervallic i0 a
       , IntervalCombinable i1 a) =>
          ((b -> Bool) ->  t b -> Bool)
        -> (b -> b -> Bool)
        -> (b -> i0 a -> t (i1 a) -> Bool)
makeGapsWithinPredicate :: ((b -> Bool) -> t b -> Bool)
-> (b -> b -> Bool) -> b -> i0 a -> t (i1 a) -> Bool
makeGapsWithinPredicate (b -> Bool) -> t b -> Bool
f b -> b -> Bool
op b
gapDuration i0 a
interval t (i1 a)
l =
     Bool -> (t (Interval a) -> Bool) -> Maybe (t (Interval a)) -> Bool
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Bool
False ((b -> Bool) -> t b -> Bool
f (b -> b -> Bool
`op` b
gapDuration) (t b -> Bool) -> (t (Interval a) -> t b) -> t (Interval a) -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. t (Interval a) -> t b
forall (f :: * -> *) (i :: * -> *) a b.
(Functor f, Intervallic i a, IntervalSizeable a b) =>
f (i a) -> f b
durations) (i0 a -> t (i1 a) -> Maybe (t (Interval a))
forall (f :: * -> *) a b (i0 :: * -> *) (i1 :: * -> *).
(Applicative f, Witherable f, Monoid (f (Interval a)),
 Monoid (f (Maybe (Interval a))), IntervalSizeable a b,
 Intervallic i0 a, IntervalCombinable i1 a) =>
i0 a -> f (i1 a) -> Maybe (f (Interval a))
gapsWithin i0 a
interval t (i1 a)
l)

-- | Within a provided spanning interval, are there any gaps of at least the
--   specified duration among the input intervals?
anyGapsWithinAtLeastDuration ::
      ( IntervalSizeable a b
      , Intervallic i0 a
      , IntervalCombinable i1 a
      , Monoid (t (Interval a))
      , Monoid (t (Maybe (Interval a)))
      , Applicative t
      , Witherable t) =>
        b       -- ^ duration of gap
        -> i0 a  -- ^ within this interval
        -> t (i1 a)
        -> Bool
anyGapsWithinAtLeastDuration :: b -> i0 a -> t (i1 a) -> Bool
anyGapsWithinAtLeastDuration = ((b -> Bool) -> t b -> Bool)
-> (b -> b -> Bool) -> b -> i0 a -> t (i1 a) -> Bool
forall (t :: * -> *) a b (i0 :: * -> *) (i1 :: * -> *).
(Monoid (t (Interval a)), Monoid (t (Maybe (Interval a))),
 Applicative t, Witherable t, IntervalSizeable a b,
 Intervallic i0 a, IntervalCombinable i1 a) =>
((b -> Bool) -> t b -> Bool)
-> (b -> b -> Bool) -> b -> i0 a -> t (i1 a) -> Bool
makeGapsWithinPredicate (b -> Bool) -> t b -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any b -> b -> Bool
forall a. Ord a => a -> a -> Bool
(>=)

-- | Within a provided spanning interval, are all gaps less than the specified
--   duration among the input intervals?
--
-- >>> allGapsWithinLessThanDuration 30 (beginerval 100 (0::Int)) [beginerval 5 (-1), beginerval 99 10]
-- True
allGapsWithinLessThanDuration ::
      ( IntervalSizeable a b
      , Intervallic i0 a
      , IntervalCombinable i1 a
      , Monoid (t (Interval a))
      , Monoid (t (Maybe (Interval a)))
      , Applicative t
      , Witherable t) =>
        b       -- ^ duration of gap
        -> i0 a  -- ^ within this interval
        -> t (i1 a)
        -> Bool
allGapsWithinLessThanDuration :: b -> i0 a -> t (i1 a) -> Bool
allGapsWithinLessThanDuration = ((b -> Bool) -> t b -> Bool)
-> (b -> b -> Bool) -> b -> i0 a -> t (i1 a) -> Bool
forall (t :: * -> *) a b (i0 :: * -> *) (i1 :: * -> *).
(Monoid (t (Interval a)), Monoid (t (Maybe (Interval a))),
 Applicative t, Witherable t, IntervalSizeable a b,
 Intervallic i0 a, IntervalCombinable i1 a) =>
((b -> Bool) -> t b -> Bool)
-> (b -> b -> Bool) -> b -> i0 a -> t (i1 a) -> Bool
makeGapsWithinPredicate (b -> Bool) -> t b -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all b -> b -> Bool
forall a. Ord a => a -> a -> Bool
(<)

-- | Compute the "age" in years between two calendar days. The difference between
--   the days is rounded down.
computeAgeAt :: Day -> Day -> Integer
computeAgeAt :: Day -> Day -> Integer
computeAgeAt Day
bd Day
at = Double -> Integer
forall a b. (RealFrac a, Integral b) => a -> b
floor (Integer -> Double
forall a. Num a => Integer -> a
fromInteger (Day -> Day -> Integer
diffDays Day
at Day
bd) Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/ Double
365.25)

-- | Gets the 'Year' from a 'Data.Time.Calendar.Day'.
yearFromDay :: Day -> Year
yearFromDay :: Day -> Integer
yearFromDay = (\(Integer
y, Int
m, Int
d) -> Integer
y) ((Integer, Int, Int) -> Integer)
-> (Day -> (Integer, Int, Int)) -> Day -> Integer
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Day -> (Integer, Int, Int)
toGregorian

-- | Gets the 'Data.Time.Calendar.MonthOfDay' from a 'Data.Time.Calendar.Day'.
monthFromDay :: Day -> MonthOfYear
monthFromDay :: Day -> Int
monthFromDay = (\(Integer
y, Int
m, Int
d) -> Int
m) ((Integer, Int, Int) -> Int)
-> (Day -> (Integer, Int, Int)) -> Day -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Day -> (Integer, Int, Int)
toGregorian

-- | Gets the 'Data.Time.Calendar.DayOfMonth' from a 'Data.Time.Calendar.Day'.
dayOfMonthFromDay :: Day -> DayOfMonth
dayOfMonthFromDay :: Day -> Int
dayOfMonthFromDay = (\(Integer
y, Int
m, Int
d) -> Int
d) ((Integer, Int, Int) -> Int)
-> (Day -> (Integer, Int, Int)) -> Day -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Day -> (Integer, Int, Int)
toGregorian

-- | Creates a new @Interval@ of a provided lookback duration ending at the 
--   'begin' of the input interval.
--
-- >>> lookback 4 (beginerval 10 (1 :: Int))
-- (-3, 1)
lookback :: (Intervallic i a, IntervalSizeable a b) =>
    b   -- ^ lookback duration
    -> i a
    -> Interval a
lookback :: b -> i a -> Interval a
lookback b
d i a
x = b -> a -> Interval a
forall a b. IntervalSizeable a b => b -> a -> Interval a
enderval b
d (i a -> a
forall (i :: * -> *) a. Intervallic i a => i a -> a
begin i a
x)

-- | Creates a new @Interval@ of a provided lookahead duration beginning at the 
--   'end' of the input interval.
--
-- >>> lookahead 4 (beginerval 1 (1 :: Int))
-- (2, 6)
lookahead :: (Intervallic i a, IntervalSizeable a b) =>
    b   -- ^ lookahead duration
    -> i a
    -> Interval a
lookahead :: b -> i a -> Interval a
lookahead b
d i a
x = b -> a -> Interval a
forall a b. IntervalSizeable a b => b -> a -> Interval a
beginerval b
d (i a -> a
forall (i :: * -> *) a. Intervallic i a => i a -> a
end i a
x)