{-# 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 are slow
-- operations, 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.
--
-- A multifurcating root node can be resolved to a bifurcating root node with
-- 'outgroup'.
--
-- The bifurcating root node can be changed with 'outgroup' or 'midpoint'.
--
-- For a given tree with bifurcating root node, a list of all rooted trees is
-- returned by 'roots'.
module ELynx.Tree.Phylogeny
  ( -- * Functions
    equal,
    equal',
    intersect,
    bifurcating,
    outgroup,
    midpoint,
    roots,

    -- * Branch labels
    Phylo (..),
    toPhyloTree,
    measurableToPhyloTree,
    supportedToPhyloTree,
    phyloToLengthTree,
    phyloToSupportTree,
    phyloToSupportTreeUnsafe,
    PhyloExplicit (..),
    toExplicitTree,
  )
where

import Control.DeepSeq
import Data.Aeson
import Data.Bifoldable
import Data.Bifunctor
import Data.Bitraversable
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 (Forest e a -> Tree e a -> Bool
forall (t :: * -> *) e a.
(Foldable t, Eq e, Eq a) =>
t (Tree e a) -> Tree e a -> Bool
elem' Forest e a
tsR) Forest e a
tsL
  where
    elem' :: t (Tree e a) -> Tree e a -> Bool
elem' t (Tree e a)
ts Tree e a
t = 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

-- | Compute the 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 a 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

-- I believe that manual treatment with 'outgroup' is preferable.

-- -- | Remove multifurcations.
-- --
-- -- A caterpillar like bifurcating structure is used to resolve all
-- -- multifurcations on a tree.
-- --
-- -- Multifurcating nodes are copied and branches are 'split'.
-- resolve :: Splittable e => Tree e a -> Tree e a
-- resolve t@(Node _ _ []) = t
-- resolve (Node br lb [x]) = Node br lb [resolve x]
-- resolve (Node br lb [x, y]) = Node br lb $ map resolve [x, y]
-- resolve (Node br lb (Node brL lbL xsL : xs)) = Node br lb [Node brL' lbL (map resolve xsL), Node brL' lb (map resolve xs)]
--   where brL' = split brL

-- | Root the tree using an outgroup.
--
-- If the current root node is multifurcating, a bifurcating root node with the
-- empty label is introduced by 'split'ting the leftmost branch. The 'Monoid'
-- instance of the node label and the 'Splittable' instance of the branch length
-- are used.
--
-- NOTE: In this case, the degree of the former root node is decreased by one!
--
-- Given that the root note is bifurcating, the root node is moved to the
-- required position specified by the outgroup.
--
-- Branches are connected according to the provided 'Semigroup' instance.
--
-- Upon insertion of the root node at the required position, the affected branch
-- is 'split' according to the provided 'Splittable' instance.
--
-- Return 'Left' if
--
-- - the root node is not multifurcating;
--
-- - the tree has duplicate leaves;
--
-- - the provided outgroup is not found on the tree or is polyphyletic.
outgroup :: (Semigroup e, Splittable e, Monoid 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 t :: Tree e a
t@(Node e
_ a
_ [Tree e a
_, Tree e a
_]) = 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, Ord a) =>
Bipartition a -> Tree e a -> Either String (Tree e a)
rootAt Bipartition a
bip Tree e a
t
outgroup Set a
o (Node e
b a
l [Tree e a]
ts) = Set a -> Tree e a -> Either String (Tree e a)
forall e a.
(Semigroup e, Splittable e, Monoid a, Ord a) =>
Set a -> Tree e a -> Either String (Tree e a)
outgroup Set a
o Tree e a
t'
  where
    (Node e
brO a
lbO [Tree e a]
tsO) = [Tree e a] -> Tree e a
forall a. [a] -> a
head [Tree e a]
ts
    -- Introduce a bifurcating root node.
    t' :: Tree e a
t' = e -> a -> [Tree e a] -> Tree e a
forall e a. e -> a -> Forest e a -> Tree e a
Node e
b a
forall a. Monoid a => a
mempty [e -> a -> [Tree 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
brO) a
lbO [Tree e a]
tsO, e -> a -> [Tree 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
brO) a
l ([Tree e a] -> [Tree e a]
forall a. [a] -> [a]
tail [Tree e a]
ts)]

-- The 'midpoint' algorithm is pretty stupid because it calculates all rooted
-- trees and then finds the one minimizing the difference between the heights of
-- the left and right sub tree. Actually, one just needs to move left or right,
-- with the aim to minimize the height difference between the left and right sub
-- tree.

-- | Root tree at the midpoint.
--
-- Return 'Left' if
--
-- - the root node is not bifurcating.
midpoint :: (Semigroup e, Splittable e, HasLength e) => 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 t :: Tree e a
t@(Node e
_ a
_ [Tree e a
_, Tree e a
_]) = Tree e a -> Either String [Tree e a]
forall e a.
(Semigroup e, Splittable e) =>
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
midpoint Tree e a
_ = String -> Either String (Tree e a)
forall a b. a -> Either a b
Left String
"midpoint: Root node is multifurcating."

-- 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
    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
applyStem ((Length -> Length) -> e -> e
forall e. HasLength e => (Length -> Length) -> e -> e
modLen (Length -> Length -> Length
forall a. Num a => a -> a -> a
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
applyStem ((Length -> Length) -> e -> e
forall e. HasLength e => (Length -> Length) -> e -> e
modLen (Length -> Length -> Length
forall a. Num a => a -> a -> a
+ Length
dh)) Tree e a
r
            ]
  -- Explicitly use 'error' here, because roots is supposed to return trees with
  -- bifurcating root nodes.
  Right Tree e a
_ -> String -> Either String (Tree e a)
forall a. HasCallStack => String -> a
error String
"getMidpoint: Root node is not bifurcating; please contact maintainer."
  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
    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

-- find index of minimum; take this tree and move root to the midpoint of the branch

-- 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
-- Explicitly use 'error' here, because roots is supposed to return trees with
-- bifurcating root nodes.
getDeltaHeight Tree e a
_ = String -> Length
forall a. HasCallStack => String -> a
error String
"getDeltaHeight: Root node is not bifurcating; please contact maintainer."

-- | For a rooted tree with a bifurcating root node, get all possible rooted
-- trees.
--
-- The root node (label and branch) is moved.
--
-- For a tree with @l=2@ leaves, there is one rooted tree. For a bifurcating
-- tree with @l>2@ leaves, there are @(2l-3)@ rooted trees. For a general tree
-- with a bifurcating root node, and a total number of @n>2@ nodes, there are
-- (n-2) rooted trees.
--
-- A bifurcating root is required because moving a multifurcating root node to
-- another branch would change the degree of the root node. To resolve a
-- multifurcating root, please use 'outgroup'.
--
-- Connect branches according to the provided 'Semigroup' instance.
--
-- Split the affected branch into one out of two equal entities according the
-- provided 'Splittable' instance.
--
-- Return 'Left' if the root node is not 'bifurcating'.
roots :: (Semigroup e, Splittable e) => 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 Tree e a
_ = String -> Either String (Forest e a)
forall a b. a -> Either a b
Left String
"roots: Root node is multifurcating."

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

-- From the bifurcating root, descend into one of the two pits.
--
-- descend splitFunction 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

-- Root a tree at a specific position.
--
-- Root the tree at the branch defined by the given bipartition. The original
-- root node is moved to the new position.
--
-- The root node must be bifurcating (see 'roots' and 'outgroup').
--
-- Connect branches according to the provided 'Semigroup' instance.
--
-- Upon insertion of the root, split the affected branch according to the
-- provided 'Splittable' instance.
--
-- Return 'Left', if:
--
-- - the root node is not bifurcating;
--
-- - the tree has duplicate leaves;
--
-- - the bipartition does not match the leaves of the tree.
rootAt ::
  (Semigroup e, Splittable e, Eq 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
  -- Tree is checked for being bifurcating in 'roots'.
  --
  -- 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 = Bipartition a -> Tree e a -> Either String (Tree e a)
forall e a.
(Semigroup e, Splittable e, Ord a) =>
Bipartition a -> Tree e a -> Either String (Tree e a)
rootAt' Bipartition a
b 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

-- Assume the leaves of the tree are unique.
rootAt' ::
  (Semigroup e, Splittable e, 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
  Forest e a
ts <- Tree e a -> Either String (Forest e a)
forall e a.
(Semigroup e, Splittable e) =>
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'

-- | Branch label for phylogenetic trees.
--
-- Branches may have a length and a support value.
data Phylo = Phylo
  { Phylo -> Maybe Length
brLen :: Maybe Length,
    Phylo -> Maybe Support
brSup :: 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 ToJSON Phylo

instance FromJSON Phylo

-- | Set all branch lengths and support values to 'Just' the value.
--
-- Useful to export a tree with branch lengths in Newick format.
toPhyloTree :: (HasLength e, HasSupport 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. (HasLength e, HasSupport e) => e -> Phylo
toPhyloLabel

toPhyloLabel :: (HasLength e, HasSupport e) => e -> Phylo
toPhyloLabel :: e -> Phylo
toPhyloLabel e
x = Maybe Length -> Maybe Support -> Phylo
Phylo (Length -> Maybe Length
forall a. a -> Maybe a
Just (Length -> Maybe Length) -> Length -> Maybe Length
forall a b. (a -> b) -> a -> b
$ e -> Length
forall e. HasLength e => e -> Length
getLen e
x) (Support -> Maybe Support
forall a. a -> Maybe a
Just (Support -> Maybe Support) -> Support -> Maybe Support
forall a b. (a -> b) -> a -> b
$ e -> Support
forall e. HasSupport e => e -> Support
getSup e
x)

-- | Set all branch lengths to 'Just' the values, and all support values to
-- 'Nothing'.
--
-- Useful to export a tree with branch lengths but without branch support values
-- to Newick format.
measurableToPhyloTree :: HasLength e => Tree e a -> Tree Phylo a
measurableToPhyloTree :: Tree e a -> Tree Phylo a
measurableToPhyloTree = (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. HasLength e => e -> Phylo
measurableToPhyloLabel

measurableToPhyloLabel :: HasLength e => e -> Phylo
measurableToPhyloLabel :: e -> Phylo
measurableToPhyloLabel e
x = Maybe Length -> Maybe Support -> Phylo
Phylo (Length -> Maybe Length
forall a. a -> Maybe a
Just (Length -> Maybe Length) -> Length -> Maybe Length
forall a b. (a -> b) -> a -> b
$ e -> Length
forall e. HasLength e => e -> Length
getLen e
x) Maybe Support
forall a. Maybe a
Nothing

-- | Set all branch lengths to 'Nothing', and all support values to 'Just' the
-- values.
--
-- Useful to export a tree with branch support values but without branch lengths
-- to Newick format.
supportedToPhyloTree :: HasSupport e => Tree e a -> Tree Phylo a
supportedToPhyloTree :: Tree e a -> Tree Phylo a
supportedToPhyloTree = (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. HasSupport e => e -> Phylo
supportedToPhyloLabel

supportedToPhyloLabel :: HasSupport e => e -> Phylo
supportedToPhyloLabel :: e -> Phylo
supportedToPhyloLabel e
x = Maybe Length -> Maybe Support -> Phylo
Phylo Maybe Length
forall a. Maybe a
Nothing (Support -> Maybe Support
forall a. a -> Maybe a
Just (Support -> Maybe Support) -> Support -> Maybe Support
forall a b. (a -> b) -> a -> b
$ e -> Support
forall e. HasSupport e => e -> Support
getSup e
x)

-- | If root branch length is not available, set it to 0.
--
-- Return 'Left' if any other branch length is unavailable.
phyloToLengthTree :: Tree Phylo a -> Either String (Tree Length a)
phyloToLengthTree :: Tree Phylo a -> Either String (Tree Length a)
phyloToLengthTree =
  Either String (Tree Length a)
-> (Tree Length a -> Either String (Tree Length a))
-> Maybe (Tree Length a)
-> Either String (Tree Length a)
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (String -> Either String (Tree Length a)
forall a b. a -> Either a b
Left String
"phyloToLengthTree: Length unavailable for some branches.") Tree Length a -> Either String (Tree Length a)
forall a b. b -> Either a b
Right
    (Maybe (Tree Length a) -> Either String (Tree Length a))
-> (Tree Phylo a -> Maybe (Tree Length a))
-> Tree Phylo a
-> Either String (Tree Length a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Phylo -> Maybe Length)
-> (a -> Maybe a) -> Tree Phylo a -> Maybe (Tree Length a)
forall (t :: * -> * -> *) (f :: * -> *) a c b d.
(Bitraversable t, Applicative f) =>
(a -> f c) -> (b -> f d) -> t a b -> f (t c d)
bitraverse Phylo -> Maybe Length
brLen a -> Maybe a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
    (Tree Phylo a -> Maybe (Tree Length a))
-> (Tree Phylo a -> Tree Phylo a)
-> Tree Phylo a
-> Maybe (Tree Length a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Tree Phylo a -> Tree Phylo a
forall a. Tree Phylo a -> Tree Phylo a
cleanStemLength

cleanStemLength :: Tree Phylo a -> Tree Phylo a
cleanStemLength :: Tree Phylo a -> Tree Phylo a
cleanStemLength (Node (Phylo Maybe Length
Nothing Maybe Support
s) a
l Forest Phylo a
f) = Phylo -> a -> Forest Phylo a -> Tree Phylo a
forall e a. e -> a -> Forest e a -> Tree e a
Node (Maybe Length -> Maybe Support -> Phylo
Phylo (Length -> Maybe Length
forall a. a -> Maybe a
Just Length
0) Maybe Support
s) a
l Forest Phylo a
f
cleanStemLength Tree Phylo a
t = Tree Phylo 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.
phyloToSupportTree :: Tree Phylo a -> Either String (Tree Support a)
phyloToSupportTree :: Tree Phylo a -> Either String (Tree Support a)
phyloToSupportTree Tree Phylo a
t =
  Either String (Tree Support a)
-> (Tree Support a -> Either String (Tree Support a))
-> Maybe (Tree Support a)
-> Either String (Tree Support a)
forall b a. b -> (a -> b) -> Maybe a -> b
maybe
    (String -> Either String (Tree Support a)
forall a b. a -> Either a b
Left String
"phyloToSupportTree: Support value unavailable for some branches.")
    Tree Support a -> Either String (Tree Support a)
forall a b. b -> Either a b
Right
    (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
$ (Phylo -> Maybe Support)
-> (a -> Maybe a) -> Tree Phylo a -> Maybe (Tree Support a)
forall (t :: * -> * -> *) (f :: * -> *) a c b d.
(Bitraversable t, Applicative f) =>
(a -> f c) -> (b -> f d) -> t a b -> f (t c d)
bitraverse Phylo -> Maybe Support
brSup a -> Maybe a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Tree Phylo a -> Maybe (Tree Support a))
-> Tree Phylo a -> Maybe (Tree Support a)
forall a b. (a -> b) -> a -> b
$
      Support -> Tree Phylo a -> Tree Phylo a
forall a. Support -> Tree Phylo a -> Tree Phylo a
cleanLeafSupport Support
m (Tree Phylo a -> Tree Phylo a) -> Tree Phylo a -> Tree Phylo a
forall a b. (a -> b) -> a -> b
$
        Support -> Tree Phylo a -> Tree Phylo a
forall a. Support -> Tree Phylo a -> Tree Phylo a
cleanRootSupport Support
m Tree Phylo a
t
  where
    m :: Support
m = Tree Phylo a -> Support
forall a. Tree Phylo a -> Support
getMaxSupport Tree Phylo a
t

-- | Set all unavailable branch support values to maximum support.
phyloToSupportTreeUnsafe :: Tree Phylo a -> Tree Support a
phyloToSupportTreeUnsafe :: Tree Phylo a -> Tree Support a
phyloToSupportTreeUnsafe Tree Phylo a
t = Support -> Tree Phylo a -> Tree Support a
forall a. Support -> Tree Phylo a -> Tree Support a
cleanSupport Support
m Tree Phylo a
t
  where
    m :: Support
m = Tree Phylo a -> Support
forall a. Tree Phylo a -> Support
getMaxSupport Tree Phylo a
t

-- If all branch support values are below 1.0, set the max support to 1.0.
getMaxSupport :: Tree Phylo a -> Support
getMaxSupport :: Tree Phylo a -> Support
getMaxSupport = Maybe Support -> Support
forall a. HasCallStack => Maybe a -> a
fromJust (Maybe Support -> Support)
-> (Tree Phylo a -> Maybe Support) -> Tree Phylo 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 Phylo a -> Maybe Support) -> Tree Phylo a -> Maybe Support
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Tree (Maybe Support) (Maybe Support) -> Maybe Support
forall (t :: * -> * -> *) a. (Bifoldable t, Ord a) => t a a -> a
bimaximum (Tree (Maybe Support) (Maybe Support) -> Maybe Support)
-> (Tree Phylo a -> Tree (Maybe Support) (Maybe Support))
-> Tree Phylo a
-> Maybe Support
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Phylo -> Maybe Support)
-> (a -> Maybe Support)
-> Tree Phylo a
-> Tree (Maybe Support) (Maybe Support)
forall (p :: * -> * -> *) a b c d.
Bifunctor p =>
(a -> b) -> (c -> d) -> p a c -> p b d
bimap Phylo -> Maybe Support
brSup (Maybe Support -> a -> Maybe Support
forall a b. a -> b -> a
const Maybe Support
forall a. Maybe a
Nothing)

cleanRootSupport :: Support -> Tree Phylo a -> Tree Phylo a
cleanRootSupport :: Support -> Tree Phylo a -> Tree Phylo a
cleanRootSupport Support
maxSup (Node (Phylo Maybe Length
b Maybe Support
Nothing) a
l Forest Phylo a
xs) = Phylo -> a -> Forest Phylo a -> Tree Phylo a
forall e a. e -> a -> Forest e a -> Tree e a
Node (Maybe Length -> Maybe Support -> Phylo
Phylo Maybe Length
b (Support -> Maybe Support
forall a. a -> Maybe a
Just Support
maxSup)) a
l Forest Phylo a
xs
cleanRootSupport Support
_ Tree Phylo a
t = Tree Phylo a
t

cleanLeafSupport :: Support -> Tree Phylo a -> Tree Phylo a
cleanLeafSupport :: Support -> Tree Phylo a -> Tree Phylo a
cleanLeafSupport Support
s (Node (Phylo Maybe Length
b Maybe Support
Nothing) a
l []) = Phylo -> a -> [Tree Phylo a] -> Tree Phylo a
forall e a. e -> a -> Forest e a -> Tree e a
Node (Maybe Length -> Maybe Support -> Phylo
Phylo Maybe Length
b (Support -> Maybe Support
forall a. a -> Maybe a
Just Support
s)) a
l []
cleanLeafSupport Support
s (Node Phylo
b a
l [Tree Phylo a]
xs) = Phylo -> a -> [Tree Phylo a] -> Tree Phylo a
forall e a. e -> a -> Forest e a -> Tree e a
Node Phylo
b a
l ([Tree Phylo a] -> Tree Phylo a) -> [Tree Phylo a] -> Tree Phylo a
forall a b. (a -> b) -> a -> b
$ (Tree Phylo a -> Tree Phylo a) -> [Tree Phylo a] -> [Tree Phylo a]
forall a b. (a -> b) -> [a] -> [b]
map (Support -> Tree Phylo a -> Tree Phylo a
forall a. Support -> Tree Phylo a -> Tree Phylo a
cleanLeafSupport Support
s) [Tree Phylo a]
xs

cleanSupport :: Support -> Tree Phylo a -> Tree Support a
cleanSupport :: Support -> Tree Phylo a -> Tree Support a
cleanSupport Support
maxSup (Node (Phylo Maybe Length
_ Maybe Support
s) a
l Forest Phylo a
xs) = Support -> a -> Forest Support a -> Tree Support a
forall e a. e -> a -> Forest e a -> Tree e a
Node (Support -> Maybe Support -> Support
forall a. a -> Maybe a -> a
fromMaybe Support
maxSup Maybe Support
s) a
l (Forest Support a -> Tree Support a)
-> Forest Support a -> Tree Support a
forall a b. (a -> b) -> a -> b
$ (Tree Phylo a -> Tree Support a)
-> Forest Phylo a -> Forest Support a
forall a b. (a -> b) -> [a] -> [b]
map (Support -> Tree Phylo a -> Tree Support a
forall a. Support -> Tree Phylo a -> Tree Support a
cleanSupport Support
maxSup) Forest Phylo a
xs

-- | Explicit branch label with branch length and branch support value.
data PhyloExplicit = PhyloExplicit
  { PhyloExplicit -> Length
sBrLen :: Length,
    PhyloExplicit -> Support
sBrSup :: 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 HasLength PhyloExplicit where
  getLen :: PhyloExplicit -> Length
getLen = PhyloExplicit -> Length
sBrLen
  setLen :: Length -> PhyloExplicit -> PhyloExplicit
setLen Length
b PhyloExplicit
pl = PhyloExplicit
pl {sBrLen :: Length
sBrLen = Length
b}
  modLen :: (Length -> Length) -> PhyloExplicit -> PhyloExplicit
modLen 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 {sBrLen :: Length
sBrLen = Length
b'}
    where
      b' :: Length
b' = PhyloExplicit -> Length
sBrLen PhyloExplicit
l Length -> Length -> Length
forall a. Fractional a => a -> a -> a
/ Length
2.0

instance HasSupport PhyloExplicit where
  getSup :: PhyloExplicit -> Support
getSup = PhyloExplicit -> Support
sBrSup
  setSup :: Support -> PhyloExplicit -> PhyloExplicit
setSup Support
s PhyloExplicit
pl = PhyloExplicit
pl {sBrSup :: Support
sBrSup = Support
s}
  modSup :: (Support -> Support) -> PhyloExplicit -> PhyloExplicit
modSup 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 'phyloToLengthTree' and 'phyloToSupportTree'.
toExplicitTree :: Tree Phylo a -> Either String (Tree PhyloExplicit a)
toExplicitTree :: Tree Phylo a -> Either String (Tree PhyloExplicit a)
toExplicitTree Tree Phylo a
t = do
  Tree Length a
lt <- Tree Phylo a -> Either String (Tree Length a)
forall a. Tree Phylo a -> Either String (Tree Length a)
phyloToLengthTree Tree Phylo a
t
  Tree Support a
st <- Tree Phylo a -> Either String (Tree Support a)
forall a. Tree Phylo a -> Either String (Tree Support a)
phyloToSupportTree Tree Phylo 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 not 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; please contact maintainer."
    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