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

-- |
-- Module      :  ELynx.Tree.Length
-- Description :  Labels having a length
-- Copyright   :  2021 Dominik Schrempf
-- License     :  GPL-3.0-or-later
--
-- Maintainer  :  dominik.schrempf@gmail.com
-- Stability   :  unstable
-- Portability :  portable
--
-- Creation date: Thu Jan 17 14:16:34 2019.
--
-- Non-negativity of lengths is not completely ensured. See the documentation of
-- 'Length'.
module ELynx.Tree.Length
  ( -- * Non-negative length
    Length (fromLength),
    toLength,
    toLengthUnsafe,
    HasMaybeLength (..),
    HasLength (..),
    height,
    rootHeight,

    -- * Functions on trees
    distancesOriginLeaves,
    totalBranchLength,
    normalizeBranchLengths,
    normalizeHeight,
    ultrametric,
    makeUltrametric,
  )
where

import Control.DeepSeq
import Data.Aeson
import Data.Bifunctor
import Data.Default.Class
import Data.Foldable
import Data.Semigroup
import ELynx.Tree.Rooted
import ELynx.Tree.Splittable
import GHC.Generics

-- | Non-negative length.
--
-- However, non-negativity is only checked with 'toLength', and negative values
-- can be obtained using the 'Num' and related instances.
--
-- Safe conversion is roughly 50 percent slower.
--
-- @
-- benchmarking length/length sum foldl' with safe conversion
-- time                 110.4 ms   (109.8 ms .. 111.0 ms)
--                      1.000 R²   (1.000 R² .. 1.000 R²)
-- mean                 110.2 ms   (110.0 ms .. 110.6 ms)
-- std dev              501.8 μs   (359.1 μs .. 730.0 μs)
--
-- benchmarking length/length sum foldl' num instance
-- time                 89.37 ms   (85.13 ms .. 94.27 ms)
--                      0.996 R²   (0.992 R² .. 1.000 R²)
-- mean                 86.53 ms   (85.63 ms .. 88.52 ms)
-- std dev              2.239 ms   (1.069 ms .. 3.421 ms)
--
-- benchmarking length/double sum foldl'
-- time                 85.47 ms   (84.88 ms .. 86.42 ms)
--                      1.000 R²   (0.999 R² .. 1.000 R²)
-- mean                 85.56 ms   (85.26 ms .. 86.02 ms)
-- std dev              611.9 μs   (101.5 μs .. 851.7 μs)
-- @
newtype Length = Length {Length -> Double
fromLength :: Double}
  deriving (ReadPrec [Length]
ReadPrec Length
Int -> ReadS Length
ReadS [Length]
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
readListPrec :: ReadPrec [Length]
$creadListPrec :: ReadPrec [Length]
readPrec :: ReadPrec Length
$creadPrec :: ReadPrec Length
readList :: ReadS [Length]
$creadList :: ReadS [Length]
readsPrec :: Int -> ReadS Length
$creadsPrec :: Int -> ReadS Length
Read, Int -> Length -> ShowS
[Length] -> ShowS
Length -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Length] -> ShowS
$cshowList :: [Length] -> ShowS
show :: Length -> String
$cshow :: Length -> String
showsPrec :: Int -> Length -> ShowS
$cshowsPrec :: Int -> Length -> ShowS
Show, forall x. Rep Length x -> Length
forall x. Length -> Rep Length x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep Length x -> Length
$cfrom :: forall x. Length -> Rep Length x
Generic, Length -> ()
forall a. (a -> ()) -> NFData a
rnf :: Length -> ()
$crnf :: Length -> ()
NFData)
  deriving
    ( Length
forall a. a -> Default a
def :: Length
$cdef :: Length
Default,
      Int -> Length
Length -> Int
Length -> [Length]
Length -> Length
Length -> Length -> [Length]
Length -> Length -> Length -> [Length]
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 :: Length -> Length -> Length -> [Length]
$cenumFromThenTo :: Length -> Length -> Length -> [Length]
enumFromTo :: Length -> Length -> [Length]
$cenumFromTo :: Length -> Length -> [Length]
enumFromThen :: Length -> Length -> [Length]
$cenumFromThen :: Length -> Length -> [Length]
enumFrom :: Length -> [Length]
$cenumFrom :: Length -> [Length]
fromEnum :: Length -> Int
$cfromEnum :: Length -> Int
toEnum :: Int -> Length
$ctoEnum :: Int -> Length
pred :: Length -> Length
$cpred :: Length -> Length
succ :: Length -> Length
$csucc :: Length -> Length
Enum,
      Length -> Length -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Length -> Length -> Bool
$c/= :: Length -> Length -> Bool
== :: Length -> Length -> Bool
$c== :: Length -> Length -> Bool
Eq,
      Fractional Length
Length
Length -> Length
Length -> Length -> Length
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 :: Length -> Length
$clog1mexp :: Length -> Length
log1pexp :: Length -> Length
$clog1pexp :: Length -> Length
expm1 :: Length -> Length
$cexpm1 :: Length -> Length
log1p :: Length -> Length
$clog1p :: Length -> Length
atanh :: Length -> Length
$catanh :: Length -> Length
acosh :: Length -> Length
$cacosh :: Length -> Length
asinh :: Length -> Length
$casinh :: Length -> Length
tanh :: Length -> Length
$ctanh :: Length -> Length
cosh :: Length -> Length
$ccosh :: Length -> Length
sinh :: Length -> Length
$csinh :: Length -> Length
atan :: Length -> Length
$catan :: Length -> Length
acos :: Length -> Length
$cacos :: Length -> Length
asin :: Length -> Length
$casin :: Length -> Length
tan :: Length -> Length
$ctan :: Length -> Length
cos :: Length -> Length
$ccos :: Length -> Length
sin :: Length -> Length
$csin :: Length -> Length
logBase :: Length -> Length -> Length
$clogBase :: Length -> Length -> Length
** :: Length -> Length -> Length
$c** :: Length -> Length -> Length
sqrt :: Length -> Length
$csqrt :: Length -> Length
log :: Length -> Length
$clog :: Length -> Length
exp :: Length -> Length
$cexp :: Length -> Length
pi :: Length
$cpi :: Length
Floating,
      Num Length
Rational -> Length
Length -> Length
Length -> Length -> Length
forall a.
Num a
-> (a -> a -> a) -> (a -> a) -> (Rational -> a) -> Fractional a
fromRational :: Rational -> Length
$cfromRational :: Rational -> Length
recip :: Length -> Length
$crecip :: Length -> Length
/ :: Length -> Length -> Length
$c/ :: Length -> Length -> Length
Fractional,
      Integer -> Length
Length -> Length
Length -> Length -> Length
forall a.
(a -> a -> a)
-> (a -> a -> a)
-> (a -> a -> a)
-> (a -> a)
-> (a -> a)
-> (a -> a)
-> (Integer -> a)
-> Num a
fromInteger :: Integer -> Length
$cfromInteger :: Integer -> Length
signum :: Length -> Length
$csignum :: Length -> Length
abs :: Length -> Length
$cabs :: Length -> Length
negate :: Length -> Length
$cnegate :: Length -> Length
* :: Length -> Length -> Length
$c* :: Length -> Length -> Length
- :: Length -> Length -> Length
$c- :: Length -> Length -> Length
+ :: Length -> Length -> Length
$c+ :: Length -> Length -> Length
Num,
      Eq Length
Length -> Length -> Bool
Length -> Length -> Ordering
Length -> Length -> Length
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 :: Length -> Length -> Length
$cmin :: Length -> Length -> Length
max :: Length -> Length -> Length
$cmax :: Length -> Length -> Length
>= :: Length -> Length -> Bool
$c>= :: Length -> Length -> Bool
> :: Length -> Length -> Bool
$c> :: Length -> Length -> Bool
<= :: Length -> Length -> Bool
$c<= :: Length -> Length -> Bool
< :: Length -> Length -> Bool
$c< :: Length -> Length -> Bool
compare :: Length -> Length -> Ordering
$ccompare :: Length -> Length -> Ordering
Ord,
      Num Length
Ord Length
Length -> Rational
forall a. Num a -> Ord a -> (a -> Rational) -> Real a
toRational :: Length -> Rational
$ctoRational :: Length -> Rational
Real,
      Floating Length
RealFrac Length
Int -> Length -> Length
Integer -> Int -> Length
Length -> Bool
Length -> Int
Length -> Integer
Length -> (Int, Int)
Length -> (Integer, Int)
Length -> Length
Length -> Length -> Length
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 :: Length -> Length -> Length
$catan2 :: Length -> Length -> Length
isIEEE :: Length -> Bool
$cisIEEE :: Length -> Bool
isNegativeZero :: Length -> Bool
$cisNegativeZero :: Length -> Bool
isDenormalized :: Length -> Bool
$cisDenormalized :: Length -> Bool
isInfinite :: Length -> Bool
$cisInfinite :: Length -> Bool
isNaN :: Length -> Bool
$cisNaN :: Length -> Bool
scaleFloat :: Int -> Length -> Length
$cscaleFloat :: Int -> Length -> Length
significand :: Length -> Length
$csignificand :: Length -> Length
exponent :: Length -> Int
$cexponent :: Length -> Int
encodeFloat :: Integer -> Int -> Length
$cencodeFloat :: Integer -> Int -> Length
decodeFloat :: Length -> (Integer, Int)
$cdecodeFloat :: Length -> (Integer, Int)
floatRange :: Length -> (Int, Int)
$cfloatRange :: Length -> (Int, Int)
floatDigits :: Length -> Int
$cfloatDigits :: Length -> Int
floatRadix :: Length -> Integer
$cfloatRadix :: Length -> Integer
RealFloat,
      Fractional Length
Real Length
forall b. Integral b => Length -> b
forall b. Integral b => Length -> (b, Length)
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 => Length -> b
$cfloor :: forall b. Integral b => Length -> b
ceiling :: forall b. Integral b => Length -> b
$cceiling :: forall b. Integral b => Length -> b
round :: forall b. Integral b => Length -> b
$cround :: forall b. Integral b => Length -> b
truncate :: forall b. Integral b => Length -> b
$ctruncate :: forall b. Integral b => Length -> b
properFraction :: forall b. Integral b => Length -> (b, Length)
$cproperFraction :: forall b. Integral b => Length -> (b, Length)
RealFrac
    )
    via Double
  deriving (NonEmpty Length -> Length
Length -> Length -> Length
forall b. Integral b => b -> Length -> Length
forall a.
(a -> a -> a)
-> (NonEmpty a -> a)
-> (forall b. Integral b => b -> a -> a)
-> Semigroup a
stimes :: forall b. Integral b => b -> Length -> Length
$cstimes :: forall b. Integral b => b -> Length -> Length
sconcat :: NonEmpty Length -> Length
$csconcat :: NonEmpty Length -> Length
<> :: Length -> Length -> Length
$c<> :: Length -> Length -> Length
Semigroup, Semigroup Length
Length
[Length] -> Length
Length -> Length -> Length
forall a.
Semigroup a -> a -> (a -> a -> a) -> ([a] -> a) -> Monoid a
mconcat :: [Length] -> Length
$cmconcat :: [Length] -> Length
mappend :: Length -> Length -> Length
$cmappend :: Length -> Length -> Length
mempty :: Length
$cmempty :: Length
Monoid) via Sum Double

instance Splittable Length where
  split :: Length -> Length
split = (forall a. Fractional a => a -> a -> a
/ Length
2.0)

instance ToJSON Length

instance FromJSON Length

instance HasMaybeLength Length where
  getMaybeLength :: Length -> Maybe Length
getMaybeLength = forall a. a -> Maybe a
Just

instance HasLength Length where
  getLength :: Length -> Length
getLength = forall a. a -> a
id
  setLength :: Length -> Length -> Length
setLength = forall a b. a -> b -> a
const
  modifyLength :: (Length -> Length) -> Length -> Length
modifyLength Length -> Length
f = Length -> Length
f

-- | Return 'Left' if negative.
toLength :: Double -> Either String Length
toLength :: Double -> Either String Length
toLength 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
"Length 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 -> Length
Length Double
x

-- | Do not check if value is negative.
toLengthUnsafe :: Double -> Length
toLengthUnsafe :: Double -> Length
toLengthUnsafe = Double -> Length
Length

-- | Class of data types that may have a length.
class HasMaybeLength e where
  getMaybeLength :: e -> Maybe Length

instance HasMaybeLength () where
  getMaybeLength :: () -> Maybe Length
getMaybeLength = forall a b. a -> b -> a
const forall a. Maybe a
Nothing

-- | Class of data types with measurable and modifiable length.
class HasMaybeLength e => HasLength e where
  getLength :: e -> Length
  setLength :: Length -> e -> e
  modifyLength :: (Length -> Length) -> e -> e

-- | The maximum distance between origin and leaves.
--
-- The height includes the branch length of the stem.
height :: HasLength e => Tree e a -> Length
height :: forall e a. HasLength e => Tree e a -> Length
height = forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
maximum forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall e a. HasLength e => Tree e a -> [Length]
distancesOriginLeaves

-- | The maximum distance between root node and leaves.
rootHeight :: HasLength e => Tree e a -> Length
rootHeight :: forall e a. HasLength e => Tree e a -> Length
rootHeight (Node e
_ a
_ []) = Length
0
rootHeight Tree e a
t = forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
maximum forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap forall e a. HasLength e => Tree e a -> [Length]
distancesOriginLeaves (forall e a. Tree e a -> Forest e a
forest Tree e a
t)

-- | Distances from the origin of a tree to the leaves.
--
-- The distances include the branch length of the stem.
distancesOriginLeaves :: HasLength e => Tree e a -> [Length]
distancesOriginLeaves :: forall e a. HasLength e => Tree e a -> [Length]
distancesOriginLeaves (Node e
br a
_ []) = [forall e. HasLength e => e -> Length
getLength e
br]
distancesOriginLeaves (Node e
br a
_ [Tree e a]
ts) = forall a b. (a -> b) -> [a] -> [b]
map (forall e. HasLength e => e -> Length
getLength e
br forall a. Num a => a -> a -> a
+) (forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap forall e a. HasLength e => Tree e a -> [Length]
distancesOriginLeaves [Tree e a]
ts)

-- | Total branch length of a tree.
totalBranchLength :: HasLength e => Tree e a -> Length
totalBranchLength :: forall e a. HasLength e => Tree e a -> Length
totalBranchLength = forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' forall a. Num a => a -> a -> a
(+) Length
0 forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall e. HasLength e => e -> Length
getLength forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a e. Tree e a -> ZipBranchTree a e
ZipBranchTree

-- | Normalize branch lengths so that the sum is 1.0.
normalizeBranchLengths :: HasLength e => Tree e a -> Tree e a
normalizeBranchLengths :: forall e a. HasLength e => Tree e a -> Tree e a
normalizeBranchLengths Tree e a
t = forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first (forall e. HasLength e => (Length -> Length) -> e -> e
modifyLength (forall a. Fractional a => a -> a -> a
/ Length
s)) Tree e a
t
  where
    s :: Length
s = forall e a. HasLength e => Tree e a -> Length
totalBranchLength Tree e a
t

-- | Normalize height of tree to 1.0.
normalizeHeight :: HasLength e => Tree e a -> Tree e a
normalizeHeight :: forall e a. HasLength e => Tree e a -> Tree e a
normalizeHeight Tree e a
t = forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first (forall e. HasLength e => (Length -> Length) -> e -> e
modifyLength (forall a. Fractional a => a -> a -> a
/ Length
h)) Tree e a
t
  where
    h :: Length
h = forall e a. HasLength e => Tree e a -> Length
height Tree e a
t

eps :: Double
eps :: Double
eps = Double
1e-12

allNearlyEqual :: [Length] -> Bool
allNearlyEqual :: [Length] -> Bool
allNearlyEqual [] = Bool
True
allNearlyEqual [Length]
xs = forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (\Length
y -> Double
eps forall a. Ord a => a -> a -> Bool
> forall a. Num a => a -> a
abs (Length -> Double
fromLength forall a b. (a -> b) -> a -> b
$ Length
x forall a. Num a => a -> a -> a
- Length
y)) (forall a. [a] -> [a]
tail [Length]
xs)
  where
    x :: Length
x = forall a. [a] -> a
head [Length]
xs

-- | Check if a tree is ultrametric.
ultrametric :: HasLength e => Tree e a -> Bool
ultrametric :: forall e a. HasLength e => Tree e a -> Bool
ultrametric = [Length] -> Bool
allNearlyEqual forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall e a. HasLength e => Tree e a -> [Length]
distancesOriginLeaves

-- | Elongate terminal branches such that the tree becomes ultrametric.
makeUltrametric :: HasLength e => Tree e a -> Tree e a
makeUltrametric :: forall e a. HasLength e => Tree e a -> Tree e a
makeUltrametric Tree e a
t = forall e a. HasLength e => Length -> Tree e a -> Tree e a
go Length
0 Tree e a
t
  where
    h :: Length
h = forall e a. HasLength e => Tree e a -> Length
height Tree e a
t
    go :: HasLength e => Length -> Tree e a -> Tree e a
    go :: forall e a. HasLength e => Length -> Tree e a -> Tree e a
go Length
h' (Node e
br a
lb []) = let dh :: Length
dh = Length
h forall a. Num a => a -> a -> a
- Length
h' forall a. Num a => a -> a -> a
- forall e. HasLength e => e -> Length
getLength e
br in forall e a. e -> a -> Forest e a -> Tree e a
Node (forall e. HasLength e => (Length -> Length) -> e -> e
modifyLength (forall a. Num a => a -> a -> a
+ Length
dh) e
br) a
lb []
    go Length
h' (Node e
br a
lb [Tree e a]
ts) = let h'' :: Length
h'' = Length
h' forall a. Num a => a -> a -> a
+ forall e. HasLength e => e -> Length
getLength e
br in 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. HasLength e => Length -> Tree e a -> Tree e a
go Length
h'') [Tree e a]
ts