hard core refactoring

src/Gargantext/Viz/Phylo.hs

@@ -183,10 +183,6 @@ data Document = Document
 type Cluster = [PhyloGroup]
 
 
-class AppendToPhylo a where
-    addPhyloLevel  :: Level -> Map (Date,Date) [a] -> Phylo -> Phylo
-    initPhyloGroup :: a -> PhyloGroup
-
 -- | A List of PhyloGroup in a PhyloGraph
 type PhyloNodes = [PhyloGroup]
 -- | A List of weighted links between some PhyloGroups in a PhyloGraph

src/Gargantext/Viz/Phylo/Aggregates/Cluster.hs

+{-|
+Module      : Gargantext.Viz.Phylo.Tools
+Description : Phylomemy Tools to build/manage it
+Copyright   : (c) CNRS, 2017-Present
+License     : AGPL + CECILL v3
+Maintainer  : team@gargantext.org
+Stability   : experimental
+Portability : POSIX
+
+
+-}
+
+{-# LANGUAGE NoImplicitPrelude #-}
+{-# LANGUAGE FlexibleContexts  #-}
+{-# LANGUAGE OverloadedStrings #-}
+
+module Gargantext.Viz.Phylo.Aggregates.Cluster
+  where
+
+import Data.List        (last,head,union,concat,null,nub,(++),init,tail,(!!))
+import Data.Map         (Map,elems,adjust,unionWith,intersectionWith)
+import Data.Set         (Set)
+import Data.Tuple       (fst, snd)
+
+import Gargantext.Prelude             hiding (head)
+import Gargantext.Viz.Phylo
+import Gargantext.Viz.Phylo.Tools
+import Gargantext.Viz.Phylo.BranchMaker
+import Gargantext.Viz.Phylo.Metrics.Proximity
+import Gargantext.Viz.Phylo.Metrics.Clustering
+
+import qualified Data.List   as List
+import qualified Data.Map    as Map
+import qualified Data.Set    as Set
+
+
+-- | To apply a Clustering method to a PhyloGraph
+graphToClusters :: (Clustering,[Double]) -> PhyloGraph -> [[PhyloGroup]]
+graphToClusters (clust,param) (nodes,edges) = case clust of 
+  Louvain           -> undefined
+  RelatedComponents -> relatedComp 0 (head nodes) (tail nodes,edges) [] []   
+
+
+-- | To transform a Phylo into Clusters of PhyloGroups at a given level
+phyloToClusters :: Level -> (Proximity,[Double]) -> (Clustering,[Double]) -> Phylo -> Map (Date,Date) [[PhyloGroup]]
+phyloToClusters lvl (prox,param) (clus,param') p = Map.fromList 
+                                                 $ zip (getPhyloPeriods p) 
+                                                       (map (\prd -> let graph = groupsToGraph (prox,param) (getGroupsWithFilters lvl prd p) p
+                                                                     in if null (fst graph) 
+                                                                        then []
+                                                                        else graphToClusters (clus,param') graph) 
+                                                       (getPhyloPeriods p))
\ No newline at end of file

src/Gargantext/Viz/Phylo/Aggregates/Cooc.hs

+{-|
+Module      : Gargantext.Viz.Phylo.Tools
+Description : Phylomemy Tools to build/manage it
+Copyright   : (c) CNRS, 2017-Present
+License     : AGPL + CECILL v3
+Maintainer  : team@gargantext.org
+Stability   : experimental
+Portability : POSIX
+
+
+-}
+
+{-# LANGUAGE NoImplicitPrelude #-}
+{-# LANGUAGE FlexibleContexts  #-}
+{-# LANGUAGE OverloadedStrings #-}
+
+module Gargantext.Viz.Phylo.Aggregates.Cooc
+  where
+
+import Data.List        (last,head,union,concat)
+import Data.Map         (Map, elems, adjust)
+import Data.Set         (Set)
+import Data.Tuple       (fst, snd)
+
+import Gargantext.Prelude                       hiding (head)
+import Gargantext.Viz.Phylo
+import Gargantext.Viz.Phylo.Tools
+
+import qualified Data.List   as List
+import qualified Data.Map    as Map
+import qualified Data.Set    as Set
+
+
+
+-- | To transform the Fis into a coocurency Matrix in a Phylo 
+fisToCooc :: Map (Date, Date) [Fis] -> Phylo -> Map (Int, Int) Double
+fisToCooc m p = map   (/docs)
+              $ foldl (\mem x -> adjust (+1) (getKeyPair x mem) mem) cooc
+              $ concat
+              $ map (\x -> listToUnDirectedCombiWith (\x -> ngramsToIdx x p) $ (Set.toList . fst) x) 
+              $ (concat . elems) m
+  where
+    --------------------------------------
+    fisNgrams :: [Ngrams]
+    fisNgrams = foldl (\mem x -> union mem $ (Set.toList . fst) x) [] $ (concat . elems) m
+    --------------------------------------
+    docs :: Double
+    docs = fromIntegral $ foldl (\mem x -> mem + (snd x)) 0 $ (concat . elems) m
+    --------------------------------------
+    cooc :: Map (Int, Int) (Double)
+    cooc = Map.fromList $ map (\x -> (x,0)) (listToUnDirectedCombiWith (\x -> ngramsToIdx x p) fisNgrams)
+    --------------------------------------
\ No newline at end of file

src/Gargantext/Viz/Phylo/Aggregates/Document.hs

+{-|
+Module      : Gargantext.Viz.Phylo.Tools
+Description : Phylomemy Tools to build/manage it
+Copyright   : (c) CNRS, 2017-Present
+License     : AGPL + CECILL v3
+Maintainer  : team@gargantext.org
+Stability   : experimental
+Portability : POSIX
+
+
+-}
+
+{-# LANGUAGE NoImplicitPrelude #-}
+{-# LANGUAGE FlexibleContexts  #-}
+{-# LANGUAGE OverloadedStrings #-}
+
+module Gargantext.Viz.Phylo.Aggregates.Document
+  where
+
+import Data.List        (last,head)
+import Data.Map         (Map)
+import Data.Text        (Text, unwords, toLower, words)
+import Data.Tuple       (fst, snd)
+import Data.Tuple.Extra
+import Data.Vector      (Vector)
+
+import Gargantext.Prelude                       hiding (head)
+import Gargantext.Text.Terms.Mono               (monoTexts)
+import Gargantext.Viz.Phylo
+import Gargantext.Viz.Phylo.Tools
+
+import qualified Data.List   as List
+import qualified Data.Map    as Map
+import qualified Data.Vector as Vector   
+
+
+-- | To init a set of periods out of a given Grain and Step 
+docsToPeriods :: (Ord date, Enum date) => (doc -> date)
+     -> Grain -> Step -> [doc] -> Map (date, date) [doc]
+docsToPeriods _ _ _ [] = panic "[ERR][Viz.Phylo.Example.docsToPeriods] Empty [Documents] can not have any periods"
+docsToPeriods f g s es = Map.fromList $ zip hs $ map (inPeriode f es) hs
+  where
+    --------------------------------------
+    hs = steps g s $ both f (head es, last es)
+    --------------------------------------
+    inPeriode :: Ord b => (t -> b) -> [t] -> (b, b) -> [t]
+    inPeriode f' h (start,end) =
+      fst $ List.partition (\d -> f' d >= start && f' d <= end) h
+    --------------------------------------
+    steps :: (Eq date, Enum date) => Grain -> Step -> (date, date) -> [(date, date)]
+    steps s' o' (start,end) = map (\l -> (head l, last l))
+                          $ chunkAlong s' o' [start .. end]
+    --------------------------------------
+
+
+-- | To parse a list of Documents by filtering on a Vector of Ngrams 
+parseDocs :: PhyloNgrams -> [Document] -> [Document]
+parseDocs l docs = map (\(Document d t) 
+                        -> Document d ( unwords 
+                                      $ filter (\x -> Vector.elem x l)
+                                      $ monoTexts t)) docs
+
+
+-- | To group a list of Documents by fixed periods
+groupDocsByPeriod :: Grain -> Step -> [Document] -> PhyloNgrams -> Map (Date, Date) [Document]
+groupDocsByPeriod g s docs ngrams = docsToPeriods date g s $ parseDocs ngrams docs 
+
+
+-- | To transform a corpus of texts into a structured list of Documents
+corpusToDocs :: [(Date, Text)] -> [Document]
+corpusToDocs l = map (\(d,t) -> Document d t) l 
\ No newline at end of file

src/Gargantext/Viz/Phylo/Aggregates/Fis.hs

+{-|
+Module      : Gargantext.Viz.Phylo.Tools
+Description : Phylomemy Tools to build/manage it
+Copyright   : (c) CNRS, 2017-Present
+License     : AGPL + CECILL v3
+Maintainer  : team@gargantext.org
+Stability   : experimental
+Portability : POSIX
+
+
+-}
+
+{-# LANGUAGE NoImplicitPrelude #-}
+{-# LANGUAGE FlexibleContexts  #-}
+{-# LANGUAGE OverloadedStrings #-}
+
+module Gargantext.Viz.Phylo.Aggregates.Fis
+  where
+
+import Data.List        (last,head)
+import Data.Map         (Map)
+import Data.Text        (Text, unwords, toLower, words)
+import Data.Tuple       (fst, snd)
+import Data.Tuple.Extra
+import Data.Vector      (Vector)
+
+import Gargantext.Prelude                       hiding (head)
+import Gargantext.Text.Metrics.FrequentItemSet  (fisWithSizePolyMap, Size(..))
+import Gargantext.Text.Terms.Mono               (monoTexts)
+import Gargantext.Viz.Phylo
+import Gargantext.Viz.Phylo.Tools
+
+import qualified Data.List   as List
+import qualified Data.Map    as Map
+import qualified Data.Vector as Vector 
+
+
+-- | To Filter Fis by support 
+filterFisBySupport :: Bool -> Int -> Map (Date, Date) [Fis] -> Map (Date, Date) [Fis]
+filterFisBySupport empty min m = case empty of
+  True  -> Map.map (\l -> filterMinorFis min l) m
+  False -> Map.map (\l -> keepFilled (filterMinorFis) min l) m
+
+
+-- | To filter Fis with small Support, to preserve nonempty periods please use : filterFisBySupport False
+filterMinorFis :: Int -> [Fis] -> [Fis]
+filterMinorFis min l = filter (\fis -> snd fis > min) l
+
+
+-- | To filter nested Fis 
+filterFisByNested :: Map (Date, Date) [Fis] -> Map (Date, Date) [Fis]
+filterFisByNested = map (\l -> let cliqueMax = filterNestedSets (head $ map fst l) (map fst l) []
+                               in  filter (\fis -> elem (fst fis) cliqueMax) l)
+
+
+-- | To transform a list of Documents into a Frequent Items Set 
+docsToFis :: Map (Date, Date) [Document] -> Map (Date, Date) [Fis]
+docsToFis docs = map (\d -> Map.toList 
+                          $ fisWithSizePolyMap (Segment 1 20) 1 (map (words . text) d)) docs
\ No newline at end of file

src/Gargantext/Viz/Phylo/BranchMaker.hs

+{-|
+Module      : Gargantext.Viz.Phylo.Tools
+Description : Phylomemy Tools to build/manage it
+Copyright   : (c) CNRS, 2017-Present
+License     : AGPL + CECILL v3
+Maintainer  : team@gargantext.org
+Stability   : experimental
+Portability : POSIX
+
+
+-}
+
+{-# LANGUAGE NoImplicitPrelude #-}
+{-# LANGUAGE FlexibleContexts  #-}
+{-# LANGUAGE OverloadedStrings #-}
+
+module Gargantext.Viz.Phylo.BranchMaker
+  where
+
+import Data.List        (last,head,union,concat,null,nub,(++),init,tail,(!!))
+import Data.Map         (Map,elems,adjust,unionWith,intersectionWith)
+import Data.Set         (Set)
+import Data.Tuple       (fst, snd)
+
+import Gargantext.Prelude             hiding (head)
+import Gargantext.Viz.Phylo
+import Gargantext.Viz.Phylo.Tools
+import Gargantext.Viz.Phylo.Metrics.Proximity
+import Gargantext.Viz.Phylo.Metrics.Clustering
+
+import qualified Data.List   as List
+import qualified Data.Map    as Map
+import qualified Data.Set    as Set
+
+
+-- | To transform a PhyloGraph into a list of PhyloBranches by using the relatedComp clustering
+graphToBranches :: Level -> PhyloGraph -> Phylo -> [PhyloBranch]
+graphToBranches lvl (nodes,edges) p = map (\(idx,c) -> PhyloBranch (lvl,idx) "" (map getGroupId c)) 
+                                    $ zip [0..] 
+                                    $ relatedComp 0 (head nodes) (tail nodes,edges) [] []
+
+
+-- | To transform a list of PhyloGroups into a PhyloGraph by using a given Proximity mesure
+groupsToGraph :: (Proximity,[Double]) -> [PhyloGroup] -> Phylo -> PhyloGraph
+groupsToGraph (prox,param) groups p = (groups,edges)
+  where 
+    edges :: PhyloEdges
+    edges = case prox of  
+      FromPairs          -> (nub . concat) $ map (\g -> (map (\g' -> ((g',g),1)) $ getGroupParents g p)
+                                                        ++
+                                                        (map (\g' -> ((g,g'),1)) $ getGroupChilds g p)) groups 
+      WeightedLogJaccard -> map (\(x,y) -> ((x,y), weightedLogJaccard 
+                                                   (param !! 0) (getGroupCooc x) 
+                                                   (unifySharedKeys (getGroupCooc x) (getGroupCooc y)))) $ listToDirectedCombi groups
+      _                  -> undefined 
+
+
+-- | To set all the PhyloBranches for a given Level in a Phylo
+setPhyloBranches :: Level -> Phylo -> Phylo 
+setPhyloBranches lvl p = alterPhyloBranches (\l -> l ++ (graphToBranches lvl (groupsToGraph (FromPairs,[]) (getGroupsWithLevel lvl p) p) p) ) p
\ No newline at end of file

src/Gargantext/Viz/Phylo/LevelMaker.hs

+{-|
+Module      : Gargantext.Viz.Phylo.Tools
+Description : Phylomemy Tools to build/manage it
+Copyright   : (c) CNRS, 2017-Present
+License     : AGPL + CECILL v3
+Maintainer  : team@gargantext.org
+Stability   : experimental
+Portability : POSIX
+
+
+-}
+
+{-# LANGUAGE NoImplicitPrelude #-}
+{-# LANGUAGE FlexibleContexts  #-}
+{-# LANGUAGE OverloadedStrings #-}
+
+module Gargantext.Viz.Phylo.LevelMaker
+  where
+
+import Control.Lens                 hiding (both, Level)
+import Data.List                    ((++), sort, concat, nub, words, zip)
+import Data.Map                     (Map, (!), empty, restrictKeys, filterWithKey, singleton)
+import Data.Set                     (Set)
+import Data.Text                    (Text, words)
+import Data.Tuple.Extra
+
+import Gargantext.Prelude                   hiding (head)
+import Gargantext.Viz.Phylo.Aggregates.Cooc
+import Gargantext.Viz.Phylo
+import Gargantext.Viz.Phylo.Tools
+
+import qualified Data.List   as List
+import qualified Data.Map    as Map
+import qualified Data.Set    as Set
+import qualified Data.Text   as Text
+
+
+-- | A typeClass for polymorphic PhyloLevel functions
+class PhyloLevelMaker aggregate 
+    where
+        -- | To add a new Level of PhyloGroups to a Phylo based on a list of Aggregates
+        addPhyloLevel :: Level -> Map (Date,Date) [aggregate] -> Phylo -> Phylo
+        -- | To create a list of PhyloGroups based on a list of aggregates a
+        toPhyloGroups :: Level -> (Date,Date)  -> [aggregate] -> Map (Date,Date) [aggregate] -> Phylo -> [PhyloGroup]
+
+
+instance PhyloLevelMaker Cluster 
+  where
+    --------------------------------------
+    -- | Level -> Map (Date,Date) [Cluster] -> Phylo -> Phylo 
+    addPhyloLevel lvl m p
+      | lvl > 1   = toPhyloLevel lvl m p
+      | otherwise = panic ("[ERR][Viz.Phylo.Example.addPhyloLevel] No process declared for adding Clusters at level < 2")    
+    --------------------------------------
+    -- | Level -> (Date,Date) -> [Cluster] -> Map (Date,Date) [Cluster] -> Phylo -> [PhyloGroup]
+    toPhyloGroups lvl (d,d') l m p = map (\(idx,cluster) -> clusterToGroup (d,d') lvl idx "" cluster m p) $ zip [1..] l
+    --------------------------------------
+
+
+instance PhyloLevelMaker Fis 
+  where
+    --------------------------------------
+    -- | Level -> Map (Date,Date) [Fis] -> Phylo -> Phylo 
+    addPhyloLevel lvl m p
+      | lvl == 1  = toPhyloLevel lvl m p
+      | otherwise = panic ("[ERR][Viz.Phylo.Example.addPhyloLevel] No process declared for adding Fis at level <> 1")    
+    --------------------------------------
+    -- | Level -> (Date,Date) -> [Fis] -> Map (Date,Date) [Fis] -> Phylo -> [PhyloGroup]
+    toPhyloGroups lvl (d,d') l m p = map (\(idx,fis) -> cliqueToGroup (d,d') lvl idx "" fis m p) $ zip [1..] l
+    --------------------------------------
+
+
+instance PhyloLevelMaker Document 
+  where
+    --------------------------------------
+    -- | Level -> Map (Date,Date) [Document] -> Phylo -> Phylo 
+    addPhyloLevel lvl m p 
+      | lvl < 0 = toPhyloLevel lvl m p
+      | otherwise = panic ("[ERR][Viz.Phylo.Example.addPhyloLevel] No process declared for adding Documents at level <> -1") 
+    --------------------------------------
+    -- | Level -> (Date,Date) -> [Document] -> Map (Date,Date) [Fis] -> Phylo -> [PhyloGroup]
+    toPhyloGroups lvl (d,d') l m p = map (\(idx,ngram) -> ngramsToGroup (d,d') lvl idx ngram [ngram] p) 
+                                          $ zip [1..] 
+                                          $ (nub . concat) 
+                                          $ map (Text.words . text) l
+    --------------------------------------
+
+
+-- | To transform a Cluster into a Phylogroup 
+clusterToGroup :: PhyloPeriodId -> Level -> Int -> Text -> Cluster -> Map (Date,Date) [Cluster] -> Phylo -> PhyloGroup
+clusterToGroup prd lvl idx lbl groups m p = 
+    PhyloGroup ((prd, lvl), idx) lbl ((sort . nub . concat) $ map getGroupNgrams groups) empty empty [] [] [] (map (\g -> (getGroupId g, 1)) groups)
+
+
+-- | To transform a Clique into a PhyloGroup
+cliqueToGroup :: PhyloPeriodId -> Level -> Int -> Text -> (Clique,Support) -> Map (Date, Date) [Fis] -> Phylo -> PhyloGroup
+cliqueToGroup prd lvl idx lbl fis m p = 
+    PhyloGroup ((prd, lvl), idx) lbl ngrams (singleton "support" (fromIntegral $ snd fis)) cooc [] [] [] []
+      where
+        --------------------------------------
+        ngrams :: [Int]
+        ngrams = sort $ map (\x -> ngramsToIdx x p)
+                      $ Set.toList
+                      $ fst fis
+        --------------------------------------
+        cooc :: Map (Int, Int) Double 
+        cooc =  filterWithKey (\k _ -> elem (fst k) ngrams && elem (snd k) ngrams) 
+                                     $ fisToCooc (restrictKeys m $ Set.fromList [prd]) p
+        -------------------------------------- 
+
+
+-- | To transform a list of Ngrams into a PhyloGroup
+ngramsToGroup ::  PhyloPeriodId -> Level -> Int -> Text -> [Ngrams] -> Phylo -> PhyloGroup
+ngramsToGroup prd lvl idx lbl ngrams p =
+    PhyloGroup ((prd, lvl), idx) lbl (sort $ map (\x -> ngramsToIdx x p) ngrams) empty empty [] [] [] []
+
+
+-- | To traverse a Phylo and add a new PhyloLevel linked to a new list of PhyloGroups
+toPhyloLevel :: PhyloLevelMaker a => Level -> Map (Date, Date) [a] -> Phylo -> Phylo 
+toPhyloLevel lvl m p = alterPhyloPeriods 
+                        (\period -> let pId = _phylo_periodId period 
+                                    in  over (phylo_periodLevels)
+                                        (\phyloLevels ->
+                                          let groups = toPhyloGroups lvl pId (m ! pId) m p 
+                                          in  phyloLevels ++ [PhyloLevel (pId, lvl) groups]
+                                        ) period) p

src/Gargantext/Viz/Phylo/LinkMaker.hs

+{-|
+Module      : Gargantext.Viz.Phylo.Tools
+Description : Phylomemy Tools to build/manage it
+Copyright   : (c) CNRS, 2017-Present
+License     : AGPL + CECILL v3
+Maintainer  : team@gargantext.org
+Stability   : experimental
+Portability : POSIX
+
+
+-}
+
+{-# LANGUAGE NoImplicitPrelude #-}
+{-# LANGUAGE FlexibleContexts  #-}
+{-# LANGUAGE OverloadedStrings #-}
+
+module Gargantext.Viz.Phylo.LinkMaker
+  where
+
+import Control.Lens                 hiding (both, Level)
+import Data.List                    ((++), sort, concat, nub, words, zip, sortOn, head, null, tail, splitAt, (!!))
+import Data.Map                     (Map)
+import Data.Set                     (Set)
+import Data.Tuple.Extra
+
+import Gargantext.Prelude           hiding (head)
+import Gargantext.Viz.Phylo
+import Gargantext.Viz.Phylo.Tools
+import Gargantext.Viz.Phylo.Metrics.Proximity
+
+import qualified Data.List  as List
+import qualified Data.Map   as Map
+import qualified Data.Maybe as Maybe
+
+
+------------------------------------------------------------------------
+-- | Make links from Level to Level
+
+
+-- | To choose a LevelLink strategy based an a given Level 
+shouldLink :: (Level,Level) -> [Int] -> [Int] -> Bool
+shouldLink (lvl,lvl') l l'
+  | lvl <= 1  = doesContainsOrd l l'
+  | lvl >  1  = undefined
+  | otherwise = panic ("[ERR][Viz.Phylo.Tools.shouldLink] LevelLink not defined") 
+
+
+-- | To set the LevelLinks between a given PhyloGroup and a list of childs/parents PhyloGroups
+linkGroupToGroups :: (Level,Level) -> PhyloGroup -> [PhyloGroup] -> PhyloGroup
+linkGroupToGroups (lvl,lvl') current targets 
+  | lvl < lvl' = setLevelParents current 
+  | lvl > lvl' = setLevelChilds current
+  | otherwise = current  
+  where
+    -------------------------------------- 
+    setLevelChilds :: PhyloGroup -> PhyloGroup 
+    setLevelChilds =  over (phylo_groupLevelChilds) addPointers 
+    --------------------------------------
+    setLevelParents :: PhyloGroup -> PhyloGroup 
+    setLevelParents =  over (phylo_groupLevelParents) addPointers
+    --------------------------------------
+    addPointers :: [Pointer] -> [Pointer]
+    addPointers lp = lp ++ Maybe.mapMaybe (\target -> 
+                                            if shouldLink (lvl,lvl') 
+                                                          (_phylo_groupNgrams current)
+                                                          (_phylo_groupNgrams target )
+                                            then Just ((getGroupId target),1)
+                                            else Nothing) targets 
+    --------------------------------------
+
+
+-- | To set the LevelLinks between two lists of PhyloGroups 
+linkGroupsByLevel :: (Level,Level) -> Phylo -> [PhyloGroup] -> [PhyloGroup]
+linkGroupsByLevel (lvl,lvl') p groups  = map (\group ->
+                                              if getGroupLevel group == lvl 
+                                              then linkGroupToGroups (lvl,lvl') group (getGroupsWithFilters lvl' (getGroupPeriod group) p)
+                                              else group) groups
+
+
+-- | To set the LevelLink of all the PhyloGroups of a Phylo
+setLevelLinks :: (Level,Level) -> Phylo -> Phylo
+setLevelLinks (lvl,lvl') p = alterPhyloGroups (linkGroupsByLevel (lvl,lvl') p) p
+
+
+------------------------------------------------------------------------
+-- | Make links from Period to Period
+
+
+-- | To apply the corresponding proximity function based on a given Proximity
+getProximity :: (Proximity,[Double]) -> PhyloGroup -> PhyloGroup -> (PhyloGroupId, Double)
+getProximity (prox,param) g1 g2 = case prox of 
+  WeightedLogJaccard -> ((getGroupId g2),weightedLogJaccard (param !! 0) (getGroupCooc g1) (unifySharedKeys (getGroupCooc g2) (getGroupCooc g1)))
+  _                  -> panic ("[ERR][Viz.Phylo.Example.getProximity] Proximity function not defined")
+
+
+-- | To get the next or previous PhyloPeriod based on a given PhyloPeriodId
+getNextPeriods :: PairTo -> PhyloPeriodId -> [PhyloPeriodId] -> [PhyloPeriodId] 
+getNextPeriods to id l = case to of 
+    Childs  -> unNested id ((tail . snd) next) 
+    Parents -> unNested id ((reverse . fst) next)
+    _       -> panic ("[ERR][Viz.Phylo.Example.getNextPeriods] PairTo type not defined")
+    where 
+      --------------------------------------
+      next :: ([PhyloPeriodId], [PhyloPeriodId])
+      next = splitAt idx l
+      --------------------------------------
+      idx :: Int
+      idx = case (List.elemIndex id l) of 
+        Nothing -> panic ("[ERR][Viz.Phylo.Example.getNextPeriods] PhyloPeriodId not defined")
+        Just i  -> i
+      --------------------------------------
+      -- | To have an non-overlapping next period
+      unNested :: PhyloPeriodId -> [PhyloPeriodId] -> [PhyloPeriodId]
+      unNested x l
+        | null l                  = []
+        | nested (fst $ head l) x = unNested x (tail l)
+        | nested (snd $ head l) x = unNested x (tail l)
+        | otherwise               = l
+      --------------------------------------
+      nested :: Date -> PhyloPeriodId -> Bool
+      nested d prd = d >= fst prd && d <= snd prd
+      --------------------------------------
+
+
+-- | To find the best set (max = 2) of Childs/Parents candidates based on a given Proximity mesure until a maximum depth (max = Period + 5 units )  
+findBestCandidates :: PairTo -> Int -> Int -> Double -> (Proximity,[Double]) -> PhyloGroup -> Phylo -> [(PhyloGroupId, Double)]
+findBestCandidates to depth max thr (prox,param) group p
+  | depth > max || null next = [] 
+  | (not . null) best = take 2 best
+  | otherwise = findBestCandidates to (depth + 1) max thr (prox,param) group p   
+  where
+    --------------------------------------
+    next :: [PhyloPeriodId]
+    next = getNextPeriods to (getGroupPeriod group) (getPhyloPeriods p)
+    --------------------------------------
+    candidates :: [PhyloGroup] 
+    candidates = getGroupsWithFilters (getGroupLevel group) (head next) p
+    --------------------------------------
+    scores :: [(PhyloGroupId, Double)]
+    scores = map (\group' -> getProximity (prox,param) group group') candidates
+    --------------------------------------
+    best :: [(PhyloGroupId, Double)]
+    best = reverse
+         $ sortOn snd 
+         $ filter (\(id,score) -> score >= thr) scores
+    --------------------------------------
+
+
+-- | To add a new list of Pointers into an existing Childs/Parents list of Pointers 
+makePair :: PairTo -> PhyloGroup -> [(PhyloGroupId, Double)] -> PhyloGroup
+makePair to group ids = case to of 
+    Childs  -> over (phylo_groupPeriodChilds) addPointers group
+    Parents -> over (phylo_groupPeriodParents) addPointers group
+    _       -> panic ("[ERR][Viz.Phylo.Example.makePair] PairTo type not defined")
+    where
+      -------------------------------------- 
+      addPointers :: [Pointer] -> [Pointer]
+      addPointers l = nub $ (l ++ ids)
+      --------------------------------------
+
+
+-- | To pair all the Phylogroups of given PhyloLevel to their best Parents or Childs
+pairGroupsToGroups :: PairTo -> Level -> Double -> (Proximity,[Double]) -> Phylo -> Phylo
+pairGroupsToGroups to lvl thr (prox,param) p = alterPhyloGroups
+                                    (\groups -> 
+                                      map (\group ->
+                                            if (getGroupLevel group) == lvl
+                                            then 
+                                              let
+                                                --------------------------------------
+                                                candidates :: [(PhyloGroupId, Double)] 
+                                                candidates = findBestCandidates to 1 5 thr (prox,param) group p
+                                                --------------------------------------
+                                              in 
+                                                makePair to group candidates
+                                            else 
+                                              group ) groups) p
\ No newline at end of file

src/Gargantext/Viz/Phylo/Metrics/Clustering.hs

+{-|
+Module      : Gargantext.Viz.Phylo.Tools
+Description : Phylomemy Tools to build/manage it
+Copyright   : (c) CNRS, 2017-Present
+License     : AGPL + CECILL v3
+Maintainer  : team@gargantext.org
+Stability   : experimental
+Portability : POSIX
+
+
+-}
+
+{-# LANGUAGE NoImplicitPrelude #-}
+{-# LANGUAGE FlexibleContexts  #-}
+{-# LANGUAGE OverloadedStrings #-}
+
+module Gargantext.Viz.Phylo.Metrics.Clustering
+  where
+
+import Data.List        (last,head,union,concat,null,nub,(++),init,tail)
+import Data.Map         (Map,elems,adjust,unionWith,intersectionWith)
+import Data.Set         (Set)
+import Data.Tuple       (fst, snd)
+
+import Gargantext.Prelude             hiding (head)
+import Gargantext.Viz.Phylo
+import Gargantext.Viz.Phylo.Tools
+
+import qualified Data.List   as List
+import qualified Data.Map    as Map
+import qualified Data.Set    as Set
+
+
+-- | To apply the related components method to a PhyloGraph
+-- curr = the current PhyloGroup 
+-- (nodes,edges) = the initial PhyloGraph minus the current PhyloGroup
+-- next = the next PhyloGroups to be added in the cluster  
+-- memo = the memory of the allready created clusters
+relatedComp :: Int -> PhyloGroup -> PhyloGraph -> [PhyloGroup] -> [[PhyloGroup]] -> [[PhyloGroup]]
+relatedComp idx curr (nodes,edges) next memo
+  | null nodes' && null next' = memo'
+  | (not . null) next'        = relatedComp idx (head next') (nodes',edges) (tail next') memo'
+  | otherwise                 = relatedComp (idx + 1) (head nodes') (tail nodes',edges) [] memo'
+  where
+    --------------------------------------
+    memo' :: [[PhyloGroup]]
+    memo' 
+      | null memo                  = [[curr]]
+      | idx == ((length memo) - 1) = (init memo) ++ [(last memo) ++ [curr]]
+      | otherwise                  = memo ++ [[curr]]
+    --------------------------------------
+    next' :: [PhyloGroup]
+    next' = filter (\x -> not $ elem x $ concat memo) $ nub $ next ++ (getNeighbours False curr edges)
+    --------------------------------------
+    nodes' :: [PhyloGroup]
+    nodes' = filter (\x -> not $ elem x next') nodes
+    --------------------------------------
\ No newline at end of file

src/Gargantext/Viz/Phylo/Metrics/Proximity.hs

+{-|
+Module      : Gargantext.Viz.Phylo.Tools
+Description : Phylomemy Tools to build/manage it
+Copyright   : (c) CNRS, 2017-Present
+License     : AGPL + CECILL v3
+Maintainer  : team@gargantext.org
+Stability   : experimental
+Portability : POSIX
+
+
+-}
+
+{-# LANGUAGE NoImplicitPrelude #-}
+{-# LANGUAGE FlexibleContexts  #-}
+{-# LANGUAGE OverloadedStrings #-}
+
+module Gargantext.Viz.Phylo.Metrics.Proximity
+  where
+
+import Data.List        (last,head,union,concat,null)
+import Data.Map         (Map,elems,adjust,unionWith,intersectionWith)
+import Data.Set         (Set)
+import Data.Tuple       (fst, snd)
+
+import Gargantext.Prelude             hiding (head)
+import Gargantext.Viz.Phylo
+import Gargantext.Viz.Phylo.Tools
+
+import qualified Data.List   as List
+import qualified Data.Map    as Map
+import qualified Data.Set    as Set
+
+
+-- | To process the weightedLogJaccard between two PhyloGroups fields
+weightedLogJaccard :: Double -> Map (Int, Int) Double -> Map (Int, Int) Double -> Double
+weightedLogJaccard s f1 f2
+  | null wUnion      = 0
+  | wUnion == wInter = 1 
+  | s == 0           = (fromIntegral $ length wInter)/(fromIntegral $ length wUnion)
+  | s > 0            = (sumInvLog wInter)/(sumInvLog wUnion)
+  | otherwise        = (sumLog wInter)/(sumLog wUnion)
+  where 
+    --------------------------------------
+    wInter :: [Double]
+    wInter = elems $ intersectionWith (+) f1 f2
+    --------------------------------------
+    wUnion :: [Double]
+    wUnion = elems $ unionWith (+) f1 f2  
+    --------------------------------------
+    sumInvLog :: [Double] -> Double
+    sumInvLog l = foldl (\mem x -> mem + (1 / log (s + x))) 0 l
+    --------------------------------------
+    sumLog :: [Double] -> Double
+    sumLog l = foldl (\mem x -> mem + log (s + x)) 0 l  
+    --------------------------------------  
\ No newline at end of file

src/Gargantext/Viz/Phylo/Tools.hs

@@ -13,14 +13,13 @@ Portability : POSIX
 {-# LANGUAGE NoImplicitPrelude #-}
 {-# LANGUAGE FlexibleContexts  #-}
 {-# LANGUAGE OverloadedStrings #-}
-{-# LANGUAGE MultiParamTypeClasses #-}
 
 module Gargantext.Viz.Phylo.Tools
   where
 
 import Control.Lens         hiding (both, Level)
-import Data.List            (filter, intersect, (++), sort, null, head, tail, last, tails, delete, nub)
-import Data.Map             (Map, mapKeys, member)
+import Data.List            (filter, intersect, (++), sort, null, head, tail, last, tails, delete, nub, concat, union)
+import Data.Map             (Map, mapKeys, member, elems, adjust)
 import Data.Set             (Set)
 import Data.Text            (Text, toLower)
 import Data.Tuple.Extra
@@ -264,10 +263,9 @@ initNgrams :: [Ngrams] -> PhyloNgrams
 initNgrams l = Vector.fromList $ map toLower l
 
 
--- | To init a Phylomemy
-initPhylo :: [Document] -> PhyloNgrams -> Phylo
-initPhylo docs ngrams = Phylo (both date $ (last &&& head) docs) ngrams [] []
-
+-- | To create a Phylo from a list of PhyloPeriods and Ngrams
+initPhylo :: [(Date, Date)] -> PhyloNgrams -> Phylo
+initPhylo l ngrams = Phylo ((fst . head) l, (snd . last) l) ngrams (map (\prd -> initPhyloPeriod prd []) l) []
 
 -- | To create a PhyloLevel
 initPhyloLevel :: PhyloLevelId -> [PhyloGroup] -> PhyloLevel
@@ -319,14 +317,6 @@ setPhyloLevelId lvl' (PhyloLevel (id, lvl) groups)
             groups' = over (traverse . phylo_groupId) (\((period, lvl), idx) -> ((period, lvl'), idx)) groups 
 
 
--- | To choose a LevelLink strategy based an a given Level 
-shouldLink :: (Level,Level) -> [Int] -> [Int] -> Bool
-shouldLink (lvl,lvl') l l'
-  | lvl <= 1  = doesContainsOrd l l'
-  | lvl >  1  = undefined
-  | otherwise = panic ("[ERR][Viz.Phylo.Tools.shouldLink] LevelLink not defined") 
-
-
 -- | To unify the keys (x,y) that Map 1 share with Map 2 such as: (x,y) <=> (y,x)
 unifySharedKeys :: Eq a => Ord a => Map (a,a) b -> Map (a,a) b -> Map (a,a) b
 unifySharedKeys m1 m2 = mapKeys (\(x,y) -> if member (y,x) m2