{-|
Module      : Gargantext.Core.Viz.Phylo.SynchronicClustering
Description : Module dedicated to the adaptative synchronic clustering of a Phylo.
Copyright   : (c) CNRS, 2017-Present
License     : AGPL + CECILL v3
Maintainer  : team@gargantext.org
Stability   : experimental
Portability : POSIX
-}


module Gargantext.Core.Viz.Phylo.SynchronicClustering where

import Gargantext.Prelude
import Gargantext.Core.Viz.AdaptativePhylo
import Gargantext.Core.Viz.Phylo.PhyloTools
import Gargantext.Core.Viz.Phylo.TemporalMatching (weightedLogJaccard', filterDiago, reduceDiagos)
import Gargantext.Core.Viz.Phylo.PhyloExport (processDynamics)

import Data.List ((++), null, intersect, nub, concat, sort, sortOn, groupBy)
import Data.Map  (Map, fromList, fromListWith, foldlWithKey, (!), insert, empty, restrictKeys, elems, mapWithKey, member)

import Control.Lens hiding (Level)
import Control.Parallel.Strategies (parList, rdeepseq, using)
import Control.Monad (sequence)
-- import Debug.Trace (trace)

import qualified Data.Map as Map


-------------------------
-- | New Level Maker | --
-------------------------


mergeGroups :: [Cooc] -> PhyloGroupId -> Map PhyloGroupId PhyloGroupId -> [PhyloGroup] -> PhyloGroup
mergeGroups :: [Cooc]
-> PhyloGroupId
-> Map PhyloGroupId PhyloGroupId
-> [PhyloGroup]
-> PhyloGroup
mergeGroups [Cooc]
coocs PhyloGroupId
id Map PhyloGroupId PhyloGroupId
mapIds [PhyloGroup]
childs = 
    let ngrams :: [Int]
ngrams = ([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 a. Eq a => [a] -> [a]
nub ([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]] -> [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 -> [Int]
_phylo_groupNgrams [PhyloGroup]
childs
    in (Int, Int)
-> (Text, Text)
-> Int
-> Int
-> Text
-> Int
-> Maybe Double
-> [Int]
-> [Int]
-> Cooc
-> PhyloBranchId
-> Map Text [Double]
-> [Pointer]
-> [Pointer]
-> [Pointer]
-> [Pointer]
-> [Pointer]
-> PhyloGroup
PhyloGroup (((Int, Int), Int) -> (Int, Int)
forall a b. (a, b) -> a
fst (((Int, Int), Int) -> (Int, Int))
-> ((Int, Int), Int) -> (Int, Int)
forall a b. (a -> b) -> a -> b
$ PhyloGroupId -> ((Int, Int), Int)
forall a b. (a, b) -> a
fst PhyloGroupId
id) (PhyloGroup -> (Text, Text)
_phylo_groupPeriod' (PhyloGroup -> (Text, Text)) -> PhyloGroup -> (Text, Text)
forall a b. (a -> b) -> a -> b
$ Text -> [PhyloGroup] -> PhyloGroup
forall a. Text -> [a] -> a
head' Text
"mergeGroups" [PhyloGroup]
childs)
                  (((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
$ PhyloGroupId -> ((Int, Int), Int)
forall a b. (a, b) -> a
fst PhyloGroupId
id) (PhyloGroupId -> Int
forall a b. (a, b) -> b
snd PhyloGroupId
id) Text
""
                  ([Int] -> Int
forall (f :: * -> *) a. (Foldable f, Num a) => f a -> a
sum ([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 -> Int
_phylo_groupSupport [PhyloGroup]
childs) 
                  (([Double] -> Double) -> Maybe [Double] -> Maybe Double
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [Double] -> Double
forall (f :: * -> *) a. (Foldable f, Num a) => f a -> a
sum (Maybe [Double] -> Maybe Double) -> Maybe [Double] -> Maybe Double
forall a b. (a -> b) -> a -> b
$ [Maybe Double] -> Maybe [Double]
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
sequence 
                            ([Maybe Double] -> Maybe [Double])
-> [Maybe Double] -> Maybe [Double]
forall a b. (a -> b) -> a -> b
$ (PhyloGroup -> Maybe Double) -> [PhyloGroup] -> [Maybe Double]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
map PhyloGroup -> Maybe Double
_phylo_groupWeight [PhyloGroup]
childs)
                  ([[Int]] -> [Int]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ([[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 -> [Int]
_phylo_groupSources [PhyloGroup]
childs) 
                  [Int]
ngrams
                  ([Int] -> [Cooc] -> Cooc
ngramsToCooc [Int]
ngrams [Cooc]
coocs) 
                  ((((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
$ PhyloGroupId -> ((Int, Int), Int)
forall a b. (a, b) -> a
fst PhyloGroupId
id),[Int]
bId)
                  ([Int] -> [PhyloGroup] -> Map Text [Double]
mergeMeta [Int]
bId [PhyloGroup]
childs) [] ((PhyloGroup -> Pointer) -> [PhyloGroup] -> [Pointer]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
map (\PhyloGroup
g -> (PhyloGroup -> PhyloGroupId
getGroupId PhyloGroup
g, Double
1)) [PhyloGroup]
childs)
                  ([Pointer] -> [Pointer]
updatePointers ([Pointer] -> [Pointer]) -> [Pointer] -> [Pointer]
forall a b. (a -> b) -> a -> b
$ [[Pointer]] -> [Pointer]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ([[Pointer]] -> [Pointer]) -> [[Pointer]] -> [Pointer]
forall a b. (a -> b) -> a -> b
$ (PhyloGroup -> [Pointer]) -> [PhyloGroup] -> [[Pointer]]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
map PhyloGroup -> [Pointer]
_phylo_groupPeriodParents [PhyloGroup]
childs)
                  ([Pointer] -> [Pointer]
updatePointers ([Pointer] -> [Pointer]) -> [Pointer] -> [Pointer]
forall a b. (a -> b) -> a -> b
$ [[Pointer]] -> [Pointer]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ([[Pointer]] -> [Pointer]) -> [[Pointer]] -> [Pointer]
forall a b. (a -> b) -> a -> b
$ (PhyloGroup -> [Pointer]) -> [PhyloGroup] -> [[Pointer]]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
map PhyloGroup -> [Pointer]
_phylo_groupPeriodChilds  [PhyloGroup]
childs)
                  ([Pointer] -> [Pointer]
mergeAncestors ([Pointer] -> [Pointer]) -> [Pointer] -> [Pointer]
forall a b. (a -> b) -> a -> b
$ [[Pointer]] -> [Pointer]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ([[Pointer]] -> [Pointer]) -> [[Pointer]] -> [Pointer]
forall a b. (a -> b) -> a -> b
$ (PhyloGroup -> [Pointer]) -> [PhyloGroup] -> [[Pointer]]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
map PhyloGroup -> [Pointer]
_phylo_groupAncestors [PhyloGroup]
childs)
    where
        --------------------
        bId :: [Int]
        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]
childs
        --------------------
        updatePointers :: [Pointer] -> [Pointer]
        updatePointers :: [Pointer] -> [Pointer]
updatePointers [Pointer]
pointers = (Pointer -> Pointer) -> [Pointer] -> [Pointer]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
map (\(PhyloGroupId
pId,Double
w) -> (Map PhyloGroupId PhyloGroupId
mapIds Map PhyloGroupId PhyloGroupId -> PhyloGroupId -> PhyloGroupId
forall k a. Ord k => Map k a -> k -> a
! PhyloGroupId
pId,Double
w)) [Pointer]
pointers
        --------------------
        mergeAncestors :: [Pointer] -> [Pointer]
        mergeAncestors :: [Pointer] -> [Pointer]
mergeAncestors [Pointer]
pointers = Map PhyloGroupId Double -> [Pointer]
forall k a. Map k a -> [(k, a)]
Map.toList (Map PhyloGroupId Double -> [Pointer])
-> Map PhyloGroupId Double -> [Pointer]
forall a b. (a -> b) -> a -> b
$ (Double -> Double -> Double)
-> [Pointer] -> Map PhyloGroupId Double
forall k a. Ord k => (a -> a -> a) -> [(k, a)] -> Map k a
fromListWith Double -> Double -> Double
forall a. Ord a => a -> a -> a
max [Pointer]
pointers

addPhyloLevel :: Level -> Phylo -> Phylo
addPhyloLevel :: Int -> Phylo -> Phylo
addPhyloLevel Int
lvl 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
phyloPrd -> PhyloPeriod
phyloPrd 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
    -> Map ((Int, Int), Int) PhyloLevel)
-> PhyloPeriod
-> PhyloPeriod
forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
%~ (((Int, Int), Int)
-> PhyloLevel
-> Map ((Int, Int), Int) PhyloLevel
-> Map ((Int, Int), Int) PhyloLevel
forall k a. Ord k => k -> a -> Map k a -> Map k a
insert (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
lvl) 
                                   ((Int, Int)
-> (Text, Text) -> Int -> Map PhyloGroupId PhyloGroup -> PhyloLevel
PhyloLevel (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) (PhyloPeriod
phyloPrd PhyloPeriod
-> Getting (Text, Text) PhyloPeriod (Text, Text) -> (Text, Text)
forall s a. s -> Getting a s a -> a
^. Getting (Text, Text) PhyloPeriod (Text, Text)
Lens' PhyloPeriod (Text, Text)
phylo_periodPeriod') Int
lvl Map PhyloGroupId PhyloGroup
forall k a. Map k a
empty))) Phylo
phylo


toNextLevel' :: Phylo -> [PhyloGroup] -> Phylo
toNextLevel' :: Phylo -> [PhyloGroup] -> Phylo
toNextLevel' Phylo
phylo [PhyloGroup]
groups =
    let curLvl :: Int
curLvl = Phylo -> Int
getLastLevel Phylo
phylo
        oldGroups :: Map PhyloGroupId PhyloGroupId
oldGroups = [(PhyloGroupId, PhyloGroupId)] -> Map PhyloGroupId PhyloGroupId
forall k a. Ord k => [(k, a)] -> Map k a
fromList ([(PhyloGroupId, PhyloGroupId)] -> Map PhyloGroupId PhyloGroupId)
-> [(PhyloGroupId, PhyloGroupId)] -> Map PhyloGroupId PhyloGroupId
forall a b. (a -> b) -> a -> b
$ (PhyloGroup -> (PhyloGroupId, PhyloGroupId))
-> [PhyloGroup] -> [(PhyloGroupId, PhyloGroupId)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
map (\PhyloGroup
g -> (PhyloGroup -> PhyloGroupId
getGroupId PhyloGroup
g, PhyloGroup -> PhyloGroupId
getLevelParentId PhyloGroup
g)) [PhyloGroup]
groups
        newGroups :: [PhyloGroup]
newGroups = [[PhyloGroup]] -> [PhyloGroup]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ([[PhyloGroup]] -> [PhyloGroup]) -> [[PhyloGroup]] -> [PhyloGroup]
forall a b. (a -> b) -> a -> b
$ Map PhyloGroupId PhyloGroup -> [[PhyloGroup]]
groupsToBranches
                  (Map PhyloGroupId PhyloGroup -> [[PhyloGroup]])
-> Map PhyloGroupId PhyloGroup -> [[PhyloGroup]]
forall a b. (a -> b) -> a -> b
$ [(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] -> [(PhyloGroupId, PhyloGroup)])
-> [PhyloGroup] -> [(PhyloGroupId, PhyloGroup)]
forall a b. (a -> b) -> a -> b
$ ([PhyloGroup] -> PhyloGroupId -> [PhyloGroup] -> [PhyloGroup])
-> [PhyloGroup] -> Map PhyloGroupId [PhyloGroup] -> [PhyloGroup]
forall a k b. (a -> k -> b -> a) -> a -> Map k b -> a
foldlWithKey (\[PhyloGroup]
acc PhyloGroupId
id [PhyloGroup]
groups' ->
                        --  4) create the parent group
                        let parent :: PhyloGroup
parent = [Cooc]
-> PhyloGroupId
-> Map PhyloGroupId PhyloGroupId
-> [PhyloGroup]
-> PhyloGroup
mergeGroups (Map Int Cooc -> [Cooc]
forall k a. Map k a -> [a]
elems (Map Int Cooc -> [Cooc]) -> Map Int Cooc -> [Cooc]
forall a b. (a -> b) -> a -> b
$ Map Int Cooc -> Set Int -> Map Int Cooc
forall k a. Ord k => Map k a -> Set k -> Map k a
restrictKeys (Phylo
phylo Phylo
-> Getting (Map Int Cooc) Phylo (Map Int Cooc) -> Map Int Cooc
forall s a. s -> Getting a s a -> a
^. Getting (Map Int Cooc) Phylo (Map Int Cooc)
Lens' Phylo (Map Int Cooc)
phylo_timeCooc) (Set Int -> Map Int Cooc) -> Set Int -> Map Int Cooc
forall a b. (a -> b) -> a -> b
$ [(Int, Int)] -> Set Int
periodsToYears [(((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]) PhyloGroupId
id Map PhyloGroupId PhyloGroupId
oldGroups [PhyloGroup]
groups'
                        in  [PhyloGroup]
acc [PhyloGroup] -> [PhyloGroup] -> [PhyloGroup]
forall a. [a] -> [a] -> [a]
++ [PhyloGroup
parent]) []
                  --  3) group the current groups by parentId
                  (Map PhyloGroupId [PhyloGroup] -> [PhyloGroup])
-> Map PhyloGroupId [PhyloGroup] -> [PhyloGroup]
forall a b. (a -> b) -> a -> b
$ ([PhyloGroup] -> [PhyloGroup] -> [PhyloGroup])
-> [(PhyloGroupId, [PhyloGroup])] -> Map PhyloGroupId [PhyloGroup]
forall k a. Ord k => (a -> a -> a) -> [(k, a)] -> Map k a
fromListWith [PhyloGroup] -> [PhyloGroup] -> [PhyloGroup]
forall a. [a] -> [a] -> [a]
(++) ([(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
getLevelParentId PhyloGroup
g, [PhyloGroup
g])) [PhyloGroup]
groups

        newPeriods :: Map (Int, Int) [PhyloGroup]
newPeriods = ([PhyloGroup] -> [PhyloGroup] -> [PhyloGroup])
-> [((Int, Int), [PhyloGroup])] -> Map (Int, Int) [PhyloGroup]
forall k a. Ord k => (a -> a -> a) -> [(k, a)] -> Map k a
fromListWith [PhyloGroup] -> [PhyloGroup] -> [PhyloGroup]
forall a. [a] -> [a] -> [a]
(++) ([((Int, Int), [PhyloGroup])] -> Map (Int, Int) [PhyloGroup])
-> [((Int, Int), [PhyloGroup])] -> Map (Int, Int) [PhyloGroup]
forall a b. (a -> b) -> a -> b
$ (PhyloGroup -> ((Int, Int), [PhyloGroup]))
-> [PhyloGroup] -> [((Int, Int), [PhyloGroup])]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
map (\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]
newGroups
    in  Phylo -> Phylo
traceSynchronyEnd 
      (Phylo -> Phylo) -> Phylo -> Phylo
forall a b. (a -> b) -> a -> b
$ ASetter Phylo Phylo PhyloLevel PhyloLevel
-> (PhyloLevel -> PhyloLevel) -> 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)
-> ((PhyloLevel -> Identity PhyloLevel)
    -> Map (Int, Int) PhyloPeriod
    -> Identity (Map (Int, Int) PhyloPeriod))
-> ASetter Phylo Phylo PhyloLevel PhyloLevel
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))
-> ((PhyloLevel -> Identity PhyloLevel)
    -> PhyloPeriod -> Identity PhyloPeriod)
-> (PhyloLevel -> Identity PhyloLevel)
-> 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)
-> ((PhyloLevel -> Identity PhyloLevel)
    -> Map ((Int, Int), Int) PhyloLevel
    -> Identity (Map ((Int, Int), Int) PhyloLevel))
-> (PhyloLevel -> Identity PhyloLevel)
-> 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
             --  6) update each period at curLvl + 1
             ((PhyloLevel -> Identity PhyloLevel)
 -> Map ((Int, Int), Int) PhyloLevel
 -> Identity (Map ((Int, Int), Int) PhyloLevel))
-> ((PhyloLevel -> Identity PhyloLevel)
    -> PhyloLevel -> Identity PhyloLevel)
-> (PhyloLevel -> Identity PhyloLevel)
-> Map ((Int, Int), Int) PhyloLevel
-> Identity (Map ((Int, Int), Int) PhyloLevel)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (PhyloLevel -> Bool)
-> (PhyloLevel -> Identity PhyloLevel)
-> PhyloLevel
-> Identity 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
curLvl Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1)))
             --  7) by adding the parents
             (\PhyloLevel
phyloLvl -> 
                if (Int, Int) -> Map (Int, Int) [PhyloGroup] -> Bool
forall k a. Ord k => k -> Map k a -> Bool
member (PhyloLevel
phyloLvl PhyloLevel
-> Getting (Int, Int) PhyloLevel (Int, Int) -> (Int, Int)
forall s a. s -> Getting a s a -> a
^. Getting (Int, Int) PhyloLevel (Int, Int)
Lens' PhyloLevel (Int, Int)
phylo_levelPeriod) Map (Int, Int) [PhyloGroup]
newPeriods
                    then PhyloLevel
phyloLvl PhyloLevel -> (PhyloLevel -> PhyloLevel) -> PhyloLevel
forall a b. a -> (a -> b) -> b
& (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)
-> Map PhyloGroupId PhyloGroup -> PhyloLevel -> PhyloLevel
forall s t a b. ASetter s t a b -> b -> s -> t
.~ [(PhyloGroupId, PhyloGroup)] -> Map PhyloGroupId PhyloGroup
forall k a. Ord k => [(k, a)] -> Map k a
fromList ((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] -> [(PhyloGroupId, PhyloGroup)])
-> [PhyloGroup] -> [(PhyloGroupId, PhyloGroup)]
forall a b. (a -> b) -> a -> b
$ Map (Int, Int) [PhyloGroup]
newPeriods Map (Int, Int) [PhyloGroup] -> (Int, Int) -> [PhyloGroup]
forall k a. Ord k => Map k a -> k -> a
! (PhyloLevel
phyloLvl PhyloLevel
-> Getting (Int, Int) PhyloLevel (Int, Int) -> (Int, Int)
forall s a. s -> Getting a s a -> a
^. Getting (Int, Int) PhyloLevel (Int, Int)
Lens' PhyloLevel (Int, Int)
phylo_levelPeriod))
                    else PhyloLevel
phyloLvl)
      --  2) add the curLvl + 1 phyloLevel to the phylo
      (Phylo -> Phylo) -> Phylo -> Phylo
forall a b. (a -> b) -> a -> b
$ Int -> Phylo -> Phylo
addPhyloLevel (Int
curLvl Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1)
      --  1) update the current groups (with level parent pointers) in the phylo
      (Phylo -> Phylo) -> Phylo -> Phylo
forall a b. (a -> b) -> a -> b
$ Int -> Map PhyloGroupId PhyloGroup -> Phylo -> Phylo
updatePhyloGroups Int
curLvl ([(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]
groups) Phylo
phylo 

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

toPairs :: SynchronyStrategy -> [PhyloGroup] -> [(PhyloGroup,PhyloGroup)]
toPairs :: SynchronyStrategy -> [PhyloGroup] -> [(PhyloGroup, PhyloGroup)]
toPairs SynchronyStrategy
strategy [PhyloGroup]
groups = case SynchronyStrategy
strategy of 
  SynchronyStrategy
MergeRegularGroups -> [PhyloGroup] -> [(PhyloGroup, PhyloGroup)]
pairs
                      ([PhyloGroup] -> [(PhyloGroup, PhyloGroup)])
-> [PhyloGroup] -> [(PhyloGroup, PhyloGroup)]
forall a b. (a -> b) -> a -> b
$ (PhyloGroup -> Bool) -> [PhyloGroup] -> [PhyloGroup]
forall a. (a -> Bool) -> [a] -> [a]
filter (\PhyloGroup
g -> (Double -> Bool) -> [Double] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (Double -> Double -> Bool
forall a. Eq a => a -> a -> Bool
== Double
3) ([Double] -> Bool) -> [Double] -> Bool
forall a b. (a -> b) -> a -> b
$ (PhyloGroup
g 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
"dynamics") [PhyloGroup]
groups
  SynchronyStrategy
MergeAllGroups -> [PhyloGroup] -> [(PhyloGroup, PhyloGroup)]
pairs [PhyloGroup]
groups
  where 
    pairs :: [PhyloGroup] -> [(PhyloGroup,PhyloGroup)]
    pairs :: [PhyloGroup] -> [(PhyloGroup, PhyloGroup)]
pairs [PhyloGroup]
gs = ((PhyloGroup, PhyloGroup) -> Bool)
-> [(PhyloGroup, PhyloGroup)] -> [(PhyloGroup, PhyloGroup)]
forall a. (a -> Bool) -> [a] -> [a]
filter (\(PhyloGroup
g,PhyloGroup
g') -> (Bool -> Bool
not (Bool -> Bool) -> ([Int] -> Bool) -> [Int] -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Int] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null) ([Int] -> Bool) -> [Int] -> Bool
forall a b. (a -> b) -> a -> b
$ [Int] -> [Int] -> [Int]
forall a. Eq a => [a] -> [a] -> [a]
intersect (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
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] -> [(PhyloGroup, PhyloGroup)]
forall a. [a] -> [(a, a)]
listToCombi' [PhyloGroup]
gs)


toDiamonds :: [PhyloGroup] -> [[PhyloGroup]]
toDiamonds :: [PhyloGroup] -> [[PhyloGroup]]
toDiamonds [PhyloGroup]
groups = ([[PhyloGroup]] -> [PhyloGroup] -> [[PhyloGroup]])
-> [[PhyloGroup]] -> [[PhyloGroup]] -> [[PhyloGroup]]
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' (\[[PhyloGroup]]
acc [PhyloGroup]
groups' ->
                        [[PhyloGroup]]
acc [[PhyloGroup]] -> [[PhyloGroup]] -> [[PhyloGroup]]
forall a. [a] -> [a] -> [a]
++ ( 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
$ ([PhyloGroup] -> Bool)
-> Map PhyloGroupId [PhyloGroup] -> Map PhyloGroupId [PhyloGroup]
forall a k. (a -> Bool) -> Map k a -> Map k a
Map.filter (\[PhyloGroup]
v -> [PhyloGroup] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [PhyloGroup]
v Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
1)
                               (Map PhyloGroupId [PhyloGroup] -> Map PhyloGroupId [PhyloGroup])
-> Map PhyloGroupId [PhyloGroup] -> Map PhyloGroupId [PhyloGroup]
forall a b. (a -> b) -> a -> b
$ ([PhyloGroup] -> [PhyloGroup] -> [PhyloGroup])
-> [(PhyloGroupId, [PhyloGroup])] -> Map PhyloGroupId [PhyloGroup]
forall k a. Ord k => (a -> a -> a) -> [(k, a)] -> Map k a
fromListWith [PhyloGroup] -> [PhyloGroup] -> [PhyloGroup]
forall a. [a] -> [a] -> [a]
(++)
                               ([(PhyloGroupId, [PhyloGroup])] -> Map PhyloGroupId [PhyloGroup])
-> [(PhyloGroupId, [PhyloGroup])] -> Map PhyloGroupId [PhyloGroup]
forall a b. (a -> b) -> a -> b
$ ([(PhyloGroupId, [PhyloGroup])]
 -> PhyloGroup -> [(PhyloGroupId, [PhyloGroup])])
-> [(PhyloGroupId, [PhyloGroup])]
-> [PhyloGroup]
-> [(PhyloGroupId, [PhyloGroup])]
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' (\[(PhyloGroupId, [PhyloGroup])]
acc' PhyloGroup
g -> 
                                    [(PhyloGroupId, [PhyloGroup])]
acc' [(PhyloGroupId, [PhyloGroup])]
-> [(PhyloGroupId, [PhyloGroup])] -> [(PhyloGroupId, [PhyloGroup])]
forall a. [a] -> [a] -> [a]
++ ((Pointer -> (PhyloGroupId, [PhyloGroup]))
-> [Pointer] -> [(PhyloGroupId, [PhyloGroup])]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
map (\(PhyloGroupId
id,Double
_) -> (PhyloGroupId
id,[PhyloGroup
g]) ) ([Pointer] -> [(PhyloGroupId, [PhyloGroup])])
-> [Pointer] -> [(PhyloGroupId, [PhyloGroup])]
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)) [] [PhyloGroup]
groups')) []
                  ([[PhyloGroup]] -> [[PhyloGroup]])
-> [[PhyloGroup]] -> [[PhyloGroup]]
forall a b. (a -> b) -> a -> b
$ 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
$ ([PhyloGroup] -> Bool)
-> Map PhyloGroupId [PhyloGroup] -> Map PhyloGroupId [PhyloGroup]
forall a k. (a -> Bool) -> Map k a -> Map k a
Map.filter (\[PhyloGroup]
v -> [PhyloGroup] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [PhyloGroup]
v Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
1)
                  (Map PhyloGroupId [PhyloGroup] -> Map PhyloGroupId [PhyloGroup])
-> Map PhyloGroupId [PhyloGroup] -> Map PhyloGroupId [PhyloGroup]
forall a b. (a -> b) -> a -> b
$ ([PhyloGroup] -> [PhyloGroup] -> [PhyloGroup])
-> [(PhyloGroupId, [PhyloGroup])] -> Map PhyloGroupId [PhyloGroup]
forall k a. Ord k => (a -> a -> a) -> [(k, a)] -> Map k a
fromListWith [PhyloGroup] -> [PhyloGroup] -> [PhyloGroup]
forall a. [a] -> [a] -> [a]
(++)
                  ([(PhyloGroupId, [PhyloGroup])] -> Map PhyloGroupId [PhyloGroup])
-> [(PhyloGroupId, [PhyloGroup])] -> Map PhyloGroupId [PhyloGroup]
forall a b. (a -> b) -> a -> b
$ ([(PhyloGroupId, [PhyloGroup])]
 -> PhyloGroup -> [(PhyloGroupId, [PhyloGroup])])
-> [(PhyloGroupId, [PhyloGroup])]
-> [PhyloGroup]
-> [(PhyloGroupId, [PhyloGroup])]
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' (\[(PhyloGroupId, [PhyloGroup])]
acc PhyloGroup
g -> [(PhyloGroupId, [PhyloGroup])]
acc [(PhyloGroupId, [PhyloGroup])]
-> [(PhyloGroupId, [PhyloGroup])] -> [(PhyloGroupId, [PhyloGroup])]
forall a. [a] -> [a] -> [a]
++ ((Pointer -> (PhyloGroupId, [PhyloGroup]))
-> [Pointer] -> [(PhyloGroupId, [PhyloGroup])]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
map (\(PhyloGroupId
id,Double
_) -> (PhyloGroupId
id,[PhyloGroup
g]) ) ([Pointer] -> [(PhyloGroupId, [PhyloGroup])])
-> [Pointer] -> [(PhyloGroupId, [PhyloGroup])]
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)  ) [] [PhyloGroup]
groups


groupsToEdges :: Proximity -> Synchrony -> Double -> Map Int Double -> [PhyloGroup] -> [((PhyloGroup,PhyloGroup),Double)]
groupsToEdges :: Proximity
-> Synchrony
-> Double
-> Map Int Double
-> [PhyloGroup]
-> [((PhyloGroup, PhyloGroup), Double)]
groupsToEdges Proximity
prox Synchrony
sync Double
nbDocs Map Int Double
diago [PhyloGroup]
groups =
    case Synchrony
sync of
        ByProximityThreshold  Double
thr Double
sens SynchronyScope
_ SynchronyStrategy
strat ->
            (((PhyloGroup, PhyloGroup), Double) -> Bool)
-> [((PhyloGroup, PhyloGroup), Double)]
-> [((PhyloGroup, PhyloGroup), Double)]
forall a. (a -> Bool) -> [a] -> [a]
filter (\((PhyloGroup, PhyloGroup)
_,Double
w) -> Double
w Double -> Double -> Bool
forall a. Ord a => a -> a -> Bool
>= Double
thr)
          ([((PhyloGroup, PhyloGroup), Double)]
 -> [((PhyloGroup, PhyloGroup), Double)])
-> [((PhyloGroup, PhyloGroup), Double)]
-> [((PhyloGroup, PhyloGroup), Double)]
forall a b. (a -> b) -> a -> b
$ Double
-> [(PhyloGroup, PhyloGroup)]
-> [((PhyloGroup, PhyloGroup), Double)]
toEdges Double
sens
          ([(PhyloGroup, PhyloGroup)]
 -> [((PhyloGroup, PhyloGroup), Double)])
-> [(PhyloGroup, PhyloGroup)]
-> [((PhyloGroup, PhyloGroup), Double)]
forall a b. (a -> b) -> a -> b
$ SynchronyStrategy -> [PhyloGroup] -> [(PhyloGroup, PhyloGroup)]
toPairs SynchronyStrategy
strat [PhyloGroup]
groups         
        ByProximityDistribution Double
sens SynchronyStrategy
strat -> 
            let diamonds :: [((PhyloGroup, PhyloGroup), Double)]
diamonds = (((PhyloGroup, PhyloGroup), Double) -> Double)
-> [((PhyloGroup, PhyloGroup), Double)]
-> [((PhyloGroup, PhyloGroup), Double)]
forall b a. Ord b => (a -> b) -> [a] -> [a]
sortOn ((PhyloGroup, PhyloGroup), Double) -> Double
forall a b. (a, b) -> b
snd 
                         ([((PhyloGroup, PhyloGroup), Double)]
 -> [((PhyloGroup, PhyloGroup), Double)])
-> [((PhyloGroup, PhyloGroup), Double)]
-> [((PhyloGroup, PhyloGroup), Double)]
forall a b. (a -> b) -> a -> b
$ Double
-> [(PhyloGroup, PhyloGroup)]
-> [((PhyloGroup, PhyloGroup), Double)]
toEdges Double
sens ([(PhyloGroup, PhyloGroup)]
 -> [((PhyloGroup, PhyloGroup), Double)])
-> [(PhyloGroup, PhyloGroup)]
-> [((PhyloGroup, PhyloGroup), Double)]
forall a b. (a -> b) -> a -> b
$ [[(PhyloGroup, PhyloGroup)]] -> [(PhyloGroup, PhyloGroup)]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
                         ([[(PhyloGroup, PhyloGroup)]] -> [(PhyloGroup, PhyloGroup)])
-> [[(PhyloGroup, PhyloGroup)]] -> [(PhyloGroup, PhyloGroup)]
forall a b. (a -> b) -> a -> b
$ ([PhyloGroup] -> [(PhyloGroup, PhyloGroup)])
-> [[PhyloGroup]] -> [[(PhyloGroup, PhyloGroup)]]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
map (\[PhyloGroup]
gs -> SynchronyStrategy -> [PhyloGroup] -> [(PhyloGroup, PhyloGroup)]
toPairs SynchronyStrategy
strat [PhyloGroup]
gs) ([[PhyloGroup]] -> [[(PhyloGroup, PhyloGroup)]])
-> [[PhyloGroup]] -> [[(PhyloGroup, PhyloGroup)]]
forall a b. (a -> b) -> a -> b
$ [PhyloGroup] -> [[PhyloGroup]]
toDiamonds [PhyloGroup]
groups 
             in Int
-> [((PhyloGroup, PhyloGroup), Double)]
-> [((PhyloGroup, PhyloGroup), Double)]
forall a. Int -> [a] -> [a]
take (Int -> Int -> Int
forall a. Integral a => a -> a -> a
div ([((PhyloGroup, PhyloGroup), Double)] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [((PhyloGroup, PhyloGroup), Double)]
diamonds) Int
2) [((PhyloGroup, PhyloGroup), Double)]
diamonds
    where 
        toEdges :: Double -> [(PhyloGroup,PhyloGroup)] -> [((PhyloGroup,PhyloGroup),Double)]
        toEdges :: Double
-> [(PhyloGroup, PhyloGroup)]
-> [((PhyloGroup, PhyloGroup), Double)]
toEdges Double
sens [(PhyloGroup, PhyloGroup)]
edges = 
            case Proximity
prox of
                WeightedLogJaccard Double
_ -> ((PhyloGroup, PhyloGroup) -> ((PhyloGroup, PhyloGroup), Double))
-> [(PhyloGroup, PhyloGroup)]
-> [((PhyloGroup, PhyloGroup), Double)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
map (\(PhyloGroup
g,PhyloGroup
g') -> 
                                                     ((PhyloGroup
g,PhyloGroup
g'), Double -> Double -> Map Int Double -> [Int] -> [Int] -> Double
weightedLogJaccard' (Double
sens) Double
nbDocs Map Int Double
diago
                                                                  (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
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, PhyloGroup)]
edges
                WeightedLogSim Double
_ -> ((PhyloGroup, PhyloGroup) -> ((PhyloGroup, PhyloGroup), Double))
-> [(PhyloGroup, PhyloGroup)]
-> [((PhyloGroup, PhyloGroup), Double)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
map (\(PhyloGroup
g,PhyloGroup
g') -> 
                                                     ((PhyloGroup
g,PhyloGroup
g'), Double -> Double -> Map Int Double -> [Int] -> [Int] -> Double
weightedLogJaccard' (Double
1 Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/ Double
sens) Double
nbDocs Map Int Double
diago
                                                                  (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
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, PhyloGroup)]
edges
                
                Proximity
_ -> [((PhyloGroup, PhyloGroup), Double)]
forall a. HasCallStack => a
undefined  

toParentId :: PhyloGroup -> PhyloGroupId
toParentId :: PhyloGroup -> PhyloGroupId
toParentId PhyloGroup
child = ((PhyloGroup
child 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
child PhyloGroup -> Getting Int PhyloGroup Int -> Int
forall s a. s -> Getting a s a -> a
^. Getting Int PhyloGroup Int
Lens' PhyloGroup Int
phylo_groupLevel Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1), PhyloGroup
child PhyloGroup -> Getting Int PhyloGroup Int -> Int
forall s a. s -> Getting a s a -> a
^. Getting Int PhyloGroup Int
Lens' PhyloGroup Int
phylo_groupIndex) 


reduceGroups :: Proximity -> Synchrony -> Map Date Double -> Map Date Cooc -> [PhyloGroup] -> [PhyloGroup]
reduceGroups :: Proximity
-> Synchrony
-> Map Int Double
-> Map Int Cooc
-> [PhyloGroup]
-> [PhyloGroup]
reduceGroups Proximity
prox Synchrony
sync Map Int Double
docs Map Int Cooc
diagos [PhyloGroup]
branch =
    --  1) reduce a branch as a set of periods & groups
    let periods :: Map (Int, Int) [PhyloGroup]
periods = ([PhyloGroup] -> [PhyloGroup] -> [PhyloGroup])
-> [((Int, Int), [PhyloGroup])] -> Map (Int, Int) [PhyloGroup]
forall k a. Ord k => (a -> a -> a) -> [(k, a)] -> Map k a
fromListWith [PhyloGroup] -> [PhyloGroup] -> [PhyloGroup]
forall a. [a] -> [a] -> [a]
(++)
                 ([((Int, Int), [PhyloGroup])] -> Map (Int, Int) [PhyloGroup])
-> [((Int, Int), [PhyloGroup])] -> Map (Int, Int) [PhyloGroup]
forall a b. (a -> b) -> a -> b
$ (PhyloGroup -> ((Int, Int), [PhyloGroup]))
-> [PhyloGroup] -> [((Int, Int), [PhyloGroup])]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
map (\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]
branch
    in  ([[PhyloGroup]] -> [PhyloGroup]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ([[PhyloGroup]] -> [PhyloGroup])
-> (Map (Int, Int) [[PhyloGroup]] -> [[PhyloGroup]])
-> Map (Int, Int) [[PhyloGroup]]
-> [PhyloGroup]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [[[PhyloGroup]]] -> [[PhyloGroup]]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ([[[PhyloGroup]]] -> [[PhyloGroup]])
-> (Map (Int, Int) [[PhyloGroup]] -> [[[PhyloGroup]]])
-> Map (Int, Int) [[PhyloGroup]]
-> [[PhyloGroup]]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Map (Int, Int) [[PhyloGroup]] -> [[[PhyloGroup]]]
forall k a. Map k a -> [a]
elems)
      (Map (Int, Int) [[PhyloGroup]] -> [PhyloGroup])
-> Map (Int, Int) [[PhyloGroup]] -> [PhyloGroup]
forall a b. (a -> b) -> a -> b
$ ((Int, Int) -> [PhyloGroup] -> [[PhyloGroup]])
-> Map (Int, Int) [PhyloGroup] -> Map (Int, Int) [[PhyloGroup]]
forall k a b. (k -> a -> b) -> Map k a -> Map k b
mapWithKey (\(Int, Int)
prd [PhyloGroup]
groups -> 
            --  2) for each period, transform the groups as a proximity graph filtered by a threshold
            let diago :: Map Int Double
diago = Map Int Cooc -> Map Int Double
reduceDiagos (Map Int Cooc -> Map Int Double) -> Map Int Cooc -> Map Int Double
forall a b. (a -> b) -> a -> b
$ Map Int Cooc -> [(Int, Int)] -> Map Int Cooc
filterDiago Map Int Cooc
diagos [(Int, Int)
prd]
                edges :: [((PhyloGroup, PhyloGroup), Double)]
edges = Proximity
-> Synchrony
-> Double
-> Map Int Double
-> [PhyloGroup]
-> [((PhyloGroup, PhyloGroup), Double)]
groupsToEdges Proximity
prox Synchrony
sync (([Double] -> Double
forall (f :: * -> *) a. (Foldable f, Num a) => f a -> a
sum ([Double] -> Double)
-> (Map Int Double -> [Double]) -> Map Int Double -> Double
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Map Int Double -> [Double]
forall k a. Map k a -> [a]
elems) (Map Int Double -> Double) -> Map Int Double -> Double
forall a b. (a -> b) -> a -> b
$ Map Int Double -> Set Int -> Map Int Double
forall k a. Ord k => Map k a -> Set k -> Map k a
restrictKeys Map Int Double
docs (Set Int -> Map Int Double) -> Set Int -> Map Int Double
forall a b. (a -> b) -> a -> b
$ [(Int, Int)] -> Set Int
periodsToYears [(Int, Int)
prd]) Map Int Double
diago [PhyloGroup]
groups
             in ([PhyloGroup] -> [PhyloGroup]) -> [[PhyloGroup]] -> [[PhyloGroup]]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
map (\[PhyloGroup]
comp -> 
                    --  4) add to each groups their futur level parent group
                    let parentId :: PhyloGroupId
parentId = PhyloGroup -> PhyloGroupId
toParentId (Text -> [PhyloGroup] -> PhyloGroup
forall a. Text -> [a] -> a
head' Text
"parentId" [PhyloGroup]
comp)
                    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
& ([Pointer] -> Identity [Pointer])
-> PhyloGroup -> Identity PhyloGroup
Lens' PhyloGroup [Pointer]
phylo_groupLevelParents (([Pointer] -> Identity [Pointer])
 -> PhyloGroup -> Identity PhyloGroup)
-> ([Pointer] -> [Pointer]) -> PhyloGroup -> PhyloGroup
forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
%~ ([Pointer] -> [Pointer] -> [Pointer]
forall a. [a] -> [a] -> [a]
++ [(PhyloGroupId
parentId,Double
1)]) ) [PhyloGroup]
comp )
                -- 3) reduce the graph a a set of related components
              ([[PhyloGroup]] -> [[PhyloGroup]])
-> [[PhyloGroup]] -> [[PhyloGroup]]
forall a b. (a -> b) -> a -> b
$ [PhyloGroup]
-> [((PhyloGroup, PhyloGroup), Double)] -> [[PhyloGroup]]
toRelatedComponents [PhyloGroup]
groups [((PhyloGroup, PhyloGroup), Double)]
edges) Map (Int, Int) [PhyloGroup]
periods 


adjustClustering :: Synchrony -> [[PhyloGroup]] -> [[PhyloGroup]]
adjustClustering :: Synchrony -> [[PhyloGroup]] -> [[PhyloGroup]]
adjustClustering Synchrony
sync [[PhyloGroup]]
branches = case Synchrony
sync of
  ByProximityThreshold Double
_ Double
_ SynchronyScope
scope SynchronyStrategy
_ -> case SynchronyScope
scope of 
      SynchronyScope
SingleBranch -> [[PhyloGroup]]
branches
      SynchronyScope
SiblingBranches -> (PhyloGroup -> PhyloGroup -> Bool)
-> [PhyloGroup] -> [[PhyloGroup]]
forall a. (a -> a -> Bool) -> [a] -> [[a]]
groupBy (\PhyloGroup
g PhyloGroup
g' -> (Text -> [Double] -> Double
forall a. Text -> [a] -> a
last' Text
"adjustClustering" ([Double] -> Double) -> [Double] -> Double
forall a b. (a -> b) -> a -> b
$ (PhyloGroup
g  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") 
                                        Double -> Double -> Bool
forall a. Eq a => a -> a -> Bool
== (Text -> [Double] -> Double
forall a. Text -> [a] -> a
last' Text
"adjustClustering" ([Double] -> Double) -> [Double] -> Double
forall a b. (a -> b) -> a -> b
$ (PhyloGroup
g' 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"))
                       ([PhyloGroup] -> [[PhyloGroup]]) -> [PhyloGroup] -> [[PhyloGroup]]
forall a b. (a -> b) -> a -> b
$ (PhyloGroup -> PhyloBranchId) -> [PhyloGroup] -> [PhyloGroup]
forall b a. Ord b => (a -> b) -> [a] -> [a]
sortOn PhyloGroup -> PhyloBranchId
_phylo_groupBranchId ([PhyloGroup] -> [PhyloGroup]) -> [PhyloGroup] -> [PhyloGroup]
forall a b. (a -> b) -> a -> b
$ [[PhyloGroup]] -> [PhyloGroup]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[PhyloGroup]]
branches
      SynchronyScope
AllBranches -> [[[PhyloGroup]] -> [PhyloGroup]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[PhyloGroup]]
branches]
  ByProximityDistribution Double
_ SynchronyStrategy
_ -> [[PhyloGroup]]
branches


levelUpAncestors :: [PhyloGroup] -> [PhyloGroup]
levelUpAncestors :: [PhyloGroup] -> [PhyloGroup]
levelUpAncestors [PhyloGroup]
groups =
  -- 1) create an associative map of (old,new) ids
  let ids' :: Map PhyloGroupId PhyloGroupId
ids' = [(PhyloGroupId, PhyloGroupId)] -> Map PhyloGroupId PhyloGroupId
forall k a. Ord k => [(k, a)] -> Map k a
fromList ([(PhyloGroupId, PhyloGroupId)] -> Map PhyloGroupId PhyloGroupId)
-> [(PhyloGroupId, PhyloGroupId)] -> Map PhyloGroupId PhyloGroupId
forall a b. (a -> b) -> a -> b
$ (PhyloGroup -> (PhyloGroupId, PhyloGroupId))
-> [PhyloGroup] -> [(PhyloGroupId, PhyloGroupId)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
map (\PhyloGroup
g -> (PhyloGroup -> PhyloGroupId
getGroupId 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
"levelUpAncestors" ( 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))) [PhyloGroup]
groups 
   in (PhyloGroup -> PhyloGroup) -> [PhyloGroup] -> [PhyloGroup]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
map (\PhyloGroup
g -> 
        let id' :: PhyloGroupId
id' = Map PhyloGroupId PhyloGroupId
ids' Map PhyloGroupId PhyloGroupId -> PhyloGroupId -> PhyloGroupId
forall k a. Ord k => Map k a -> k -> a
! (PhyloGroup -> PhyloGroupId
getGroupId PhyloGroup
g)
            ancestors :: [Pointer]
ancestors  = 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
            -- 2) level up the ancestors ids and filter the ones that will be merged
            ancestors' :: [Pointer]
ancestors' = (Pointer -> Bool) -> [Pointer] -> [Pointer]
forall a. (a -> Bool) -> [a] -> [a]
filter (\(PhyloGroupId
id,Double
_) -> PhyloGroupId
id PhyloGroupId -> PhyloGroupId -> Bool
forall a. Eq a => a -> a -> Bool
/= PhyloGroupId
id') ([Pointer] -> [Pointer]) -> [Pointer] -> [Pointer]
forall a b. (a -> b) -> a -> b
$ (Pointer -> Pointer) -> [Pointer] -> [Pointer]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
map (\(PhyloGroupId
id,Double
w) -> (Map PhyloGroupId PhyloGroupId
ids' Map PhyloGroupId PhyloGroupId -> PhyloGroupId -> PhyloGroupId
forall k a. Ord k => Map k a -> k -> a
! PhyloGroupId
id,Double
w)) [Pointer]
ancestors 
         in PhyloGroup
g PhyloGroup -> (PhyloGroup -> PhyloGroup) -> PhyloGroup
forall a b. a -> (a -> b) -> b
& ([Pointer] -> Identity [Pointer])
-> PhyloGroup -> Identity PhyloGroup
Lens' PhyloGroup [Pointer]
phylo_groupAncestors (([Pointer] -> Identity [Pointer])
 -> PhyloGroup -> Identity PhyloGroup)
-> [Pointer] -> PhyloGroup -> PhyloGroup
forall s t a b. ASetter s t a b -> b -> s -> t
.~ [Pointer]
ancestors'
      ) [PhyloGroup]
groups

synchronicClustering :: Phylo -> Phylo
synchronicClustering :: Phylo -> Phylo
synchronicClustering Phylo
phylo =
    let prox :: Proximity
prox = Config -> Proximity
phyloProximity (Config -> Proximity) -> Config -> Proximity
forall a b. (a -> b) -> a -> b
$ Phylo -> Config
getConfig Phylo
phylo
        sync :: Synchrony
sync = Config -> Synchrony
phyloSynchrony (Config -> Synchrony) -> Config -> Synchrony
forall a b. (a -> b) -> a -> b
$ Phylo -> Config
getConfig Phylo
phylo
        docs :: Map Int Double
docs = Phylo
phylo Phylo
-> Getting (Map Int Double) Phylo (Map Int Double)
-> Map Int Double
forall s a. s -> Getting a s a -> a
^. Getting (Map Int Double) Phylo (Map Int Double)
Lens' Phylo (Map Int Double)
phylo_timeDocs
        diagos :: Map Int Cooc
diagos = (Cooc -> Cooc) -> Map Int Cooc -> Map Int Cooc
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
map Cooc -> Cooc
coocToDiago (Map Int Cooc -> Map Int Cooc) -> Map Int Cooc -> Map Int Cooc
forall a b. (a -> b) -> a -> b
$ Phylo
phylo Phylo
-> Getting (Map Int Cooc) Phylo (Map Int Cooc) -> Map Int Cooc
forall s a. s -> Getting a s a -> a
^. Getting (Map Int Cooc) Phylo (Map Int Cooc)
Lens' Phylo (Map Int Cooc)
phylo_timeCooc
        newBranches :: [[PhyloGroup]]
newBranches  = ([PhyloGroup] -> [PhyloGroup]) -> [[PhyloGroup]] -> [[PhyloGroup]]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
map (\[PhyloGroup]
branch -> Proximity
-> Synchrony
-> Map Int Double
-> Map Int Cooc
-> [PhyloGroup]
-> [PhyloGroup]
reduceGroups Proximity
prox Synchrony
sync Map Int Double
docs Map Int Cooc
diagos [PhyloGroup]
branch) 
                     ([[PhyloGroup]] -> [[PhyloGroup]])
-> [[PhyloGroup]] -> [[PhyloGroup]]
forall a b. (a -> b) -> a -> b
$ ([PhyloGroup] -> [PhyloGroup]) -> [[PhyloGroup]] -> [[PhyloGroup]]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
map [PhyloGroup] -> [PhyloGroup]
processDynamics
                     ([[PhyloGroup]] -> [[PhyloGroup]])
-> [[PhyloGroup]] -> [[PhyloGroup]]
forall a b. (a -> b) -> a -> b
$ Synchrony -> [[PhyloGroup]] -> [[PhyloGroup]]
adjustClustering Synchrony
sync
                     ([[PhyloGroup]] -> [[PhyloGroup]])
-> [[PhyloGroup]] -> [[PhyloGroup]]
forall a b. (a -> b) -> a -> b
$ Phylo -> [[PhyloGroup]]
phyloToLastBranches 
                     (Phylo -> [[PhyloGroup]]) -> Phylo -> [[PhyloGroup]]
forall a b. (a -> b) -> a -> b
$ Phylo -> Phylo
traceSynchronyStart Phylo
phylo
        newBranches' :: [[PhyloGroup]]
newBranches' = [[PhyloGroup]]
newBranches [[PhyloGroup]] -> Strategy [[PhyloGroup]] -> [[PhyloGroup]]
forall a. a -> Strategy a -> a
`using` Strategy [PhyloGroup] -> Strategy [[PhyloGroup]]
forall a. Strategy a -> Strategy [a]
parList Strategy [PhyloGroup]
forall a. NFData a => Strategy a
rdeepseq
     in Phylo -> [PhyloGroup] -> Phylo
toNextLevel' Phylo
phylo ([PhyloGroup] -> Phylo) -> [PhyloGroup] -> Phylo
forall a b. (a -> b) -> a -> b
$ [PhyloGroup] -> [PhyloGroup]
levelUpAncestors ([PhyloGroup] -> [PhyloGroup]) -> [PhyloGroup] -> [PhyloGroup]
forall a b. (a -> b) -> a -> b
$ [[PhyloGroup]] -> [PhyloGroup]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[PhyloGroup]]
newBranches'


-- synchronicDistance :: Phylo -> Level -> String
-- synchronicDistance phylo lvl = 
--     foldl' (\acc branch -> 
--              acc <> (foldl' (\acc' period ->
--                               acc' <> let prox  = phyloProximity $ getConfig phylo
--                                           sync  = phyloSynchrony $ getConfig phylo
--                                           docs  = _phylo_timeDocs phylo
--                                           prd   = _phylo_groupPeriod $ head' "distance" period
--                                           edges = groupsToEdges prox 0.1 (_bpt_sensibility sync) 
--                                                   ((sum . elems) $ restrictKeys docs $ periodsToYears [_phylo_groupPeriod $ head' "distance" period]) period
--                                       in foldl' (\mem (_,w) -> 
--                                           mem <> show (prd)
--                                               <> "\t"
--                                               <> show (w)
--                                               <> "\n"
--                                         ) "" edges 
--                      ) ""  $ elems $ groupByField _phylo_groupPeriod branch)
--     ) "period\tdistance\n" $ elems $ groupByField _phylo_groupBranchId $ getGroupsFromLevel lvl phylo