{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DerivingVia #-}
module ELynx.Tree.Phylogeny
(
equal,
equal',
intersect,
bifurcating,
outgroup,
midpoint,
roots,
Phylo (..),
toPhyloLabel,
toPhyloTree,
lengthToPhyloLabel,
lengthToPhyloTree,
supportToPhyloLabel,
supportToPhyloTree,
toLengthTree,
toSupportTree,
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
equal :: (Eq e, Eq a, Ord a) => Tree e a -> Tree e a -> Either String Bool
equal :: forall e a.
(Eq e, Eq a, Ord a) =>
Tree e a -> Tree e a -> Either String Bool
equal Tree e a
tL Tree e a
tR
| forall a e. Ord a => Tree e a -> Bool
duplicateLeaves Tree e a
tL = forall a b. a -> Either a b
Left String
"equal: Left tree has duplicate leaves."
| forall a e. Ord a => Tree e a -> Bool
duplicateLeaves Tree e a
tR = forall a b. a -> Either a b
Left String
"equal: Right tree has duplicate leaves."
| Bool
otherwise = forall a b. b -> Either a b
Right forall a b. (a -> b) -> a -> b
$ forall e a. (Eq e, Eq a) => Tree e a -> Tree e a -> Bool
equal' Tree e a
tL Tree e a
tR
equal' :: (Eq e, Eq a) => Tree e a -> Tree e a -> Bool
equal' :: forall e a. (Eq e, Eq a) => 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 forall a. Eq a => a -> a -> Bool
== e
brR)
Bool -> Bool -> Bool
&& (a
lbL forall a. Eq a => a -> a -> Bool
== a
lbR)
Bool -> Bool -> Bool
&& (forall (t :: * -> *) a. Foldable t => t a -> Int
length Forest e a
tsL forall a. Eq a => a -> a -> Bool
== forall (t :: * -> *) a. Foldable t => t a -> Int
length Forest e a
tsR)
Bool -> Bool -> Bool
&& forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (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 = 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 e a. (Eq e, Eq a) => Tree e a -> Tree e a -> Bool
equal' Tree e a
t) t (Tree e a)
ts
intersect ::
(Semigroup e, Eq e, Ord a) => Forest e a -> Either String (Forest e a)
intersect :: forall e a.
(Semigroup e, Eq e, Ord a) =>
Forest e a -> Either String (Forest e a)
intersect Forest e 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 e. (a -> Bool) -> Tree e a -> Maybe (Tree e a)
dropLeavesWith (forall {a}. Ord a => Set a -> a -> Bool
predicate Set a
ls) Tree e a
t | (Set a
ls, Tree e a
t) <- forall a b. [a] -> [b] -> [(a, b)]
zip [Set a]
leavesToDrop Forest e a
ts] of
Maybe (Forest e a)
Nothing -> forall a b. a -> Either a b
Left String
"intersect: A tree is empty."
Just Forest e a
ts' -> forall a b. b -> Either a b
Right Forest e 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 e a. Tree e a -> [a]
leaves) Forest e 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 :: Tree e a -> Bool
bifurcating :: forall e a. Tree e a -> Bool
bifurcating (Node e
_ a
_ []) = Bool
True
bifurcating (Node e
_ a
_ [Tree e a
x, Tree e a
y]) = forall e a. Tree e a -> Bool
bifurcating Tree e a
x Bool -> Bool -> Bool
&& forall e a. Tree e a -> Bool
bifurcating Tree e a
y
bifurcating Tree e a
_ = Bool
False
outgroup ::
(Semigroup e, Splittable e, Default a, Ord a) =>
Set a ->
Tree e a ->
Either String (Tree e a)
outgroup :: forall e a.
(Semigroup e, Splittable e, Default a, Ord a) =>
Set a -> Tree e a -> Either String (Tree e a)
outgroup Set a
_ (Node 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
_]) = 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 <- forall a. Ord a => Set a -> Set a -> Either String (Bipartition a)
bp Set a
o (forall a. Ord a => [a] -> Set a
S.fromList (forall e a. Tree e a -> [a]
leaves Tree e a
t) forall a. Ord a => Set a -> Set a -> Set a
S.\\ Set a
o)
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
rootAt ::
(Semigroup e, Splittable e, Eq a, Default a, Ord a) =>
Bipartition a ->
Tree e a ->
Either String (Tree e a)
rootAt :: 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
b Tree e a
t
| forall (t :: * -> *) a. Foldable t => t a -> Int
length [a]
lvLst forall a. Eq a => a -> a -> Bool
/= forall a. Set a -> Int
S.size Set a
lvSet = forall a b. a -> Either a b
Left String
"rootAt: Tree has duplicate leaves."
| forall a. Ord a => Bipartition a -> Set a
toSet Bipartition a
b forall a. Eq a => a -> a -> Bool
/= Set a
lvSet = forall a b. a -> Either a b
Left String
"rootAt: Bipartition does not match leaves of tree."
| Bool
otherwise = do
Forest e a
ts <- forall e a.
(Semigroup e, Splittable e, Default a) =>
Tree e a -> Either String (Forest e a)
roots Tree e a
t
case forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
find (\Tree e a
x -> forall a e. Ord a => Tree e a -> Either String (Bipartition a)
bipartition Tree e a
x forall a. Eq a => a -> a -> Bool
== forall a b. b -> Either a b
Right Bipartition a
b) Forest e a
ts of
Maybe (Tree e a)
Nothing -> forall a b. a -> Either a b
Left String
"rootAt': Bipartition not found on tree."
Just Tree e a
t' -> forall a b. b -> Either a b
Right Tree e a
t'
where
lvLst :: [a]
lvLst = forall e a. Tree e a -> [a]
leaves Tree e a
t
lvSet :: Set a
lvSet = forall a. Ord a => [a] -> Set a
S.fromList forall a b. (a -> b) -> a -> b
$ forall e a. Tree e a -> [a]
leaves Tree e a
t
midpoint ::
(Semigroup e, Splittable e, HasLength e, Default a) =>
Tree e a ->
Either String (Tree e a)
midpoint :: forall e a.
(Semigroup e, Splittable e, HasLength e, Default a) =>
Tree e a -> Either String (Tree e a)
midpoint (Node e
_ a
_ []) = forall a b. a -> Either a b
Left String
"midpoint: Root node is a leaf."
midpoint (Node e
_ a
_ [Tree e a
_]) = forall a b. a -> Either a b
Left String
"midpoint: Root node has degree two."
midpoint Tree e a
t = forall e a.
(Semigroup e, Splittable e, Default a) =>
Tree e a -> Either String (Forest e a)
roots Tree e a
t forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall e a. HasLength e => [Tree e a] -> Either String (Tree e a)
getMidpoint
findMinIndex :: Ord a => [a] -> Either String Int
findMinIndex :: forall a. Ord a => [a] -> Either String Int
findMinIndex (a
x : [a]
xs) = 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
_ [] = forall a b. b -> Either a b
Right a
i
go (a
i, b
z) a
j (b
y : [b]
ys) = if b
z forall a. Ord a => a -> a -> Bool
< b
y then (a, b) -> a -> [b] -> Either a a
go (a
i, b
z) (a
j 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 forall a. Num a => a -> a -> a
+ a
1) [b]
ys
findMinIndex [] = forall a b. a -> Either a b
Left String
"findMinIndex: Empty list."
getMidpoint :: HasLength e => [Tree e a] -> Either String (Tree e a)
getMidpoint :: forall e a. HasLength e => [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 = forall e a. HasLength e => Tree e a -> Length
height Tree e a
l
hr :: Length
hr = forall e a. HasLength e => Tree e a -> Length
height Tree e a
r
dh :: Length
dh = (Length
hl forall a. Num a => a -> a -> a
- Length
hr) forall a. Fractional a => a -> a -> a
/ Length
2
in forall a b. b -> Either a b
Right forall a b. (a -> b) -> a -> b
$
forall e a. e -> a -> Forest e a -> Tree e a
Node
e
br
a
lb
[ forall e a. (e -> e) -> Tree e a -> Tree e a
modifyStem (forall e. HasLength e => (Length -> Length) -> e -> e
modifyLength (forall {a}. (Ord a, Fractional a) => a -> a -> a
subtract' Length
dh)) Tree e a
l,
forall e a. (e -> e) -> Tree e a -> Tree e a
modifyStem (forall e. HasLength e => (Length -> Length) -> e -> e
modifyLength (forall a. Num a => a -> a -> a
+ Length
dh)) Tree e a
r
]
Right Tree e a
_ -> forall a. HasCallStack => String -> a
error String
"getMidpoint: Root node is not bifurcating?"
Left String
e -> forall a b. a -> Either a b
Left String
e
where
dhs :: [Length]
dhs = forall a b. (a -> b) -> [a] -> [b]
map 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 forall a. [a] -> Int -> a
!!) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. Ord a => [a] -> Either String Int
findMinIndex [Length]
dhs
subtract' :: a -> a -> a
subtract' a
dx a
x =
let x' :: a
x' = forall a. Num a => a -> a -> a
subtract a
dx a
x
in case forall a. Ord a => a -> a -> Ordering
compare a
x' a
0 of
Ordering
LT -> if a
x' forall a. Ord a => a -> a -> Bool
< a
1e-14 then forall a. HasCallStack => String -> a
error String
"getMidpoint: Length less than zero." else a
0
Ordering
_ -> a
x'
getDeltaHeight :: HasLength e => Tree e a -> Length
getDeltaHeight :: forall e a. HasLength e => Tree e a -> Length
getDeltaHeight (Node e
_ a
_ [Tree e a
l, Tree e a
r]) = forall a. Num a => a -> a
abs forall a b. (a -> b) -> a -> b
$ forall e a. HasLength e => Tree e a -> Length
height Tree e a
l forall a. Num a => a -> a -> a
- forall e a. HasLength e => Tree e a -> Length
height Tree e a
r
getDeltaHeight Tree e a
_ = forall a. HasCallStack => String -> a
error String
"getDeltaHeight: Root node is not bifurcating?"
roots :: (Semigroup e, Splittable e, Default a) => Tree e a -> Either String (Forest e a)
roots :: forall e a.
(Semigroup e, Splittable e, Default a) =>
Tree e a -> Either String (Forest e a)
roots (Node e
_ a
_ []) = forall a b. a -> Either a b
Left String
"roots: Root node is a leaf."
roots (Node e
_ a
_ [Tree 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]) = forall a b. b -> Either a b
Right forall a b. (a -> b) -> a -> b
$ Tree e a
t forall a. a -> [a] -> [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 forall a. [a] -> [a] -> [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 [Tree e a]
ts) = forall e a.
(Semigroup e, Splittable e, Default a) =>
Tree e a -> Either String (Forest e a)
roots forall a b. (a -> b) -> a -> b
$ forall e a. e -> a -> Forest e a -> Tree e a
Node e
b forall a. Default a => a
def [Tree e a
tL, Tree e a
tR]
where
(Node e
bL a
lL [Tree e a]
tsL) = forall a. [a] -> a
head [Tree e a]
ts
bL' :: e
bL' = forall e. Splittable e => e -> e
split e
bL
tL :: Tree e a
tL = forall e a. e -> a -> Forest e a -> Tree e a
Node e
bL' a
lL [Tree e a]
tsL
tR :: Tree e a
tR = forall e a. e -> a -> Forest e a -> Tree e a
Node e
bL' a
c forall a b. (a -> b) -> a -> b
$ forall a. [a] -> [a]
tail [Tree e a]
ts
complementaryForests :: Tree e a -> Forest e a -> [Forest e a]
complementaryForests :: forall e a. Tree e a -> Forest e a -> [Forest e a]
complementaryForests Tree e a
t Forest e a
ts = [Tree e a
t forall a. a -> [a] -> [a]
: forall a. Int -> [a] -> [a]
take Int
i Forest e a
ts forall a. [a] -> [a] -> [a]
++ forall a. Int -> [a] -> [a]
drop (Int
i forall a. Num a => a -> a -> a
+ Int
1) Forest e a
ts | Int
i <- [Int
0 .. (Int
n forall a. Num a => a -> a -> a
- Int
1)]]
where
n :: Int
n = forall (t :: * -> *) a. Foldable t => t a -> Int
length Forest e a
ts
descend :: (Semigroup e, Splittable e) => e -> a -> Tree e a -> Tree e a -> Forest e a
descend :: forall e a.
(Semigroup e, Splittable e) =>
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 [Tree e a]
tsD) =
[ forall e a. e -> a -> Forest e a -> Tree e a
Node e
brR a
lbR [forall e a. e -> a -> Forest e a -> Tree e a
Node (forall e. Splittable e => e -> e
split e
brDd) a
lbD [Tree e a]
f, forall e a. e -> a -> Forest e a -> Tree e a
Node (forall e. Splittable e => e -> e
split e
brDd) a
lbDd [Tree e a]
tsDd]
| (Node e
brDd a
lbDd [Tree e a]
tsDd, [Tree e a]
f) <- forall a b. [a] -> [b] -> [(a, b)]
zip [Tree e a]
tsD [[Tree e a]]
cfs
]
forall a. [a] -> [a] -> [a]
++ forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
[ forall e a.
(Semigroup e, Splittable e) =>
e -> a -> Tree e a -> Tree e a -> Forest e a
descend e
brR a
lbR (forall e a. e -> a -> Forest e a -> Tree e a
Node (forall e. Splittable e => e -> e
split e
brDd) a
lbD [Tree e a]
f) (forall e a. e -> a -> Forest e a -> Tree e a
Node (forall e. Splittable e => e -> e
split e
brDd) a
lbDd [Tree e a]
tsDd)
| (Node e
brDd a
lbDd [Tree e a]
tsDd, [Tree e a]
f) <- forall a b. [a] -> [b] -> [(a, b)]
zip [Tree e a]
tsD [[Tree e a]]
cfs
]
where
brC' :: e
brC' = forall e a. Tree e a -> e
branch Tree e a
tC forall a. Semigroup a => a -> a -> a
<> e
brD
tC' :: Tree e a
tC' = Tree e a
tC {branch :: e
branch = e
brC'}
cfs :: [[Tree e a]]
cfs = forall e a. Tree e a -> Forest e a -> [Forest e a]
complementaryForests Tree e a
tC' [Tree e a]
tsD
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]
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
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
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
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
Ord, 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 -> ()
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
(forall a. Sum a -> a
getSum forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (forall a. a -> Sum a
Sum forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe Length
mBL) forall a. Semigroup a => a -> a -> a
<> (forall a. a -> Sum a
Sum forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe Length
mBR))
(forall a. Min a -> a
getMin forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (forall a. a -> Min a
Min forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe Support
mSL) forall a. Semigroup a => a -> a -> a
<> (forall a. a -> Min a
Min 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
toPhyloLabel :: (HasMaybeLength e, HasMaybeSupport e) => e -> Phylo
toPhyloLabel :: forall e. (HasMaybeLength e, HasMaybeSupport e) => e -> Phylo
toPhyloLabel e
x = Maybe Length -> Maybe Support -> Phylo
Phylo (forall e. HasMaybeLength e => e -> Maybe Length
getMaybeLength e
x) (forall e. HasMaybeSupport e => e -> Maybe Support
getMaybeSupport e
x)
toPhyloTree :: (HasMaybeLength e, HasMaybeSupport e) => Tree e a -> Tree Phylo a
toPhyloTree :: forall e a.
(HasMaybeLength e, HasMaybeSupport e) =>
Tree e a -> Tree Phylo a
toPhyloTree = forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first forall e. (HasMaybeLength e, HasMaybeSupport e) => e -> Phylo
toPhyloLabel
lengthToPhyloLabel :: HasMaybeLength e => e -> Phylo
lengthToPhyloLabel :: forall e. HasMaybeLength e => e -> Phylo
lengthToPhyloLabel e
x = Maybe Length -> Maybe Support -> Phylo
Phylo (forall e. HasMaybeLength e => e -> Maybe Length
getMaybeLength e
x) forall a. Maybe a
Nothing
lengthToPhyloTree :: HasMaybeLength e => Tree e a -> Tree Phylo a
lengthToPhyloTree :: forall e a. HasMaybeLength e => Tree e a -> Tree Phylo a
lengthToPhyloTree = forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first forall e. HasMaybeLength e => e -> Phylo
lengthToPhyloLabel
supportToPhyloLabel :: HasMaybeSupport e => e -> Phylo
supportToPhyloLabel :: forall e. HasMaybeSupport e => e -> Phylo
supportToPhyloLabel e
x = Maybe Length -> Maybe Support -> Phylo
Phylo forall a. Maybe a
Nothing (forall e. HasMaybeSupport e => e -> Maybe Support
getMaybeSupport e
x)
supportToPhyloTree :: HasMaybeSupport e => Tree e a -> Tree Phylo a
supportToPhyloTree :: forall e a. HasMaybeSupport e => Tree e a -> Tree Phylo a
supportToPhyloTree = forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first forall e. HasMaybeSupport e => e -> Phylo
supportToPhyloLabel
fromMaybeWithError :: String -> Maybe a -> Either String a
fromMaybeWithError :: forall a. String -> Maybe a -> Either String a
fromMaybeWithError String
s = forall b a. b -> (a -> b) -> Maybe a -> b
maybe (forall a b. a -> Either a b
Left String
s) forall a b. b -> Either a b
Right
toLengthTree :: HasMaybeLength e => Tree e a -> Either String (Tree Length a)
toLengthTree :: forall e a.
HasMaybeLength e =>
Tree e a -> Either String (Tree Length a)
toLengthTree (Node e
br a
lb Forest e a
ts) =
case forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse forall {a} {a}.
HasMaybeLength a =>
Tree a a -> Maybe (Tree Length a)
go Forest e a
ts of
Maybe [Tree Length a]
Nothing -> forall a b. a -> Either a b
Left String
"toLengthTree: Length unavailable for some branches."
Just [Tree Length a]
ts' -> forall a b. b -> Either a b
Right forall a b. (a -> b) -> a -> b
$ forall e a. e -> a -> Forest e a -> Tree e a
Node Length
br' a
lb [Tree Length a]
ts'
where
br' :: Length
br' = forall a. a -> Maybe a -> a
fromMaybe Length
0 forall a b. (a -> b) -> a -> b
$ forall e. HasMaybeLength e => e -> Maybe Length
getMaybeLength e
br
go :: Tree a a -> Maybe (Tree Length a)
go Tree a a
t = forall a e. BranchTree a e -> Tree e a
getBranchTree forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse forall e. HasMaybeLength e => e -> Maybe Length
getMaybeLength (forall a e. Tree e a -> BranchTree a e
BranchTree Tree a a
t)
toSupportTree :: HasMaybeSupport e => Tree e a -> Either String (Tree Support a)
toSupportTree :: forall e a.
HasMaybeSupport e =>
Tree e a -> Either String (Tree Support a)
toSupportTree t :: Tree e a
t@(Node e
br a
lb Forest e a
ts) =
forall a. String -> Maybe a -> Either String a
fromMaybeWithError String
"toSupportTree: Support value unavailable for some branches." forall a b. (a -> b) -> a -> b
$
forall a e. BranchTree a e -> Tree e a
getBranchTree forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (t :: * -> *) (f :: * -> *) a.
(Traversable t, Applicative f) =>
t (f a) -> f (t a)
sequenceA (forall a e. Tree e a -> BranchTree a e
BranchTree (forall e a. e -> a -> Forest e a -> Tree e a
Node Maybe Support
br' a
lb forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map forall {e} {a}.
HasMaybeSupport e =>
Tree e a -> Tree (Maybe Support) a
go Forest e a
ts))
where
m :: Support
m = forall e a. HasMaybeSupport e => Tree e a -> Support
getMaxSupport Tree e a
t
br' :: Maybe Support
br' = 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 []) = forall e a. e -> a -> Forest e a -> Tree e a
Node (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) = forall e a. e -> a -> Forest e a -> Tree e a
Node (forall e. HasMaybeSupport e => e -> Maybe Support
getMaybeSupport e
b) a
l (forall a b. (a -> b) -> [a] -> [b]
map Tree e a -> Tree (Maybe Support) a
go [Tree e a]
xs)
getMaxSupport :: HasMaybeSupport e => Tree e a -> Support
getMaxSupport :: forall e a. HasMaybeSupport e => Tree e a -> Support
getMaxSupport = forall a. HasCallStack => Maybe a -> a
fromJust forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Ord a => a -> a -> a
max (forall a. a -> Maybe a
Just Support
1.0) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
maximum 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. HasMaybeSupport e => e -> Maybe Support
getMaybeSupport forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a e. Tree e a -> ZipBranchTree a e
ZipBranchTree
cleanSupportWith :: HasMaybeSupport e => Support -> e -> Maybe Support
cleanSupportWith :: forall e. HasMaybeSupport e => Support -> e -> Maybe Support
cleanSupportWith Support
m e
x = case forall e. HasMaybeSupport e => e -> Maybe Support
getMaybeSupport e
x of
Maybe Support
Nothing -> forall a. a -> Maybe a
Just Support
m
Just Support
y -> forall a. a -> Maybe a
Just Support
y
data PhyloExplicit = PhyloExplicit
{ PhyloExplicit -> Length
eBranchLength :: Length,
PhyloExplicit -> Support
eBranchSupport :: Support
}
deriving (ReadPrec [PhyloExplicit]
ReadPrec PhyloExplicit
Int -> ReadS PhyloExplicit
ReadS [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
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
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
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
Ord, 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 forall a. Num a => a -> a -> a
+ Length
bR) (forall a. Ord a => a -> a -> a
min Support
sL Support
sR)
instance HasMaybeLength PhyloExplicit where
getMaybeLength :: PhyloExplicit -> Maybe Length
getMaybeLength = forall a. a -> Maybe a
Just 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 forall a. Fractional a => a -> a -> a
/ Length
2.0
instance HasMaybeSupport PhyloExplicit where
getMaybeSupport :: PhyloExplicit -> Maybe Support
getMaybeSupport = forall a. a -> Maybe a
Just 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
toExplicitTree ::
(HasMaybeLength e, HasMaybeSupport e) =>
Tree e a ->
Either String (Tree PhyloExplicit a)
toExplicitTree :: forall e a.
(HasMaybeLength e, HasMaybeSupport e) =>
Tree e a -> Either String (Tree PhyloExplicit a)
toExplicitTree Tree e a
t = do
Tree Length a
lt <- forall e a.
HasMaybeLength e =>
Tree e a -> Either String (Tree Length a)
toLengthTree Tree e a
t
Tree Support a
st <- forall e a.
HasMaybeSupport e =>
Tree e a -> Either String (Tree Support a)
toSupportTree Tree e a
t
case 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 forall a b. a -> b -> a
const Tree Length a
lt Tree Support a
st of
Maybe (Tree PhyloExplicit a)
Nothing -> forall a. HasCallStack => String -> a
error String
"toExplicitTree: Can not zip two trees with different topologies."
Just Tree PhyloExplicit a
zt -> forall (m :: * -> *) a. Monad m => a -> m a
return Tree PhyloExplicit a
zt