Merge branch 'dev-phylo' of ssh://gitlab.iscpif.fr:20022/gargantext/haskell-gargantext into dev

src/Gargantext/Viz/Phylo/Metrics.hs

@@ -18,9 +18,13 @@ module Gargantext.Viz.Phylo.Metrics
   where
 
 import Gargantext.Prelude
+import Gargantext.Viz.Phylo
+import Gargantext.Viz.Phylo.Tools
 
-import Data.List ((\\), sortOn, concat, nub, take, union, intersect, null)
-import Data.Map  (Map, foldlWithKey, toList, size, unionWith, intersection, intersectionWith, filterWithKey, elems, fromList, findWithDefault)
+import Control.Lens hiding (Level)
+
+import Data.List ((\\), sortOn, concat, nub, take, union, intersect, null, (++), sort)
+import Data.Map  (Map, (!), foldlWithKey, toList, size, insert, unionWith, intersection, intersectionWith, filterWithKey, elems, fromList, findWithDefault, fromListWith)
 import Data.Text (Text)
 
 -- import Debug.Trace (trace)
@@ -61,7 +65,7 @@ getNgramsMeta :: Map (Int, Int) Double -> [Int] -> Map Text [Double]
 getNgramsMeta m ngrams = fromList 
     [ ("genericity" , map (\n -> genericity  m (ngrams \\ [n]) n) ngrams ),
       ("specificity", map (\n -> specificity m (ngrams \\ [n]) n) ngrams ),
-      ("coverage"   , map (\n -> coverage    m (ngrams \\ [n]) n) ngrams  )]
+      ("coverage"   , map (\n -> coverage    m (ngrams \\ [n]) n) ngrams )]
 
 
 -- | To get the nth most occurent elems in a coocurency matrix
@@ -77,6 +81,48 @@ getNthMostOcc nth cooc = (nub . concat)
 -- | Ngrams Dynamics | --
 -------------------------
 
+sharedWithParents :: Date -> PhyloBranchId -> Int -> PhyloView -> Bool 
+sharedWithParents inf bid n pv = elem n 
+                                $ foldl (\mem pn -> if ((bid == (fromJust $ (pn ^. pn_bid)))
+                                                      && (inf > (fst $ getNodePeriod pn)))
+                                                   then nub $ mem ++ (pn ^. pn_idx)
+                                                   else mem ) []
+                                $ (pv ^. pv_nodes)
+
+
+findDynamics :: Int -> PhyloView -> PhyloNode -> Map Int (Date,Date) -> Double
+findDynamics n pv pn m = 
+    let prd = getNodePeriod pn
+        bid = fromJust $ (pn ^. pn_bid)
+        end = last' "dynamics" (sort $ map snd $ elems m)
+    in  if (((snd prd) == (snd $ m ! n)) && (snd prd /= end))
+            -- | decrease
+            then 0
+        else if ((fst prd) == (fst $ m ! n))
+            -- | emergence
+            then 1
+        else if (not $ sharedWithParents (fst prd) bid n pv)
+            -- | recombination
+            then 2
+        else 3
+
+
+
+processDynamics :: PhyloView -> PhyloView
+processDynamics pv = alterPhyloNode (\pn -> 
+            pn & pn_metrics %~ insert "dynamics" (map (\n -> findDynamics n pv pn ngramsDates) $ (pn ^. pn_idx) ) ) pv
+    where
+        --------------------------------------
+        ngramsDates :: Map Int (Date,Date)
+        ngramsDates = map (\ds -> let ds' = sort ds
+                                  in  (head' "Dynamics" ds', last' "Dynamics" ds'))
+                    $ fromListWith (++)
+                    $ foldl (\mem pn -> mem ++ (map (\n -> (n, [fst $ getNodePeriod pn, snd $ getNodePeriod pn])) 
+                                                 $ (pn ^. pn_idx))) []
+                    $ (pv ^. pv_nodes)
+        --------------------------------------
+
+
 
 -------------------
 -- | Proximity | --

src/Gargantext/Viz/Phylo/Tools.hs

@@ -565,6 +565,13 @@ getFisPeriod = _phyloFis_period
 ----------------------------
 
 
+-- | To alter a PhyloNode
+alterPhyloNode :: (PhyloNode -> PhyloNode) -> PhyloView -> PhyloView
+alterPhyloNode f v = over ( pv_nodes
+                          .  traverse
+                          ) (\pn ->  f pn ) v
+
+
 -- | To filter some GroupEdges with a given threshold
 filterGroupEdges :: Double -> [GroupEdge] -> [GroupEdge]
 filterGroupEdges thr edges = filter (\((_s,_t),w) -> w > thr) edges
@@ -591,6 +598,10 @@ getNodeId :: PhyloNode -> PhyloGroupId
 getNodeId n = n ^. pn_id
 
 
+getNodePeriod :: PhyloNode -> (Date,Date)
+getNodePeriod n = fst $ fst $ getNodeId n
+
+
 -- | To get the Level of a PhyloNode
 getNodeLevel :: PhyloNode -> Level
 getNodeLevel n = (snd . fst) $ getNodeId n

src/Gargantext/Viz/Phylo/View/Export.hs

@@ -23,8 +23,8 @@ import Data.GraphViz   hiding (DotGraph)
 import Data.GraphViz.Attributes.Complete hiding (EdgeType) 
 import Data.GraphViz.Types.Generalised (DotGraph)
 import Data.GraphViz.Types.Monadic
-import Data.List        ((++),unwords,concat,sortOn,nub)
-import Data.Map         (Map,toList)
+import Data.List        ((++),unwords,concat,sortOn,nub,sort,group)
+import Data.Map         (Map,toList,(!))
 import Data.Maybe       (isNothing,fromJust)
 import Data.Text.Lazy   (fromStrict, pack, unpack)
 
@@ -36,6 +36,8 @@ import Gargantext.Prelude
 import Gargantext.Viz.Phylo hiding (Dot)
 import Gargantext.Viz.Phylo.Tools
 
+-- import Debug.Trace (trace)
+
 
 import Prelude (writeFile)
 import System.FilePath
@@ -130,6 +132,20 @@ setPeakDotEdge ::  DotId -> DotId -> Dot DotId
 setPeakDotEdge bId nId = edge bId nId [Width 3, Color [toWColor Black], ArrowHead (AType [(ArrMod FilledArrow RightSide,DotArrow)])]
 
 
+colorFromDynamics :: Double -> H.Attribute
+colorFromDynamics d 
+  | d == 0    = H.BGColor (toColor LightPink)
+  | d == 1    = H.BGColor (toColor PaleGreen)
+  | d == 2    = H.BGColor (toColor SkyBlue)
+  | otherwise = H.Color (toColor Black)
+
+
+getGroupDynamic :: [Double] -> H.Attribute
+getGroupDynamic dy = colorFromDynamics $ head' "getGroupDynamic" (head' "getGroupDynamic" $ reverse $ sortOn length $ group $ sort dy)
+
+  
+
+
 -- | To set an HTML table
 setHtmlTable :: PhyloNode -> H.Label
 setHtmlTable pn = H.Table H.HTable
@@ -137,14 +153,18 @@ setHtmlTable pn = H.Table H.HTable
                     , H.tableAttrs = [H.Border 0, H.CellBorder 0, H.BGColor (toColor White)]
                     , H.tableRows = [header] <> (if isNothing $ pn ^. pn_ngrams
                                                  then []
-                                                 else map ngramsToRow $ splitEvery 4 $ fromJust $ pn ^. pn_ngrams) }
+                                                 else map ngramsToRow $ splitEvery 4 $ zip (fromJust $ pn ^. pn_ngrams) dynamics) }
     where
         --------------------------------------
-        ngramsToRow :: [Ngrams] -> H.Row
-        ngramsToRow ns = H.Cells $ map (\n -> H.LabelCell [H.BAlign H.HLeft] $ H.Text [H.Str $ fromStrict n]) ns
+        ngramsToRow :: [(Ngrams,Double)] -> H.Row
+        ngramsToRow ns = H.Cells $ map (\(n,d) -> H.LabelCell [H.BAlign H.HLeft,colorFromDynamics d] 
+                                                $ H.Text [H.Str $ fromStrict n]) ns
+        --------------------------------------
+        dynamics :: [Double]
+        dynamics =  (pn ^. pn_metrics) ! "dynamics"
         --------------------------------------
         header :: H.Row
-        header = H.Cells [H.LabelCell [H.Color (toColor Black), H.BGColor (toColor Chartreuse2)] 
+        header = H.Cells [H.LabelCell [getGroupDynamic dynamics] 
                                       $ H.Text [H.Str $ (fromStrict . T.toUpper) $ pn ^. pn_label]]
         --------------------------------------
 

src/Gargantext/Viz/Phylo/View/Taggers.hs

@@ -28,7 +28,7 @@ import Gargantext.Viz.Phylo
 import Gargantext.Viz.Phylo.Tools
 import Gargantext.Viz.Phylo.BranchMaker
 import qualified Data.Map    as Map
-import Debug.Trace (trace)
+-- import Debug.Trace (trace)
 
 
 -- | To get the nth most frequent Ngrams in a list of PhyloGroups
@@ -88,14 +88,13 @@ getNthMostMeta nth meta g = map (\(idx,_) -> (getGroupNgrams g !! idx))
                           $ sortOn snd $ zip [0..]
                           $ (g ^. phylo_groupNgramsMeta) ! meta 
 
-
 -- | To set the label of a PhyloNode as the nth most coocurent terms of its PhyloNodes
 nodeLabelCooc :: PhyloView -> Int -> Phylo -> PhyloView
 nodeLabelCooc v thr p = over (pv_nodes
                              . traverse)
                              (\n -> let g = head' "nodeLabelCooc" $ getGroupsFromIds [getNodeId n] p
-                                        lbl' = ngramsToLabel (getFoundationsRoots p) $ getNthMostMeta thr "coverage" g
-                                    in trace (show (lbl')) $ n & pn_label .~ lbl') v
+                                        lbl = ngramsToLabel (getFoundationsRoots p) $ getNthMostMeta thr "coverage" g
+                                    in n & pn_label .~ lbl) v
 
 
 -- | To process a sorted list of Taggers to a PhyloView

src/Gargantext/Viz/Phylo/View/ViewMaker.hs

@@ -26,6 +26,7 @@ import Data.Vector      (Vector)
 import Gargantext.Prelude
 import Gargantext.Viz.Phylo
 import Gargantext.Viz.Phylo.Tools
+import Gargantext.Viz.Phylo.Metrics
 import Gargantext.Viz.Phylo.View.Display
 import Gargantext.Viz.Phylo.View.Filters
 import Gargantext.Viz.Phylo.View.Metrics
@@ -71,7 +72,7 @@ groupsToNodes isR isV ns gs = map (\g -> let idxs = getGroupNgrams g
                                               (if isV
                                                 then Just (ngramsToText ns idxs)
                                                 else Nothing)
-                                              empty
+                                              (g ^. phylo_groupNgramsMeta)
                                               (if (not isR)
                                                 then Just (getGroupLevelParentsId g)
                                                 else Nothing)
@@ -146,6 +147,7 @@ toPhyloView q p = traceView
                 $ processDisplay (q ^. qv_display) (q ^. qv_export)
                 $ processSort    (q ^. qv_sort   ) p
                 $ processTaggers (q ^. qv_taggers) p
+                $ processDynamics
                 $ processFilters (q ^. qv_filters) p
                 $ processMetrics (q ^. qv_metrics) p
                 $ addChildNodes  (q ^. qv_levelChilds) (q ^. qv_lvl) (q ^. qv_levelChildsDepth) (q ^. qv_verbose) (q ^. qv_filiation) p