{-|
Module      : Gargantext.Core.Viz.Phylo.PhyloTools
Description : Module dedicated to all the tools needed for making a Phylo
Copyright   : (c) CNRS, 2017-Present
License     : AGPL + CECILL v3
Maintainer  : team@gargantext.org
Stability   : experimental
Portability : POSIX
-}

{-# LANGUAGE ViewPatterns      #-}

module Gargantext.Core.Viz.Phylo.PhyloTools where

import Data.Vector (Vector, elemIndex)
import Data.List (sort, concat, null, union, (++), tails, sortOn, nub, init, tail, partition, tails, nubBy, group)
import Data.Set (Set, disjoint)
import Data.Map (Map, elems, fromList, unionWith, keys, member, (!), filterWithKey, fromListWith, empty, restrictKeys)
import Data.String (String)
import Data.Text (Text,unpack)

import Prelude (floor,read)

import Gargantext.Prelude
import Gargantext.Core.Viz.AdaptativePhylo
import Text.Printf


import Debug.Trace (trace)
import Control.Lens hiding (Level)

import qualified Data.Vector as Vector
import qualified Data.List as List
import qualified Data.Set as Set
import qualified Data.Map as Map
import qualified Data.Text as Text

------------
-- | Io | --
------------

-- | To print an important message as an IO()
printIOMsg :: String -> IO ()
printIOMsg :: String -> IO ()
printIOMsg String
msg = 
    String -> IO ()
putStrLn ( String
"\n"
            String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
"------------" 
            String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
"\n"
            String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
"-- | " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
msg String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
"\n" )


-- | To print a comment as an IO()
printIOComment :: String -> IO ()
printIOComment :: String -> IO ()
printIOComment String
cmt =
    String -> IO ()
putStrLn ( String
"\n" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
cmt String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
"\n" )


--------------
-- | Misc | --
--------------

-- truncate' :: Double -> Int -> Double
-- truncate' x n = (fromIntegral (floor (x * t))) / t
--     where t = 10^n

truncate' :: Double -> Int -> Double
truncate' :: Double -> Int -> Double
truncate' Double
x Int
n = (Int -> Double
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> Double) -> Int -> Double
forall a b. (a -> b) -> a -> b
$ (Double -> Int
forall a b. (RealFrac a, Integral b) => a -> b
floor (Double
x Double -> Double -> Double
forall a. Num a => a -> a -> a
* Double
t) :: Int)) Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/ Double
t
    where 
        --------------
        t :: Double
        t :: Double
t = Double
10 Double -> Int -> Double
forall a b. (Num a, Integral b) => a -> b -> a
^Int
n

getInMap :: Int -> Map Int Double -> Double
getInMap :: Int -> Map Int Double -> Double
getInMap Int
k Map Int Double
m = 
    if (Int -> Map Int Double -> Bool
forall k a. Ord k => k -> Map k a -> Bool
member Int
k Map Int Double
m)
        then Map Int Double
m Map Int Double -> Int -> Double
forall k a. Ord k => Map k a -> k -> a
! Int
k
        else Double
0

roundToStr :: (PrintfArg a, Floating a) => Int -> a -> String
roundToStr :: Int -> a -> String
roundToStr = String -> Int -> a -> String
forall r. PrintfType r => String -> r
printf String
"%0.*f"


countSup :: Double -> [Double] -> Int
countSup :: Double -> [Double] -> Int
countSup Double
s [Double]
l = [Double] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length ([Double] -> Int) -> [Double] -> Int
forall a b. (a -> b) -> a -> b
$ (Double -> Bool) -> [Double] -> [Double]
forall a. (a -> Bool) -> [a] -> [a]
filter (Double -> Double -> Bool
forall a. Ord a => a -> a -> Bool
>Double
s) [Double]
l


dropByIdx :: Int -> [a] -> [a]
dropByIdx :: Int -> [a] -> [a]
dropByIdx Int
k [a]
l = Int -> [a] -> [a]
forall a. Int -> [a] -> [a]
take Int
k [a]
l [a] -> [a] -> [a]
forall a. [a] -> [a] -> [a]
++ Int -> [a] -> [a]
forall a. Int -> [a] -> [a]
drop (Int
kInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1) [a]
l


elemIndex' :: Eq a => a -> [a] -> Int
elemIndex' :: a -> [a] -> Int
elemIndex' a
e [a]
l = case (a -> [a] -> Maybe Int
forall a. Eq a => a -> [a] -> Maybe Int
List.elemIndex a
e [a]
l) of
    Maybe Int
Nothing -> Text -> Int
forall a. HasCallStack => Text -> a
panic (Text
"[ERR][Viz.Phylo.PhyloTools] element not in list")
    Just Int
i  -> Int
i


commonPrefix :: Eq a => [a] -> [a] -> [a] -> [a]
commonPrefix :: [a] -> [a] -> [a] -> [a]
commonPrefix [a]
lst [a]
lst' [a]
acc =
    if ([a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [a]
lst Bool -> Bool -> Bool
|| [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [a]
lst')
        then [a]
acc
        else if (Text -> [a] -> a
forall a. Text -> [a] -> a
head' Text
"commonPrefix" [a]
lst a -> a -> Bool
forall a. Eq a => a -> a -> Bool
== Text -> [a] -> a
forall a. Text -> [a] -> a
head' Text
"commonPrefix" [a]
lst')
                then [a] -> [a] -> [a] -> [a]
forall a. Eq a => [a] -> [a] -> [a] -> [a]
commonPrefix ([a] -> [a]
forall a. [a] -> [a]
tail [a]
lst) ([a] -> [a]
forall a. [a] -> [a]
tail [a]
lst') ([a]
acc [a] -> [a] -> [a]
forall a. [a] -> [a] -> [a]
++ [Text -> [a] -> a
forall a. Text -> [a] -> a
head' Text
"commonPrefix" [a]
lst])
                else [a]
acc


---------------------
-- | Foundations | --
---------------------


-- | Is this Ngrams a Foundations Root ?
isRoots :: Ngrams -> Vector Ngrams -> Bool
isRoots :: Text -> Vector Text -> Bool
isRoots Text
n Vector Text
ns = Text -> Vector Text -> Bool
forall a. Eq a => a -> Vector a -> Bool
Vector.elem Text
n Vector Text
ns

-- | To transform a list of nrams into a list of foundation's index
ngramsToIdx :: [Ngrams] -> Vector Ngrams -> [Int]
ngramsToIdx :: [Text] -> Vector Text -> [Int]
ngramsToIdx [Text]
ns Vector Text
fdt = (Text -> Int) -> [Text] -> [Int]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
map (\Text
n -> Maybe Int -> Int
forall a. HasCallStack => Maybe a -> a
fromJust (Maybe Int -> Int) -> Maybe Int -> Int
forall a b. (a -> b) -> a -> b
$ Text -> Vector Text -> Maybe Int
forall a. Eq a => a -> Vector a -> Maybe Int
elemIndex Text
n Vector Text
fdt) [Text]
ns

-- | To transform a list of sources into a list of sources' index
sourcesToIdx :: [Text] -> Vector Text -> [Int]
sourcesToIdx :: [Text] -> Vector Text -> [Int]
sourcesToIdx [Text]
ss Vector Text
ps = [Int] -> [Int]
forall a. Eq a => [a] -> [a]
nub ([Int] -> [Int]) -> [Int] -> [Int]
forall a b. (a -> b) -> a -> b
$ (Text -> Int) -> [Text] -> [Int]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
map (\Text
s -> Maybe Int -> Int
forall a. HasCallStack => Maybe a -> a
fromJust (Maybe Int -> Int) -> Maybe Int -> Int
forall a b. (a -> b) -> a -> b
$ Text -> Vector Text -> Maybe Int
forall a. Eq a => a -> Vector a -> Maybe Int
elemIndex Text
s Vector Text
ps) [Text]
ss

-- | To transform a list of Ngrams Indexes into a Label
ngramsToLabel :: Vector Ngrams -> [Int] -> Text
ngramsToLabel :: Vector Text -> [Int] -> Text
ngramsToLabel Vector Text
ngrams [Int]
l = [Text] -> Text
Text.unwords ([Text] -> Text) -> [Text] -> Text
forall a b. (a -> b) -> a -> b
$ Text -> [Text] -> [Text]
forall a. Text -> [a] -> [a]
tail' Text
"ngramsToLabel" ([Text] -> [Text]) -> [Text] -> [Text]
forall a b. (a -> b) -> a -> b
$ [[Text]] -> [Text]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ([[Text]] -> [Text]) -> [[Text]] -> [Text]
forall a b. (a -> b) -> a -> b
$ (Text -> [Text]) -> [Text] -> [[Text]]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
map (\Text
n -> [Text
"|",Text
n]) ([Text] -> [[Text]]) -> [Text] -> [[Text]]
forall a b. (a -> b) -> a -> b
$ Vector Text -> [Int] -> [Text]
ngramsToText Vector Text
ngrams [Int]
l

idxToLabel :: [Int] -> String
idxToLabel :: [Int] -> String
idxToLabel [Int]
l = [String] -> String
List.unwords ([String] -> String) -> [String] -> String
forall a b. (a -> b) -> a -> b
$ Text -> [String] -> [String]
forall a. Text -> [a] -> [a]
tail' Text
"idxToLabel" ([String] -> [String]) -> [String] -> [String]
forall a b. (a -> b) -> a -> b
$ [[String]] -> [String]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ([[String]] -> [String]) -> [[String]] -> [String]
forall a b. (a -> b) -> a -> b
$ (Int -> [String]) -> [Int] -> [[String]]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
map (\Int
n -> [String
"|",Int -> String
forall a. Show a => a -> String
show Int
n]) [Int]
l

idxToLabel' :: [Double] -> String
idxToLabel' :: [Double] -> String
idxToLabel' [Double]
l = [String] -> String
List.unwords ([String] -> String) -> [String] -> String
forall a b. (a -> b) -> a -> b
$ Text -> [String] -> [String]
forall a. Text -> [a] -> [a]
tail' Text
"idxToLabel" ([String] -> [String]) -> [String] -> [String]
forall a b. (a -> b) -> a -> b
$ [[String]] -> [String]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ([[String]] -> [String]) -> [[String]] -> [String]
forall a b. (a -> b) -> a -> b
$ (Double -> [String]) -> [Double] -> [[String]]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
map (\Double
n -> [String
"|",Double -> String
forall a. Show a => a -> String
show Double
n]) [Double]
l

-- | To transform a list of Ngrams Indexes into a list of Text
ngramsToText :: Vector Ngrams -> [Int] -> [Text]
ngramsToText :: Vector Text -> [Int] -> [Text]
ngramsToText Vector Text
ngrams [Int]
l = (Int -> Text) -> [Int] -> [Text]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
map (\Int
idx -> Vector Text
ngrams Vector Text -> Int -> Text
forall a. Vector a -> Int -> a
Vector.! Int
idx) [Int]
l


--------------
-- | Time | --
--------------

-- | To transform a list of periods into a set of Dates
periodsToYears :: [(Date,Date)] -> Set Date
periodsToYears :: [(Int, Int)] -> Set Int
periodsToYears [(Int, Int)]
periods = ([Int] -> Set Int
forall a. Ord a => [a] -> Set a
Set.fromList ([Int] -> Set Int) -> ([[Int]] -> [Int]) -> [[Int]] -> Set Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Int] -> [Int]
forall a. Ord a => [a] -> [a]
sort ([Int] -> [Int]) -> ([[Int]] -> [Int]) -> [[Int]] -> [Int]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [[Int]] -> [Int]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat)
                       ([[Int]] -> Set Int) -> [[Int]] -> Set Int
forall a b. (a -> b) -> a -> b
$ ((Int, Int) -> [Int]) -> [(Int, Int)] -> [[Int]]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
map (\(Int
d,Int
d') -> [Int
d..Int
d']) [(Int, Int)]
periods


findBounds :: [Date] -> (Date,Date)
findBounds :: [Int] -> (Int, Int)
findBounds [Int]
dates = 
    let dates' :: [Int]
dates' = [Int] -> [Int]
forall a. Ord a => [a] -> [a]
sort [Int]
dates
    in  (Text -> [Int] -> Int
forall a. Text -> [a] -> a
head' Text
"findBounds" [Int]
dates', Text -> [Int] -> Int
forall a. Text -> [a] -> a
last' Text
"findBounds" [Int]
dates')


toPeriods :: [Date] -> Int -> Int -> [(Date,Date)]
toPeriods :: [Int] -> Int -> Int -> [(Int, Int)]
toPeriods [Int]
dates Int
p Int
s = 
    let (Int
start,Int
end) = [Int] -> (Int, Int)
findBounds [Int]
dates
    in ([Int] -> (Int, Int)) -> [[Int]] -> [(Int, Int)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
map (\[Int]
dates' -> (Text -> [Int] -> Int
forall a. Text -> [a] -> a
head' Text
"toPeriods" [Int]
dates', Text -> [Int] -> Int
forall a. Text -> [a] -> a
last' Text
"toPeriods" [Int]
dates')) 
     ([[Int]] -> [(Int, Int)]) -> [[Int]] -> [(Int, Int)]
forall a b. (a -> b) -> a -> b
$ Int -> Int -> [Int] -> [[Int]]
forall a. Eq a => Int -> Int -> [a] -> [[a]]
chunkAlong Int
p Int
s [Int
start .. Int
end]


toFstDate :: [Text] -> Text
toFstDate :: [Text] -> Text
toFstDate [Text]
ds = (Int, Text) -> Text
forall a b. (a, b) -> b
snd
             ((Int, Text) -> Text) -> (Int, Text) -> Text
forall a b. (a -> b) -> a -> b
$ Text -> [(Int, Text)] -> (Int, Text)
forall a. Text -> [a] -> a
head' Text
"firstDate"
             ([(Int, Text)] -> (Int, Text)) -> [(Int, Text)] -> (Int, Text)
forall a b. (a -> b) -> a -> b
$ ((Int, Text) -> Int) -> [(Int, Text)] -> [(Int, Text)]
forall b a. Ord b => (a -> b) -> [a] -> [a]
sortOn (Int, Text) -> Int
forall a b. (a, b) -> a
fst
             ([(Int, Text)] -> [(Int, Text)]) -> [(Int, Text)] -> [(Int, Text)]
forall a b. (a -> b) -> a -> b
$ (Text -> (Int, Text)) -> [Text] -> [(Int, Text)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
map (\Text
d -> 
                      let d' :: Int
d' = String -> Int
forall a. Read a => String -> a
read ((Char -> Bool) -> String -> String
forall a. (a -> Bool) -> [a] -> [a]
filter (\Char
c -> Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= Char
'-') (String -> String) -> String -> String
forall a b. (a -> b) -> a -> b
$ Text -> String
unpack Text
d)::Int
                       in (Int
d',Text
d)) [Text]
ds

toLstDate :: [Text] -> Text
toLstDate :: [Text] -> Text
toLstDate [Text]
ds = (Int, Text) -> Text
forall a b. (a, b) -> b
snd
             ((Int, Text) -> Text) -> (Int, Text) -> Text
forall a b. (a -> b) -> a -> b
$ Text -> [(Int, Text)] -> (Int, Text)
forall a. Text -> [a] -> a
head' Text
"firstDate"
             ([(Int, Text)] -> (Int, Text)) -> [(Int, Text)] -> (Int, Text)
forall a b. (a -> b) -> a -> b
$ [(Int, Text)] -> [(Int, Text)]
forall a. [a] -> [a]
reverse
             ([(Int, Text)] -> [(Int, Text)]) -> [(Int, Text)] -> [(Int, Text)]
forall a b. (a -> b) -> a -> b
$ ((Int, Text) -> Int) -> [(Int, Text)] -> [(Int, Text)]
forall b a. Ord b => (a -> b) -> [a] -> [a]
sortOn (Int, Text) -> Int
forall a b. (a, b) -> a
fst
             ([(Int, Text)] -> [(Int, Text)]) -> [(Int, Text)] -> [(Int, Text)]
forall a b. (a -> b) -> a -> b
$ (Text -> (Int, Text)) -> [Text] -> [(Int, Text)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
map (\Text
d -> 
                      let d' :: Int
d' = String -> Int
forall a. Read a => String -> a
read ((Char -> Bool) -> String -> String
forall a. (a -> Bool) -> [a] -> [a]
filter (\Char
c -> Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= Char
'-') (String -> String) -> String -> String
forall a b. (a -> b) -> a -> b
$ Text -> String
unpack Text
d)::Int
                       in (Int
d',Text
d)) [Text]
ds  


getTimeScale :: Phylo -> [Char]
getTimeScale :: Phylo -> String
getTimeScale Phylo
p = case (Config -> TimeUnit
timeUnit (Config -> TimeUnit) -> Config -> TimeUnit
forall a b. (a -> b) -> a -> b
$ Phylo -> Config
getConfig Phylo
p) of
    Year  Int
_ Int
_ Int
_ -> String
"year"
    Month Int
_ Int
_ Int
_ -> String
"month"
    Week  Int
_ Int
_ Int
_ -> String
"week"  
    Day   Int
_ Int
_ Int
_ -> String
"day"      


-- | Get a regular & ascendante timeScale from a given list of dates
toTimeScale :: [Date] -> Int -> [Date]
toTimeScale :: [Int] -> Int -> [Int]
toTimeScale [Int]
dates Int
step = 
    let (Int
start,Int
end) = [Int] -> (Int, Int)
findBounds [Int]
dates
    in  [Int
start, (Int
start Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
step) .. Int
end]


getTimeStep :: TimeUnit -> Int
getTimeStep :: TimeUnit -> Int
getTimeStep TimeUnit
time = case TimeUnit
time of 
    Year  Int
_ Int
s Int
_ -> Int
s
    Month Int
_ Int
s Int
_ -> Int
s  
    Week  Int
_ Int
s Int
_ -> Int
s  
    Day   Int
_ Int
s Int
_ -> Int
s  

getTimePeriod :: TimeUnit -> Int
getTimePeriod :: TimeUnit -> Int
getTimePeriod TimeUnit
time = case TimeUnit
time of 
    Year  Int
p Int
_ Int
_ -> Int
p
    Month Int
p Int
_ Int
_ -> Int
p  
    Week  Int
p Int
_ Int
_ -> Int
p  
    Day   Int
p Int
_ Int
_ -> Int
p  

getTimeFrame :: TimeUnit -> Int
getTimeFrame :: TimeUnit -> Int
getTimeFrame TimeUnit
time = case TimeUnit
time of 
    Year  Int
_ Int
_ Int
f -> Int
f
    Month Int
_ Int
_ Int
f -> Int
f
    Week  Int
_ Int
_ Int
f -> Int
f
    Day   Int
_ Int
_ Int
f -> Int
f            

-------------
-- | Fis | --
-------------


-- | To find if l' is nested in l
isNested :: Eq a => [a] -> [a] -> Bool
isNested :: [a] -> [a] -> Bool
isNested [a]
l [a]
l'
  | [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [a]
l'               = Bool
True
  | [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [a]
l' Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [a]
l  = Bool
False
  | ([a] -> [a] -> [a]
forall a. Eq a => [a] -> [a] -> [a]
union  [a]
l [a]
l') [a] -> [a] -> Bool
forall a. Eq a => a -> a -> Bool
== [a]
l    = Bool
True
  | Bool
otherwise             = Bool
False 


-- | To filter Fis with small Support but by keeping non empty Periods
keepFilled :: (Int -> [a] -> [a]) -> Int -> [a] -> [a]
keepFilled :: (Int -> [a] -> [a]) -> Int -> [a] -> [a]
keepFilled Int -> [a] -> [a]
f Int
thr [a]
l = if ([a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null ([a] -> Bool) -> [a] -> Bool
forall a b. (a -> b) -> a -> b
$ Int -> [a] -> [a]
f Int
thr [a]
l) Bool -> Bool -> Bool
&& (Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [a]
l)
                     then (Int -> [a] -> [a]) -> Int -> [a] -> [a]
forall a. (Int -> [a] -> [a]) -> Int -> [a] -> [a]
keepFilled Int -> [a] -> [a]
f (Int
thr Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1) [a]
l
                     else Int -> [a] -> [a]
f Int
thr [a]
l


traceClique :: Map (Date, Date) [PhyloClique] -> String
traceClique :: Map (Int, Int) [PhyloClique] -> String
traceClique Map (Int, Int) [PhyloClique]
mFis = (String -> Double -> String) -> String -> [Double] -> String
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl (\String
msg Double
cpt -> String
msg String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Int -> String
forall a. Show a => a -> String
show (Double -> [Double] -> Int
countSup Double
cpt [Double]
cliques) String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
" (>" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Double -> String
forall a. Show a => a -> String
show (Double
cpt) String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
") "  ) String
"" [Double
1..Double
6]
    where
        --------------------------------------
        cliques :: [Double]
        cliques :: [Double]
cliques = [Double] -> [Double]
forall a. Ord a => [a] -> [a]
sort ([Double] -> [Double]) -> [Double] -> [Double]
forall a b. (a -> b) -> a -> b
$ (PhyloClique -> Double) -> [PhyloClique] -> [Double]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
map (Int -> Double
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> Double) -> (PhyloClique -> Int) -> PhyloClique -> Double
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Int] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length ([Int] -> Int) -> (PhyloClique -> [Int]) -> PhyloClique -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PhyloClique -> [Int]
_phyloClique_nodes) ([PhyloClique] -> [Double]) -> [PhyloClique] -> [Double]
forall a b. (a -> b) -> a -> b
$ [[PhyloClique]] -> [PhyloClique]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ([[PhyloClique]] -> [PhyloClique])
-> [[PhyloClique]] -> [PhyloClique]
forall a b. (a -> b) -> a -> b
$ Map (Int, Int) [PhyloClique] -> [[PhyloClique]]
forall k a. Map k a -> [a]
elems Map (Int, Int) [PhyloClique]
mFis
        -------------------------------------- 


traceSupport :: Map (Date, Date) [PhyloClique] -> String
traceSupport :: Map (Int, Int) [PhyloClique] -> String
traceSupport Map (Int, Int) [PhyloClique]
mFis = (String -> Double -> String) -> String -> [Double] -> String
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl (\String
msg Double
cpt -> String
msg String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Int -> String
forall a. Show a => a -> String
show (Double -> [Double] -> Int
countSup Double
cpt [Double]
supports) String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
" (>" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Double -> String
forall a. Show a => a -> String
show (Double
cpt) String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
") "  ) String
"" [Double
1..Double
6]
    where
        --------------------------------------
        supports :: [Double]
        supports :: [Double]
supports = [Double] -> [Double]
forall a. Ord a => [a] -> [a]
sort ([Double] -> [Double]) -> [Double] -> [Double]
forall a b. (a -> b) -> a -> b
$ (PhyloClique -> Double) -> [PhyloClique] -> [Double]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
map (Int -> Double
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> Double) -> (PhyloClique -> Int) -> PhyloClique -> Double
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PhyloClique -> Int
_phyloClique_support) ([PhyloClique] -> [Double]) -> [PhyloClique] -> [Double]
forall a b. (a -> b) -> a -> b
$ [[PhyloClique]] -> [PhyloClique]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ([[PhyloClique]] -> [PhyloClique])
-> [[PhyloClique]] -> [PhyloClique]
forall a b. (a -> b) -> a -> b
$ Map (Int, Int) [PhyloClique] -> [[PhyloClique]]
forall k a. Map k a -> [a]
elems Map (Int, Int) [PhyloClique]
mFis
        -------------------------------------- 


traceFis :: [Char] -> Map (Date, Date) [PhyloClique] -> Map (Date, Date) [PhyloClique]
traceFis :: String
-> Map (Int, Int) [PhyloClique] -> Map (Int, Int) [PhyloClique]
traceFis String
msg Map (Int, Int) [PhyloClique]
mFis = String
-> Map (Int, Int) [PhyloClique] -> Map (Int, Int) [PhyloClique]
forall a. String -> a -> a
trace ( String
"\n" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
"-- | " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
msg String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
" : " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Int -> String
forall a. Show a => a -> String
show ([Int] -> Int
forall (f :: * -> *) a. (Foldable f, Num a) => f a -> a
sum ([Int] -> Int) -> [Int] -> Int
forall a b. (a -> b) -> a -> b
$ ([PhyloClique] -> Int) -> [[PhyloClique]] -> [Int]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
map [PhyloClique] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length ([[PhyloClique]] -> [Int]) -> [[PhyloClique]] -> [Int]
forall a b. (a -> b) -> a -> b
$ Map (Int, Int) [PhyloClique] -> [[PhyloClique]]
forall k a. Map k a -> [a]
elems Map (Int, Int) [PhyloClique]
mFis) String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
"\n"
                         String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
"Support : " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> (Map (Int, Int) [PhyloClique] -> String
traceSupport Map (Int, Int) [PhyloClique]
mFis) String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
"\n"
                         String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
"Nb Ngrams : "  String -> String -> String
forall a. Semigroup a => a -> a -> a
<> (Map (Int, Int) [PhyloClique] -> String
traceClique Map (Int, Int) [PhyloClique]
mFis)  String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
"\n" ) Map (Int, Int) [PhyloClique]
mFis


---------------
-- | Clique| --
---------------


getCliqueSupport :: Clique -> Int
getCliqueSupport :: Clique -> Int
getCliqueSupport Clique
unit = case Clique
unit of 
    Fis Int
s Int
_ -> Int
s
    MaxClique Int
_ Double
_ CliqueFilter
_ -> Int
0

getCliqueSize :: Clique -> Int
getCliqueSize :: Clique -> Int
getCliqueSize Clique
unit = case Clique
unit of 
    Fis Int
_ Int
s -> Int
s
    MaxClique Int
s Double
_ CliqueFilter
_ -> Int
s


--------------
-- | Cooc | --
--------------

listToCombi' :: [a] -> [(a,a)]
listToCombi' :: [a] -> [(a, a)]
listToCombi' [a]
l = [(a
x,a
y) | (a
x:[a]
rest) <- [a] -> [[a]]
forall a. [a] -> [[a]]
tails [a]
l,  a
y <- [a]
rest]

listToEqual' :: Eq a => [a] -> [(a,a)]
listToEqual' :: [a] -> [(a, a)]
listToEqual' [a]
l = [(a
x,a
y) | a
x <- [a]
l, a
y <- [a]
l, a
x a -> a -> Bool
forall a. Eq a => a -> a -> Bool
== a
y]

listToKeys :: Eq a =>  [a] -> [(a,a)]
listToKeys :: [a] -> [(a, a)]
listToKeys [a]
lst = ([a] -> [(a, a)]
forall a. [a] -> [(a, a)]
listToCombi' [a]
lst) [(a, a)] -> [(a, a)] -> [(a, a)]
forall a. [a] -> [a] -> [a]
++ ([a] -> [(a, a)]
forall a. Eq a => [a] -> [(a, a)]
listToEqual' [a]
lst)

listToMatrix :: [Int] -> Map (Int,Int) Double
listToMatrix :: [Int] -> Map (Int, Int) Double
listToMatrix [Int]
lst = [((Int, Int), Double)] -> Map (Int, Int) Double
forall k a. Ord k => [(k, a)] -> Map k a
fromList ([((Int, Int), Double)] -> Map (Int, Int) Double)
-> [((Int, Int), Double)] -> Map (Int, Int) Double
forall a b. (a -> b) -> a -> b
$ ((Int, Int) -> ((Int, Int), Double))
-> [(Int, Int)] -> [((Int, Int), Double)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
map (\(Int, Int)
k -> ((Int, Int)
k,Double
1)) ([(Int, Int)] -> [((Int, Int), Double)])
-> [(Int, Int)] -> [((Int, Int), Double)]
forall a b. (a -> b) -> a -> b
$ [Int] -> [(Int, Int)]
forall a. Eq a => [a] -> [(a, a)]
listToKeys ([Int] -> [(Int, Int)]) -> [Int] -> [(Int, Int)]
forall a b. (a -> b) -> a -> b
$ [Int] -> [Int]
forall a. Ord a => [a] -> [a]
sort [Int]
lst

listToMatrix' :: [Ngrams] -> Map (Ngrams,Ngrams) Int
listToMatrix' :: [Text] -> Map (Text, Text) Int
listToMatrix' [Text]
lst = [((Text, Text), Int)] -> Map (Text, Text) Int
forall k a. Ord k => [(k, a)] -> Map k a
fromList ([((Text, Text), Int)] -> Map (Text, Text) Int)
-> [((Text, Text), Int)] -> Map (Text, Text) Int
forall a b. (a -> b) -> a -> b
$ ((Text, Text) -> ((Text, Text), Int))
-> [(Text, Text)] -> [((Text, Text), Int)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
map (\(Text, Text)
k -> ((Text, Text)
k,Int
1)) ([(Text, Text)] -> [((Text, Text), Int)])
-> [(Text, Text)] -> [((Text, Text), Int)]
forall a b. (a -> b) -> a -> b
$ [Text] -> [(Text, Text)]
forall a. Eq a => [a] -> [(a, a)]
listToKeys ([Text] -> [(Text, Text)]) -> [Text] -> [(Text, Text)]
forall a b. (a -> b) -> a -> b
$ [Text] -> [Text]
forall a. Ord a => [a] -> [a]
sort [Text]
lst

listToSeq :: Eq a =>  [a] -> [(a,a)]
listToSeq :: [a] -> [(a, a)]
listToSeq [a]
l = ((a, a) -> (a, a) -> Bool) -> [(a, a)] -> [(a, a)]
forall a. (a -> a -> Bool) -> [a] -> [a]
nubBy (\(a, a)
x (a, a)
y -> (a, a) -> a
forall a b. (a, b) -> a
fst (a, a)
x a -> a -> Bool
forall a. Eq a => a -> a -> Bool
== (a, a) -> a
forall a b. (a, b) -> a
fst (a, a)
y) ([(a, a)] -> [(a, a)]) -> [(a, a)] -> [(a, a)]
forall a b. (a -> b) -> a -> b
$ [ (a
x,a
y) | (a
x:[a]
rest) <- [a] -> [[a]]
forall a. [a] -> [[a]]
tails [a]
l,  a
y <- [a]
rest ]

sumCooc :: Cooc -> Cooc -> Cooc
sumCooc :: Map (Int, Int) Double
-> Map (Int, Int) Double -> Map (Int, Int) Double
sumCooc Map (Int, Int) Double
cooc Map (Int, Int) Double
cooc' = (Double -> Double -> Double)
-> Map (Int, Int) Double
-> Map (Int, Int) Double
-> Map (Int, Int) Double
forall k a. Ord k => (a -> a -> a) -> Map k a -> Map k a -> Map k a
unionWith Double -> Double -> Double
forall a. Num a => a -> a -> a
(+) Map (Int, Int) Double
cooc Map (Int, Int) Double
cooc'

getTrace :: Cooc -> Double 
getTrace :: Map (Int, Int) Double -> Double
getTrace Map (Int, Int) Double
cooc = [Double] -> Double
forall (f :: * -> *) a. (Foldable f, Num a) => f a -> a
sum ([Double] -> Double) -> [Double] -> Double
forall a b. (a -> b) -> a -> b
$ Map (Int, Int) Double -> [Double]
forall k a. Map k a -> [a]
elems (Map (Int, Int) Double -> [Double])
-> Map (Int, Int) Double -> [Double]
forall a b. (a -> b) -> a -> b
$ ((Int, Int) -> Double -> Bool)
-> Map (Int, Int) Double -> Map (Int, Int) Double
forall k a. (k -> a -> Bool) -> Map k a -> Map k a
filterWithKey (\(Int
k,Int
k') Double
_ -> Int
k Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
k') Map (Int, Int) Double
cooc

coocToDiago :: Cooc -> Cooc
coocToDiago :: Map (Int, Int) Double -> Map (Int, Int) Double
coocToDiago Map (Int, Int) Double
cooc = ((Int, Int) -> Double -> Bool)
-> Map (Int, Int) Double -> Map (Int, Int) Double
forall k a. (k -> a -> Bool) -> Map k a -> Map k a
filterWithKey (\(Int
k,Int
k') Double
_ -> Int
k Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
k') Map (Int, Int) Double
cooc

-- | To build the local cooc matrix of each phylogroup
ngramsToCooc :: [Int] -> [Cooc] -> Cooc
ngramsToCooc :: [Int] -> [Map (Int, Int) Double] -> Map (Int, Int) Double
ngramsToCooc [Int]
ngrams [Map (Int, Int) Double]
coocs =
    let cooc :: Map (Int, Int) Double
cooc  = (Map (Int, Int) Double
 -> Map (Int, Int) Double -> Map (Int, Int) Double)
-> Map (Int, Int) Double
-> [Map (Int, Int) Double]
-> Map (Int, Int) Double
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl (\Map (Int, Int) Double
acc Map (Int, Int) Double
cooc' -> Map (Int, Int) Double
-> Map (Int, Int) Double -> Map (Int, Int) Double
sumCooc Map (Int, Int) Double
acc Map (Int, Int) Double
cooc') Map (Int, Int) Double
forall k a. Map k a
empty [Map (Int, Int) Double]
coocs
        pairs :: [(Int, Int)]
pairs = [Int] -> [(Int, Int)]
forall a. Eq a => [a] -> [(a, a)]
listToKeys [Int]
ngrams
    in  ((Int, Int) -> Double -> Bool)
-> Map (Int, Int) Double -> Map (Int, Int) Double
forall k a. (k -> a -> Bool) -> Map k a -> Map k a
filterWithKey (\(Int, Int)
k Double
_ -> (Int, Int) -> [(Int, Int)] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
elem (Int, Int)
k [(Int, Int)]
pairs) Map (Int, Int) Double
cooc


--------------------
-- | PhyloGroup | --
--------------------

getGroupId :: PhyloGroup -> PhyloGroupId 
getGroupId :: PhyloGroup -> PhyloGroupId
getGroupId PhyloGroup
g = ((PhyloGroup
g PhyloGroup
-> Getting (Int, Int) PhyloGroup (Int, Int) -> (Int, Int)
forall s a. s -> Getting a s a -> a
^. Getting (Int, Int) PhyloGroup (Int, Int)
Lens' PhyloGroup (Int, Int)
phylo_groupPeriod, PhyloGroup
g PhyloGroup -> Getting Int PhyloGroup Int -> Int
forall s a. s -> Getting a s a -> a
^. Getting Int PhyloGroup Int
Lens' PhyloGroup Int
phylo_groupLevel), PhyloGroup
g PhyloGroup -> Getting Int PhyloGroup Int -> Int
forall s a. s -> Getting a s a -> a
^. Getting Int PhyloGroup Int
Lens' PhyloGroup Int
phylo_groupIndex)

idToPrd :: PhyloGroupId -> PhyloPeriodId
idToPrd :: PhyloGroupId -> (Int, Int)
idToPrd PhyloGroupId
id = (((Int, Int), Int) -> (Int, Int)
forall a b. (a, b) -> a
fst (((Int, Int), Int) -> (Int, Int))
-> (PhyloGroupId -> ((Int, Int), Int))
-> PhyloGroupId
-> (Int, Int)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PhyloGroupId -> ((Int, Int), Int)
forall a b. (a, b) -> a
fst) PhyloGroupId
id

groupByField :: Ord a => (PhyloGroup -> a) -> [PhyloGroup] ->  Map a [PhyloGroup]
groupByField :: (PhyloGroup -> a) -> [PhyloGroup] -> Map a [PhyloGroup]
groupByField PhyloGroup -> a
toField [PhyloGroup]
groups = ([PhyloGroup] -> [PhyloGroup] -> [PhyloGroup])
-> [(a, [PhyloGroup])] -> Map a [PhyloGroup]
forall k a. Ord k => (a -> a -> a) -> [(k, a)] -> Map k a
fromListWith [PhyloGroup] -> [PhyloGroup] -> [PhyloGroup]
forall a. [a] -> [a] -> [a]
(++) ([(a, [PhyloGroup])] -> Map a [PhyloGroup])
-> [(a, [PhyloGroup])] -> Map a [PhyloGroup]
forall a b. (a -> b) -> a -> b
$ (PhyloGroup -> (a, [PhyloGroup]))
-> [PhyloGroup] -> [(a, [PhyloGroup])]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
map (\PhyloGroup
g -> (PhyloGroup -> a
toField PhyloGroup
g, [PhyloGroup
g])) [PhyloGroup]
groups

getPeriodPointers :: Filiation -> PhyloGroup -> [Pointer]
getPeriodPointers :: Filiation -> PhyloGroup -> [Pointer]
getPeriodPointers Filiation
fil PhyloGroup
g = 
    case Filiation
fil of 
        Filiation
ToChilds  -> PhyloGroup
g PhyloGroup -> Getting [Pointer] PhyloGroup [Pointer] -> [Pointer]
forall s a. s -> Getting a s a -> a
^. Getting [Pointer] PhyloGroup [Pointer]
Lens' PhyloGroup [Pointer]
phylo_groupPeriodChilds
        Filiation
ToParents -> PhyloGroup
g PhyloGroup -> Getting [Pointer] PhyloGroup [Pointer] -> [Pointer]
forall s a. s -> Getting a s a -> a
^. Getting [Pointer] PhyloGroup [Pointer]
Lens' PhyloGroup [Pointer]
phylo_groupPeriodParents

filterProximity :: Proximity -> Double -> Double -> Bool
filterProximity :: Proximity -> Double -> Double -> Bool
filterProximity Proximity
proximity Double
thr Double
local = 
    case Proximity
proximity of
        WeightedLogJaccard Double
_ -> Double
local Double -> Double -> Bool
forall a. Ord a => a -> a -> Bool
>= Double
thr
        WeightedLogSim Double
_ -> Double
local Double -> Double -> Bool
forall a. Ord a => a -> a -> Bool
>= Double
thr
        Proximity
Hamming -> Bool
forall a. HasCallStack => a
undefined   

getProximityName :: Proximity -> String
getProximityName :: Proximity -> String
getProximityName Proximity
proximity =
    case Proximity
proximity of
        WeightedLogJaccard Double
_ -> String
"WLJaccard"
        WeightedLogSim Double
_ -> String
"WeightedLogSim"
        Proximity
Hamming -> String
"Hamming"            

---------------
-- | Phylo | --
---------------

addPointers :: Filiation -> PointerType -> [Pointer] -> PhyloGroup -> PhyloGroup
addPointers :: Filiation -> PointerType -> [Pointer] -> PhyloGroup -> PhyloGroup
addPointers Filiation
fil PointerType
pty [Pointer]
pointers PhyloGroup
g = 
    case PointerType
pty of 
        PointerType
TemporalPointer -> case Filiation
fil of 
                                Filiation
ToChilds  -> PhyloGroup
g PhyloGroup -> (PhyloGroup -> PhyloGroup) -> PhyloGroup
forall a b. a -> (a -> b) -> b
& ([Pointer] -> Identity [Pointer])
-> PhyloGroup -> Identity PhyloGroup
Lens' PhyloGroup [Pointer]
phylo_groupPeriodChilds  (([Pointer] -> Identity [Pointer])
 -> PhyloGroup -> Identity PhyloGroup)
-> [Pointer] -> PhyloGroup -> PhyloGroup
forall s t a b. ASetter s t a b -> b -> s -> t
.~ [Pointer]
pointers
                                Filiation
ToParents -> PhyloGroup
g PhyloGroup -> (PhyloGroup -> PhyloGroup) -> PhyloGroup
forall a b. a -> (a -> b) -> b
& ([Pointer] -> Identity [Pointer])
-> PhyloGroup -> Identity PhyloGroup
Lens' PhyloGroup [Pointer]
phylo_groupPeriodParents (([Pointer] -> Identity [Pointer])
 -> PhyloGroup -> Identity PhyloGroup)
-> [Pointer] -> PhyloGroup -> PhyloGroup
forall s t a b. ASetter s t a b -> b -> s -> t
.~ [Pointer]
pointers
        PointerType
LevelPointer    -> case Filiation
fil of 
                                Filiation
ToChilds  -> PhyloGroup
g PhyloGroup -> (PhyloGroup -> PhyloGroup) -> PhyloGroup
forall a b. a -> (a -> b) -> b
& ([Pointer] -> Identity [Pointer])
-> PhyloGroup -> Identity PhyloGroup
Lens' PhyloGroup [Pointer]
phylo_groupLevelChilds   (([Pointer] -> Identity [Pointer])
 -> PhyloGroup -> Identity PhyloGroup)
-> [Pointer] -> PhyloGroup -> PhyloGroup
forall s t a b. ASetter s t a b -> b -> s -> t
.~ [Pointer]
pointers
                                Filiation
ToParents -> PhyloGroup
g PhyloGroup -> (PhyloGroup -> PhyloGroup) -> PhyloGroup
forall a b. a -> (a -> b) -> b
& ([Pointer] -> Identity [Pointer])
-> PhyloGroup -> Identity PhyloGroup
Lens' PhyloGroup [Pointer]
phylo_groupLevelParents  (([Pointer] -> Identity [Pointer])
 -> PhyloGroup -> Identity PhyloGroup)
-> [Pointer] -> PhyloGroup -> PhyloGroup
forall s t a b. ASetter s t a b -> b -> s -> t
.~ [Pointer]
pointers


getPeriodIds :: Phylo -> [(Date,Date)]
getPeriodIds :: Phylo -> [(Int, Int)]
getPeriodIds Phylo
phylo = ((Int, Int) -> Int) -> [(Int, Int)] -> [(Int, Int)]
forall b a. Ord b => (a -> b) -> [a] -> [a]
sortOn (Int, Int) -> Int
forall a b. (a, b) -> a
fst
                   ([(Int, Int)] -> [(Int, Int)]) -> [(Int, Int)] -> [(Int, Int)]
forall a b. (a -> b) -> a -> b
$ Map (Int, Int) PhyloPeriod -> [(Int, Int)]
forall k a. Map k a -> [k]
keys
                   (Map (Int, Int) PhyloPeriod -> [(Int, Int)])
-> Map (Int, Int) PhyloPeriod -> [(Int, Int)]
forall a b. (a -> b) -> a -> b
$ Phylo
phylo Phylo
-> Getting
     (Map (Int, Int) PhyloPeriod) Phylo (Map (Int, Int) PhyloPeriod)
-> Map (Int, Int) PhyloPeriod
forall s a. s -> Getting a s a -> a
^. Getting
  (Map (Int, Int) PhyloPeriod) Phylo (Map (Int, Int) PhyloPeriod)
Lens' Phylo (Map (Int, Int) PhyloPeriod)
phylo_periods

getLevelParentId :: PhyloGroup -> PhyloGroupId 
getLevelParentId :: PhyloGroup -> PhyloGroupId
getLevelParentId PhyloGroup
g = Pointer -> PhyloGroupId
forall a b. (a, b) -> a
fst (Pointer -> PhyloGroupId) -> Pointer -> PhyloGroupId
forall a b. (a -> b) -> a -> b
$ Text -> [Pointer] -> Pointer
forall a. Text -> [a] -> a
head' Text
"getLevelParentId" ([Pointer] -> Pointer) -> [Pointer] -> Pointer
forall a b. (a -> b) -> a -> b
$ PhyloGroup
g PhyloGroup -> Getting [Pointer] PhyloGroup [Pointer] -> [Pointer]
forall s a. s -> Getting a s a -> a
^. Getting [Pointer] PhyloGroup [Pointer]
Lens' PhyloGroup [Pointer]
phylo_groupLevelParents

getLastLevel :: Phylo -> Level
getLastLevel :: Phylo -> Int
getLastLevel Phylo
phylo = Text -> [Int] -> Int
forall a. Text -> [a] -> a
last' Text
"lastLevel" ([Int] -> Int) -> [Int] -> Int
forall a b. (a -> b) -> a -> b
$ Phylo -> [Int]
getLevels Phylo
phylo

getLevels :: Phylo -> [Level]
getLevels :: Phylo -> [Int]
getLevels Phylo
phylo = [Int] -> [Int]
forall a. Eq a => [a] -> [a]
nub 
                ([Int] -> [Int]) -> [Int] -> [Int]
forall a b. (a -> b) -> a -> b
$ (((Int, Int), Int) -> Int) -> [((Int, Int), Int)] -> [Int]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
map ((Int, Int), Int) -> Int
forall a b. (a, b) -> b
snd
                ([((Int, Int), Int)] -> [Int]) -> [((Int, Int), Int)] -> [Int]
forall a b. (a -> b) -> a -> b
$ Map ((Int, Int), Int) PhyloLevel -> [((Int, Int), Int)]
forall k a. Map k a -> [k]
keys (Map ((Int, Int), Int) PhyloLevel -> [((Int, Int), Int)])
-> Map ((Int, Int), Int) PhyloLevel -> [((Int, Int), Int)]
forall a b. (a -> b) -> a -> b
$ Getting
  (Map ((Int, Int), Int) PhyloLevel)
  Phylo
  (Map ((Int, Int), Int) PhyloLevel)
-> Phylo -> Map ((Int, Int), Int) PhyloLevel
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view ( (Map (Int, Int) PhyloPeriod
 -> Const
      (Map ((Int, Int), Int) PhyloLevel) (Map (Int, Int) PhyloPeriod))
-> Phylo -> Const (Map ((Int, Int), Int) PhyloLevel) Phylo
Lens' Phylo (Map (Int, Int) PhyloPeriod)
phylo_periods
                       ((Map (Int, Int) PhyloPeriod
  -> Const
       (Map ((Int, Int), Int) PhyloLevel) (Map (Int, Int) PhyloPeriod))
 -> Phylo -> Const (Map ((Int, Int), Int) PhyloLevel) Phylo)
-> ((Map ((Int, Int), Int) PhyloLevel
     -> Const
          (Map ((Int, Int), Int) PhyloLevel)
          (Map ((Int, Int), Int) PhyloLevel))
    -> Map (Int, Int) PhyloPeriod
    -> Const
         (Map ((Int, Int), Int) PhyloLevel) (Map (Int, Int) PhyloPeriod))
-> Getting
     (Map ((Int, Int), Int) PhyloLevel)
     Phylo
     (Map ((Int, Int), Int) PhyloLevel)
forall b c a. (b -> c) -> (a -> b) -> a -> c
.  (PhyloPeriod
 -> Const (Map ((Int, Int), Int) PhyloLevel) PhyloPeriod)
-> Map (Int, Int) PhyloPeriod
-> Const
     (Map ((Int, Int), Int) PhyloLevel) (Map (Int, Int) PhyloPeriod)
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse
                       ((PhyloPeriod
  -> Const (Map ((Int, Int), Int) PhyloLevel) PhyloPeriod)
 -> Map (Int, Int) PhyloPeriod
 -> Const
      (Map ((Int, Int), Int) PhyloLevel) (Map (Int, Int) PhyloPeriod))
-> ((Map ((Int, Int), Int) PhyloLevel
     -> Const
          (Map ((Int, Int), Int) PhyloLevel)
          (Map ((Int, Int), Int) PhyloLevel))
    -> PhyloPeriod
    -> Const (Map ((Int, Int), Int) PhyloLevel) PhyloPeriod)
-> (Map ((Int, Int), Int) PhyloLevel
    -> Const
         (Map ((Int, Int), Int) PhyloLevel)
         (Map ((Int, Int), Int) PhyloLevel))
-> Map (Int, Int) PhyloPeriod
-> Const
     (Map ((Int, Int), Int) PhyloLevel) (Map (Int, Int) PhyloPeriod)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Map ((Int, Int), Int) PhyloLevel
 -> Const
      (Map ((Int, Int), Int) PhyloLevel)
      (Map ((Int, Int), Int) PhyloLevel))
-> PhyloPeriod
-> Const (Map ((Int, Int), Int) PhyloLevel) PhyloPeriod
Lens' PhyloPeriod (Map ((Int, Int), Int) PhyloLevel)
phylo_periodLevels ) Phylo
phylo

getSeaElevation :: Phylo -> SeaElevation
getSeaElevation :: Phylo -> SeaElevation
getSeaElevation Phylo
phylo = Config -> SeaElevation
seaElevation (Phylo -> Config
getConfig Phylo
phylo)


getConfig :: Phylo -> Config
getConfig :: Phylo -> Config
getConfig Phylo
phylo = (Phylo
phylo Phylo -> Getting PhyloParam Phylo PhyloParam -> PhyloParam
forall s a. s -> Getting a s a -> a
^. Getting PhyloParam Phylo PhyloParam
Lens' Phylo PhyloParam
phylo_param) PhyloParam -> Getting Config PhyloParam Config -> Config
forall s a. s -> Getting a s a -> a
^. Getting Config PhyloParam Config
Lens' PhyloParam Config
phyloParam_config


setConfig :: Config -> Phylo -> Phylo
setConfig :: Config -> Phylo -> Phylo
setConfig Config
config Phylo
phylo = Phylo
phylo 
                       Phylo -> (Phylo -> Phylo) -> Phylo
forall a b. a -> (a -> b) -> b
& (PhyloParam -> Identity PhyloParam) -> Phylo -> Identity Phylo
Lens' Phylo PhyloParam
phylo_param ((PhyloParam -> Identity PhyloParam) -> Phylo -> Identity Phylo)
-> PhyloParam -> Phylo -> Phylo
forall s t a b. ASetter s t a b -> b -> s -> t
.~ (Text -> Software -> Config -> PhyloParam
PhyloParam 
                                            ((Phylo
phylo Phylo -> Getting PhyloParam Phylo PhyloParam -> PhyloParam
forall s a. s -> Getting a s a -> a
^. Getting PhyloParam Phylo PhyloParam
Lens' Phylo PhyloParam
phylo_param) PhyloParam -> Getting Text PhyloParam Text -> Text
forall s a. s -> Getting a s a -> a
^. Getting Text PhyloParam Text
Lens' PhyloParam Text
phyloParam_version) 
                                            ((Phylo
phylo Phylo -> Getting PhyloParam Phylo PhyloParam -> PhyloParam
forall s a. s -> Getting a s a -> a
^. Getting PhyloParam Phylo PhyloParam
Lens' Phylo PhyloParam
phylo_param) PhyloParam -> Getting Software PhyloParam Software -> Software
forall s a. s -> Getting a s a -> a
^. Getting Software PhyloParam Software
Lens' PhyloParam Software
phyloParam_software) 
                                            Config
config)

-- & phylo_param & phyloParam_config & phyloParam_config .~ config


getRoots :: Phylo -> Vector Ngrams
getRoots :: Phylo -> Vector Text
getRoots Phylo
phylo = (Phylo
phylo Phylo
-> Getting PhyloFoundations Phylo PhyloFoundations
-> PhyloFoundations
forall s a. s -> Getting a s a -> a
^. Getting PhyloFoundations Phylo PhyloFoundations
Lens' Phylo PhyloFoundations
phylo_foundations) PhyloFoundations
-> Getting (Vector Text) PhyloFoundations (Vector Text)
-> Vector Text
forall s a. s -> Getting a s a -> a
^. Getting (Vector Text) PhyloFoundations (Vector Text)
Lens' PhyloFoundations (Vector Text)
foundations_roots

getSources :: Phylo -> Vector Text
getSources :: Phylo -> Vector Text
getSources Phylo
phylo = PhyloSources -> Vector Text
_sources (Phylo
phylo Phylo -> Getting PhyloSources Phylo PhyloSources -> PhyloSources
forall s a. s -> Getting a s a -> a
^. Getting PhyloSources Phylo PhyloSources
Lens' Phylo PhyloSources
phylo_sources)

phyloToLastBranches :: Phylo -> [[PhyloGroup]]
phyloToLastBranches :: Phylo -> [[PhyloGroup]]
phyloToLastBranches Phylo
phylo = Map PhyloBranchId [PhyloGroup] -> [[PhyloGroup]]
forall k a. Map k a -> [a]
elems 
    (Map PhyloBranchId [PhyloGroup] -> [[PhyloGroup]])
-> Map PhyloBranchId [PhyloGroup] -> [[PhyloGroup]]
forall a b. (a -> b) -> a -> b
$ ([PhyloGroup] -> [PhyloGroup] -> [PhyloGroup])
-> [(PhyloBranchId, [PhyloGroup])]
-> Map PhyloBranchId [PhyloGroup]
forall k a. Ord k => (a -> a -> a) -> [(k, a)] -> Map k a
fromListWith [PhyloGroup] -> [PhyloGroup] -> [PhyloGroup]
forall a. [a] -> [a] -> [a]
(++)
    ([(PhyloBranchId, [PhyloGroup])] -> Map PhyloBranchId [PhyloGroup])
-> [(PhyloBranchId, [PhyloGroup])]
-> Map PhyloBranchId [PhyloGroup]
forall a b. (a -> b) -> a -> b
$ (PhyloGroup -> (PhyloBranchId, [PhyloGroup]))
-> [PhyloGroup] -> [(PhyloBranchId, [PhyloGroup])]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
map (\PhyloGroup
g -> (PhyloGroup
g PhyloGroup
-> Getting PhyloBranchId PhyloGroup PhyloBranchId -> PhyloBranchId
forall s a. s -> Getting a s a -> a
^. Getting PhyloBranchId PhyloGroup PhyloBranchId
Lens' PhyloGroup PhyloBranchId
phylo_groupBranchId, [PhyloGroup
g]))
    ([PhyloGroup] -> [(PhyloBranchId, [PhyloGroup])])
-> [PhyloGroup] -> [(PhyloBranchId, [PhyloGroup])]
forall a b. (a -> b) -> a -> b
$ Int -> Phylo -> [PhyloGroup]
getGroupsFromLevel (Text -> [Int] -> Int
forall a. Text -> [a] -> a
last' Text
"byBranches" ([Int] -> Int) -> [Int] -> Int
forall a b. (a -> b) -> a -> b
$ Phylo -> [Int]
getLevels Phylo
phylo) Phylo
phylo

getGroupsFromLevel :: Level -> Phylo -> [PhyloGroup]
getGroupsFromLevel :: Int -> Phylo -> [PhyloGroup]
getGroupsFromLevel Int
lvl Phylo
phylo = 
    Map PhyloGroupId PhyloGroup -> [PhyloGroup]
forall k a. Map k a -> [a]
elems (Map PhyloGroupId PhyloGroup -> [PhyloGroup])
-> Map PhyloGroupId PhyloGroup -> [PhyloGroup]
forall a b. (a -> b) -> a -> b
$ Getting
  (Map PhyloGroupId PhyloGroup) Phylo (Map PhyloGroupId PhyloGroup)
-> Phylo -> Map PhyloGroupId PhyloGroup
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view ( (Map (Int, Int) PhyloPeriod
 -> Const
      (Map PhyloGroupId PhyloGroup) (Map (Int, Int) PhyloPeriod))
-> Phylo -> Const (Map PhyloGroupId PhyloGroup) Phylo
Lens' Phylo (Map (Int, Int) PhyloPeriod)
phylo_periods
                 ((Map (Int, Int) PhyloPeriod
  -> Const
       (Map PhyloGroupId PhyloGroup) (Map (Int, Int) PhyloPeriod))
 -> Phylo -> Const (Map PhyloGroupId PhyloGroup) Phylo)
-> ((Map PhyloGroupId PhyloGroup
     -> Const
          (Map PhyloGroupId PhyloGroup) (Map PhyloGroupId PhyloGroup))
    -> Map (Int, Int) PhyloPeriod
    -> Const
         (Map PhyloGroupId PhyloGroup) (Map (Int, Int) PhyloPeriod))
-> Getting
     (Map PhyloGroupId PhyloGroup) Phylo (Map PhyloGroupId PhyloGroup)
forall b c a. (b -> c) -> (a -> b) -> a -> c
.  (PhyloPeriod -> Const (Map PhyloGroupId PhyloGroup) PhyloPeriod)
-> Map (Int, Int) PhyloPeriod
-> Const (Map PhyloGroupId PhyloGroup) (Map (Int, Int) PhyloPeriod)
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse
                 ((PhyloPeriod -> Const (Map PhyloGroupId PhyloGroup) PhyloPeriod)
 -> Map (Int, Int) PhyloPeriod
 -> Const
      (Map PhyloGroupId PhyloGroup) (Map (Int, Int) PhyloPeriod))
-> ((Map PhyloGroupId PhyloGroup
     -> Const
          (Map PhyloGroupId PhyloGroup) (Map PhyloGroupId PhyloGroup))
    -> PhyloPeriod -> Const (Map PhyloGroupId PhyloGroup) PhyloPeriod)
-> (Map PhyloGroupId PhyloGroup
    -> Const
         (Map PhyloGroupId PhyloGroup) (Map PhyloGroupId PhyloGroup))
-> Map (Int, Int) PhyloPeriod
-> Const (Map PhyloGroupId PhyloGroup) (Map (Int, Int) PhyloPeriod)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Map ((Int, Int), Int) PhyloLevel
 -> Const
      (Map PhyloGroupId PhyloGroup) (Map ((Int, Int), Int) PhyloLevel))
-> PhyloPeriod -> Const (Map PhyloGroupId PhyloGroup) PhyloPeriod
Lens' PhyloPeriod (Map ((Int, Int), Int) PhyloLevel)
phylo_periodLevels
                 ((Map ((Int, Int), Int) PhyloLevel
  -> Const
       (Map PhyloGroupId PhyloGroup) (Map ((Int, Int), Int) PhyloLevel))
 -> PhyloPeriod -> Const (Map PhyloGroupId PhyloGroup) PhyloPeriod)
-> ((Map PhyloGroupId PhyloGroup
     -> Const
          (Map PhyloGroupId PhyloGroup) (Map PhyloGroupId PhyloGroup))
    -> Map ((Int, Int), Int) PhyloLevel
    -> Const
         (Map PhyloGroupId PhyloGroup) (Map ((Int, Int), Int) PhyloLevel))
-> (Map PhyloGroupId PhyloGroup
    -> Const
         (Map PhyloGroupId PhyloGroup) (Map PhyloGroupId PhyloGroup))
-> PhyloPeriod
-> Const (Map PhyloGroupId PhyloGroup) PhyloPeriod
forall b c a. (b -> c) -> (a -> b) -> a -> c
.  (PhyloLevel -> Const (Map PhyloGroupId PhyloGroup) PhyloLevel)
-> Map ((Int, Int), Int) PhyloLevel
-> Const
     (Map PhyloGroupId PhyloGroup) (Map ((Int, Int), Int) PhyloLevel)
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse
                 ((PhyloLevel -> Const (Map PhyloGroupId PhyloGroup) PhyloLevel)
 -> Map ((Int, Int), Int) PhyloLevel
 -> Const
      (Map PhyloGroupId PhyloGroup) (Map ((Int, Int), Int) PhyloLevel))
-> ((Map PhyloGroupId PhyloGroup
     -> Const
          (Map PhyloGroupId PhyloGroup) (Map PhyloGroupId PhyloGroup))
    -> PhyloLevel -> Const (Map PhyloGroupId PhyloGroup) PhyloLevel)
-> (Map PhyloGroupId PhyloGroup
    -> Const
         (Map PhyloGroupId PhyloGroup) (Map PhyloGroupId PhyloGroup))
-> Map ((Int, Int), Int) PhyloLevel
-> Const
     (Map PhyloGroupId PhyloGroup) (Map ((Int, Int), Int) PhyloLevel)
forall b c a. (b -> c) -> (a -> b) -> a -> c
.  (PhyloLevel -> Bool)
-> Optic'
     (->) (Const (Map PhyloGroupId PhyloGroup)) PhyloLevel PhyloLevel
forall (p :: * -> * -> *) (f :: * -> *) a.
(Choice p, Applicative f) =>
(a -> Bool) -> Optic' p f a a
filtered (\PhyloLevel
phyloLvl -> PhyloLevel
phyloLvl PhyloLevel -> Getting Int PhyloLevel Int -> Int
forall s a. s -> Getting a s a -> a
^. Getting Int PhyloLevel Int
Lens' PhyloLevel Int
phylo_levelLevel Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
lvl)
                 Optic'
  (->) (Const (Map PhyloGroupId PhyloGroup)) PhyloLevel PhyloLevel
-> ((Map PhyloGroupId PhyloGroup
     -> Const
          (Map PhyloGroupId PhyloGroup) (Map PhyloGroupId PhyloGroup))
    -> PhyloLevel -> Const (Map PhyloGroupId PhyloGroup) PhyloLevel)
-> (Map PhyloGroupId PhyloGroup
    -> Const
         (Map PhyloGroupId PhyloGroup) (Map PhyloGroupId PhyloGroup))
-> PhyloLevel
-> Const (Map PhyloGroupId PhyloGroup) PhyloLevel
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Map PhyloGroupId PhyloGroup
 -> Const
      (Map PhyloGroupId PhyloGroup) (Map PhyloGroupId PhyloGroup))
-> PhyloLevel -> Const (Map PhyloGroupId PhyloGroup) PhyloLevel
Lens' PhyloLevel (Map PhyloGroupId PhyloGroup)
phylo_levelGroups ) Phylo
phylo


getGroupsFromLevelPeriods :: Level -> [PhyloPeriodId] -> Phylo -> [PhyloGroup]
getGroupsFromLevelPeriods :: Int -> [(Int, Int)] -> Phylo -> [PhyloGroup]
getGroupsFromLevelPeriods Int
lvl [(Int, Int)]
periods Phylo
phylo = 
    Map PhyloGroupId PhyloGroup -> [PhyloGroup]
forall k a. Map k a -> [a]
elems (Map PhyloGroupId PhyloGroup -> [PhyloGroup])
-> Map PhyloGroupId PhyloGroup -> [PhyloGroup]
forall a b. (a -> b) -> a -> b
$ Getting
  (Map PhyloGroupId PhyloGroup) Phylo (Map PhyloGroupId PhyloGroup)
-> Phylo -> Map PhyloGroupId PhyloGroup
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view ( (Map (Int, Int) PhyloPeriod
 -> Const
      (Map PhyloGroupId PhyloGroup) (Map (Int, Int) PhyloPeriod))
-> Phylo -> Const (Map PhyloGroupId PhyloGroup) Phylo
Lens' Phylo (Map (Int, Int) PhyloPeriod)
phylo_periods
                 ((Map (Int, Int) PhyloPeriod
  -> Const
       (Map PhyloGroupId PhyloGroup) (Map (Int, Int) PhyloPeriod))
 -> Phylo -> Const (Map PhyloGroupId PhyloGroup) Phylo)
-> ((Map PhyloGroupId PhyloGroup
     -> Const
          (Map PhyloGroupId PhyloGroup) (Map PhyloGroupId PhyloGroup))
    -> Map (Int, Int) PhyloPeriod
    -> Const
         (Map PhyloGroupId PhyloGroup) (Map (Int, Int) PhyloPeriod))
-> Getting
     (Map PhyloGroupId PhyloGroup) Phylo (Map PhyloGroupId PhyloGroup)
forall b c a. (b -> c) -> (a -> b) -> a -> c
.  (PhyloPeriod -> Const (Map PhyloGroupId PhyloGroup) PhyloPeriod)
-> Map (Int, Int) PhyloPeriod
-> Const (Map PhyloGroupId PhyloGroup) (Map (Int, Int) PhyloPeriod)
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse
                 ((PhyloPeriod -> Const (Map PhyloGroupId PhyloGroup) PhyloPeriod)
 -> Map (Int, Int) PhyloPeriod
 -> Const
      (Map PhyloGroupId PhyloGroup) (Map (Int, Int) PhyloPeriod))
-> ((Map PhyloGroupId PhyloGroup
     -> Const
          (Map PhyloGroupId PhyloGroup) (Map PhyloGroupId PhyloGroup))
    -> PhyloPeriod -> Const (Map PhyloGroupId PhyloGroup) PhyloPeriod)
-> (Map PhyloGroupId PhyloGroup
    -> Const
         (Map PhyloGroupId PhyloGroup) (Map PhyloGroupId PhyloGroup))
-> Map (Int, Int) PhyloPeriod
-> Const (Map PhyloGroupId PhyloGroup) (Map (Int, Int) PhyloPeriod)
forall b c a. (b -> c) -> (a -> b) -> a -> c
.  (PhyloPeriod -> Bool)
-> Optic'
     (->) (Const (Map PhyloGroupId PhyloGroup)) PhyloPeriod PhyloPeriod
forall (p :: * -> * -> *) (f :: * -> *) a.
(Choice p, Applicative f) =>
(a -> Bool) -> Optic' p f a a
filtered (\PhyloPeriod
phyloPrd -> (Int, Int) -> [(Int, Int)] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
elem (PhyloPeriod
phyloPrd PhyloPeriod
-> Getting (Int, Int) PhyloPeriod (Int, Int) -> (Int, Int)
forall s a. s -> Getting a s a -> a
^. Getting (Int, Int) PhyloPeriod (Int, Int)
Lens' PhyloPeriod (Int, Int)
phylo_periodPeriod) [(Int, Int)]
periods)
                 Optic'
  (->) (Const (Map PhyloGroupId PhyloGroup)) PhyloPeriod PhyloPeriod
-> ((Map PhyloGroupId PhyloGroup
     -> Const
          (Map PhyloGroupId PhyloGroup) (Map PhyloGroupId PhyloGroup))
    -> PhyloPeriod -> Const (Map PhyloGroupId PhyloGroup) PhyloPeriod)
-> (Map PhyloGroupId PhyloGroup
    -> Const
         (Map PhyloGroupId PhyloGroup) (Map PhyloGroupId PhyloGroup))
-> PhyloPeriod
-> Const (Map PhyloGroupId PhyloGroup) PhyloPeriod
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Map ((Int, Int), Int) PhyloLevel
 -> Const
      (Map PhyloGroupId PhyloGroup) (Map ((Int, Int), Int) PhyloLevel))
-> PhyloPeriod -> Const (Map PhyloGroupId PhyloGroup) PhyloPeriod
Lens' PhyloPeriod (Map ((Int, Int), Int) PhyloLevel)
phylo_periodLevels
                 ((Map ((Int, Int), Int) PhyloLevel
  -> Const
       (Map PhyloGroupId PhyloGroup) (Map ((Int, Int), Int) PhyloLevel))
 -> PhyloPeriod -> Const (Map PhyloGroupId PhyloGroup) PhyloPeriod)
-> ((Map PhyloGroupId PhyloGroup
     -> Const
          (Map PhyloGroupId PhyloGroup) (Map PhyloGroupId PhyloGroup))
    -> Map ((Int, Int), Int) PhyloLevel
    -> Const
         (Map PhyloGroupId PhyloGroup) (Map ((Int, Int), Int) PhyloLevel))
-> (Map PhyloGroupId PhyloGroup
    -> Const
         (Map PhyloGroupId PhyloGroup) (Map PhyloGroupId PhyloGroup))
-> PhyloPeriod
-> Const (Map PhyloGroupId PhyloGroup) PhyloPeriod
forall b c a. (b -> c) -> (a -> b) -> a -> c
.  (PhyloLevel -> Const (Map PhyloGroupId PhyloGroup) PhyloLevel)
-> Map ((Int, Int), Int) PhyloLevel
-> Const
     (Map PhyloGroupId PhyloGroup) (Map ((Int, Int), Int) PhyloLevel)
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse
                 ((PhyloLevel -> Const (Map PhyloGroupId PhyloGroup) PhyloLevel)
 -> Map ((Int, Int), Int) PhyloLevel
 -> Const
      (Map PhyloGroupId PhyloGroup) (Map ((Int, Int), Int) PhyloLevel))
-> ((Map PhyloGroupId PhyloGroup
     -> Const
          (Map PhyloGroupId PhyloGroup) (Map PhyloGroupId PhyloGroup))
    -> PhyloLevel -> Const (Map PhyloGroupId PhyloGroup) PhyloLevel)
-> (Map PhyloGroupId PhyloGroup
    -> Const
         (Map PhyloGroupId PhyloGroup) (Map PhyloGroupId PhyloGroup))
-> Map ((Int, Int), Int) PhyloLevel
-> Const
     (Map PhyloGroupId PhyloGroup) (Map ((Int, Int), Int) PhyloLevel)
forall b c a. (b -> c) -> (a -> b) -> a -> c
.  (PhyloLevel -> Bool)
-> Optic'
     (->) (Const (Map PhyloGroupId PhyloGroup)) PhyloLevel PhyloLevel
forall (p :: * -> * -> *) (f :: * -> *) a.
(Choice p, Applicative f) =>
(a -> Bool) -> Optic' p f a a
filtered (\PhyloLevel
phyloLvl -> PhyloLevel
phyloLvl PhyloLevel -> Getting Int PhyloLevel Int -> Int
forall s a. s -> Getting a s a -> a
^. Getting Int PhyloLevel Int
Lens' PhyloLevel Int
phylo_levelLevel Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
lvl)
                 Optic'
  (->) (Const (Map PhyloGroupId PhyloGroup)) PhyloLevel PhyloLevel
-> ((Map PhyloGroupId PhyloGroup
     -> Const
          (Map PhyloGroupId PhyloGroup) (Map PhyloGroupId PhyloGroup))
    -> PhyloLevel -> Const (Map PhyloGroupId PhyloGroup) PhyloLevel)
-> (Map PhyloGroupId PhyloGroup
    -> Const
         (Map PhyloGroupId PhyloGroup) (Map PhyloGroupId PhyloGroup))
-> PhyloLevel
-> Const (Map PhyloGroupId PhyloGroup) PhyloLevel
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Map PhyloGroupId PhyloGroup
 -> Const
      (Map PhyloGroupId PhyloGroup) (Map PhyloGroupId PhyloGroup))
-> PhyloLevel -> Const (Map PhyloGroupId PhyloGroup) PhyloLevel
Lens' PhyloLevel (Map PhyloGroupId PhyloGroup)
phylo_levelGroups ) Phylo
phylo    


getGroupsFromPeriods :: Level -> Map PhyloPeriodId PhyloPeriod -> [PhyloGroup]
getGroupsFromPeriods :: Int -> Map (Int, Int) PhyloPeriod -> [PhyloGroup]
getGroupsFromPeriods Int
lvl Map (Int, Int) PhyloPeriod
periods = 
    Map PhyloGroupId PhyloGroup -> [PhyloGroup]
forall k a. Map k a -> [a]
elems (Map PhyloGroupId PhyloGroup -> [PhyloGroup])
-> Map PhyloGroupId PhyloGroup -> [PhyloGroup]
forall a b. (a -> b) -> a -> b
$ ((Map PhyloGroupId PhyloGroup
  -> Const
       (Map PhyloGroupId PhyloGroup) (Map PhyloGroupId PhyloGroup))
 -> Map (Int, Int) PhyloPeriod
 -> Const
      (Map PhyloGroupId PhyloGroup) (Map (Int, Int) PhyloPeriod))
-> Map (Int, Int) PhyloPeriod -> Map PhyloGroupId PhyloGroup
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view (  (PhyloPeriod -> Const (Map PhyloGroupId PhyloGroup) PhyloPeriod)
-> Map (Int, Int) PhyloPeriod
-> Const (Map PhyloGroupId PhyloGroup) (Map (Int, Int) PhyloPeriod)
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse
                 ((PhyloPeriod -> Const (Map PhyloGroupId PhyloGroup) PhyloPeriod)
 -> Map (Int, Int) PhyloPeriod
 -> Const
      (Map PhyloGroupId PhyloGroup) (Map (Int, Int) PhyloPeriod))
-> ((Map PhyloGroupId PhyloGroup
     -> Const
          (Map PhyloGroupId PhyloGroup) (Map PhyloGroupId PhyloGroup))
    -> PhyloPeriod -> Const (Map PhyloGroupId PhyloGroup) PhyloPeriod)
-> (Map PhyloGroupId PhyloGroup
    -> Const
         (Map PhyloGroupId PhyloGroup) (Map PhyloGroupId PhyloGroup))
-> Map (Int, Int) PhyloPeriod
-> Const (Map PhyloGroupId PhyloGroup) (Map (Int, Int) PhyloPeriod)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Map ((Int, Int), Int) PhyloLevel
 -> Const
      (Map PhyloGroupId PhyloGroup) (Map ((Int, Int), Int) PhyloLevel))
-> PhyloPeriod -> Const (Map PhyloGroupId PhyloGroup) PhyloPeriod
Lens' PhyloPeriod (Map ((Int, Int), Int) PhyloLevel)
phylo_periodLevels
                 ((Map ((Int, Int), Int) PhyloLevel
  -> Const
       (Map PhyloGroupId PhyloGroup) (Map ((Int, Int), Int) PhyloLevel))
 -> PhyloPeriod -> Const (Map PhyloGroupId PhyloGroup) PhyloPeriod)
-> ((Map PhyloGroupId PhyloGroup
     -> Const
          (Map PhyloGroupId PhyloGroup) (Map PhyloGroupId PhyloGroup))
    -> Map ((Int, Int), Int) PhyloLevel
    -> Const
         (Map PhyloGroupId PhyloGroup) (Map ((Int, Int), Int) PhyloLevel))
-> (Map PhyloGroupId PhyloGroup
    -> Const
         (Map PhyloGroupId PhyloGroup) (Map PhyloGroupId PhyloGroup))
-> PhyloPeriod
-> Const (Map PhyloGroupId PhyloGroup) PhyloPeriod
forall b c a. (b -> c) -> (a -> b) -> a -> c
.  (PhyloLevel -> Const (Map PhyloGroupId PhyloGroup) PhyloLevel)
-> Map ((Int, Int), Int) PhyloLevel
-> Const
     (Map PhyloGroupId PhyloGroup) (Map ((Int, Int), Int) PhyloLevel)
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse
                 ((PhyloLevel -> Const (Map PhyloGroupId PhyloGroup) PhyloLevel)
 -> Map ((Int, Int), Int) PhyloLevel
 -> Const
      (Map PhyloGroupId PhyloGroup) (Map ((Int, Int), Int) PhyloLevel))
-> ((Map PhyloGroupId PhyloGroup
     -> Const
          (Map PhyloGroupId PhyloGroup) (Map PhyloGroupId PhyloGroup))
    -> PhyloLevel -> Const (Map PhyloGroupId PhyloGroup) PhyloLevel)
-> (Map PhyloGroupId PhyloGroup
    -> Const
         (Map PhyloGroupId PhyloGroup) (Map PhyloGroupId PhyloGroup))
-> Map ((Int, Int), Int) PhyloLevel
-> Const
     (Map PhyloGroupId PhyloGroup) (Map ((Int, Int), Int) PhyloLevel)
forall b c a. (b -> c) -> (a -> b) -> a -> c
.  (PhyloLevel -> Bool)
-> Optic'
     (->) (Const (Map PhyloGroupId PhyloGroup)) PhyloLevel PhyloLevel
forall (p :: * -> * -> *) (f :: * -> *) a.
(Choice p, Applicative f) =>
(a -> Bool) -> Optic' p f a a
filtered (\PhyloLevel
phyloLvl -> PhyloLevel
phyloLvl PhyloLevel -> Getting Int PhyloLevel Int -> Int
forall s a. s -> Getting a s a -> a
^. Getting Int PhyloLevel Int
Lens' PhyloLevel Int
phylo_levelLevel Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
lvl)
                 Optic'
  (->) (Const (Map PhyloGroupId PhyloGroup)) PhyloLevel PhyloLevel
-> ((Map PhyloGroupId PhyloGroup
     -> Const
          (Map PhyloGroupId PhyloGroup) (Map PhyloGroupId PhyloGroup))
    -> PhyloLevel -> Const (Map PhyloGroupId PhyloGroup) PhyloLevel)
-> (Map PhyloGroupId PhyloGroup
    -> Const
         (Map PhyloGroupId PhyloGroup) (Map PhyloGroupId PhyloGroup))
-> PhyloLevel
-> Const (Map PhyloGroupId PhyloGroup) PhyloLevel
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Map PhyloGroupId PhyloGroup
 -> Const
      (Map PhyloGroupId PhyloGroup) (Map PhyloGroupId PhyloGroup))
-> PhyloLevel -> Const (Map PhyloGroupId PhyloGroup) PhyloLevel
Lens' PhyloLevel (Map PhyloGroupId PhyloGroup)
phylo_levelGroups ) Map (Int, Int) PhyloPeriod
periods


updatePhyloGroups :: Level -> Map PhyloGroupId PhyloGroup -> Phylo -> Phylo
updatePhyloGroups :: Int -> Map PhyloGroupId PhyloGroup -> Phylo -> Phylo
updatePhyloGroups Int
lvl Map PhyloGroupId PhyloGroup
m Phylo
phylo = 
    ASetter Phylo Phylo PhyloGroup PhyloGroup
-> (PhyloGroup -> PhyloGroup) -> Phylo -> Phylo
forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
over ( (Map (Int, Int) PhyloPeriod
 -> Identity (Map (Int, Int) PhyloPeriod))
-> Phylo -> Identity Phylo
Lens' Phylo (Map (Int, Int) PhyloPeriod)
phylo_periods
         ((Map (Int, Int) PhyloPeriod
  -> Identity (Map (Int, Int) PhyloPeriod))
 -> Phylo -> Identity Phylo)
-> ((PhyloGroup -> Identity PhyloGroup)
    -> Map (Int, Int) PhyloPeriod
    -> Identity (Map (Int, Int) PhyloPeriod))
-> ASetter Phylo Phylo PhyloGroup PhyloGroup
forall b c a. (b -> c) -> (a -> b) -> a -> c
.  (PhyloPeriod -> Identity PhyloPeriod)
-> Map (Int, Int) PhyloPeriod
-> Identity (Map (Int, Int) PhyloPeriod)
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse
         ((PhyloPeriod -> Identity PhyloPeriod)
 -> Map (Int, Int) PhyloPeriod
 -> Identity (Map (Int, Int) PhyloPeriod))
-> ((PhyloGroup -> Identity PhyloGroup)
    -> PhyloPeriod -> Identity PhyloPeriod)
-> (PhyloGroup -> Identity PhyloGroup)
-> Map (Int, Int) PhyloPeriod
-> Identity (Map (Int, Int) PhyloPeriod)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Map ((Int, Int), Int) PhyloLevel
 -> Identity (Map ((Int, Int), Int) PhyloLevel))
-> PhyloPeriod -> Identity PhyloPeriod
Lens' PhyloPeriod (Map ((Int, Int), Int) PhyloLevel)
phylo_periodLevels
         ((Map ((Int, Int), Int) PhyloLevel
  -> Identity (Map ((Int, Int), Int) PhyloLevel))
 -> PhyloPeriod -> Identity PhyloPeriod)
-> ((PhyloGroup -> Identity PhyloGroup)
    -> Map ((Int, Int), Int) PhyloLevel
    -> Identity (Map ((Int, Int), Int) PhyloLevel))
-> (PhyloGroup -> Identity PhyloGroup)
-> PhyloPeriod
-> Identity PhyloPeriod
forall b c a. (b -> c) -> (a -> b) -> a -> c
.  (PhyloLevel -> Identity PhyloLevel)
-> Map ((Int, Int), Int) PhyloLevel
-> Identity (Map ((Int, Int), Int) PhyloLevel)
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse
         ((PhyloLevel -> Identity PhyloLevel)
 -> Map ((Int, Int), Int) PhyloLevel
 -> Identity (Map ((Int, Int), Int) PhyloLevel))
-> ((PhyloGroup -> Identity PhyloGroup)
    -> PhyloLevel -> Identity PhyloLevel)
-> (PhyloGroup -> Identity PhyloGroup)
-> Map ((Int, Int), Int) PhyloLevel
-> Identity (Map ((Int, Int), Int) PhyloLevel)
forall b c a. (b -> c) -> (a -> b) -> a -> c
.  (PhyloLevel -> Bool) -> Optic' (->) Identity PhyloLevel PhyloLevel
forall (p :: * -> * -> *) (f :: * -> *) a.
(Choice p, Applicative f) =>
(a -> Bool) -> Optic' p f a a
filtered (\PhyloLevel
phyloLvl -> PhyloLevel
phyloLvl PhyloLevel -> Getting Int PhyloLevel Int -> Int
forall s a. s -> Getting a s a -> a
^. Getting Int PhyloLevel Int
Lens' PhyloLevel Int
phylo_levelLevel Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
lvl)
         Optic' (->) Identity PhyloLevel PhyloLevel
-> ((PhyloGroup -> Identity PhyloGroup)
    -> PhyloLevel -> Identity PhyloLevel)
-> (PhyloGroup -> Identity PhyloGroup)
-> PhyloLevel
-> Identity PhyloLevel
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Map PhyloGroupId PhyloGroup
 -> Identity (Map PhyloGroupId PhyloGroup))
-> PhyloLevel -> Identity PhyloLevel
Lens' PhyloLevel (Map PhyloGroupId PhyloGroup)
phylo_levelGroups
         ((Map PhyloGroupId PhyloGroup
  -> Identity (Map PhyloGroupId PhyloGroup))
 -> PhyloLevel -> Identity PhyloLevel)
-> ((PhyloGroup -> Identity PhyloGroup)
    -> Map PhyloGroupId PhyloGroup
    -> Identity (Map PhyloGroupId PhyloGroup))
-> (PhyloGroup -> Identity PhyloGroup)
-> PhyloLevel
-> Identity PhyloLevel
forall b c a. (b -> c) -> (a -> b) -> a -> c
.  (PhyloGroup -> Identity PhyloGroup)
-> Map PhyloGroupId PhyloGroup
-> Identity (Map PhyloGroupId PhyloGroup)
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse 
         ) (\PhyloGroup
g -> 
                let id :: PhyloGroupId
id = PhyloGroup -> PhyloGroupId
getGroupId PhyloGroup
g
                in 
                    if PhyloGroupId -> Map PhyloGroupId PhyloGroup -> Bool
forall k a. Ord k => k -> Map k a -> Bool
member PhyloGroupId
id Map PhyloGroupId PhyloGroup
m 
                    then Map PhyloGroupId PhyloGroup
m Map PhyloGroupId PhyloGroup -> PhyloGroupId -> PhyloGroup
forall k a. Ord k => Map k a -> k -> a
! PhyloGroupId
id
                    else PhyloGroup
g ) Phylo
phylo

updatePeriods :: Map (Date,Date) (Text,Text) -> Phylo -> Phylo
updatePeriods :: Map (Int, Int) (Text, Text) -> Phylo -> Phylo
updatePeriods Map (Int, Int) (Text, Text)
periods' Phylo
phylo = 
    ASetter Phylo Phylo PhyloPeriod PhyloPeriod
-> (PhyloPeriod -> PhyloPeriod) -> Phylo -> Phylo
forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
over ((Map (Int, Int) PhyloPeriod
 -> Identity (Map (Int, Int) PhyloPeriod))
-> Phylo -> Identity Phylo
Lens' Phylo (Map (Int, Int) PhyloPeriod)
phylo_periods ((Map (Int, Int) PhyloPeriod
  -> Identity (Map (Int, Int) PhyloPeriod))
 -> Phylo -> Identity Phylo)
-> ((PhyloPeriod -> Identity PhyloPeriod)
    -> Map (Int, Int) PhyloPeriod
    -> Identity (Map (Int, Int) PhyloPeriod))
-> ASetter Phylo Phylo PhyloPeriod PhyloPeriod
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (PhyloPeriod -> Identity PhyloPeriod)
-> Map (Int, Int) PhyloPeriod
-> Identity (Map (Int, Int) PhyloPeriod)
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse) 
            (\PhyloPeriod
prd -> 
                let prd' :: (Text, Text)
prd' = Map (Int, Int) (Text, Text)
periods' Map (Int, Int) (Text, Text) -> (Int, Int) -> (Text, Text)
forall k a. Ord k => Map k a -> k -> a
! (PhyloPeriod
prd PhyloPeriod
-> Getting (Int, Int) PhyloPeriod (Int, Int) -> (Int, Int)
forall s a. s -> Getting a s a -> a
^. Getting (Int, Int) PhyloPeriod (Int, Int)
Lens' PhyloPeriod (Int, Int)
phylo_periodPeriod)
                    lvls :: Map ((Int, Int), Int) PhyloLevel
lvls = (PhyloLevel -> PhyloLevel)
-> Map ((Int, Int), Int) PhyloLevel
-> Map ((Int, Int), Int) PhyloLevel
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
map (\PhyloLevel
lvl -> PhyloLevel
lvl PhyloLevel -> (PhyloLevel -> PhyloLevel) -> PhyloLevel
forall a b. a -> (a -> b) -> b
& ((Text, Text) -> Identity (Text, Text))
-> PhyloLevel -> Identity PhyloLevel
Lens' PhyloLevel (Text, Text)
phylo_levelPeriod' (((Text, Text) -> Identity (Text, Text))
 -> PhyloLevel -> Identity PhyloLevel)
-> (Text, Text) -> PhyloLevel -> PhyloLevel
forall s t a b. ASetter s t a b -> b -> s -> t
.~ (Text, Text)
prd') (Map ((Int, Int), Int) PhyloLevel
 -> Map ((Int, Int), Int) PhyloLevel)
-> Map ((Int, Int), Int) PhyloLevel
-> Map ((Int, Int), Int) PhyloLevel
forall a b. (a -> b) -> a -> b
$ PhyloPeriod
prd PhyloPeriod
-> ((Map ((Int, Int), Int) PhyloLevel
     -> Const
          (Map ((Int, Int), Int) PhyloLevel)
          (Map ((Int, Int), Int) PhyloLevel))
    -> PhyloPeriod
    -> Const (Map ((Int, Int), Int) PhyloLevel) PhyloPeriod)
-> Map ((Int, Int), Int) PhyloLevel
forall s a. s -> Getting a s a -> a
^. (Map ((Int, Int), Int) PhyloLevel
 -> Const
      (Map ((Int, Int), Int) PhyloLevel)
      (Map ((Int, Int), Int) PhyloLevel))
-> PhyloPeriod
-> Const (Map ((Int, Int), Int) PhyloLevel) PhyloPeriod
Lens' PhyloPeriod (Map ((Int, Int), Int) PhyloLevel)
phylo_periodLevels
                 in PhyloPeriod
prd PhyloPeriod -> (PhyloPeriod -> PhyloPeriod) -> PhyloPeriod
forall a b. a -> (a -> b) -> b
& ((Text, Text) -> Identity (Text, Text))
-> PhyloPeriod -> Identity PhyloPeriod
Lens' PhyloPeriod (Text, Text)
phylo_periodPeriod' (((Text, Text) -> Identity (Text, Text))
 -> PhyloPeriod -> Identity PhyloPeriod)
-> (Text, Text) -> PhyloPeriod -> PhyloPeriod
forall s t a b. ASetter s t a b -> b -> s -> t
.~ (Text, Text)
prd'
                        PhyloPeriod -> (PhyloPeriod -> PhyloPeriod) -> PhyloPeriod
forall a b. a -> (a -> b) -> b
& (Map ((Int, Int), Int) PhyloLevel
 -> Identity (Map ((Int, Int), Int) PhyloLevel))
-> PhyloPeriod -> Identity PhyloPeriod
Lens' PhyloPeriod (Map ((Int, Int), Int) PhyloLevel)
phylo_periodLevels  ((Map ((Int, Int), Int) PhyloLevel
  -> Identity (Map ((Int, Int), Int) PhyloLevel))
 -> PhyloPeriod -> Identity PhyloPeriod)
-> Map ((Int, Int), Int) PhyloLevel -> PhyloPeriod -> PhyloPeriod
forall s t a b. ASetter s t a b -> b -> s -> t
.~ Map ((Int, Int), Int) PhyloLevel
lvls
                ) Phylo
phylo


traceToPhylo :: Level -> Phylo -> Phylo
traceToPhylo :: Int -> Phylo -> Phylo
traceToPhylo Int
lvl Phylo
phylo = 
    String -> Phylo -> Phylo
forall a. String -> a -> a
trace (String
"\n" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
"-- | End of phylo making at level " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Int -> String
forall a. Show a => a -> String
show (Int
lvl) String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
" with "
                String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Int -> String
forall a. Show a => a -> String
show ([PhyloGroup] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length ([PhyloGroup] -> Int) -> [PhyloGroup] -> Int
forall a b. (a -> b) -> a -> b
$ Int -> Phylo -> [PhyloGroup]
getGroupsFromLevel Int
lvl Phylo
phylo) String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
" groups and "
                String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Int -> String
forall a. Show a => a -> String
show ([PhyloBranchId] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length ([PhyloBranchId] -> Int) -> [PhyloBranchId] -> Int
forall a b. (a -> b) -> a -> b
$ [PhyloBranchId] -> [PhyloBranchId]
forall a. Eq a => [a] -> [a]
nub ([PhyloBranchId] -> [PhyloBranchId])
-> [PhyloBranchId] -> [PhyloBranchId]
forall a b. (a -> b) -> a -> b
$ (PhyloGroup -> PhyloBranchId) -> [PhyloGroup] -> [PhyloBranchId]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
map PhyloGroup -> PhyloBranchId
_phylo_groupBranchId ([PhyloGroup] -> [PhyloBranchId])
-> [PhyloGroup] -> [PhyloBranchId]
forall a b. (a -> b) -> a -> b
$ Int -> Phylo -> [PhyloGroup]
getGroupsFromLevel Int
lvl Phylo
phylo) String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
" branches" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
"\n") Phylo
phylo 

--------------------
-- | Clustering | --
--------------------

mergeBranchIds :: [[Int]] -> [Int]
mergeBranchIds :: [[Int]] -> [Int]
mergeBranchIds [[Int]]
ids = (Text -> [[Int]] -> [Int]
forall a. Text -> [a] -> a
head' Text
"mergeBranchIds" ([[Int]] -> [Int]) -> ([[Int]] -> [[Int]]) -> [[Int]] -> [Int]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [[Int]] -> [[Int]]
forall a. Ord a => [a] -> [a]
sort ([[Int]] -> [[Int]]) -> ([[Int]] -> [[Int]]) -> [[Int]] -> [[Int]]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [[Int]] -> [[Int]]
mostFreq') [[Int]]
ids
  where
    -- | 2) find the most Up Left ids in the hierarchy of similarity
    -- mostUpLeft :: [[Int]] -> [[Int]]
    -- mostUpLeft ids' = 
    --      let groupIds = (map (\gIds -> (length $ head' "gIds" gIds, head' "gIds" gIds)) . groupBy (\id id' -> length id == length id') . sortOn length) ids'
    --          inf = (fst . minimum) groupIds
    --      in map snd $ filter (\gIds -> fst gIds == inf) groupIds
    -- | 1) find the most frequent ids
    mostFreq' :: [[Int]] -> [[Int]]
    mostFreq' :: [[Int]] -> [[Int]]
mostFreq' [[Int]]
ids' = 
       let groupIds :: [PhyloBranchId]
groupIds = (([[Int]] -> PhyloBranchId) -> [[[Int]]] -> [PhyloBranchId]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
map (\[[Int]]
gIds -> ([[Int]] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [[Int]]
gIds, Text -> [[Int]] -> [Int]
forall a. Text -> [a] -> a
head' Text
"gIds" [[Int]]
gIds)) ([[[Int]]] -> [PhyloBranchId])
-> ([[Int]] -> [[[Int]]]) -> [[Int]] -> [PhyloBranchId]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [[Int]] -> [[[Int]]]
forall a. Eq a => [a] -> [[a]]
group ([[Int]] -> [[[Int]]])
-> ([[Int]] -> [[Int]]) -> [[Int]] -> [[[Int]]]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [[Int]] -> [[Int]]
forall a. Ord a => [a] -> [a]
sort) [[Int]]
ids'
           sup :: Int
sup = (PhyloBranchId -> Int
forall a b. (a, b) -> a
fst (PhyloBranchId -> Int)
-> ([PhyloBranchId] -> PhyloBranchId) -> [PhyloBranchId] -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [PhyloBranchId] -> PhyloBranchId
forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
maximum) [PhyloBranchId]
groupIds
        in (PhyloBranchId -> [Int]) -> [PhyloBranchId] -> [[Int]]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
map PhyloBranchId -> [Int]
forall a b. (a, b) -> b
snd ([PhyloBranchId] -> [[Int]]) -> [PhyloBranchId] -> [[Int]]
forall a b. (a -> b) -> a -> b
$ (PhyloBranchId -> Bool) -> [PhyloBranchId] -> [PhyloBranchId]
forall a. (a -> Bool) -> [a] -> [a]
filter (\PhyloBranchId
gIds -> PhyloBranchId -> Int
forall a b. (a, b) -> a
fst PhyloBranchId
gIds Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
sup) [PhyloBranchId]
groupIds


mergeMeta :: [Int] -> [PhyloGroup] -> Map Text [Double]
mergeMeta :: [Int] -> [PhyloGroup] -> Map Text [Double]
mergeMeta [Int]
bId [PhyloGroup]
groups = 
  let ego :: PhyloGroup
ego = Text -> [PhyloGroup] -> PhyloGroup
forall a. Text -> [a] -> a
head' Text
"mergeMeta" ([PhyloGroup] -> PhyloGroup) -> [PhyloGroup] -> PhyloGroup
forall a b. (a -> b) -> a -> b
$ (PhyloGroup -> Bool) -> [PhyloGroup] -> [PhyloGroup]
forall a. (a -> Bool) -> [a] -> [a]
filter (\PhyloGroup
g -> (PhyloBranchId -> [Int]
forall a b. (a, b) -> b
snd (PhyloGroup
g PhyloGroup
-> Getting PhyloBranchId PhyloGroup PhyloBranchId -> PhyloBranchId
forall s a. s -> Getting a s a -> a
^. Getting PhyloBranchId PhyloGroup PhyloBranchId
Lens' PhyloGroup PhyloBranchId
phylo_groupBranchId)) [Int] -> [Int] -> Bool
forall a. Eq a => a -> a -> Bool
== [Int]
bId) [PhyloGroup]
groups  
   in [(Text, [Double])] -> Map Text [Double]
forall k a. Ord k => [(k, a)] -> Map k a
fromList [(Text
"breaks",(PhyloGroup
ego PhyloGroup
-> Getting (Map Text [Double]) PhyloGroup (Map Text [Double])
-> Map Text [Double]
forall s a. s -> Getting a s a -> a
^. Getting (Map Text [Double]) PhyloGroup (Map Text [Double])
Lens' PhyloGroup (Map Text [Double])
phylo_groupMeta) Map Text [Double] -> Text -> [Double]
forall k a. Ord k => Map k a -> k -> a
! Text
"breaks"),(Text
"seaLevels",(PhyloGroup
ego PhyloGroup
-> Getting (Map Text [Double]) PhyloGroup (Map Text [Double])
-> Map Text [Double]
forall s a. s -> Getting a s a -> a
^. Getting (Map Text [Double]) PhyloGroup (Map Text [Double])
Lens' PhyloGroup (Map Text [Double])
phylo_groupMeta) Map Text [Double] -> Text -> [Double]
forall k a. Ord k => Map k a -> k -> a
! Text
"seaLevels")]   


groupsToBranches :: Map PhyloGroupId PhyloGroup -> [[PhyloGroup]]
groupsToBranches :: Map PhyloGroupId PhyloGroup -> [[PhyloGroup]]
groupsToBranches Map PhyloGroupId PhyloGroup
groups =
    {- run the related component algorithm -}
    let egos :: [[PhyloGroupId]]
egos  = (PhyloGroup -> [PhyloGroupId]) -> [PhyloGroup] -> [[PhyloGroupId]]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
map (\PhyloGroup
g -> [PhyloGroup -> PhyloGroupId
getGroupId PhyloGroup
g] 
                        [PhyloGroupId] -> [PhyloGroupId] -> [PhyloGroupId]
forall a. [a] -> [a] -> [a]
++ ((Pointer -> PhyloGroupId) -> [Pointer] -> [PhyloGroupId]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
map Pointer -> PhyloGroupId
forall a b. (a, b) -> a
fst ([Pointer] -> [PhyloGroupId]) -> [Pointer] -> [PhyloGroupId]
forall a b. (a -> b) -> a -> b
$ PhyloGroup
g PhyloGroup -> Getting [Pointer] PhyloGroup [Pointer] -> [Pointer]
forall s a. s -> Getting a s a -> a
^. Getting [Pointer] PhyloGroup [Pointer]
Lens' PhyloGroup [Pointer]
phylo_groupPeriodParents)
                        [PhyloGroupId] -> [PhyloGroupId] -> [PhyloGroupId]
forall a. [a] -> [a] -> [a]
++ ((Pointer -> PhyloGroupId) -> [Pointer] -> [PhyloGroupId]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
map Pointer -> PhyloGroupId
forall a b. (a, b) -> a
fst ([Pointer] -> [PhyloGroupId]) -> [Pointer] -> [PhyloGroupId]
forall a b. (a -> b) -> a -> b
$ PhyloGroup
g PhyloGroup -> Getting [Pointer] PhyloGroup [Pointer] -> [Pointer]
forall s a. s -> Getting a s a -> a
^. Getting [Pointer] PhyloGroup [Pointer]
Lens' PhyloGroup [Pointer]
phylo_groupPeriodChilds)
                        [PhyloGroupId] -> [PhyloGroupId] -> [PhyloGroupId]
forall a. [a] -> [a] -> [a]
++ ((Pointer -> PhyloGroupId) -> [Pointer] -> [PhyloGroupId]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
map Pointer -> PhyloGroupId
forall a b. (a, b) -> a
fst ([Pointer] -> [PhyloGroupId]) -> [Pointer] -> [PhyloGroupId]
forall a b. (a -> b) -> a -> b
$ PhyloGroup
g PhyloGroup -> Getting [Pointer] PhyloGroup [Pointer] -> [Pointer]
forall s a. s -> Getting a s a -> a
^. Getting [Pointer] PhyloGroup [Pointer]
Lens' PhyloGroup [Pointer]
phylo_groupAncestors)) ([PhyloGroup] -> [[PhyloGroupId]])
-> [PhyloGroup] -> [[PhyloGroupId]]
forall a b. (a -> b) -> a -> b
$ Map PhyloGroupId PhyloGroup -> [PhyloGroup]
forall k a. Map k a -> [a]
elems Map PhyloGroupId PhyloGroup
groups
        graph :: [[PhyloGroupId]]
graph = [[PhyloGroupId]] -> [[PhyloGroupId]]
forall a. Ord a => [[a]] -> [[a]]
relatedComponents [[PhyloGroupId]]
egos
    {- update each group's branch id -}
    in ([PhyloGroupId] -> [PhyloGroup])
-> [[PhyloGroupId]] -> [[PhyloGroup]]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
map (\[PhyloGroupId]
ids ->
        let groups' :: [PhyloGroup]
groups' = Map PhyloGroupId PhyloGroup -> [PhyloGroup]
forall k a. Map k a -> [a]
elems (Map PhyloGroupId PhyloGroup -> [PhyloGroup])
-> Map PhyloGroupId PhyloGroup -> [PhyloGroup]
forall a b. (a -> b) -> a -> b
$ Map PhyloGroupId PhyloGroup
-> Set PhyloGroupId -> Map PhyloGroupId PhyloGroup
forall k a. Ord k => Map k a -> Set k -> Map k a
restrictKeys Map PhyloGroupId PhyloGroup
groups ([PhyloGroupId] -> Set PhyloGroupId
forall a. Ord a => [a] -> Set a
Set.fromList [PhyloGroupId]
ids)
            bId :: [Int]
bId = [[Int]] -> [Int]
mergeBranchIds ([[Int]] -> [Int]) -> [[Int]] -> [Int]
forall a b. (a -> b) -> a -> b
$ (PhyloGroup -> [Int]) -> [PhyloGroup] -> [[Int]]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
map (\PhyloGroup
g -> PhyloBranchId -> [Int]
forall a b. (a, b) -> b
snd (PhyloBranchId -> [Int]) -> PhyloBranchId -> [Int]
forall a b. (a -> b) -> a -> b
$ PhyloGroup
g PhyloGroup
-> Getting PhyloBranchId PhyloGroup PhyloBranchId -> PhyloBranchId
forall s a. s -> Getting a s a -> a
^. Getting PhyloBranchId PhyloGroup PhyloBranchId
Lens' PhyloGroup PhyloBranchId
phylo_groupBranchId) [PhyloGroup]
groups'
         in (PhyloGroup -> PhyloGroup) -> [PhyloGroup] -> [PhyloGroup]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
map (\PhyloGroup
g -> PhyloGroup
g PhyloGroup -> (PhyloGroup -> PhyloGroup) -> PhyloGroup
forall a b. a -> (a -> b) -> b
& (PhyloBranchId -> Identity PhyloBranchId)
-> PhyloGroup -> Identity PhyloGroup
Lens' PhyloGroup PhyloBranchId
phylo_groupBranchId ((PhyloBranchId -> Identity PhyloBranchId)
 -> PhyloGroup -> Identity PhyloGroup)
-> (PhyloBranchId -> PhyloBranchId) -> PhyloGroup -> PhyloGroup
forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
%~ (\(Int
lvl,[Int]
_) -> (Int
lvl,[Int]
bId))) [PhyloGroup]
groups') [[PhyloGroupId]]
graph

relatedComponents :: Ord a => [[a]] -> [[a]]
relatedComponents :: [[a]] -> [[a]]
relatedComponents [[a]]
graph = ([[a]] -> [a] -> [[a]]) -> [[a]] -> [[a]] -> [[a]]
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' (\[[a]]
acc [a]
groups ->
    if ([[a]] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [[a]]
acc)
    then [[a]]
acc [[a]] -> [[a]] -> [[a]]
forall a. [a] -> [a] -> [a]
++ [[a]
groups]
    else 
        let acc' :: ([[a]], [[a]])
acc' = ([a] -> Bool) -> [[a]] -> ([[a]], [[a]])
forall a. (a -> Bool) -> [a] -> ([a], [a])
partition (\[a]
groups' -> Set a -> Set a -> Bool
forall a. Ord a => Set a -> Set a -> Bool
disjoint ([a] -> Set a
forall a. Ord a => [a] -> Set a
Set.fromList [a]
groups') ([a] -> Set a
forall a. Ord a => [a] -> Set a
Set.fromList [a]
groups)) [[a]]
acc
         in (([[a]], [[a]]) -> [[a]]
forall a b. (a, b) -> a
fst ([[a]], [[a]])
acc') [[a]] -> [[a]] -> [[a]]
forall a. [a] -> [a] -> [a]
++ [[a] -> [a]
forall a. Eq a => [a] -> [a]
nub ([a] -> [a]) -> [a] -> [a]
forall a b. (a -> b) -> a -> b
$ [[a]] -> [a]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ([[a]] -> [a]) -> [[a]] -> [a]
forall a b. (a -> b) -> a -> b
$ (([[a]], [[a]]) -> [[a]]
forall a b. (a, b) -> b
snd ([[a]], [[a]])
acc') [[a]] -> [[a]] -> [[a]]
forall a. [a] -> [a] -> [a]
++ [[a]
groups]]) [] [[a]]
graph

toRelatedComponents :: [PhyloGroup] -> [((PhyloGroup,PhyloGroup),Double)] -> [[PhyloGroup]]
toRelatedComponents :: [PhyloGroup]
-> [((PhyloGroup, PhyloGroup), Double)] -> [[PhyloGroup]]
toRelatedComponents [PhyloGroup]
nodes [((PhyloGroup, PhyloGroup), Double)]
edges = 
  let ref :: Map PhyloGroupId PhyloGroup
ref = [(PhyloGroupId, PhyloGroup)] -> Map PhyloGroupId PhyloGroup
forall k a. Ord k => [(k, a)] -> Map k a
fromList ([(PhyloGroupId, PhyloGroup)] -> Map PhyloGroupId PhyloGroup)
-> [(PhyloGroupId, PhyloGroup)] -> Map PhyloGroupId PhyloGroup
forall a b. (a -> b) -> a -> b
$ (PhyloGroup -> (PhyloGroupId, PhyloGroup))
-> [PhyloGroup] -> [(PhyloGroupId, PhyloGroup)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
map (\PhyloGroup
g -> (PhyloGroup -> PhyloGroupId
getGroupId PhyloGroup
g, PhyloGroup
g)) [PhyloGroup]
nodes
      clusters :: [[PhyloGroupId]]
clusters = [[PhyloGroupId]] -> [[PhyloGroupId]]
forall a. Ord a => [[a]] -> [[a]]
relatedComponents ([[PhyloGroupId]] -> [[PhyloGroupId]])
-> [[PhyloGroupId]] -> [[PhyloGroupId]]
forall a b. (a -> b) -> a -> b
$ (((((PhyloGroup, PhyloGroup), Double) -> [PhyloGroupId])
-> [((PhyloGroup, PhyloGroup), Double)] -> [[PhyloGroupId]]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
map (\((PhyloGroup
g,PhyloGroup
g'),Double
_) -> [PhyloGroup -> PhyloGroupId
getGroupId PhyloGroup
g, PhyloGroup -> PhyloGroupId
getGroupId PhyloGroup
g']) [((PhyloGroup, PhyloGroup), Double)]
edges) [[PhyloGroupId]] -> [[PhyloGroupId]] -> [[PhyloGroupId]]
forall a. [a] -> [a] -> [a]
++ ((PhyloGroup -> [PhyloGroupId]) -> [PhyloGroup] -> [[PhyloGroupId]]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
map (\PhyloGroup
g -> [PhyloGroup -> PhyloGroupId
getGroupId PhyloGroup
g]) [PhyloGroup]
nodes)) 
   in ([PhyloGroupId] -> [PhyloGroup])
-> [[PhyloGroupId]] -> [[PhyloGroup]]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
map (\[PhyloGroupId]
cluster -> (PhyloGroupId -> PhyloGroup) -> [PhyloGroupId] -> [PhyloGroup]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
map (\PhyloGroupId
gId -> Map PhyloGroupId PhyloGroup
ref Map PhyloGroupId PhyloGroup -> PhyloGroupId -> PhyloGroup
forall k a. Ord k => Map k a -> k -> a
! PhyloGroupId
gId) [PhyloGroupId]
cluster) [[PhyloGroupId]]
clusters 


traceSynchronyEnd :: Phylo -> Phylo
traceSynchronyEnd :: Phylo -> Phylo
traceSynchronyEnd Phylo
phylo = 
    String -> Phylo -> Phylo
forall a. String -> a -> a
trace ( String
"-- | End synchronic clustering at level " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Int -> String
forall a. Show a => a -> String
show (Phylo -> Int
getLastLevel Phylo
phylo) 
                 String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
" with " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Int -> String
forall a. Show a => a -> String
show ([PhyloGroup] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length ([PhyloGroup] -> Int) -> [PhyloGroup] -> Int
forall a b. (a -> b) -> a -> b
$ Int -> Phylo -> [PhyloGroup]
getGroupsFromLevel (Phylo -> Int
getLastLevel Phylo
phylo) Phylo
phylo) String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
" groups"
                 String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
" and "  String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Int -> String
forall a. Show a => a -> String
show ([PhyloBranchId] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length ([PhyloBranchId] -> Int) -> [PhyloBranchId] -> Int
forall a b. (a -> b) -> a -> b
$ [PhyloBranchId] -> [PhyloBranchId]
forall a. Eq a => [a] -> [a]
nub ([PhyloBranchId] -> [PhyloBranchId])
-> [PhyloBranchId] -> [PhyloBranchId]
forall a b. (a -> b) -> a -> b
$ (PhyloGroup -> PhyloBranchId) -> [PhyloGroup] -> [PhyloBranchId]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
map PhyloGroup -> PhyloBranchId
_phylo_groupBranchId ([PhyloGroup] -> [PhyloBranchId])
-> [PhyloGroup] -> [PhyloBranchId]
forall a b. (a -> b) -> a -> b
$ Int -> Phylo -> [PhyloGroup]
getGroupsFromLevel (Phylo -> Int
getLastLevel Phylo
phylo) Phylo
phylo) String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
" branches"
                 String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
"\n" ) Phylo
phylo

traceSynchronyStart :: Phylo -> Phylo
traceSynchronyStart :: Phylo -> Phylo
traceSynchronyStart Phylo
phylo = 
    String -> Phylo -> Phylo
forall a. String -> a -> a
trace ( String
"\n" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
"-- | Start synchronic clustering at level " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Int -> String
forall a. Show a => a -> String
show (Phylo -> Int
getLastLevel Phylo
phylo) 
                 String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
" with " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Int -> String
forall a. Show a => a -> String
show ([PhyloGroup] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length ([PhyloGroup] -> Int) -> [PhyloGroup] -> Int
forall a b. (a -> b) -> a -> b
$ Int -> Phylo -> [PhyloGroup]
getGroupsFromLevel (Phylo -> Int
getLastLevel Phylo
phylo) Phylo
phylo) String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
" groups"
                 String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
" and "  String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Int -> String
forall a. Show a => a -> String
show ([PhyloBranchId] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length ([PhyloBranchId] -> Int) -> [PhyloBranchId] -> Int
forall a b. (a -> b) -> a -> b
$ [PhyloBranchId] -> [PhyloBranchId]
forall a. Eq a => [a] -> [a]
nub ([PhyloBranchId] -> [PhyloBranchId])
-> [PhyloBranchId] -> [PhyloBranchId]
forall a b. (a -> b) -> a -> b
$ (PhyloGroup -> PhyloBranchId) -> [PhyloGroup] -> [PhyloBranchId]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
map PhyloGroup -> PhyloBranchId
_phylo_groupBranchId ([PhyloGroup] -> [PhyloBranchId])
-> [PhyloGroup] -> [PhyloBranchId]
forall a b. (a -> b) -> a -> b
$ Int -> Phylo -> [PhyloGroup]
getGroupsFromLevel (Phylo -> Int
getLastLevel Phylo
phylo) Phylo
phylo) String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
" branches"
                 String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
"\n" ) Phylo
phylo    


-------------------
-- | Proximity | --
-------------------

getSensibility :: Proximity -> Double
getSensibility :: Proximity -> Double
getSensibility Proximity
proxi = case Proximity
proxi of 
    WeightedLogJaccard Double
s -> Double
s
    WeightedLogSim Double
s -> Double
s
    Proximity
Hamming -> Double
forall a. HasCallStack => a
undefined

----------------
-- | Branch | --
----------------

intersectInit :: Eq a => [a] -> [a] -> [a] -> [a]
intersectInit :: [a] -> [a] -> [a] -> [a]
intersectInit [a]
acc [a]
lst [a]
lst' =
    if ([a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [a]
lst) Bool -> Bool -> Bool
|| ([a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [a]
lst')
    then [a]
acc
    else if (Text -> [a] -> a
forall a. Text -> [a] -> a
head' Text
"intersectInit" [a]
lst) a -> a -> Bool
forall a. Eq a => a -> a -> Bool
== (Text -> [a] -> a
forall a. Text -> [a] -> a
head' Text
"intersectInit" [a]
lst')
         then [a] -> [a] -> [a] -> [a]
forall a. Eq a => [a] -> [a] -> [a] -> [a]
intersectInit ([a]
acc [a] -> [a] -> [a]
forall a. [a] -> [a] -> [a]
++ [Text -> [a] -> a
forall a. Text -> [a] -> a
head' Text
"intersectInit" [a]
lst]) ([a] -> [a]
forall a. [a] -> [a]
tail [a]
lst) ([a] -> [a]
forall a. [a] -> [a]
tail [a]
lst')
         else [a]
acc

branchIdsToProximity :: PhyloBranchId -> PhyloBranchId -> Double -> Double -> Double
branchIdsToProximity :: PhyloBranchId -> PhyloBranchId -> Double -> Double -> Double
branchIdsToProximity PhyloBranchId
id PhyloBranchId
id' Double
thrInit Double
thrStep = Double
thrInit Double -> Double -> Double
forall a. Num a => a -> a -> a
+ Double
thrStep Double -> Double -> Double
forall a. Num a => a -> a -> a
* (Int -> Double
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> Double) -> Int -> Double
forall a b. (a -> b) -> a -> b
$ [Int] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length ([Int] -> Int) -> [Int] -> Int
forall a b. (a -> b) -> a -> b
$ [Int] -> [Int] -> [Int] -> [Int]
forall a. Eq a => [a] -> [a] -> [a] -> [a]
intersectInit [] (PhyloBranchId -> [Int]
forall a b. (a, b) -> b
snd PhyloBranchId
id) (PhyloBranchId -> [Int]
forall a b. (a, b) -> b
snd PhyloBranchId
id'))

ngramsInBranches :: [[PhyloGroup]] -> [Int]
ngramsInBranches :: [[PhyloGroup]] -> [Int]
ngramsInBranches [[PhyloGroup]]
branches = [Int] -> [Int]
forall a. Eq a => [a] -> [a]
nub ([Int] -> [Int]) -> [Int] -> [Int]
forall a b. (a -> b) -> a -> b
$ ([Int] -> PhyloGroup -> [Int]) -> [Int] -> [PhyloGroup] -> [Int]
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl (\[Int]
acc PhyloGroup
g -> [Int]
acc [Int] -> [Int] -> [Int]
forall a. [a] -> [a] -> [a]
++ (PhyloGroup
g PhyloGroup -> Getting [Int] PhyloGroup [Int] -> [Int]
forall s a. s -> Getting a s a -> a
^. Getting [Int] PhyloGroup [Int]
Lens' PhyloGroup [Int]
phylo_groupNgrams)) [] ([PhyloGroup] -> [Int]) -> [PhyloGroup] -> [Int]
forall a b. (a -> b) -> a -> b
$ [[PhyloGroup]] -> [PhyloGroup]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[PhyloGroup]]
branches


traceMatchSuccess :: Double -> Double -> Double -> [[[PhyloGroup]]] -> [[[PhyloGroup]]]
traceMatchSuccess :: Double -> Double -> Double -> [[[PhyloGroup]]] -> [[[PhyloGroup]]]
traceMatchSuccess Double
thr Double
qua Double
qua' [[[PhyloGroup]]]
nextBranches =
    String -> [[[PhyloGroup]]] -> [[[PhyloGroup]]]
forall a. String -> a -> a
trace ( String
"\n" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
"-- local branches : " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> (String -> String
forall a. [a] -> [a]
init (String -> String) -> String -> String
forall a b. (a -> b) -> a -> b
$ [Int] -> String
forall a. Show a => a -> String
show (([Int] -> [Int]
forall a. [a] -> [a]
init ([Int] -> [Int])
-> (PhyloBranchId -> [Int]) -> PhyloBranchId -> [Int]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Int] -> [Int]
forall a. [a] -> [a]
init ([Int] -> [Int])
-> (PhyloBranchId -> [Int]) -> PhyloBranchId -> [Int]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PhyloBranchId -> [Int]
forall a b. (a, b) -> b
snd)
                                                    (PhyloBranchId -> [Int]) -> PhyloBranchId -> [Int]
forall a b. (a -> b) -> a -> b
$ (Text -> [PhyloGroup] -> PhyloGroup
forall a. Text -> [a] -> a
head' Text
"trace" ([PhyloGroup] -> PhyloGroup) -> [PhyloGroup] -> PhyloGroup
forall a b. (a -> b) -> a -> b
$ Text -> [[PhyloGroup]] -> [PhyloGroup]
forall a. Text -> [a] -> a
head' Text
"trace" ([[PhyloGroup]] -> [PhyloGroup]) -> [[PhyloGroup]] -> [PhyloGroup]
forall a b. (a -> b) -> a -> b
$ Text -> [[[PhyloGroup]]] -> [[PhyloGroup]]
forall a. Text -> [a] -> a
head' Text
"trace" [[[PhyloGroup]]]
nextBranches) PhyloGroup
-> Getting PhyloBranchId PhyloGroup PhyloBranchId -> PhyloBranchId
forall s a. s -> Getting a s a -> a
^. Getting PhyloBranchId PhyloGroup PhyloBranchId
Lens' PhyloGroup PhyloBranchId
phylo_groupBranchId))
                                           String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
",(1.." String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Int -> String
forall a. Show a => a -> String
show ([[[PhyloGroup]]] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [[[PhyloGroup]]]
nextBranches) String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
")]"
                 String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
" | " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Int -> String
forall a. Show a => a -> String
show (([PhyloGroup] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length ([PhyloGroup] -> Int)
-> ([[[PhyloGroup]]] -> [PhyloGroup]) -> [[[PhyloGroup]]] -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [[PhyloGroup]] -> [PhyloGroup]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ([[PhyloGroup]] -> [PhyloGroup])
-> ([[[PhyloGroup]]] -> [[PhyloGroup]])
-> [[[PhyloGroup]]]
-> [PhyloGroup]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [[[PhyloGroup]]] -> [[PhyloGroup]]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat) [[[PhyloGroup]]]
nextBranches) String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
" groups" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
"\n"
         String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
" - splited with success in "  String -> String -> String
forall a. Semigroup a => a -> a -> a
<> [Int] -> String
forall a. Show a => a -> String
show (([[PhyloGroup]] -> Int) -> [[[PhyloGroup]]] -> [Int]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
map [[PhyloGroup]] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [[[PhyloGroup]]]
nextBranches) String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
" sub-branches" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
"\n"
         String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
" - for the local threshold "  String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Double -> String
forall a. Show a => a -> String
show (Double
thr) String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
" ( quality : " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Double -> String
forall a. Show a => a -> String
show (Double
qua) String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
" < " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Double -> String
forall a. Show a => a -> String
show(Double
qua') String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
")\n" ) [[[PhyloGroup]]]
nextBranches


traceMatchFailure :: Double -> Double -> Double -> [[PhyloGroup]] -> [[PhyloGroup]]
traceMatchFailure :: Double -> Double -> Double -> [[PhyloGroup]] -> [[PhyloGroup]]
traceMatchFailure Double
thr Double
qua Double
qua' [[PhyloGroup]]
branches =
    String -> [[PhyloGroup]] -> [[PhyloGroup]]
forall a. String -> a -> a
trace ( String
"\n" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
"-- local branches : " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> (String -> String
forall a. [a] -> [a]
init (String -> String) -> String -> String
forall a b. (a -> b) -> a -> b
$ [Int] -> String
forall a. Show a => a -> String
show (([Int] -> [Int]
forall a. [a] -> [a]
init ([Int] -> [Int])
-> (PhyloBranchId -> [Int]) -> PhyloBranchId -> [Int]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PhyloBranchId -> [Int]
forall a b. (a, b) -> b
snd) (PhyloBranchId -> [Int]) -> PhyloBranchId -> [Int]
forall a b. (a -> b) -> a -> b
$ (Text -> [PhyloGroup] -> PhyloGroup
forall a. Text -> [a] -> a
head' Text
"trace" ([PhyloGroup] -> PhyloGroup) -> [PhyloGroup] -> PhyloGroup
forall a b. (a -> b) -> a -> b
$ Text -> [[PhyloGroup]] -> [PhyloGroup]
forall a. Text -> [a] -> a
head' Text
"trace" [[PhyloGroup]]
branches) PhyloGroup
-> Getting PhyloBranchId PhyloGroup PhyloBranchId -> PhyloBranchId
forall s a. s -> Getting a s a -> a
^. Getting PhyloBranchId PhyloGroup PhyloBranchId
Lens' PhyloGroup PhyloBranchId
phylo_groupBranchId))
                                           String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
",(1.." String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Int -> String
forall a. Show a => a -> String
show ([[PhyloGroup]] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [[PhyloGroup]]
branches) String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
")]"
                 String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
" | " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Int -> String
forall a. Show a => a -> String
show ([PhyloGroup] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length ([PhyloGroup] -> Int) -> [PhyloGroup] -> Int
forall a b. (a -> b) -> a -> b
$ [[PhyloGroup]] -> [PhyloGroup]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[PhyloGroup]]
branches) String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
" groups" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
"\n"
         String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
" - split with failure for the local threshold " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Double -> String
forall a. Show a => a -> String
show (Double
thr) String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
" ( quality : " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Double -> String
forall a. Show a => a -> String
show (Double
qua) String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
" > " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Double -> String
forall a. Show a => a -> String
show(Double
qua') String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
")\n"
        ) [[PhyloGroup]]
branches


traceMatchNoSplit :: [[PhyloGroup]] -> [[PhyloGroup]]
traceMatchNoSplit :: [[PhyloGroup]] -> [[PhyloGroup]]
traceMatchNoSplit [[PhyloGroup]]
branches =
    String -> [[PhyloGroup]] -> [[PhyloGroup]]
forall a. String -> a -> a
trace ( String
"\n" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
"-- local branches : " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> (String -> String
forall a. [a] -> [a]
init (String -> String) -> String -> String
forall a b. (a -> b) -> a -> b
$ [Int] -> String
forall a. Show a => a -> String
show (([Int] -> [Int]
forall a. [a] -> [a]
init ([Int] -> [Int])
-> (PhyloBranchId -> [Int]) -> PhyloBranchId -> [Int]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PhyloBranchId -> [Int]
forall a b. (a, b) -> b
snd) (PhyloBranchId -> [Int]) -> PhyloBranchId -> [Int]
forall a b. (a -> b) -> a -> b
$ (Text -> [PhyloGroup] -> PhyloGroup
forall a. Text -> [a] -> a
head' Text
"trace" ([PhyloGroup] -> PhyloGroup) -> [PhyloGroup] -> PhyloGroup
forall a b. (a -> b) -> a -> b
$ Text -> [[PhyloGroup]] -> [PhyloGroup]
forall a. Text -> [a] -> a
head' Text
"trace" [[PhyloGroup]]
branches) PhyloGroup
-> Getting PhyloBranchId PhyloGroup PhyloBranchId -> PhyloBranchId
forall s a. s -> Getting a s a -> a
^. Getting PhyloBranchId PhyloGroup PhyloBranchId
Lens' PhyloGroup PhyloBranchId
phylo_groupBranchId))
                                           String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
",(1.." String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Int -> String
forall a. Show a => a -> String
show ([[PhyloGroup]] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [[PhyloGroup]]
branches) String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
")]"
                 String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
" | " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Int -> String
forall a. Show a => a -> String
show ([PhyloGroup] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length ([PhyloGroup] -> Int) -> [PhyloGroup] -> Int
forall a b. (a -> b) -> a -> b
$ [[PhyloGroup]] -> [PhyloGroup]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[PhyloGroup]]
branches) String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
" groups" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
"\n"
         String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
" - unable to split in smaller branches" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
"\n"
        ) [[PhyloGroup]]
branches


traceMatchLimit :: [[PhyloGroup]] -> [[PhyloGroup]]
traceMatchLimit :: [[PhyloGroup]] -> [[PhyloGroup]]
traceMatchLimit [[PhyloGroup]]
branches =
    String -> [[PhyloGroup]] -> [[PhyloGroup]]
forall a. String -> a -> a
trace ( String
"\n" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
"-- local branches : " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> (String -> String
forall a. [a] -> [a]
init (String -> String) -> String -> String
forall a b. (a -> b) -> a -> b
$ [Int] -> String
forall a. Show a => a -> String
show (([Int] -> [Int]
forall a. [a] -> [a]
init ([Int] -> [Int])
-> (PhyloBranchId -> [Int]) -> PhyloBranchId -> [Int]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PhyloBranchId -> [Int]
forall a b. (a, b) -> b
snd) (PhyloBranchId -> [Int]) -> PhyloBranchId -> [Int]
forall a b. (a -> b) -> a -> b
$ (Text -> [PhyloGroup] -> PhyloGroup
forall a. Text -> [a] -> a
head' Text
"trace" ([PhyloGroup] -> PhyloGroup) -> [PhyloGroup] -> PhyloGroup
forall a b. (a -> b) -> a -> b
$ Text -> [[PhyloGroup]] -> [PhyloGroup]
forall a. Text -> [a] -> a
head' Text
"trace" [[PhyloGroup]]
branches) PhyloGroup
-> Getting PhyloBranchId PhyloGroup PhyloBranchId -> PhyloBranchId
forall s a. s -> Getting a s a -> a
^. Getting PhyloBranchId PhyloGroup PhyloBranchId
Lens' PhyloGroup PhyloBranchId
phylo_groupBranchId))
                                           String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
",(1.." String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Int -> String
forall a. Show a => a -> String
show ([[PhyloGroup]] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [[PhyloGroup]]
branches) String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
")]"
                 String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
" | " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Int -> String
forall a. Show a => a -> String
show ([PhyloGroup] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length ([PhyloGroup] -> Int) -> [PhyloGroup] -> Int
forall a b. (a -> b) -> a -> b
$ [[PhyloGroup]] -> [PhyloGroup]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[PhyloGroup]]
branches) String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
" groups" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
"\n"
         String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
" - unable to increase the threshold above 1" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
"\n"
        ) [[PhyloGroup]]
branches            


traceMatchEnd :: [PhyloGroup] -> [PhyloGroup]
traceMatchEnd :: [PhyloGroup] -> [PhyloGroup]
traceMatchEnd [PhyloGroup]
groups =
    String -> [PhyloGroup] -> [PhyloGroup]
forall a. String -> a -> a
trace (String
"\n" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
"-- | End temporal matching with " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Int -> String
forall a. Show a => a -> String
show ([PhyloBranchId] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length ([PhyloBranchId] -> Int) -> [PhyloBranchId] -> Int
forall a b. (a -> b) -> a -> b
$ [PhyloBranchId] -> [PhyloBranchId]
forall a. Eq a => [a] -> [a]
nub ([PhyloBranchId] -> [PhyloBranchId])
-> [PhyloBranchId] -> [PhyloBranchId]
forall a b. (a -> b) -> a -> b
$ (PhyloGroup -> PhyloBranchId) -> [PhyloGroup] -> [PhyloBranchId]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
map (\PhyloGroup
g -> PhyloGroup
g PhyloGroup
-> Getting PhyloBranchId PhyloGroup PhyloBranchId -> PhyloBranchId
forall s a. s -> Getting a s a -> a
^. Getting PhyloBranchId PhyloGroup PhyloBranchId
Lens' PhyloGroup PhyloBranchId
phylo_groupBranchId) [PhyloGroup]
groups)
                                                         String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
" branches and " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Int -> String
forall a. Show a => a -> String
show ([PhyloGroup] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [PhyloGroup]
groups) String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
" groups" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
"\n") [PhyloGroup]
groups


traceTemporalMatching :: [PhyloGroup] -> [PhyloGroup]
traceTemporalMatching :: [PhyloGroup] -> [PhyloGroup]
traceTemporalMatching [PhyloGroup]
groups = 
    String -> [PhyloGroup] -> [PhyloGroup]
forall a. String -> a -> a
trace ( String
"\n" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
"-- | Start temporal matching for " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Int -> String
forall a. Show a => a -> String
show([PhyloGroup] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [PhyloGroup]
groups) String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
" groups" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
"\n") [PhyloGroup]
groups


traceGroupsProxi :: Map (PhyloGroupId,PhyloGroupId) Double -> Map (PhyloGroupId,PhyloGroupId) Double
traceGroupsProxi :: Map (PhyloGroupId, PhyloGroupId) Double
-> Map (PhyloGroupId, PhyloGroupId) Double
traceGroupsProxi Map (PhyloGroupId, PhyloGroupId) Double
m = 
    String
-> Map (PhyloGroupId, PhyloGroupId) Double
-> Map (PhyloGroupId, PhyloGroupId) Double
forall a. String -> a -> a
trace ( String
"\n" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
"-- | " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Int -> String
forall a. Show a => a -> String
show(Map (PhyloGroupId, PhyloGroupId) Double -> Int
forall k a. Map k a -> Int
Map.size Map (PhyloGroupId, PhyloGroupId) Double
m) String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
" computed pairs of groups proximity" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
"\n") Map (PhyloGroupId, PhyloGroupId) Double
m