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 Debug.Trace (trace)
import Control.Lens hiding (Level)
+import Control.Monad (sequence)
import Control.Parallel.Strategies (parList, rdeepseq, using)
--- import Debug.Trace (trace)
-
+import Data.List ((++), null, intersect, nub, concat, sort, sortOn, groupBy)
+import Data.Map (Map, fromList, fromListWith, foldlWithKey, (!), insert, empty, restrictKeys, elems, mapWithKey, member)
+import Gargantext.Core.Viz.Phylo
+import Gargantext.Core.Viz.Phylo.PhyloExport (processDynamics)
+import Gargantext.Core.Viz.Phylo.PhyloTools
+import Gargantext.Core.Viz.Phylo.TemporalMatching (weightedLogJaccard', filterDiago, reduceDiagos)
+import Gargantext.Prelude
import qualified Data.Map as Map
-- | New Level Maker | --
-------------------------
-
mergeGroups :: [Cooc] -> PhyloGroupId -> Map PhyloGroupId PhyloGroupId -> [PhyloGroup] -> PhyloGroup
mergeGroups coocs id mapIds childs =
let ngrams = (sort . nub . concat) $ map _phylo_groupNgrams childs
- in PhyloGroup (fst $ fst id) (snd $ fst id) (snd id) ""
- (sum $ map _phylo_groupSupport childs) ngrams
+ in PhyloGroup (fst $ fst id) (_phylo_groupPeriod' $ head' "mergeGroups" childs)
+ (snd $ fst id) (snd id) ""
+ (sum $ map _phylo_groupSupport childs)
+ (fmap sum $ sequence
+ $ map _phylo_groupWeight childs)
+ (concat $ map _phylo_groupSources childs)
+ ngrams
(ngramsToCooc ngrams coocs)
((snd $ fst id),bId)
(mergeMeta bId childs) [] (map (\g -> (getGroupId g, 1)) childs)
(updatePointers $ concat $ map _phylo_groupPeriodParents childs)
(updatePointers $ concat $ map _phylo_groupPeriodChilds childs)
(mergeAncestors $ concat $ map _phylo_groupAncestors childs)
+ (updatePointers' $ concat $ map _phylo_groupPeriodMemoryParents childs)
+ (updatePointers' $ concat $ map _phylo_groupPeriodMemoryChilds childs)
where
--------------------
bId :: [Int]
--------------------
updatePointers :: [Pointer] -> [Pointer]
updatePointers pointers = map (\(pId,w) -> (mapIds ! pId,w)) pointers
+ updatePointers' :: [Pointer'] -> [Pointer']
+ updatePointers' pointers = map (\(pId,(t,w)) -> (mapIds ! pId,(t,w))) pointers
--------------------
mergeAncestors :: [Pointer] -> [Pointer]
mergeAncestors pointers = Map.toList $ fromListWith max pointers
-
addPhyloLevel :: Level -> Phylo -> Phylo
addPhyloLevel lvl phylo =
over ( phylo_periods . traverse )
(\phyloPrd -> phyloPrd & phylo_periodLevels
- %~ (insert (phyloPrd ^. phylo_periodPeriod, lvl) (PhyloLevel (phyloPrd ^. phylo_periodPeriod) lvl empty))) phylo
+ %~ (insert (phyloPrd ^. phylo_periodPeriod, lvl)
+ (PhyloLevel (phyloPrd ^. phylo_periodPeriod) (phyloPrd ^. phylo_periodPeriod') lvl empty))) phylo
toNextLevel' :: Phylo -> [PhyloGroup] -> Phylo
toEdges sens edges =
case prox of
WeightedLogJaccard _ -> map (\(g,g') ->
+ ((g,g'), weightedLogJaccard' (sens) nbDocs diago
+ (g ^. phylo_groupNgrams) (g' ^. phylo_groupNgrams))) edges
+ WeightedLogSim _ -> map (\(g,g') ->
((g,g'), weightedLogJaccard' (1 / sens) nbDocs diago
(g ^. phylo_groupNgrams) (g' ^. phylo_groupNgrams))) edges
+
_ -> undefined
toParentId :: PhyloGroup -> PhyloGroupId