{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DerivingVia #-}

-- |
-- Module      :  ELynx.Tree.Support
-- Description :  Labels with support values
-- Copyright   :  2021 Dominik Schrempf
-- License     :  GPL-3.0-or-later
--
-- Maintainer  :  dominik.schrempf@gmail.com
-- Stability   :  unstable
-- Portability :  portable
--
-- Creation date: Thu Jun 13 14:06:45 2019.
module ELynx.Tree.Support
  ( -- * Non-negative support value
    Support (fromSupport),
    toSupport,
    toSupportUnsafe,
    HasMaybeSupport (..),
    HasSupport (..),

    -- * Functions on trees
    normalizeBranchSupport,
    collapse,
  )
where

import Control.DeepSeq
import Data.Aeson
import Data.Bifunctor
import Data.List
import Data.Semigroup
import ELynx.Tree.Rooted
import ELynx.Tree.Splittable
import GHC.Generics

-- | Non-negative support value.
--
-- However, non-negativity is only checked with 'toSupport', and negative values
-- can be obtained using the 'Num' and related instances.
--
-- See also the documentation of 'ELynx.Tree.Length.Length'.
newtype Support = Support {Support -> Double
fromSupport :: Double}
  deriving (ReadPrec [Support]
ReadPrec Support
Int -> ReadS Support
ReadS [Support]
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
readListPrec :: ReadPrec [Support]
$creadListPrec :: ReadPrec [Support]
readPrec :: ReadPrec Support
$creadPrec :: ReadPrec Support
readList :: ReadS [Support]
$creadList :: ReadS [Support]
readsPrec :: Int -> ReadS Support
$creadsPrec :: Int -> ReadS Support
Read, Int -> Support -> ShowS
[Support] -> ShowS
Support -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Support] -> ShowS
$cshowList :: [Support] -> ShowS
show :: Support -> String
$cshow :: Support -> String
showsPrec :: Int -> Support -> ShowS
$cshowsPrec :: Int -> Support -> ShowS
Show, forall x. Rep Support x -> Support
forall x. Support -> Rep Support x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep Support x -> Support
$cfrom :: forall x. Support -> Rep Support x
Generic, Support -> ()
forall a. (a -> ()) -> NFData a
rnf :: Support -> ()
$crnf :: Support -> ()
NFData)
  deriving (Int -> Support
Support -> Int
Support -> [Support]
Support -> Support
Support -> Support -> [Support]
Support -> Support -> Support -> [Support]
forall a.
(a -> a)
-> (a -> a)
-> (Int -> a)
-> (a -> Int)
-> (a -> [a])
-> (a -> a -> [a])
-> (a -> a -> [a])
-> (a -> a -> a -> [a])
-> Enum a
enumFromThenTo :: Support -> Support -> Support -> [Support]
$cenumFromThenTo :: Support -> Support -> Support -> [Support]
enumFromTo :: Support -> Support -> [Support]
$cenumFromTo :: Support -> Support -> [Support]
enumFromThen :: Support -> Support -> [Support]
$cenumFromThen :: Support -> Support -> [Support]
enumFrom :: Support -> [Support]
$cenumFrom :: Support -> [Support]
fromEnum :: Support -> Int
$cfromEnum :: Support -> Int
toEnum :: Int -> Support
$ctoEnum :: Int -> Support
pred :: Support -> Support
$cpred :: Support -> Support
succ :: Support -> Support
$csucc :: Support -> Support
Enum, Support -> Support -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Support -> Support -> Bool
$c/= :: Support -> Support -> Bool
== :: Support -> Support -> Bool
$c== :: Support -> Support -> Bool
Eq, Fractional Support
Support
Support -> Support
Support -> Support -> Support
forall a.
Fractional a
-> a
-> (a -> a)
-> (a -> a)
-> (a -> a)
-> (a -> a -> a)
-> (a -> a -> a)
-> (a -> a)
-> (a -> a)
-> (a -> a)
-> (a -> a)
-> (a -> a)
-> (a -> a)
-> (a -> a)
-> (a -> a)
-> (a -> a)
-> (a -> a)
-> (a -> a)
-> (a -> a)
-> (a -> a)
-> (a -> a)
-> (a -> a)
-> (a -> a)
-> Floating a
log1mexp :: Support -> Support
$clog1mexp :: Support -> Support
log1pexp :: Support -> Support
$clog1pexp :: Support -> Support
expm1 :: Support -> Support
$cexpm1 :: Support -> Support
log1p :: Support -> Support
$clog1p :: Support -> Support
atanh :: Support -> Support
$catanh :: Support -> Support
acosh :: Support -> Support
$cacosh :: Support -> Support
asinh :: Support -> Support
$casinh :: Support -> Support
tanh :: Support -> Support
$ctanh :: Support -> Support
cosh :: Support -> Support
$ccosh :: Support -> Support
sinh :: Support -> Support
$csinh :: Support -> Support
atan :: Support -> Support
$catan :: Support -> Support
acos :: Support -> Support
$cacos :: Support -> Support
asin :: Support -> Support
$casin :: Support -> Support
tan :: Support -> Support
$ctan :: Support -> Support
cos :: Support -> Support
$ccos :: Support -> Support
sin :: Support -> Support
$csin :: Support -> Support
logBase :: Support -> Support -> Support
$clogBase :: Support -> Support -> Support
** :: Support -> Support -> Support
$c** :: Support -> Support -> Support
sqrt :: Support -> Support
$csqrt :: Support -> Support
log :: Support -> Support
$clog :: Support -> Support
exp :: Support -> Support
$cexp :: Support -> Support
pi :: Support
$cpi :: Support
Floating, Num Support
Rational -> Support
Support -> Support
Support -> Support -> Support
forall a.
Num a
-> (a -> a -> a) -> (a -> a) -> (Rational -> a) -> Fractional a
fromRational :: Rational -> Support
$cfromRational :: Rational -> Support
recip :: Support -> Support
$crecip :: Support -> Support
/ :: Support -> Support -> Support
$c/ :: Support -> Support -> Support
Fractional, Integer -> Support
Support -> Support
Support -> Support -> Support
forall a.
(a -> a -> a)
-> (a -> a -> a)
-> (a -> a -> a)
-> (a -> a)
-> (a -> a)
-> (a -> a)
-> (Integer -> a)
-> Num a
fromInteger :: Integer -> Support
$cfromInteger :: Integer -> Support
signum :: Support -> Support
$csignum :: Support -> Support
abs :: Support -> Support
$cabs :: Support -> Support
negate :: Support -> Support
$cnegate :: Support -> Support
* :: Support -> Support -> Support
$c* :: Support -> Support -> Support
- :: Support -> Support -> Support
$c- :: Support -> Support -> Support
+ :: Support -> Support -> Support
$c+ :: Support -> Support -> Support
Num, Eq Support
Support -> Support -> Bool
Support -> Support -> Ordering
Support -> Support -> Support
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: Support -> Support -> Support
$cmin :: Support -> Support -> Support
max :: Support -> Support -> Support
$cmax :: Support -> Support -> Support
>= :: Support -> Support -> Bool
$c>= :: Support -> Support -> Bool
> :: Support -> Support -> Bool
$c> :: Support -> Support -> Bool
<= :: Support -> Support -> Bool
$c<= :: Support -> Support -> Bool
< :: Support -> Support -> Bool
$c< :: Support -> Support -> Bool
compare :: Support -> Support -> Ordering
$ccompare :: Support -> Support -> Ordering
Ord, Num Support
Ord Support
Support -> Rational
forall a. Num a -> Ord a -> (a -> Rational) -> Real a
toRational :: Support -> Rational
$ctoRational :: Support -> Rational
Real, Floating Support
RealFrac Support
Int -> Support -> Support
Integer -> Int -> Support
Support -> Bool
Support -> Int
Support -> Integer
Support -> (Int, Int)
Support -> (Integer, Int)
Support -> Support
Support -> Support -> Support
forall a.
RealFrac a
-> Floating a
-> (a -> Integer)
-> (a -> Int)
-> (a -> (Int, Int))
-> (a -> (Integer, Int))
-> (Integer -> Int -> a)
-> (a -> Int)
-> (a -> a)
-> (Int -> a -> a)
-> (a -> Bool)
-> (a -> Bool)
-> (a -> Bool)
-> (a -> Bool)
-> (a -> Bool)
-> (a -> a -> a)
-> RealFloat a
atan2 :: Support -> Support -> Support
$catan2 :: Support -> Support -> Support
isIEEE :: Support -> Bool
$cisIEEE :: Support -> Bool
isNegativeZero :: Support -> Bool
$cisNegativeZero :: Support -> Bool
isDenormalized :: Support -> Bool
$cisDenormalized :: Support -> Bool
isInfinite :: Support -> Bool
$cisInfinite :: Support -> Bool
isNaN :: Support -> Bool
$cisNaN :: Support -> Bool
scaleFloat :: Int -> Support -> Support
$cscaleFloat :: Int -> Support -> Support
significand :: Support -> Support
$csignificand :: Support -> Support
exponent :: Support -> Int
$cexponent :: Support -> Int
encodeFloat :: Integer -> Int -> Support
$cencodeFloat :: Integer -> Int -> Support
decodeFloat :: Support -> (Integer, Int)
$cdecodeFloat :: Support -> (Integer, Int)
floatRange :: Support -> (Int, Int)
$cfloatRange :: Support -> (Int, Int)
floatDigits :: Support -> Int
$cfloatDigits :: Support -> Int
floatRadix :: Support -> Integer
$cfloatRadix :: Support -> Integer
RealFloat, Fractional Support
Real Support
forall b. Integral b => Support -> b
forall b. Integral b => Support -> (b, Support)
forall a.
Real a
-> Fractional a
-> (forall b. Integral b => a -> (b, a))
-> (forall b. Integral b => a -> b)
-> (forall b. Integral b => a -> b)
-> (forall b. Integral b => a -> b)
-> (forall b. Integral b => a -> b)
-> RealFrac a
floor :: forall b. Integral b => Support -> b
$cfloor :: forall b. Integral b => Support -> b
ceiling :: forall b. Integral b => Support -> b
$cceiling :: forall b. Integral b => Support -> b
round :: forall b. Integral b => Support -> b
$cround :: forall b. Integral b => Support -> b
truncate :: forall b. Integral b => Support -> b
$ctruncate :: forall b. Integral b => Support -> b
properFraction :: forall b. Integral b => Support -> (b, Support)
$cproperFraction :: forall b. Integral b => Support -> (b, Support)
RealFrac) via Double
  deriving (NonEmpty Support -> Support
Support -> Support -> Support
forall b. Integral b => b -> Support -> Support
forall a.
(a -> a -> a)
-> (NonEmpty a -> a)
-> (forall b. Integral b => b -> a -> a)
-> Semigroup a
stimes :: forall b. Integral b => b -> Support -> Support
$cstimes :: forall b. Integral b => b -> Support -> Support
sconcat :: NonEmpty Support -> Support
$csconcat :: NonEmpty Support -> Support
<> :: Support -> Support -> Support
$c<> :: Support -> Support -> Support
Semigroup) via Min Double

instance Splittable Support where
  split :: Support -> Support
split = forall a. a -> a
id

instance ToJSON Support

instance FromJSON Support

instance HasMaybeSupport Support where
  getMaybeSupport :: Support -> Maybe Support
getMaybeSupport = forall a. a -> Maybe a
Just

instance HasMaybeSupport () where
  getMaybeSupport :: () -> Maybe Support
getMaybeSupport = forall a b. a -> b -> a
const forall a. Maybe a
Nothing

instance HasSupport Support where
  getSupport :: Support -> Support
getSupport = forall a. a -> a
id
  setSupport :: Support -> Support -> Support
setSupport = forall a b. a -> b -> a
const
  modifySupport :: (Support -> Support) -> Support -> Support
modifySupport Support -> Support
f = Support -> Support
f

-- | Return 'Left' if negative.
toSupport :: Double -> Either String Support
toSupport :: Double -> Either String Support
toSupport Double
x
  | Double
x forall a. Ord a => a -> a -> Bool
< Double
0 = forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ String
"Support is negative: " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show Double
x forall a. [a] -> [a] -> [a]
++ String
"."
  | Bool
otherwise = forall a b. b -> Either a b
Right forall a b. (a -> b) -> a -> b
$ Double -> Support
Support Double
x

-- | Do not check if value is negative.
toSupportUnsafe :: Double -> Support
toSupportUnsafe :: Double -> Support
toSupportUnsafe = Double -> Support
Support

-- | Class of data types that may have a support value.
class HasMaybeSupport e where
  getMaybeSupport :: e -> Maybe Support

-- | Class of data types with measurable and modifiable support values.
class HasMaybeSupport e => HasSupport e where
  getSupport :: e -> Support
  setSupport :: Support -> e -> e
  modifySupport :: (Support -> Support) -> e -> e

-- | Normalize branch support values. The maximum branch support value will be
-- set to 1.0.
normalizeBranchSupport :: HasSupport e => Tree e a -> Tree e a
normalizeBranchSupport :: forall e a. HasSupport e => Tree e a -> Tree e a
normalizeBranchSupport Tree e a
t = forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first (forall e. HasSupport e => (Support -> Support) -> e -> e
modifySupport (forall a. Fractional a => a -> a -> a
/ Support
m)) Tree e a
t
  where
    m :: Support
m = forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
maximum forall a b. (a -> b) -> a -> b
$ forall e. HasSupport e => e -> Support
getSupport forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a e. Tree e a -> ZipBranchTree a e
ZipBranchTree Tree e a
t

-- | Collapse branches with support lower than given value.
--
-- The branch and node labels of the collapsed branches are discarded.
collapse :: (Eq e, Eq a, HasSupport e) => Support -> Tree e a -> Tree e a
collapse :: forall e a.
(Eq e, Eq a, HasSupport e) =>
Support -> Tree e a -> Tree e a
collapse Support
th Tree e a
tr =
  let tr' :: Tree e a
tr' = forall e a. HasSupport e => Support -> Tree e a -> Tree e a
collapse' Support
th Tree e a
tr
   in if Tree e a
tr forall a. Eq a => a -> a -> Bool
== Tree e a
tr' then Tree e a
tr else forall e a.
(Eq e, Eq a, HasSupport e) =>
Support -> Tree e a -> Tree e a
collapse Support
th Tree e a
tr'

-- A leaf has full support.
highP :: HasSupport e => Support -> Tree e a -> Bool
highP :: forall e a. HasSupport e => Support -> Tree e a -> Bool
highP Support
_ (Node e
_ a
_ []) = Bool
True
highP Support
th (Node e
br a
_ [Tree e a]
_) = forall e. HasSupport e => e -> Support
getSupport e
br forall a. Ord a => a -> a -> Bool
>= Support
th

-- See 'collapse'.
collapse' :: HasSupport e => Support -> Tree e a -> Tree e a
collapse' :: forall e a. HasSupport e => Support -> Tree e a -> Tree e a
collapse' Support
th (Node e
br a
lb Forest e a
ts) = forall e a. e -> a -> Forest e a -> Tree e a
Node e
br a
lb forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map (forall e a. HasSupport e => Support -> Tree e a -> Tree e a
collapse' Support
th) (Forest e a
highSupport forall a. [a] -> [a] -> [a]
++ Forest e a
lowSupportForest)
  where
    (Forest e a
highSupport, Forest e a
lowSupport) = forall a. (a -> Bool) -> [a] -> ([a], [a])
partition (forall e a. HasSupport e => Support -> Tree e a -> Bool
highP Support
th) Forest e a
ts
    lowSupportForest :: Forest e a
lowSupportForest = forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap forall e a. Tree e a -> Forest e a
forest Forest e a
lowSupport