{-|
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           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(..)
                                                , mapMaybe
                                                , maybe
                                                )
import           Data.Monoid                    ( (<>)
                                                , Monoid(..)
                                                )
import           Data.Ord                       ( Ord(..) )
import           Data.Text                      ( Text )
import           Data.Time.Calendar             ( Day
                                                , DayOfMonth
                                                , MonthOfYear
                                                , Year
                                                , diffDays
                                                , toGregorian
                                                )
import           Data.Tuple                     ( fst
                                                , uncurry
                                                )
import           EventData                      ( ConceptEvent
                                                , Domain(Demographics)
                                                , Event
                                                , Events
                                                , context
                                                , ctxt
                                                )
import           EventData.Context              ( Concept
                                                , Concepts
                                                , Context
                                                , HasConcept(hasConcepts)
                                                , facts
                                                )
import           EventData.Context.Domain       ( DemographicsFacts(..)
                                                , DemographicsField(..)
                                                , DemographicsInfo(..)
                                                , Domain(..)
                                                , demo
                                                , info
                                                )
import           GHC.Num                        ( Integer
                                                , fromInteger
                                                )
import           GHC.Real                       ( (/)
                                                , RealFrac(floor)
                                                )
import           IntervalAlgebra                ( ComparativePredicateOf1
                                                , ComparativePredicateOf2
                                                , Interval
                                                , IntervalCombinable(..)
                                                , IntervalSizeable(..)
                                                , Intervallic
                                                , begin
                                                , beginerval
                                                , end
                                                , enderval
                                                )
import           IntervalAlgebra.IntervalUtilities
                                                ( durations
                                                , gapsWithin
                                                )
import           IntervalAlgebra.PairedInterval ( PairedInterval
                                                , getPairData
                                                )
import           Safe                           ( headMay
                                                , lastMay
                                                )
import           Witherable                     ( Filterable
                                                , Witherable
                                                , filter
                                                )

-- | 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)