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

-- |
-- Module      :  ELynx.Tree.Phylogeny
-- Description :  Phylogenetic trees
-- Copyright   :  (c) Dominik Schrempf 2021
-- License     :  GPL-3.0-or-later
--
-- Maintainer  :  dominik.schrempf@gmail.com
-- Stability   :  unstable
-- Portability :  portable
--
-- Creation date: Thu Jan 17 16:08:54 2019.
--
-- The purpose of this module is to facilitate usage of 'Tree's in phylogenetic
-- analyses. A /phylogeny/ is a 'Tree' with unique leaf labels, and unordered
-- sub-forest.
--
-- Using the 'Tree' data type has some disadvantages.
--
-- 1. All trees are rooted. Unrooted trees can be treated with a rooted data
-- structure, as it is used here. However, some functions may be meaningless.
--
-- 2. Changing branch labels, node labels, or the topology of the tree is slow,
-- especially when the changes are close to the leaves of the tree.
--
-- 3. Internally, the underlying 'Tree' data structure stores the sub-forest as
-- an ordered list. Hence, we have to do some tricks when comparing phylogenies
-- (see 'equal'), and comparison is slow.
--
-- 4. Uniqueness of the leaves is not ensured by the data type, but has to be
-- checked at runtime. Functions relying on the tree to have unique leaves do
-- perform this check, and return 'Left' with a message, if the tree has
-- duplicate leaves.
--
-- NOTE: 'Tree's are rooted.
--
-- NOTE: 'Tree's encoded in Newick format correspond to rooted trees. By
-- convention only, a tree parsed from Newick format is usually thought to be
-- unrooted, when the root node is multifurcating and has three or more
-- children. This convention is not used here. Newick trees are just parsed as
-- they are, and a rooted tree is returned.
module ELynx.Tree.Phylogeny
  ( -- * Functions
    equal,
    equal',
    intersect,
    bifurcating,
    outgroup,
    midpoint,
    roots,

    -- * Branch labels
    Phylo (..),
    toPhyloLabel,
    toPhyloTree,
    lengthToPhyloLabel,
    lengthToPhyloTree,
    supportToPhyloLabel,
    supportToPhyloTree,
    toLengthTree,
    toSupportTree,

    -- * Explicit branch labels
    PhyloExplicit (..),
    toExplicitTree,
  )
where

import Control.DeepSeq
import Data.Aeson
import Data.Bifunctor
import Data.Default.Class
import Data.List hiding (intersect)
import Data.Maybe
import Data.Monoid
import Data.Semigroup
import Data.Set (Set)
import qualified Data.Set as S
import ELynx.Tree.Bipartition
import ELynx.Tree.Length
import ELynx.Tree.Rooted
import ELynx.Tree.Splittable
import ELynx.Tree.Support
import GHC.Generics

-- | The equality check is slow because the order of children is considered to
-- be arbitrary.
--
-- Return 'Left' if a tree does not have unique leaves.
equal :: (Eq e, Eq a, Ord a) => Tree e a -> Tree e a -> Either String Bool
equal :: Tree e a -> Tree e a -> Either String Bool
equal Tree e a
tL Tree e a
tR
  | Tree e a -> Bool
forall a e. Ord a => Tree e a -> Bool
duplicateLeaves Tree e a
tL = String -> Either String Bool
forall a b. a -> Either a b
Left String
"equal: Left tree has duplicate leaves."
  | Tree e a -> Bool
forall a e. Ord a => Tree e a -> Bool
duplicateLeaves Tree e a
tR = String -> Either String Bool
forall a b. a -> Either a b
Left String
"equal: Right tree has duplicate leaves."
  | Bool
otherwise = Bool -> Either String Bool
forall a b. b -> Either a b
Right (Bool -> Either String Bool) -> Bool -> Either String Bool
forall a b. (a -> b) -> a -> b
$ Tree e a -> Tree e a -> Bool
forall e a. (Eq e, Eq a) => Tree e a -> Tree e a -> Bool
equal' Tree e a
tL Tree e a
tR

-- | Same as 'equal', but assume that leaves are unique.
equal' :: (Eq e, Eq a) => Tree e a -> Tree e a -> Bool
equal' :: Tree e a -> Tree e a -> Bool
equal' ~(Node e
brL a
lbL Forest e a
tsL) ~(Node e
brR a
lbR Forest e a
tsR) =
  (e
brL e -> e -> Bool
forall a. Eq a => a -> a -> Bool
== e
brR)
    Bool -> Bool -> Bool
&& (a
lbL a -> a -> Bool
forall a. Eq a => a -> a -> Bool
== a
lbR)
    Bool -> Bool -> Bool
&& (Forest e a -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length Forest e a
tsL Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Forest e a -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length Forest e a
tsR)
    Bool -> Bool -> Bool
&& (Tree e a -> Bool) -> Forest e a -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (Tree e a -> Forest e a -> Bool
forall (t :: * -> *) e a.
(Foldable t, Eq e, Eq a) =>
Tree e a -> t (Tree e a) -> Bool
`elem'` Forest e a
tsR) Forest e a
tsL
  where
    elem' :: Tree e a -> t (Tree e a) -> Bool
elem' Tree e a
t t (Tree e a)
ts = Maybe (Tree e a) -> Bool
forall a. Maybe a -> Bool
isJust (Maybe (Tree e a) -> Bool) -> Maybe (Tree e a) -> Bool
forall a b. (a -> b) -> a -> b
$ (Tree e a -> Bool) -> t (Tree e a) -> Maybe (Tree e a)
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
find (Tree e a -> Tree e a -> Bool
forall e a. (Eq e, Eq a) => Tree e a -> Tree e a -> Bool
equal' Tree e a
t) t (Tree e a)
ts

-- | Intersection of trees.
--
-- The intersections are the largest subtrees sharing the same leaf set.
--
-- Degree two nodes are pruned with 'prune'.
--
-- Return 'Left' if:
--
-- - the intersection of leaves is empty.
intersect ::
  (Semigroup e, Eq e, Ord a) => Forest e a -> Either String (Forest e a)
intersect :: Forest e a -> Either String (Forest e a)
intersect Forest e a
ts
  | Set a -> Bool
forall a. Set a -> Bool
S.null Set a
lvsCommon = String -> Either String (Forest e a)
forall a b. a -> Either a b
Left String
"intersect: Intersection of leaves is empty."
  | Bool
otherwise = case [Maybe (Tree e a)] -> Maybe (Forest e a)
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
sequence [(a -> Bool) -> Tree e a -> Maybe (Tree e a)
forall a e. (a -> Bool) -> Tree e a -> Maybe (Tree e a)
dropLeavesWith (Set a -> a -> Bool
forall a. Ord a => Set a -> a -> Bool
predicate Set a
ls) Tree e a
t | (Set a
ls, Tree e a
t) <- [Set a] -> Forest e a -> [(Set a, Tree e a)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Set a]
leavesToDrop Forest e a
ts] of
    Maybe (Forest e a)
Nothing -> String -> Either String (Forest e a)
forall a b. a -> Either a b
Left String
"intersect: A tree is empty."
    Just Forest e a
ts' -> Forest e a -> Either String (Forest e a)
forall a b. b -> Either a b
Right Forest e a
ts'
  where
    -- Leaf sets.
    lvss :: [Set a]
lvss = (Tree e a -> Set a) -> Forest e a -> [Set a]
forall a b. (a -> b) -> [a] -> [b]
map ([a] -> Set a
forall a. Ord a => [a] -> Set a
S.fromList ([a] -> Set a) -> (Tree e a -> [a]) -> Tree e a -> Set a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Tree e a -> [a]
forall e a. Tree e a -> [a]
leaves) Forest e a
ts
    -- Common leaf set.
    lvsCommon :: Set a
lvsCommon = (Set a -> Set a -> Set a) -> [Set a] -> Set a
forall a. (a -> a -> a) -> [a] -> a
foldl1' Set a -> Set a -> Set a
forall a. Ord a => Set a -> Set a -> Set a
S.intersection [Set a]
lvss
    -- Leaves to drop for each tree in the forest.
    leavesToDrop :: [Set a]
leavesToDrop = (Set a -> Set a) -> [Set a] -> [Set a]
forall a b. (a -> b) -> [a] -> [b]
map (Set a -> Set a -> Set a
forall a. Ord a => Set a -> Set a -> Set a
S.\\ Set a
lvsCommon) [Set a]
lvss
    -- Predicate.
    predicate :: Set a -> a -> Bool
predicate Set a
lvsToDr a
l = a
l a -> Set a -> Bool
forall a. Ord a => a -> Set a -> Bool
`S.member` Set a
lvsToDr

-- | Check if tree is bifurcating.
--
-- A Bifurcating tree only contains degree one (leaves) and degree three nodes
-- (internal bifurcating nodes).
bifurcating :: Tree e a -> Bool
bifurcating :: Tree e a -> Bool
bifurcating (Node e
_ a
_ []) = Bool
True
bifurcating (Node e
_ a
_ [Tree e a
x, Tree e a
y]) = Tree e a -> Bool
forall e a. Tree e a -> Bool
bifurcating Tree e a
x Bool -> Bool -> Bool
&& Tree e a -> Bool
forall e a. Tree e a -> Bool
bifurcating Tree e a
y
bifurcating Tree e a
_ = Bool
False

-- | Root tree using an outgroup.
--
-- If the root note is bifurcating, the root node is moved to the position
-- specified by the outgroup.
--
-- If the root node is multifurcating, a new root node is introduced using the
-- 'Default' instance of the node labels. Thereby, the degree of the original
-- root node is reduced by one.
--
-- Branches are connected and split according to the provided 'Semigroup' and
-- 'Splittable' instances.
--
-- Return 'Left' if
--
-- - the root node is a leaf;
--
-- - the root node has degree two;
--
-- - the tree has duplicate leaves;
--
-- - the provided outgroup is polyphyletic or not found on the tree.
outgroup ::
  (Semigroup e, Splittable e, Default a, Ord a) =>
  Set a ->
  Tree e a ->
  Either String (Tree e a)
outgroup :: Set a -> Tree e a -> Either String (Tree e a)
outgroup Set a
_ (Node e
_ a
_ []) = String -> Either String (Tree e a)
forall a b. a -> Either a b
Left String
"outgroup: Root node is a leaf."
outgroup Set a
_ (Node e
_ a
_ [Tree e a
_]) = String -> Either String (Tree e a)
forall a b. a -> Either a b
Left String
"outgroup: Root node has degree two."
outgroup Set a
o Tree e a
t = do
  Bipartition a
bip <- Set a -> Set a -> Either String (Bipartition a)
forall a. Ord a => Set a -> Set a -> Either String (Bipartition a)
bp Set a
o ([a] -> Set a
forall a. Ord a => [a] -> Set a
S.fromList (Tree e a -> [a]
forall e a. Tree e a -> [a]
leaves Tree e a
t) Set a -> Set a -> Set a
forall a. Ord a => Set a -> Set a -> Set a
S.\\ Set a
o)
  Bipartition a -> Tree e a -> Either String (Tree e a)
forall e a.
(Semigroup e, Splittable e, Eq a, Default a, Ord a) =>
Bipartition a -> Tree e a -> Either String (Tree e a)
rootAt Bipartition a
bip Tree e a
t

-- Root the tree at the branch defined by the given bipartition. The original
-- root node is moved to the new position.
rootAt ::
  (Semigroup e, Splittable e, Eq a, Default a, Ord a) =>
  Bipartition a ->
  Tree e a ->
  Either String (Tree e a)
rootAt :: Bipartition a -> Tree e a -> Either String (Tree e a)
rootAt Bipartition a
b Tree e a
t
  -- Do not use 'duplicateLeaves' here, because we also need to compare the leaf
  -- set with the bipartition.
  | [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [a]
lvLst Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
/= Set a -> Int
forall a. Set a -> Int
S.size Set a
lvSet = String -> Either String (Tree e a)
forall a b. a -> Either a b
Left String
"rootAt: Tree has duplicate leaves."
  | Bipartition a -> Set a
forall a. Ord a => Bipartition a -> Set a
toSet Bipartition a
b Set a -> Set a -> Bool
forall a. Eq a => a -> a -> Bool
/= Set a
lvSet = String -> Either String (Tree e a)
forall a b. a -> Either a b
Left String
"rootAt: Bipartition does not match leaves of tree."
  | Bool
otherwise = do
    Forest e a
ts <- Tree e a -> Either String (Forest e a)
forall e a.
(Semigroup e, Splittable e, Default a) =>
Tree e a -> Either String (Forest e a)
roots Tree e a
t
    case (Tree e a -> Bool) -> Forest e a -> Maybe (Tree e a)
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
find (\Tree e a
x -> Tree e a -> Either String (Bipartition a)
forall a e. Ord a => Tree e a -> Either String (Bipartition a)
bipartition Tree e a
x Either String (Bipartition a)
-> Either String (Bipartition a) -> Bool
forall a. Eq a => a -> a -> Bool
== Bipartition a -> Either String (Bipartition a)
forall a b. b -> Either a b
Right Bipartition a
b) Forest e a
ts of
      Maybe (Tree e a)
Nothing -> String -> Either String (Tree e a)
forall a b. a -> Either a b
Left String
"rootAt': Bipartition not found on tree."
      Just Tree e a
t' -> Tree e a -> Either String (Tree e a)
forall a b. b -> Either a b
Right Tree e a
t'
  where
    lvLst :: [a]
lvLst = Tree e a -> [a]
forall e a. Tree e a -> [a]
leaves Tree e a
t
    lvSet :: Set a
lvSet = [a] -> Set a
forall a. Ord a => [a] -> Set a
S.fromList ([a] -> Set a) -> [a] -> Set a
forall a b. (a -> b) -> a -> b
$ Tree e a -> [a]
forall e a. Tree e a -> [a]
leaves Tree e a
t

-- NOTE: The 'midpoint' algorithm has not been optimized. All rooted trees are
-- calculated and then the one minimizing the difference between the heights of
-- the left and right sub tree is chosen. Better: Move left or right minimizing
-- the height difference between the left and right sub tree.

-- | Root tree at midpoint.
--
-- Branches are connected and split according to the provided 'Semigroup' and
-- 'Splittable' instances.
--
-- Return 'Left' if
--
-- - the root node is a leaf;
--
-- - the root node has degree two.
midpoint ::
  (Semigroup e, Splittable e, HasLength e, Default a) =>
  Tree e a ->
  Either String (Tree e a)
midpoint :: Tree e a -> Either String (Tree e a)
midpoint (Node e
_ a
_ []) = String -> Either String (Tree e a)
forall a b. a -> Either a b
Left String
"midpoint: Root node is a leaf."
midpoint (Node e
_ a
_ [Tree e a
_]) = String -> Either String (Tree e a)
forall a b. a -> Either a b
Left String
"midpoint: Root node has degree two."
midpoint Tree e a
t = Tree e a -> Either String [Tree e a]
forall e a.
(Semigroup e, Splittable e, Default a) =>
Tree e a -> Either String (Forest e a)
roots Tree e a
t Either String [Tree e a]
-> ([Tree e a] -> Either String (Tree e a))
-> Either String (Tree e a)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= [Tree e a] -> Either String (Tree e a)
forall e a. HasLength e => [Tree e a] -> Either String (Tree e a)
getMidpoint

-- Find the index of the smallest element.
findMinIndex :: Ord a => [a] -> Either String Int
findMinIndex :: [a] -> Either String Int
findMinIndex (a
x : [a]
xs) = (Int, a) -> Int -> [a] -> Either String Int
forall b a a. (Ord b, Num a) => (a, b) -> a -> [b] -> Either a a
go (Int
0, a
x) Int
1 [a]
xs
  where
    go :: (a, b) -> a -> [b] -> Either a a
go (a
i, b
_) a
_ [] = a -> Either a a
forall a b. b -> Either a b
Right a
i
    -- Indices with respect to original list: i is index of z, j is index of y.
    go (a
i, b
z) a
j (b
y : [b]
ys) = if b
z b -> b -> Bool
forall a. Ord a => a -> a -> Bool
< b
y then (a, b) -> a -> [b] -> Either a a
go (a
i, b
z) (a
j a -> a -> a
forall a. Num a => a -> a -> a
+ a
1) [b]
ys else (a, b) -> a -> [b] -> Either a a
go (a
j, b
y) (a
j a -> a -> a
forall a. Num a => a -> a -> a
+ a
1) [b]
ys
findMinIndex [] = String -> Either String Int
forall a b. a -> Either a b
Left String
"findMinIndex: Empty list."

getMidpoint :: HasLength e => [Tree e a] -> Either String (Tree e a)
getMidpoint :: [Tree e a] -> Either String (Tree e a)
getMidpoint [Tree e a]
ts = case Either String (Tree e a)
t of
  Right (Node e
br a
lb [Tree e a
l, Tree e a
r]) ->
    let hl :: Length
hl = Tree e a -> Length
forall e a. HasLength e => Tree e a -> Length
height Tree e a
l
        hr :: Length
hr = Tree e a -> Length
forall e a. HasLength e => Tree e a -> Length
height Tree e a
r
        dh :: Length
dh = (Length
hl Length -> Length -> Length
forall a. Num a => a -> a -> a
- Length
hr) Length -> Length -> Length
forall a. Fractional a => a -> a -> a
/ Length
2
     in Tree e a -> Either String (Tree e a)
forall a b. b -> Either a b
Right (Tree e a -> Either String (Tree e a))
-> Tree e a -> Either String (Tree e a)
forall a b. (a -> b) -> a -> b
$
          e -> a -> [Tree e a] -> Tree e a
forall e a. e -> a -> Forest e a -> Tree e a
Node
            e
br
            a
lb
            [ (e -> e) -> Tree e a -> Tree e a
forall e a. (e -> e) -> Tree e a -> Tree e a
modifyStem ((Length -> Length) -> e -> e
forall e. HasLength e => (Length -> Length) -> e -> e
modifyLength (Length -> Length -> Length
forall p. (Ord p, Fractional p) => p -> p -> p
subtract' Length
dh)) Tree e a
l,
              (e -> e) -> Tree e a -> Tree e a
forall e a. (e -> e) -> Tree e a -> Tree e a
modifyStem ((Length -> Length) -> e -> e
forall e. HasLength e => (Length -> Length) -> e -> e
modifyLength (Length -> Length -> Length
forall a. Num a => a -> a -> a
+ Length
dh)) Tree e a
r
            ]
  Right Tree e a
_ -> String -> Either String (Tree e a)
forall a. HasCallStack => String -> a
error String
"getMidpoint: Root node is not bifurcating?"
  Left String
e -> String -> Either String (Tree e a)
forall a b. a -> Either a b
Left String
e
  where
    dhs :: [Length]
dhs = (Tree e a -> Length) -> [Tree e a] -> [Length]
forall a b. (a -> b) -> [a] -> [b]
map Tree e a -> Length
forall e a. HasLength e => Tree e a -> Length
getDeltaHeight [Tree e a]
ts
    -- Find index of minimum. Take this tree and move root to the midpoint of
    -- the branch.
    t :: Either String (Tree e a)
t = ([Tree e a]
ts [Tree e a] -> Int -> Tree e a
forall a. [a] -> Int -> a
!!) (Int -> Tree e a) -> Either String Int -> Either String (Tree e a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Length] -> Either String Int
forall a. Ord a => [a] -> Either String Int
findMinIndex [Length]
dhs
    -- Subtract, and check that larger equal 0 with a precision close to the
    -- machine precision of roughly 1e-16.
    subtract' :: p -> p -> p
subtract' p
dx p
x =
      let x' :: p
x' = p -> p -> p
forall a. Num a => a -> a -> a
subtract p
dx p
x
       in case p -> p -> Ordering
forall a. Ord a => a -> a -> Ordering
compare p
x' p
0 of
            Ordering
LT -> if p
x' p -> p -> Bool
forall a. Ord a => a -> a -> Bool
< p
1e-14 then String -> p
forall a. HasCallStack => String -> a
error String
"getMidpoint: Length less than zero." else p
0
            Ordering
_ -> p
x'

-- Get delta height of left and right sub tree.
getDeltaHeight :: HasLength e => Tree e a -> Length
getDeltaHeight :: Tree e a -> Length
getDeltaHeight (Node e
_ a
_ [Tree e a
l, Tree e a
r]) = Length -> Length
forall a. Num a => a -> a
abs (Length -> Length) -> Length -> Length
forall a b. (a -> b) -> a -> b
$ Tree e a -> Length
forall e a. HasLength e => Tree e a -> Length
height Tree e a
l Length -> Length -> Length
forall a. Num a => a -> a -> a
- Tree e a -> Length
forall e a. HasLength e => Tree e a -> Length
height Tree e a
r
getDeltaHeight Tree e a
_ = String -> Length
forall a. HasCallStack => String -> a
error String
"getDeltaHeight: Root node is not bifurcating?"

-- | Get all rooted trees with bifurcating root nodes.
--
-- If the root node of the original tree is bifurcating, the root node (label
-- and branch) is moved, and the original tree is part of the result.
--
-- If the root node of the original tree is multifurcating, a new root node is
-- introduced using the 'Default' instance of the node labels. Thereby, the
-- degree of the original root node is reduced by one. The original,
-- multifurcating tree is not part of the result.
--
-- Branches are connected and split according to the provided 'Semigroup' and
-- 'Splittable' instances.
--
-- For a tree with @n@ nodes we have:
--
-- - @n-2@ rooted trees if the root node is bifurcating;
--
-- - (n-1) rooted trees if the root node is multifurcating.
roots :: (Semigroup e, Splittable e, Default a) => Tree e a -> Either String (Forest e a)
roots :: Tree e a -> Either String (Forest e a)
roots (Node e
_ a
_ []) = String -> Either String (Forest e a)
forall a b. a -> Either a b
Left String
"roots: Root node is a leaf."
roots (Node e
_ a
_ [Tree e a
_]) = String -> Either String (Forest e a)
forall a b. a -> Either a b
Left String
"roots: Root node has degree two."
roots t :: Tree e a
t@(Node e
b a
c [Tree e a
tL, Tree e a
tR]) = Forest e a -> Either String (Forest e a)
forall a b. b -> Either a b
Right (Forest e a -> Either String (Forest e a))
-> Forest e a -> Either String (Forest e a)
forall a b. (a -> b) -> a -> b
$ Tree e a
t Tree e a -> Forest e a -> Forest e a
forall a. a -> [a] -> [a]
: e -> a -> Tree e a -> Tree e a -> Forest e a
forall e a.
(Semigroup e, Splittable e) =>
e -> a -> Tree e a -> Tree e a -> Forest e a
descend e
b a
c Tree e a
tR Tree e a
tL Forest e a -> Forest e a -> Forest e a
forall a. [a] -> [a] -> [a]
++ e -> a -> Tree e a -> Tree e a -> Forest e a
forall e a.
(Semigroup e, Splittable e) =>
e -> a -> Tree e a -> Tree e a -> Forest e a
descend e
b a
c Tree e a
tL Tree e a
tR
roots (Node e
b a
c Forest e a
ts) = Tree e a -> Either String (Forest e a)
forall e a.
(Semigroup e, Splittable e, Default a) =>
Tree e a -> Either String (Forest e a)
roots (Tree e a -> Either String (Forest e a))
-> Tree e a -> Either String (Forest e a)
forall a b. (a -> b) -> a -> b
$ e -> a -> Forest e a -> Tree e a
forall e a. e -> a -> Forest e a -> Tree e a
Node e
b a
forall a. Default a => a
def [Tree e a
tL, Tree e a
tR]
  where
    (Node e
bL a
lL Forest e a
tsL) = Forest e a -> Tree e a
forall a. [a] -> a
head Forest e a
ts
    bL' :: e
bL' = e -> e
forall e. Splittable e => e -> e
split e
bL
    tL :: Tree e a
tL = e -> a -> Forest e a -> Tree e a
forall e a. e -> a -> Forest e a -> Tree e a
Node e
bL' a
lL Forest e a
tsL
    tR :: Tree e a
tR = e -> a -> Forest e a -> Tree e a
forall e a. e -> a -> Forest e a -> Tree e a
Node e
bL' a
c (Forest e a -> Tree e a) -> Forest e a -> Tree e a
forall a b. (a -> b) -> a -> b
$ Forest e a -> Forest e a
forall a. [a] -> [a]
tail Forest e a
ts

complementaryForests :: Tree e a -> Forest e a -> [Forest e a]
complementaryForests :: Tree e a -> Forest e a -> [Forest e a]
complementaryForests Tree e a
t Forest e a
ts = [Tree e a
t Tree e a -> Forest e a -> Forest e a
forall a. a -> [a] -> [a]
: Int -> Forest e a -> Forest e a
forall a. Int -> [a] -> [a]
take Int
i Forest e a
ts Forest e a -> Forest e a -> Forest e a
forall a. [a] -> [a] -> [a]
++ Int -> Forest e a -> Forest e a
forall a. Int -> [a] -> [a]
drop (Int
i Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1) Forest e a
ts | Int
i <- [Int
0 .. (Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
-Int
1)]]
  where
    n :: Int
n = Forest e a -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length Forest e a
ts

-- Descend into the downward tree.
--
-- @
-- descend rootBranch rootLabel complementaryTree downwardsTree
-- @
descend :: (Semigroup e, Splittable e) => e -> a -> Tree e a -> Tree e a -> Forest e a
descend :: e -> a -> Tree e a -> Tree e a -> Forest e a
descend e
_ a
_ Tree e a
_ (Node e
_ a
_ []) = []
descend e
brR a
lbR Tree e a
tC (Node e
brD a
lbD Forest e a
tsD) =
  [ e -> a -> Forest e a -> Tree e a
forall e a. e -> a -> Forest e a -> Tree e a
Node e
brR a
lbR [e -> a -> Forest e a -> Tree e a
forall e a. e -> a -> Forest e a -> Tree e a
Node (e -> e
forall e. Splittable e => e -> e
split e
brDd) a
lbD Forest e a
f, e -> a -> Forest e a -> Tree e a
forall e a. e -> a -> Forest e a -> Tree e a
Node (e -> e
forall e. Splittable e => e -> e
split e
brDd) a
lbDd Forest e a
tsDd]
    | (Node e
brDd a
lbDd Forest e a
tsDd, Forest e a
f) <- Forest e a -> [Forest e a] -> [(Tree e a, Forest e a)]
forall a b. [a] -> [b] -> [(a, b)]
zip Forest e a
tsD [Forest e a]
cfs
  ]
    Forest e a -> Forest e a -> Forest e a
forall a. [a] -> [a] -> [a]
++ [Forest e a] -> Forest e a
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
      [ e -> a -> Tree e a -> Tree e a -> Forest e a
forall e a.
(Semigroup e, Splittable e) =>
e -> a -> Tree e a -> Tree e a -> Forest e a
descend e
brR a
lbR (e -> a -> Forest e a -> Tree e a
forall e a. e -> a -> Forest e a -> Tree e a
Node (e -> e
forall e. Splittable e => e -> e
split e
brDd) a
lbD Forest e a
f) (e -> a -> Forest e a -> Tree e a
forall e a. e -> a -> Forest e a -> Tree e a
Node (e -> e
forall e. Splittable e => e -> e
split e
brDd) a
lbDd Forest e a
tsDd)
        | (Node e
brDd a
lbDd Forest e a
tsDd, Forest e a
f) <- Forest e a -> [Forest e a] -> [(Tree e a, Forest e a)]
forall a b. [a] -> [b] -> [(a, b)]
zip Forest e a
tsD [Forest e a]
cfs
      ]
  where
    brC' :: e
brC' = Tree e a -> e
forall e a. Tree e a -> e
branch Tree e a
tC e -> e -> e
forall a. Semigroup a => a -> a -> a
<> e
brD
    tC' :: Tree e a
tC' = Tree e a
tC {branch :: e
branch = e
brC'}
    cfs :: [Forest e a]
cfs = Tree e a -> Forest e a -> [Forest e a]
forall e a. Tree e a -> Forest e a -> [Forest e a]
complementaryForests Tree e a
tC' Forest e a
tsD

-- | Branch label for phylogenetic trees.
--
-- Branches may have a length and a support value.
--
-- Especially useful to export trees to Newick format; see
-- 'ELynx.Tree.Export.Newick.toNewick'.
data Phylo = Phylo
  { Phylo -> Maybe Length
pBranchLength :: Maybe Length,
    Phylo -> Maybe Support
pBranchSupport :: Maybe Support
  }
  deriving (ReadPrec [Phylo]
ReadPrec Phylo
Int -> ReadS Phylo
ReadS [Phylo]
(Int -> ReadS Phylo)
-> ReadS [Phylo]
-> ReadPrec Phylo
-> ReadPrec [Phylo]
-> Read Phylo
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
readListPrec :: ReadPrec [Phylo]
$creadListPrec :: ReadPrec [Phylo]
readPrec :: ReadPrec Phylo
$creadPrec :: ReadPrec Phylo
readList :: ReadS [Phylo]
$creadList :: ReadS [Phylo]
readsPrec :: Int -> ReadS Phylo
$creadsPrec :: Int -> ReadS Phylo
Read, Int -> Phylo -> ShowS
[Phylo] -> ShowS
Phylo -> String
(Int -> Phylo -> ShowS)
-> (Phylo -> String) -> ([Phylo] -> ShowS) -> Show Phylo
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Phylo] -> ShowS
$cshowList :: [Phylo] -> ShowS
show :: Phylo -> String
$cshow :: Phylo -> String
showsPrec :: Int -> Phylo -> ShowS
$cshowsPrec :: Int -> Phylo -> ShowS
Show, Phylo -> Phylo -> Bool
(Phylo -> Phylo -> Bool) -> (Phylo -> Phylo -> Bool) -> Eq Phylo
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Phylo -> Phylo -> Bool
$c/= :: Phylo -> Phylo -> Bool
== :: Phylo -> Phylo -> Bool
$c== :: Phylo -> Phylo -> Bool
Eq, Eq Phylo
Eq Phylo
-> (Phylo -> Phylo -> Ordering)
-> (Phylo -> Phylo -> Bool)
-> (Phylo -> Phylo -> Bool)
-> (Phylo -> Phylo -> Bool)
-> (Phylo -> Phylo -> Bool)
-> (Phylo -> Phylo -> Phylo)
-> (Phylo -> Phylo -> Phylo)
-> Ord Phylo
Phylo -> Phylo -> Bool
Phylo -> Phylo -> Ordering
Phylo -> Phylo -> Phylo
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 :: Phylo -> Phylo -> Phylo
$cmin :: Phylo -> Phylo -> Phylo
max :: Phylo -> Phylo -> Phylo
$cmax :: Phylo -> Phylo -> Phylo
>= :: Phylo -> Phylo -> Bool
$c>= :: Phylo -> Phylo -> Bool
> :: Phylo -> Phylo -> Bool
$c> :: Phylo -> Phylo -> Bool
<= :: Phylo -> Phylo -> Bool
$c<= :: Phylo -> Phylo -> Bool
< :: Phylo -> Phylo -> Bool
$c< :: Phylo -> Phylo -> Bool
compare :: Phylo -> Phylo -> Ordering
$ccompare :: Phylo -> Phylo -> Ordering
$cp1Ord :: Eq Phylo
Ord, (forall x. Phylo -> Rep Phylo x)
-> (forall x. Rep Phylo x -> Phylo) -> Generic Phylo
forall x. Rep Phylo x -> Phylo
forall x. Phylo -> Rep Phylo x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep Phylo x -> Phylo
$cfrom :: forall x. Phylo -> Rep Phylo x
Generic, Phylo -> ()
(Phylo -> ()) -> NFData Phylo
forall a. (a -> ()) -> NFData a
rnf :: Phylo -> ()
$crnf :: Phylo -> ()
NFData)

instance Semigroup Phylo where
  Phylo Maybe Length
mBL Maybe Support
mSL <> :: Phylo -> Phylo -> Phylo
<> Phylo Maybe Length
mBR Maybe Support
mSR =
    Maybe Length -> Maybe Support -> Phylo
Phylo
      (Sum Length -> Length
forall a. Sum a -> a
getSum (Sum Length -> Length) -> Maybe (Sum Length) -> Maybe Length
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Length -> Sum Length
forall a. a -> Sum a
Sum (Length -> Sum Length) -> Maybe Length -> Maybe (Sum Length)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe Length
mBL) Maybe (Sum Length) -> Maybe (Sum Length) -> Maybe (Sum Length)
forall a. Semigroup a => a -> a -> a
<> (Length -> Sum Length
forall a. a -> Sum a
Sum (Length -> Sum Length) -> Maybe Length -> Maybe (Sum Length)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe Length
mBR))
      (Min Support -> Support
forall a. Min a -> a
getMin (Min Support -> Support) -> Maybe (Min Support) -> Maybe Support
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Support -> Min Support
forall a. a -> Min a
Min (Support -> Min Support) -> Maybe Support -> Maybe (Min Support)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe Support
mSL) Maybe (Min Support) -> Maybe (Min Support) -> Maybe (Min Support)
forall a. Semigroup a => a -> a -> a
<> (Support -> Min Support
forall a. a -> Min a
Min (Support -> Min Support) -> Maybe Support -> Maybe (Min Support)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe Support
mSR))

instance HasMaybeLength Phylo where
  getMaybeLength :: Phylo -> Maybe Length
getMaybeLength = Phylo -> Maybe Length
pBranchLength

instance HasMaybeSupport Phylo where
  getMaybeSupport :: Phylo -> Maybe Support
getMaybeSupport = Phylo -> Maybe Support
pBranchSupport

instance ToJSON Phylo

instance FromJSON Phylo

-- | Set branch length and support value.
toPhyloLabel :: (HasMaybeLength e, HasMaybeSupport e) => e -> Phylo
toPhyloLabel :: e -> Phylo
toPhyloLabel e
x = Maybe Length -> Maybe Support -> Phylo
Phylo (e -> Maybe Length
forall e. HasMaybeLength e => e -> Maybe Length
getMaybeLength e
x) (e -> Maybe Support
forall e. HasMaybeSupport e => e -> Maybe Support
getMaybeSupport e
x)

-- | See 'toPhyloLabel'.
toPhyloTree :: (HasMaybeLength e, HasMaybeSupport e) => Tree e a -> Tree Phylo a
toPhyloTree :: Tree e a -> Tree Phylo a
toPhyloTree = (e -> Phylo) -> Tree e a -> Tree Phylo a
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first e -> Phylo
forall e. (HasMaybeLength e, HasMaybeSupport e) => e -> Phylo
toPhyloLabel

-- | Set branch length. Do not set support value.
lengthToPhyloLabel :: HasMaybeLength e => e -> Phylo
lengthToPhyloLabel :: e -> Phylo
lengthToPhyloLabel e
x = Maybe Length -> Maybe Support -> Phylo
Phylo (e -> Maybe Length
forall e. HasMaybeLength e => e -> Maybe Length
getMaybeLength e
x) Maybe Support
forall a. Maybe a
Nothing

-- | See 'lengthToPhyloLabel'.
lengthToPhyloTree :: HasMaybeLength e => Tree e a -> Tree Phylo a
lengthToPhyloTree :: Tree e a -> Tree Phylo a
lengthToPhyloTree = (e -> Phylo) -> Tree e a -> Tree Phylo a
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first e -> Phylo
forall e. HasMaybeLength e => e -> Phylo
lengthToPhyloLabel

-- | Set support value. Do not set branch length.
supportToPhyloLabel :: HasMaybeSupport e => e -> Phylo
supportToPhyloLabel :: e -> Phylo
supportToPhyloLabel e
x = Maybe Length -> Maybe Support -> Phylo
Phylo Maybe Length
forall a. Maybe a
Nothing (e -> Maybe Support
forall e. HasMaybeSupport e => e -> Maybe Support
getMaybeSupport e
x)

-- | See 'supportToPhyloLabel'.
supportToPhyloTree :: HasMaybeSupport e => Tree e a -> Tree Phylo a
supportToPhyloTree :: Tree e a -> Tree Phylo a
supportToPhyloTree = (e -> Phylo) -> Tree e a -> Tree Phylo a
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first e -> Phylo
forall e. HasMaybeSupport e => e -> Phylo
supportToPhyloLabel

fromMaybeWithError :: String -> Maybe a -> Either String a
fromMaybeWithError :: String -> Maybe a -> Either String a
fromMaybeWithError String
s = Either String a
-> (a -> Either String a) -> Maybe a -> Either String a
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (String -> Either String a
forall a b. a -> Either a b
Left String
s) a -> Either String a
forall a b. b -> Either a b
Right

-- | If root branch length is not available, set it to 0.
--
-- Return 'Left' if any other branch length is unavailable.
toLengthTree :: HasMaybeLength e => Tree e a -> Either String (Tree Length a)
toLengthTree :: Tree e a -> Either String (Tree Length a)
toLengthTree (Node e
br a
lb Forest e a
ts) =
  case (Tree e a -> Maybe (Tree Length a))
-> Forest e a -> Maybe [Tree Length a]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse Tree e a -> Maybe (Tree Length a)
forall e a. HasMaybeLength e => Tree e a -> Maybe (Tree Length a)
go Forest e a
ts of
    Maybe [Tree Length a]
Nothing -> String -> Either String (Tree Length a)
forall a b. a -> Either a b
Left String
"toLengthTree: Length unavailable for some branches."
    Just [Tree Length a]
ts' -> Tree Length a -> Either String (Tree Length a)
forall a b. b -> Either a b
Right (Tree Length a -> Either String (Tree Length a))
-> Tree Length a -> Either String (Tree Length a)
forall a b. (a -> b) -> a -> b
$ Length -> a -> [Tree Length a] -> Tree Length a
forall e a. e -> a -> Forest e a -> Tree e a
Node Length
br' a
lb [Tree Length a]
ts'
  where
    br' :: Length
br' = Length -> Maybe Length -> Length
forall a. a -> Maybe a -> a
fromMaybe Length
0 (Maybe Length -> Length) -> Maybe Length -> Length
forall a b. (a -> b) -> a -> b
$ e -> Maybe Length
forall e. HasMaybeLength e => e -> Maybe Length
getMaybeLength e
br
    go :: Tree e a -> Maybe (Tree Length a)
go Tree e a
t = BranchTree a Length -> Tree Length a
forall a e. BranchTree a e -> Tree e a
getBranchTree (BranchTree a Length -> Tree Length a)
-> Maybe (BranchTree a Length) -> Maybe (Tree Length a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (e -> Maybe Length)
-> BranchTree a e -> Maybe (BranchTree a Length)
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse e -> Maybe Length
forall e. HasMaybeLength e => e -> Maybe Length
getMaybeLength (Tree e a -> BranchTree a e
forall a e. Tree e a -> BranchTree a e
BranchTree Tree e a
t)

-- | Set branch support values of branches leading to the leaves and of the root
-- branch to maximum support.
--
-- Return 'Left' if any other branch has no available support value.
toSupportTree :: HasMaybeSupport e => Tree e a -> Either String (Tree Support a)
toSupportTree :: Tree e a -> Either String (Tree Support a)
toSupportTree t :: Tree e a
t@(Node e
br a
lb Forest e a
ts) =
  String -> Maybe (Tree Support a) -> Either String (Tree Support a)
forall a. String -> Maybe a -> Either String a
fromMaybeWithError String
"toSupportTree: Support value unavailable for some branches." (Maybe (Tree Support a) -> Either String (Tree Support a))
-> Maybe (Tree Support a) -> Either String (Tree Support a)
forall a b. (a -> b) -> a -> b
$
    BranchTree a Support -> Tree Support a
forall a e. BranchTree a e -> Tree e a
getBranchTree (BranchTree a Support -> Tree Support a)
-> Maybe (BranchTree a Support) -> Maybe (Tree Support a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> BranchTree a (Maybe Support) -> Maybe (BranchTree a Support)
forall (t :: * -> *) (f :: * -> *) a.
(Traversable t, Applicative f) =>
t (f a) -> f (t a)
sequenceA (Tree (Maybe Support) a -> BranchTree a (Maybe Support)
forall a e. Tree e a -> BranchTree a e
BranchTree (Maybe Support
-> a -> Forest (Maybe Support) a -> Tree (Maybe Support) a
forall e a. e -> a -> Forest e a -> Tree e a
Node Maybe Support
br' a
lb (Forest (Maybe Support) a -> Tree (Maybe Support) a)
-> Forest (Maybe Support) a -> Tree (Maybe Support) a
forall a b. (a -> b) -> a -> b
$ (Tree e a -> Tree (Maybe Support) a)
-> Forest e a -> Forest (Maybe Support) a
forall a b. (a -> b) -> [a] -> [b]
map Tree e a -> Tree (Maybe Support) a
forall e a. HasMaybeSupport e => Tree e a -> Tree (Maybe Support) a
go Forest e a
ts))
  where
    m :: Support
m = Tree e a -> Support
forall e a. HasMaybeSupport e => Tree e a -> Support
getMaxSupport Tree e a
t
    br' :: Maybe Support
br' = Support -> e -> Maybe Support
forall e. HasMaybeSupport e => Support -> e -> Maybe Support
cleanSupportWith Support
m e
br
    go :: Tree e a -> Tree (Maybe Support) a
go (Node e
b a
l []) = Maybe Support
-> a -> Forest (Maybe Support) a -> Tree (Maybe Support) a
forall e a. e -> a -> Forest e a -> Tree e a
Node (Support -> e -> Maybe Support
forall e. HasMaybeSupport e => Support -> e -> Maybe Support
cleanSupportWith Support
m e
b) a
l []
    go (Node e
b a
l [Tree e a]
xs) = Maybe Support
-> a -> Forest (Maybe Support) a -> Tree (Maybe Support) a
forall e a. e -> a -> Forest e a -> Tree e a
Node (e -> Maybe Support
forall e. HasMaybeSupport e => e -> Maybe Support
getMaybeSupport e
b) a
l ((Tree e a -> Tree (Maybe Support) a)
-> [Tree e a] -> Forest (Maybe Support) a
forall a b. (a -> b) -> [a] -> [b]
map Tree e a -> Tree (Maybe Support) a
go [Tree e a]
xs)

-- If all branch support values are below 1.0, set the max support to 1.0.
getMaxSupport :: HasMaybeSupport e => Tree e a -> Support
getMaxSupport :: Tree e a -> Support
getMaxSupport = Maybe Support -> Support
forall a. HasCallStack => Maybe a -> a
fromJust (Maybe Support -> Support)
-> (Tree e a -> Maybe Support) -> Tree e a -> Support
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Maybe Support -> Maybe Support -> Maybe Support
forall a. Ord a => a -> a -> a
max (Support -> Maybe Support
forall a. a -> Maybe a
Just Support
1.0) (Maybe Support -> Maybe Support)
-> (Tree e a -> Maybe Support) -> Tree e a -> Maybe Support
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ZipBranchTree a (Maybe Support) -> Maybe Support
forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
maximum (ZipBranchTree a (Maybe Support) -> Maybe Support)
-> (Tree e a -> ZipBranchTree a (Maybe Support))
-> Tree e a
-> Maybe Support
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (e -> Maybe Support)
-> ZipBranchTree a e -> ZipBranchTree a (Maybe Support)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap e -> Maybe Support
forall e. HasMaybeSupport e => e -> Maybe Support
getMaybeSupport (ZipBranchTree a e -> ZipBranchTree a (Maybe Support))
-> (Tree e a -> ZipBranchTree a e)
-> Tree e a
-> ZipBranchTree a (Maybe Support)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Tree e a -> ZipBranchTree a e
forall a e. Tree e a -> ZipBranchTree a e
ZipBranchTree

cleanSupportWith :: HasMaybeSupport e => Support -> e -> Maybe Support
cleanSupportWith :: Support -> e -> Maybe Support
cleanSupportWith Support
m e
x = case e -> Maybe Support
forall e. HasMaybeSupport e => e -> Maybe Support
getMaybeSupport e
x of
  Maybe Support
Nothing -> Support -> Maybe Support
forall a. a -> Maybe a
Just Support
m
  Just Support
y -> Support -> Maybe Support
forall a. a -> Maybe a
Just Support
y

-- | Explicit branch label with branch length and branch support value.
data PhyloExplicit = PhyloExplicit
  { PhyloExplicit -> Length
eBranchLength :: Length,
    PhyloExplicit -> Support
eBranchSupport :: Support
  }
  deriving (ReadPrec [PhyloExplicit]
ReadPrec PhyloExplicit
Int -> ReadS PhyloExplicit
ReadS [PhyloExplicit]
(Int -> ReadS PhyloExplicit)
-> ReadS [PhyloExplicit]
-> ReadPrec PhyloExplicit
-> ReadPrec [PhyloExplicit]
-> Read PhyloExplicit
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
readListPrec :: ReadPrec [PhyloExplicit]
$creadListPrec :: ReadPrec [PhyloExplicit]
readPrec :: ReadPrec PhyloExplicit
$creadPrec :: ReadPrec PhyloExplicit
readList :: ReadS [PhyloExplicit]
$creadList :: ReadS [PhyloExplicit]
readsPrec :: Int -> ReadS PhyloExplicit
$creadsPrec :: Int -> ReadS PhyloExplicit
Read, Int -> PhyloExplicit -> ShowS
[PhyloExplicit] -> ShowS
PhyloExplicit -> String
(Int -> PhyloExplicit -> ShowS)
-> (PhyloExplicit -> String)
-> ([PhyloExplicit] -> ShowS)
-> Show PhyloExplicit
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [PhyloExplicit] -> ShowS
$cshowList :: [PhyloExplicit] -> ShowS
show :: PhyloExplicit -> String
$cshow :: PhyloExplicit -> String
showsPrec :: Int -> PhyloExplicit -> ShowS
$cshowsPrec :: Int -> PhyloExplicit -> ShowS
Show, PhyloExplicit -> PhyloExplicit -> Bool
(PhyloExplicit -> PhyloExplicit -> Bool)
-> (PhyloExplicit -> PhyloExplicit -> Bool) -> Eq PhyloExplicit
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: PhyloExplicit -> PhyloExplicit -> Bool
$c/= :: PhyloExplicit -> PhyloExplicit -> Bool
== :: PhyloExplicit -> PhyloExplicit -> Bool
$c== :: PhyloExplicit -> PhyloExplicit -> Bool
Eq, Eq PhyloExplicit
Eq PhyloExplicit
-> (PhyloExplicit -> PhyloExplicit -> Ordering)
-> (PhyloExplicit -> PhyloExplicit -> Bool)
-> (PhyloExplicit -> PhyloExplicit -> Bool)
-> (PhyloExplicit -> PhyloExplicit -> Bool)
-> (PhyloExplicit -> PhyloExplicit -> Bool)
-> (PhyloExplicit -> PhyloExplicit -> PhyloExplicit)
-> (PhyloExplicit -> PhyloExplicit -> PhyloExplicit)
-> Ord PhyloExplicit
PhyloExplicit -> PhyloExplicit -> Bool
PhyloExplicit -> PhyloExplicit -> Ordering
PhyloExplicit -> PhyloExplicit -> PhyloExplicit
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 :: PhyloExplicit -> PhyloExplicit -> PhyloExplicit
$cmin :: PhyloExplicit -> PhyloExplicit -> PhyloExplicit
max :: PhyloExplicit -> PhyloExplicit -> PhyloExplicit
$cmax :: PhyloExplicit -> PhyloExplicit -> PhyloExplicit
>= :: PhyloExplicit -> PhyloExplicit -> Bool
$c>= :: PhyloExplicit -> PhyloExplicit -> Bool
> :: PhyloExplicit -> PhyloExplicit -> Bool
$c> :: PhyloExplicit -> PhyloExplicit -> Bool
<= :: PhyloExplicit -> PhyloExplicit -> Bool
$c<= :: PhyloExplicit -> PhyloExplicit -> Bool
< :: PhyloExplicit -> PhyloExplicit -> Bool
$c< :: PhyloExplicit -> PhyloExplicit -> Bool
compare :: PhyloExplicit -> PhyloExplicit -> Ordering
$ccompare :: PhyloExplicit -> PhyloExplicit -> Ordering
$cp1Ord :: Eq PhyloExplicit
Ord, (forall x. PhyloExplicit -> Rep PhyloExplicit x)
-> (forall x. Rep PhyloExplicit x -> PhyloExplicit)
-> Generic PhyloExplicit
forall x. Rep PhyloExplicit x -> PhyloExplicit
forall x. PhyloExplicit -> Rep PhyloExplicit x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep PhyloExplicit x -> PhyloExplicit
$cfrom :: forall x. PhyloExplicit -> Rep PhyloExplicit x
Generic)

instance Semigroup PhyloExplicit where
  PhyloExplicit Length
bL Support
sL <> :: PhyloExplicit -> PhyloExplicit -> PhyloExplicit
<> PhyloExplicit Length
bR Support
sR = Length -> Support -> PhyloExplicit
PhyloExplicit (Length
bL Length -> Length -> Length
forall a. Num a => a -> a -> a
+ Length
bR) (Support -> Support -> Support
forall a. Ord a => a -> a -> a
min Support
sL Support
sR)

instance HasMaybeLength PhyloExplicit where
  getMaybeLength :: PhyloExplicit -> Maybe Length
getMaybeLength = Length -> Maybe Length
forall a. a -> Maybe a
Just (Length -> Maybe Length)
-> (PhyloExplicit -> Length) -> PhyloExplicit -> Maybe Length
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PhyloExplicit -> Length
eBranchLength

instance HasLength PhyloExplicit where
  getLength :: PhyloExplicit -> Length
getLength = PhyloExplicit -> Length
eBranchLength
  setLength :: Length -> PhyloExplicit -> PhyloExplicit
setLength Length
b PhyloExplicit
pl = PhyloExplicit
pl {eBranchLength :: Length
eBranchLength = Length
b}
  modifyLength :: (Length -> Length) -> PhyloExplicit -> PhyloExplicit
modifyLength Length -> Length
f (PhyloExplicit Length
l Support
s) = Length -> Support -> PhyloExplicit
PhyloExplicit (Length -> Length
f Length
l) Support
s

instance Splittable PhyloExplicit where
  split :: PhyloExplicit -> PhyloExplicit
split PhyloExplicit
l = PhyloExplicit
l {eBranchLength :: Length
eBranchLength = Length
b'}
    where
      b' :: Length
b' = PhyloExplicit -> Length
eBranchLength PhyloExplicit
l Length -> Length -> Length
forall a. Fractional a => a -> a -> a
/ Length
2.0

instance HasMaybeSupport PhyloExplicit where
  getMaybeSupport :: PhyloExplicit -> Maybe Support
getMaybeSupport = Support -> Maybe Support
forall a. a -> Maybe a
Just (Support -> Maybe Support)
-> (PhyloExplicit -> Support) -> PhyloExplicit -> Maybe Support
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PhyloExplicit -> Support
eBranchSupport

instance HasSupport PhyloExplicit where
  getSupport :: PhyloExplicit -> Support
getSupport = PhyloExplicit -> Support
eBranchSupport
  setSupport :: Support -> PhyloExplicit -> PhyloExplicit
setSupport Support
s PhyloExplicit
pl = PhyloExplicit
pl {eBranchSupport :: Support
eBranchSupport = Support
s}
  modifySupport :: (Support -> Support) -> PhyloExplicit -> PhyloExplicit
modifySupport Support -> Support
f (PhyloExplicit Length
l Support
s) = Length -> Support -> PhyloExplicit
PhyloExplicit Length
l (Support -> Support
f Support
s)

instance ToJSON PhyloExplicit

instance FromJSON PhyloExplicit

-- | Conversion to a 'PhyloExplicit' tree.
--
-- See 'toLengthTree' and 'toSupportTree'.
toExplicitTree ::
  (HasMaybeLength e, HasMaybeSupport e) =>
  Tree e a ->
  Either String (Tree PhyloExplicit a)
toExplicitTree :: Tree e a -> Either String (Tree PhyloExplicit a)
toExplicitTree Tree e a
t = do
  Tree Length a
lt <- Tree e a -> Either String (Tree Length a)
forall e a.
HasMaybeLength e =>
Tree e a -> Either String (Tree Length a)
toLengthTree Tree e a
t
  Tree Support a
st <- Tree e a -> Either String (Tree Support a)
forall e a.
HasMaybeSupport e =>
Tree e a -> Either String (Tree Support a)
toSupportTree Tree e a
t
  case (Length -> Support -> PhyloExplicit)
-> (a -> a -> a)
-> Tree Length a
-> Tree Support a
-> Maybe (Tree PhyloExplicit a)
forall e1 e2 e a1 a2 a.
(e1 -> e2 -> e)
-> (a1 -> a2 -> a) -> Tree e1 a1 -> Tree e2 a2 -> Maybe (Tree e a)
zipTreesWith Length -> Support -> PhyloExplicit
PhyloExplicit a -> a -> a
forall a b. a -> b -> a
const Tree Length a
lt Tree Support a
st of
    -- Explicit use of error, since this case should never happen.
    Maybe (Tree PhyloExplicit a)
Nothing -> String -> Either String (Tree PhyloExplicit a)
forall a. HasCallStack => String -> a
error String
"toExplicitTree: Can not zip two trees with different topologies."
    Just Tree PhyloExplicit a
zt -> Tree PhyloExplicit a -> Either String (Tree PhyloExplicit a)
forall (m :: * -> *) a. Monad m => a -> m a
return Tree PhyloExplicit a
zt