add the dynamics and the labels

src/Gargantext/Viz/AdaptativePhylo.hs

@@ -92,6 +92,7 @@ data Config =
             , phyloProximity :: Proximity
             , timeUnit       :: TimeUnit
             , contextualUnit :: ContextualUnit
+            , exportLabel    :: [Label]
             , branchSize     :: Int  
             } deriving (Show,Generic,Eq)
 
@@ -107,6 +108,7 @@ defaultConfig =
             , phyloProximity = WeightedLogJaccard 10 0 0.2
             , timeUnit       = Year 3 1 5
             , contextualUnit = Fis 2 4
+            , exportLabel    = [BranchLabel MostInclusive 2, GroupLabel MostEmergentInclusive 2]
             , branchSize     = 3  
             }
 
@@ -120,6 +122,10 @@ instance FromJSON TimeUnit
 instance ToJSON TimeUnit
 instance FromJSON ContextualUnit
 instance ToJSON ContextualUnit
+instance FromJSON Label
+instance ToJSON Label
+instance FromJSON Tagger
+instance ToJSON Tagger
 
 
 -- | Software parameters
@@ -250,15 +256,16 @@ data PhyloGroup =
       PhyloGroup { _phylo_groupPeriod   :: (Date,Date)
                  , _phylo_groupLevel    :: Level
                  , _phylo_groupIndex    :: Int
+                 , _phylo_groupLabel    :: Text
                  , _phylo_groupSupport  :: Support
                  , _phylo_groupNgrams   :: [Int]
                  , _phylo_groupCooc     :: !(Cooc)
                  , _phylo_groupBranchId :: PhyloBranchId
+                 , _phylo_groupMeta     :: Map Text [Double]
                  , _phylo_groupLevelParents  :: [Pointer]
                  , _phylo_groupLevelChilds   :: [Pointer]
                  , _phylo_groupPeriodParents :: [Pointer]
                  , _phylo_groupPeriodChilds  :: [Pointer]
-                 , _phylo_groupGhostPointers :: [Pointer]
                  }
                  deriving (Generic, Show, Eq)
 
@@ -268,8 +275,6 @@ type Weight = Double
 -- | Pointer : A weighted pointer to a given PhyloGroup
 type Pointer = (PhyloGroupId, Weight)
 
-type Link = ((PhyloGroupId, PhyloGroupId), Weight)
-
 data Filiation = ToParents | ToChilds deriving (Generic, Show)    
 data PointerType = TemporalPointer | LevelPointer deriving (Generic, Show)                
 
@@ -298,6 +303,29 @@ data PhyloFis = PhyloFis
 
 type DotId = TextLazy.Text
 
+data Tagger = MostInclusive | MostEmergentInclusive deriving (Show,Generic,Eq)
+
+data Label = 
+      BranchLabel
+      { _branch_labelTagger :: Tagger
+      , _branch_labelSize   :: Int }
+    | GroupLabel
+      { _group_labelTagger  :: Tagger
+      , _group_labelSize    :: Int }
+    deriving (Show,Generic,Eq)
+
+data PhyloBranch =
+      PhyloBranch
+      { _branch_id :: PhyloBranchId
+      , _branch_label :: Text 
+      } deriving (Generic, Show)
+
+data PhyloExport =
+      PhyloExport
+      { _export_groups   :: [PhyloGroup]
+      , _export_branches :: [PhyloBranch]
+      } deriving (Generic, Show)
+
 ----------------
 -- | Lenses | --
 ----------------
@@ -305,6 +333,7 @@ type DotId = TextLazy.Text
 makeLenses ''Config
 makeLenses ''Proximity
 makeLenses ''ContextualUnit
+makeLenses ''Label
 makeLenses ''TimeUnit
 makeLenses ''PhyloFoundations
 makeLenses ''PhyloFis
@@ -313,6 +342,8 @@ makeLenses ''PhyloPeriod
 makeLenses ''PhyloLevel
 makeLenses ''PhyloGroup
 makeLenses ''PhyloParam
+makeLenses ''PhyloExport
+makeLenses ''PhyloBranch
 
 ------------------------
 -- | JSON instances | --

src/Gargantext/Viz/Phylo/PhyloExport.hs

@@ -12,13 +12,21 @@ Portability : POSIX
 {-# LANGUAGE FlexibleContexts  #-}
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE TypeSynonymInstances #-}
+{-# LANGUAGE FlexibleInstances    #-}
 
 module Gargantext.Viz.Phylo.PhyloExport where
 
+import Data.Map (Map, fromList, empty, fromListWith, insert, (!), elems, unionWith, findWithDefault)
+import Data.List ((++), sort, nub, concat, sortOn, reverse, groupBy, union, (\\), (!!))
+import Data.Text (Text)
+import Data.Vector (Vector)
+
 import Gargantext.Prelude
 import Gargantext.Viz.AdaptativePhylo
 import Gargantext.Viz.Phylo.PhyloTools 
 
+import Control.Lens
 import Data.GraphViz.Types.Generalised (DotGraph)
 
 --------------------
@@ -26,32 +34,120 @@ import Data.GraphViz.Types.Generalised (DotGraph)
 --------------------
 
 
-toDot :: [PhyloGroup] -> DotGraph DotId
-toDot branches = undefined
-
-
-----------------------
--- | post process | --
-----------------------
-
+toDot :: PhyloExport -> DotGraph DotId
+toDot export = undefined
+
+-----------------
+-- | Metrics | --
+-----------------
+
+-- | Return the conditional probability of i knowing j 
+conditional :: Ord a => Map (a,a) Double -> a -> a -> Double
+conditional m i j = (findWithDefault 0 (i,j) m) 
+                  / (m ! (j,j))
+
+
+-- | Return the inclusion score of a given ngram
+inclusion :: Map (Int, Int) Double -> [Int] -> Int -> Double 
+inclusion m l i = ( (sum $ map (\j -> conditional m j i) l)
+                  + (sum $ map (\j -> conditional m i j) l)) / (fromIntegral $ (length l) + 1)
+
+
+-----------------
+-- | Taggers | --
+----------------- 
+
+getNthMostMeta :: Int -> [Double] -> [Int] -> [Int]
+getNthMostMeta nth meta ns = map (\(idx,_) -> (ns !! idx))
+                           $ take nth
+                           $ reverse
+                           $ sortOn snd $ zip [0..] meta 
+
+
+mostInclusive :: Int -> Vector Ngrams -> PhyloExport -> PhyloExport
+mostInclusive nth foundations export =
+    over ( export_branches
+         .  traverse )
+         (\b -> 
+            let groups = filter (\g -> g ^. phylo_groupBranchId == b ^. branch_id) $ export ^. export_groups
+                cooc   = foldl (\acc g -> unionWith (+) acc (g ^. phylo_groupCooc)) empty groups
+                ngrams = sort $ foldl (\acc g -> union acc (g ^. phylo_groupNgrams)) [] groups
+                inc    = map (\n -> inclusion cooc (ngrams \\ [n]) n) ngrams
+                lbl    = ngramsToLabel foundations $ getNthMostMeta nth inc ngrams
+            in b & branch_label .~ lbl ) export
+
+
+mostEmergentInclusive :: Int -> Vector Ngrams -> PhyloExport -> PhyloExport
+mostEmergentInclusive nth foundations export =
+    over ( export_groups
+         .  traverse ) 
+         (\g -> 
+            let lbl = ngramsToLabel foundations
+                    $ take nth 
+                    $ map (\(_,(_,idx)) -> idx)
+                    $ concat
+                    $ map (\groups -> sortOn (fst . snd) groups)
+                    $ groupBy ((==) `on` fst) $ reverse $ sortOn fst                
+                    $ zip ((g ^. phylo_groupMeta) ! "inclusion")
+                    $ zip ((g ^. phylo_groupMeta) ! "dynamics") (g ^. phylo_groupNgrams)
+            in g & phylo_groupLabel .~ lbl ) export
+
+
+processLabels :: [Label] -> Vector Ngrams -> PhyloExport -> PhyloExport
+processLabels labels foundations export =
+    foldl (\export' label -> 
+                case label of
+                    GroupLabel  tagger nth -> 
+                        case tagger of
+                            MostEmergentInclusive -> mostEmergentInclusive nth foundations export' 
+                            _ -> panic "[ERR][Viz.Phylo.PhyloExport] unknown tagger"
+                    BranchLabel tagger nth ->
+                        case tagger of
+                            MostInclusive -> undefined
+                            _ -> panic "[ERR][Viz.Phylo.PhyloExport] unknown tagger" ) export labels 
+
+
+------------------
+-- | Dynamics | --
+------------------ 
+
+
+toDynamics :: Int -> [PhyloGroup] -> PhyloGroup -> Map Int (Date,Date) -> Double
+toDynamics n parents group m = 
+    let prd = group ^. phylo_groupPeriod
+        bid = group ^. phylo_groupBranchId
+        end = last' "dynamics" (sort $ map snd $ elems m)
+    in  if (((snd prd) == (snd $ m ! n)) && (snd prd /= end))
+            -- | decrease
+            then 2
+        else if ((fst prd) == (fst $ m ! n))
+            -- | recombination
+            then 0
+        else if isNew
+            -- | emergence
+            then 1
+        else 3
+    where
+        -------------------------------------- 
+        isNew :: Bool
+        isNew = not $ elem n $ concat $ map _phylo_groupNgrams parents
 
-processFilters :: [PhyloGroup] -> [PhyloGroup]
-processFilters branches = branches
-
-processSort :: [PhyloGroup] -> [PhyloGroup]
-processSort branches = branches
-
-processMetrics :: [PhyloGroup] -> [PhyloGroup]
-processMetrics branches = branches
 
 processDynamics :: [PhyloGroup] -> [PhyloGroup]
-processDynamics branches = branches
-
-processLabels :: [PhyloGroup] -> [PhyloGroup]
-processLabels branches = branches
-
-phyloPostProcess :: [PhyloGroup] -> [PhyloGroup]
-phyloPostProcess branches = branches
+processDynamics groups = 
+    map (\g ->
+        let parents = filter (\g' -> (g ^. phylo_groupBranchId == g' ^. phylo_groupBranchId)
+                                  && ((fst $ g ^. phylo_groupPeriod) > (fst $ g' ^. phylo_groupPeriod))) groups
+        in  g & phylo_groupMeta %~ insert "dynamics" (map (\n -> toDynamics n parents g mapNgrams) $ g ^. phylo_groupNgrams) ) groups
+    where
+        --------------------------------------
+        mapNgrams :: Map Int (Date,Date)
+        mapNgrams = map (\dates -> 
+                        let dates' = sort dates
+                        in (head' "dynamics" dates', last' "dynamics" dates'))
+                  $ fromListWith (++)
+                  $ foldl (\acc g -> acc ++ ( map (\n -> (n,[fst $ g ^. phylo_groupPeriod, snd $ g ^. phylo_groupPeriod])) 
+                                            $ (g ^. phylo_groupNgrams))) [] groups
 
 
 ---------------------
@@ -60,8 +156,15 @@ phyloPostProcess branches = branches
 
 
 toPhyloExport :: Phylo -> DotGraph DotId
-toPhyloExport phylo = toDot
-                    $ phyloPostProcess groups
-    where 
+toPhyloExport phylo = toDot 
+                    $ processLabels (exportLabel $ getConfig phylo) (getRoots phylo) export           
+    where
+        export :: PhyloExport
+        export = PhyloExport groups branches
+        --------------------------------------
+        branches :: [PhyloBranch] 
+        branches = map (\bId -> PhyloBranch bId "") $ nub $ map _phylo_groupBranchId groups
+        --------------------------------------    
         groups :: [PhyloGroup]
-        groups =  getGroupsFromLevel (phyloLevel $ getConfig phylo) phylo
+        groups = processDynamics 
\ No newline at end of file
+               $ getGroupsFromLevel (phyloLevel $ getConfig phylo) phylo
\ No newline at end of file

src/Gargantext/Viz/Phylo/PhyloMaker.hs

@@ -83,12 +83,13 @@ appendGroups f lvl m phylo =  trace ("\n" <> "-- | Append " <> show (length $ co
 fisToGroup :: PhyloFis -> PhyloPeriodId -> Level ->  Int -> Vector Ngrams -> [Cooc] -> PhyloGroup
 fisToGroup fis pId lvl idx fdt coocs =
     let ngrams = ngramsToIdx (Set.toList $ fis ^. phyloFis_clique) fdt
-    in  PhyloGroup pId lvl idx
+    in  PhyloGroup pId lvl idx ""
                    (fis ^. phyloFis_support)
                    ngrams
                    (ngramsToCooc ngrams coocs)
                    (1,[0])
-                   [] [] [] [] []
+                   empty
+                   [] [] [] []
 
 
 toPhylo1 :: [Document] -> Phylo -> Phylo

src/Gargantext/Viz/Phylo/PhyloTools.hs

@@ -21,6 +21,7 @@ import Data.List (sort, concat, null, union, (++), tails, sortOn, nub, init)
 import Data.Set (Set, size)
 import Data.Map (Map, elems, fromList, unionWith, keys, member, (!), filterWithKey)
 import Data.String (String)
+import Data.Text (Text, unwords)
 
 import Gargantext.Prelude
 import Gargantext.Viz.AdaptativePhylo
@@ -60,6 +61,15 @@ isRoots n ns = Vector.elem n ns
 ngramsToIdx :: [Ngrams] -> Vector Ngrams -> [Int]
 ngramsToIdx ns fdt = map (\n -> fromJust $ elemIndex n fdt) ns
 
+-- | To transform a list of Ngrams Indexes into a Label
+ngramsToLabel :: Vector Ngrams -> [Int] -> Text
+ngramsToLabel ngrams l = unwords $ tail' "ngramsToLabel" $ concat $ map (\n -> ["|",n]) $ ngramsToText ngrams l
+
+
+-- | To transform a list of Ngrams Indexes into a list of Text
+ngramsToText :: Vector Ngrams -> [Int] -> [Text]
+ngramsToText ngrams l = map (\idx -> ngrams Vector.! idx) l
+
 
 --------------
 -- | Time | --
@@ -250,15 +260,6 @@ updatePhyloGroups lvl m phylo =
                     else group ) phylo
 
 
-------------------
--- | Pointers | --
-------------------
-
-
-pointersToLinks :: PhyloGroupId -> [Pointer] -> [Link]
-pointersToLinks id pointers = map (\p -> ((id,fst p),snd p)) pointers
-
-
 -------------------
 -- | Proximity | --
 -------------------