-- |
-- Module      :  ELynx.Topology.Phylogeny
-- Description :  Phylogenetic topologies
-- Copyright   :  2021 Dominik Schrempf
-- License     :  GPL-3.0-or-later
--
-- Maintainer  :  dominik.schrempf@gmail.com
-- Stability   :  unstable
-- Portability :  portable
--
-- Creation date: Sat Jul 18 13:15:49 2020.
--
-- A topology, as it is used in phylogenetics is a 'Topology' with unique leaf
-- labels, and the order of the topologies in the sub-forest is considered to be
-- meaningless.
--
-- NOTE: The functions in this module are defined using the functions in
-- "ELynx.Tree.Phylogeny". This induces a runtime overhead, but greatly reduces
-- the probability of additional bugs.
module ELynx.Topology.Phylogeny
  ( equal,
    equal',
    intersect,
    bifurcating,
    outgroup,
    midpoint,
    roots,
  )
where

import Data.Default.Class
import Data.List hiding (intersect)
import Data.Maybe
import qualified Data.Set as S
import ELynx.Topology.Rooted
import ELynx.Tree.Length
import qualified ELynx.Tree.Phylogeny as T
import qualified ELynx.Tree.Rooted as T

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

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

-- | Intersection of topologies.
--
-- | See 'ELynx.Tree.Phylogeny.intersect'.
intersect ::
  (Ord a) => [Topology a] -> Either String [Topology a]
intersect :: forall a. Ord a => [Topology a] -> Either String [Topology a]
intersect [Topology a]
ts
  | forall a. Set a -> Bool
S.null Set a
lvsCommon = forall a b. a -> Either a b
Left String
"intersect: Intersection of leaves is empty."
  | Bool
otherwise = case forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
sequence [forall a. (a -> Bool) -> Topology a -> Maybe (Topology a)
dropLeavesWith (forall {a}. Ord a => Set a -> a -> Bool
predicate Set a
ls) Topology a
t | (Set a
ls, Topology a
t) <- forall a b. [a] -> [b] -> [(a, b)]
zip [Set a]
leavesToDrop [Topology a]
ts] of
      Maybe [Topology a]
Nothing -> forall a b. a -> Either a b
Left String
"intersect: A topology is empty."
      Just [Topology a]
ts' -> forall a b. b -> Either a b
Right [Topology a]
ts'
  where
    -- Leaf sets.
    lvss :: [Set a]
lvss = forall a b. (a -> b) -> [a] -> [b]
map (forall a. Ord a => [a] -> Set a
S.fromList forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Topology a -> [a]
leaves) [Topology a]
ts
    -- Common leaf set.
    lvsCommon :: Set a
lvsCommon = forall a. (a -> a -> a) -> [a] -> a
foldl1' forall a. Ord a => Set a -> Set a -> Set a
S.intersection [Set a]
lvss
    -- Leaves to drop for each topology in the forest.
    leavesToDrop :: [Set a]
leavesToDrop = forall a b. (a -> b) -> [a] -> [b]
map (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 forall a. Ord a => a -> Set a -> Bool
`S.member` Set a
lvsToDr

-- | Check if topology is bifurcating.
--
-- | See 'ELynx.Tree.Phylogeny.intersect'.
bifurcating :: Topology a -> Bool
bifurcating :: forall a. Topology a -> Bool
bifurcating (Leaf a
_) = Bool
True
bifurcating (Node Forest a
ts) = (forall (t :: * -> *) a. Foldable t => t a -> Int
length Forest a
ts forall a. Eq a => a -> a -> Bool
== Int
2) Bool -> Bool -> Bool
&& forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all forall a. Topology a -> Bool
bifurcating Forest a
ts

-- Perform a computation over the 'Tree' data type.
overTree ::
  (Default a, Functor f) =>
  (T.Tree Length a -> f (T.Tree Length a)) ->
  Topology a ->
  f (Topology a)
overTree :: forall a (f :: * -> *).
(Default a, Functor f) =>
(Tree Length a -> f (Tree Length a))
-> Topology a -> f (Topology a)
overTree Tree Length a -> f (Tree Length a)
f = forall {e} {a}. f (Tree e a) -> f (Topology a)
goBack forall b c a. (b -> c) -> (a -> b) -> a -> c
. Tree Length a -> f (Tree Length a)
f forall b c a. (b -> c) -> (a -> b) -> a -> c
. Topology a -> Tree Length a
goThere
  where
    goThere :: Topology a -> Tree Length a
goThere = forall e a. e -> a -> Topology a -> Tree e a
toBranchLabelTreeWith (Double -> Length
toLengthUnsafe Double
1.0) forall a. Default a => a
def
    goBack :: f (Tree e a) -> f (Topology a)
goBack = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall e a. Tree e a -> Topology a
fromBranchLabelTree

-- | Root topology using an outgroup.
--
--   See 'ELynx.Tree.Phylogeny.outgroup'.
outgroup :: (Default a, Ord a) => S.Set a -> Topology a -> Either String (Topology a)
outgroup :: forall a.
(Default a, Ord a) =>
Set a -> Topology a -> Either String (Topology a)
outgroup Set a
xs = forall a (f :: * -> *).
(Default a, Functor f) =>
(Tree Length a -> f (Tree Length a))
-> Topology a -> f (Topology a)
overTree (forall e a.
(Semigroup e, Splittable e, Default a, Ord a) =>
Set a -> Tree e a -> Either String (Tree e a)
T.outgroup Set a
xs)

-- | Root topology at the midpoint.
--
-- See 'ELynx.Tree.Phylogeny.midpoint'.
--
-- Use 'depth' to measure topology height.
--
-- If the midpoint is ambiguous because the sum of the left and right depths is
-- odd, the depth of the left sub-topology will be set to be one node greater
-- than the one of the right sub-topology.
midpoint :: Default a => Topology a -> Either String (Topology a)
midpoint :: forall a. Default a => Topology a -> Either String (Topology a)
midpoint = forall a (f :: * -> *).
(Default a, Functor f) =>
(Tree Length a -> f (Tree Length a))
-> Topology a -> f (Topology a)
overTree forall e a.
(Semigroup e, Splittable e, HasLength e, Default a) =>
Tree e a -> Either String (Tree e a)
T.midpoint

-- | For a rooted tree with a bifurcating root node, get all possible rooted
-- trees.
--
-- See 'ELynx.Tree.Phylogeny.roots'.
roots :: Default a => Topology a -> Either String [Topology a]
roots :: forall a. Default a => Topology a -> Either String [Topology a]
roots = forall {e} {a}.
Either String [Tree e a] -> Either String [Topology a]
goBack forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall e a.
(Semigroup e, Splittable e, Default a) =>
Tree e a -> Either String (Forest e a)
T.roots forall b c a. (b -> c) -> (a -> b) -> a -> c
. Topology a -> Tree Length a
goThere
  where
    -- We have to use a special 'overTree' function here, since a list of
    -- topologies is returned.
    goThere :: Topology a -> Tree Length a
goThere = forall e a. e -> a -> Topology a -> Tree e a
toBranchLabelTreeWith (Double -> Length
toLengthUnsafe Double
1.0) forall a. Default a => a
def
    goBack :: Either String [Tree e a] -> Either String [Topology a]
goBack = (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap) forall e a. Tree e a -> Topology a
fromBranchLabelTree