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

-- |
-- Module      :  ELynx.Tree.Support
-- Description :  Labels with support values
-- Copyright   :  (c) Dominik Schrempf 2021
-- 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]
(Int -> ReadS Support)
-> ReadS [Support]
-> ReadPrec Support
-> ReadPrec [Support]
-> Read 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
(Int -> Support -> ShowS)
-> (Support -> String) -> ([Support] -> ShowS) -> Show Support
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. Support -> Rep Support x)
-> (forall x. Rep Support x -> Support) -> Generic Support
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 -> ()
(Support -> ()) -> NFData 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]
(Support -> Support)
-> (Support -> Support)
-> (Int -> Support)
-> (Support -> Int)
-> (Support -> [Support])
-> (Support -> Support -> [Support])
-> (Support -> Support -> [Support])
-> (Support -> Support -> Support -> [Support])
-> Enum 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
(Support -> Support -> Bool)
-> (Support -> Support -> Bool) -> Eq Support
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
Fractional Support
-> Support
-> (Support -> Support)
-> (Support -> Support)
-> (Support -> Support)
-> (Support -> Support -> Support)
-> (Support -> Support -> Support)
-> (Support -> Support)
-> (Support -> Support)
-> (Support -> Support)
-> (Support -> Support)
-> (Support -> Support)
-> (Support -> Support)
-> (Support -> Support)
-> (Support -> Support)
-> (Support -> Support)
-> (Support -> Support)
-> (Support -> Support)
-> (Support -> Support)
-> (Support -> Support)
-> (Support -> Support)
-> (Support -> Support)
-> (Support -> Support)
-> Floating 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
$cp1Floating :: Fractional Support
Floating, Num Support
Num Support
-> (Support -> Support -> Support)
-> (Support -> Support)
-> (Rational -> Support)
-> Fractional 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
$cp1Fractional :: Num Support
Fractional, Integer -> Support
Support -> Support
Support -> Support -> Support
(Support -> Support -> Support)
-> (Support -> Support -> Support)
-> (Support -> Support -> Support)
-> (Support -> Support)
-> (Support -> Support)
-> (Support -> Support)
-> (Integer -> Support)
-> Num 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
Eq Support
-> (Support -> Support -> Ordering)
-> (Support -> Support -> Bool)
-> (Support -> Support -> Bool)
-> (Support -> Support -> Bool)
-> (Support -> Support -> Bool)
-> (Support -> Support -> Support)
-> (Support -> Support -> Support)
-> Ord 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
$cp1Ord :: Eq Support
Ord, Num Support
Ord Support
Num Support -> Ord Support -> (Support -> Rational) -> Real Support
Support -> Rational
forall a. Num a -> Ord a -> (a -> Rational) -> Real a
toRational :: Support -> Rational
$ctoRational :: Support -> Rational
$cp2Real :: Ord Support
$cp1Real :: Num Support
Real, Floating Support
RealFrac Support
RealFrac Support
-> Floating Support
-> (Support -> Integer)
-> (Support -> Int)
-> (Support -> (Int, Int))
-> (Support -> (Integer, Int))
-> (Integer -> Int -> Support)
-> (Support -> Int)
-> (Support -> Support)
-> (Int -> Support -> Support)
-> (Support -> Bool)
-> (Support -> Bool)
-> (Support -> Bool)
-> (Support -> Bool)
-> (Support -> Bool)
-> (Support -> Support -> Support)
-> RealFloat 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
$cp2RealFloat :: Floating Support
$cp1RealFloat :: RealFrac Support
RealFloat, Fractional Support
Real Support
Real Support
-> Fractional Support
-> (forall b. Integral b => Support -> (b, Support))
-> (forall b. Integral b => Support -> b)
-> (forall b. Integral b => Support -> b)
-> (forall b. Integral b => Support -> b)
-> (forall b. Integral b => Support -> b)
-> RealFrac Support
Support -> b
Support -> b
Support -> b
Support -> b
Support -> (b, 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 :: Support -> b
$cfloor :: forall b. Integral b => Support -> b
ceiling :: Support -> b
$cceiling :: forall b. Integral b => Support -> b
round :: Support -> b
$cround :: forall b. Integral b => Support -> b
truncate :: Support -> b
$ctruncate :: forall b. Integral b => Support -> b
properFraction :: Support -> (b, Support)
$cproperFraction :: forall b. Integral b => Support -> (b, Support)
$cp2RealFrac :: Fractional Support
$cp1RealFrac :: Real Support
RealFrac) via Double
  deriving (b -> Support -> Support
NonEmpty Support -> Support
Support -> Support -> Support
(Support -> Support -> Support)
-> (NonEmpty Support -> Support)
-> (forall b. Integral b => b -> Support -> Support)
-> Semigroup 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 :: 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 = Support -> Support
forall a. a -> a
id

instance ToJSON Support

instance FromJSON Support

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

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

instance HasSupport Support where
  getSupport :: Support -> Support
getSupport = Support -> Support
forall a. a -> a
id
  setSupport :: Support -> Support -> Support
setSupport = Support -> Support -> Support
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 Double -> Double -> Bool
forall a. Ord a => a -> a -> Bool
< Double
0 = String -> Either String Support
forall a b. a -> Either a b
Left (String -> Either String Support)
-> String -> Either String Support
forall a b. (a -> b) -> a -> b
$ String
"Support is negative: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Double -> String
forall a. Show a => a -> String
show Double
x String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"."
  | Bool
otherwise = Support -> Either String Support
forall a b. b -> Either a b
Right (Support -> Either String Support)
-> Support -> Either String Support
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 :: Tree e a -> Tree e a
normalizeBranchSupport Tree e a
t = (e -> e) -> Tree e a -> Tree e a
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first ((Support -> Support) -> e -> e
forall e. HasSupport e => (Support -> Support) -> e -> e
modifySupport (Support -> Support -> Support
forall a. Fractional a => a -> a -> a
/ Support
m)) Tree e a
t
  where
    m :: Support
m = ZipBranchTree a Support -> Support
forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
maximum (ZipBranchTree a Support -> Support)
-> ZipBranchTree a Support -> Support
forall a b. (a -> b) -> a -> b
$ e -> Support
forall e. HasSupport e => e -> Support
getSupport (e -> Support) -> ZipBranchTree a e -> ZipBranchTree a Support
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Tree e a -> ZipBranchTree a e
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 :: Support -> Tree e a -> Tree e a
collapse Support
th Tree e a
tr =
  let tr' :: Tree e a
tr' = Support -> Tree e a -> Tree e a
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 Tree e a -> Tree e a -> Bool
forall a. Eq a => a -> a -> Bool
== Tree e a
tr' then Tree e a
tr else Support -> Tree e a -> Tree e a
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 :: Support -> Tree e a -> Bool
highP Support
_ (Node e
_ a
_ []) = Bool
True
highP Support
th (Node e
br a
_ [Tree e a]
_) = e -> Support
forall e. HasSupport e => e -> Support
getSupport e
br Support -> Support -> Bool
forall a. Ord a => a -> a -> Bool
>= Support
th

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