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
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
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
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
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
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
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 :: 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
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
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
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)
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
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
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