module ELynx.Data.Tree.Measurable
( BranchLength,
Measurable (..),
applyStem,
getStem,
setStem,
height,
rootHeight,
distancesOriginLeaves,
totalBranchLength,
normalizeBranchLengths,
normalizeHeight,
ultrametric,
makeUltrametric,
)
where
import Data.Bifoldable
import Data.Bifunctor
import ELynx.Data.Tree.Rooted
type BranchLength = Double
class Measurable e where
getLen :: e -> BranchLength
setLen :: BranchLength -> e -> e
instance Measurable Double where
getLen = id
setLen = const
apply :: Measurable e => (BranchLength -> BranchLength) -> e -> e
apply f l = setLen (f s) l where s = getLen l
applyStem :: Measurable e => (BranchLength -> BranchLength) -> Tree e a -> Tree e a
applyStem f t = t {branch = apply f b}
where
b = branch t
getStem :: Measurable e => Tree e a -> BranchLength
getStem (Node br _ _) = getLen br
setStem :: Measurable e => BranchLength -> Tree e a -> Tree e a
setStem x = applyStem (const x)
height :: Measurable e => Tree e a -> BranchLength
height = maximum . distancesOriginLeaves
rootHeight :: Measurable e => Tree e a -> BranchLength
rootHeight (Node _ _ []) = 0
rootHeight t = maximum $ concatMap distancesOriginLeaves (forest t)
distancesOriginLeaves :: Measurable e => Tree e a -> [BranchLength]
distancesOriginLeaves (Node br _ []) = [getLen br]
distancesOriginLeaves (Node br _ ts) = map (getLen br +) (concatMap distancesOriginLeaves ts)
totalBranchLength :: Measurable e => Tree e a -> BranchLength
totalBranchLength = bifoldl' (+) const 0 . first getLen
normalizeBranchLengths :: Measurable e => Tree e a -> Tree e a
normalizeBranchLengths t = first (apply (/ s)) t
where
s = totalBranchLength t
normalizeHeight :: Measurable e => Tree e a -> Tree e a
normalizeHeight t = first (apply (/ h)) t
where
h = height t
eps :: Double
eps = 1e-12
allNearlyEqual :: [Double] -> Bool
allNearlyEqual [] = True
allNearlyEqual xs = all (\y -> eps > abs (x - y)) (tail xs)
where
x = head xs
ultrametric :: Measurable e => Tree e a -> Bool
ultrametric = allNearlyEqual . distancesOriginLeaves
makeUltrametric :: Measurable e => Tree e a -> Tree e a
makeUltrametric t = go 0 t
where
h = height t
go :: Measurable e => BranchLength -> Tree e a -> Tree e a
go h' (Node br lb []) = let dh = h - h' - getLen br in Node (apply (+ dh) br) lb []
go h' (Node br lb ts) = let h'' = h' + getLen br in Node br lb $ map (go h'') ts