add the view maker system

src/Gargantext/Viz/Phylo.hs

@@ -237,6 +237,7 @@ data PhyloNode = PhyloNode
   , _phylo_nodeNgrams    :: Maybe [Ngrams]
   , _phylo_nodeMeta      :: Map Text Double
   , _phylo_nodeParent    :: Maybe PhyloGroupId 
+  , _phylo_nodeChilds    :: [PhyloNode]
   } deriving (Show)
 
 -- | PhyloQuery | --

src/Gargantext/Viz/Phylo/Tools.hs

@@ -18,7 +18,8 @@ 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, concat, union)
+import Data.List            (filter, intersect, (++), sort, null, head, tail, last, tails, delete, nub, concat, union, sortOn)
+import Data.Maybe           (mapMaybe)
 import Data.Map             (Map, mapKeys, member, elems, adjust)
 import Data.Set             (Set)
 import Data.Text            (Text, toLower)
@@ -37,6 +38,7 @@ import qualified Data.Vector as Vector
 -- | Tools | --
 
 
+-- | To alter a PhyloGroup matching a given Level
 alterGroupWithLevel :: (PhyloGroup -> PhyloGroup) -> Level -> Phylo -> Phylo
 alterGroupWithLevel f lvl p = over ( phylo_periods
                                    .  traverse
@@ -49,7 +51,6 @@ alterGroupWithLevel f lvl p = over ( phylo_periods
                                             else g ) p  
 
 
-
 -- | To alter each list of PhyloGroups following a given function
 alterPhyloGroups :: ([PhyloGroup] -> [PhyloGroup]) -> Phylo -> Phylo
 alterPhyloGroups f p = over ( phylo_periods
@@ -121,6 +122,23 @@ filterGroupEdges :: Double -> GroupEdges -> GroupEdges
 filterGroupEdges thr edges = filter (\((s,t),w) -> w > thr) edges 
 
 
+-- | To get the PhyloBranchId of a PhyloBranch
+getBranchId :: PhyloBranch -> PhyloBranchId
+getBranchId b = b ^. phylo_branchId
+
+
+-- | To get a list of PhyloBranchIds given a Level in a Phylo
+getBranchIdsWith :: Level -> Phylo -> [PhyloBranchId]
+getBranchIdsWith lvl p = sortOn snd
+                       $ mapMaybe getGroupBranchId
+                       $ getGroupsWithLevel lvl p
+
+
+-- | To get the Meta value of a PhyloBranch 
+getBranchMeta :: Text -> PhyloBranch -> Double 
+getBranchMeta k b = (b ^. phylo_branchMeta) Map.! k
+
+
 -- | To get the foundations of a Phylo
 getFoundations :: Phylo -> Vector Ngrams
 getFoundations = _phylo_foundations
@@ -228,11 +246,16 @@ getGroups = view ( phylo_periods
                  )
 
 
--- | To all PhyloGroups matching a list of PhyloGroupIds in a Phylo
+-- | To get all PhyloGroups matching a list of PhyloGroupIds in a Phylo
 getGroupsFromIds :: [PhyloGroupId] -> Phylo -> [PhyloGroup]
 getGroupsFromIds ids p = filter (\g -> elem (getGroupId g) ids) $ getGroups p
 
 
+-- | To get the corresponding list of PhyloGroups from a list of PhyloNodes
+getGroupsFromNodes :: [PhyloNode] -> Phylo -> [PhyloGroup]
+getGroupsFromNodes ns p = getGroupsFromIds (map getNodeId ns) p 
+
+
 -- | To get all the PhyloGroup of a Phylo with a given level and period
 getGroupsWithFilters :: Int -> (Date,Date) -> Phylo -> [PhyloGroup]
 getGroupsWithFilters lvl prd p = (getGroupsWithLevel  lvl p)
@@ -274,6 +297,7 @@ getLastLevel p = (last . sort)
                       . phylo_periodLevels ) p
 
 
+
 -- | To get the neighbours (directed/undirected) of a PhyloGroup from a list of GroupEdges 
 getNeighbours :: Bool -> PhyloGroup -> GroupEdges -> [PhyloGroup]
 getNeighbours directed g e = case directed of 
@@ -283,9 +307,52 @@ getNeighbours directed g e = case directed of
              $ filter (\((s,t),w) -> s == g || t == g) e
 
 
--- | To get the Branches of a Phylo
--- getPhyloBranches :: Phylo -> [PhyloBranch] 
--- getPhyloBranches = _phylo_branches
+-- | To get the PhyloBranchId of PhyloNode if it exists
+getNodeBranchId :: PhyloNode -> PhyloBranchId
+getNodeBranchId n = case n ^. phylo_nodeBranchId of
+                     Nothing -> panic "[ERR][Viz.Phylo.Tools.getNodeBranchId] branchId not found"
+                     Just i  -> i 
+
+
+-- | To get the PhyloGroupId of a PhyloNode
+getNodeId :: PhyloNode -> PhyloGroupId
+getNodeId n = n ^. phylo_nodeId
+
+
+-- | To get the Level of a PhyloNode
+getNodeLevel :: PhyloNode -> Level
+getNodeLevel n = (snd . fst) $ getNodeId n
+
+
+-- | To get the Parent Node of a PhyloNode in a PhyloView
+getNodeParent :: PhyloNode -> PhyloView -> PhyloNode
+getNodeParent n v = head 
+                  $ filter (\n' -> getNodeId n' == getNodeParentId n)
+                  $ v ^. phylo_viewNodes
+
+
+-- | To get the Parent Node id of a PhyloNode if it exists
+getNodeParentId :: PhyloNode -> PhyloGroupId
+getNodeParentId n = case n ^. phylo_nodeParent of
+                    Nothing -> panic "[ERR][Viz.Phylo.Tools.getNodeParentId] node parent not found"
+                    Just id -> id
+
+
+-- | To get a list of PhyloNodes grouped by PhyloBranch in a PhyloView
+getNodesByBranches :: PhyloView -> [(PhyloBranchId,[PhyloNode])]
+getNodesByBranches v = zip bIds $ map (\id -> filter (\n -> (getNodeBranchId n) == id) 
+                                            $ getNodesInBranches v ) bIds
+  where
+    -------------------------------------- 
+    bIds :: [PhyloBranchId] 
+    bIds = getViewBranchIds v 
+    --------------------------------------
+
+
+-- | To get a list of PhyloNodes owned by any PhyloBranches in a PhyloView
+getNodesInBranches :: PhyloView -> [PhyloNode]
+getNodesInBranches v = filter (\n -> isJust $ n ^. phylo_nodeBranchId)
+                     $ v ^. phylo_viewNodes
 
 
 -- | To get the PhylolevelId of a given PhyloLevel
@@ -309,6 +376,21 @@ getPhyloPeriodId :: PhyloPeriod -> PhyloPeriodId
 getPhyloPeriodId prd = _phylo_periodId prd 
 
 
+-- | To get the PhyloGroupId of the Source of a PhyloEdge 
+getSourceId :: PhyloEdge -> PhyloGroupId
+getSourceId e = e ^. phylo_edgeSource 
+
+
+-- | To get the PhyloGroupId of the Target of a PhyloEdge
+getTargetId :: PhyloEdge -> PhyloGroupId
+getTargetId e = e ^. phylo_edgeTarget
+
+
+-- | To get all the PhyloBranchIds of a PhyloView
+getViewBranchIds :: PhyloView -> [PhyloBranchId]
+getViewBranchIds v = map getBranchId $ v ^. phylo_viewBranches
+
+
 -- | To init the foundation of the Phylo as a Vector of Ngrams 
 initFoundations :: [Ngrams] -> Vector Ngrams
 initFoundations l = Vector.fromList $ map toLower l

src/Gargantext/Viz/Phylo/View/Display.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.View.Display
+  where
+
+import Control.Lens     hiding (makeLenses, both, Level)
+
+import Data.List        (notElem,last,head,union,concat,null,nub,(++),init,tail,elemIndex,groupBy,(!!),sortOn,sort,(\\))
+import Data.Map         (Map,elems,adjust,unionWith,intersectionWith,fromList,mapKeys,insert)
+import Data.Maybe       (isNothing)
+import Data.Set         (Set)
+import Data.Text        (Text,unwords)
+import Data.Tuple       (fst, snd)
+import Data.Vector      (Vector)
+
+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
+import qualified Data.Vector as Vector
+
+
+-- | To transform a flat Phyloview into a nested Phyloview 
+toNestedView :: [PhyloNode] -> [PhyloNode] -> [PhyloNode]
+toNestedView ns ns'
+  | null ns'  = ns
+  | otherwise = toNestedView (filter (\n -> lvl' == getNodeLevel n) nested)
+                             (filter (\n -> lvl' <  getNodeLevel n) nested)
+    where
+      --------------------------------------
+      lvl' :: Level
+      lvl' = getNodeLevel $ head $ nested
+      --------------------------------------
+      nested :: [PhyloNode]
+      nested = foldl (\ns' n -> let nId' = getNodeParentId n
+                                in map (\n' -> if getNodeId n' == nId'
+                                               then n' & phylo_nodeChilds %~ (++ [n])
+                                               else n') ns') ns' ns
+      --------------------------------------  
+
+
+-- | To process a DisplayMode to a PhyloView
+processDisplay :: DisplayMode -> PhyloView -> PhyloView
+processDisplay d v = case d of 
+                     Flat   -> v
+                     Nested -> let ns  = sortOn getNodeLevel $ v ^. phylo_viewNodes
+                                   lvl = getNodeLevel $ head ns
+                               in v & phylo_viewNodes .~ toNestedView (filter (\n -> lvl == getNodeLevel n) ns)
+                                                                      (filter (\n -> lvl <  getNodeLevel n) ns) 
+                     _      -> panic "[ERR][Viz.Phylo.Example.processDisplay] display not found"
\ No newline at end of file

src/Gargantext/Viz/Phylo/View/Filters.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.View.Filters
+  where
+
+import Control.Lens     hiding (makeLenses, both, Level)
+
+import Data.List        (notElem,last,head,union,concat,null,nub,(++),init,tail,elemIndex,groupBy,(!!),sortOn,sort,(\\))
+import Data.Map         (Map,elems,adjust,unionWith,intersectionWith,fromList,mapKeys)
+import Data.Maybe       (isNothing)
+import Data.Set         (Set)
+import Data.Text        (Text,unwords)
+import Data.Tuple       (fst, snd)
+import Data.Vector      (Vector)
+
+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
+import qualified Data.Vector as Vector
+
+
+-- | To clean a PhyloView list of Nodes, Edges, etc after having filtered its Branches
+cleanNodesEdges :: PhyloView -> PhyloView -> PhyloView
+cleanNodesEdges v v' = v' & phylo_viewNodes %~ (filter (\n -> not $ elem (getNodeId n) nIds))
+                          & phylo_viewNodes %~ (map (\n -> if isNothing (n ^. phylo_nodeParent)
+                                                           then n
+                                                           else if elem (getNodeParentId n) nIds
+                                                                then n & phylo_nodeParent .~ Nothing
+                                                                else n ))
+                          & phylo_viewEdges %~ (filter (\e -> (not $ elem (getSourceId e) nIds)
+                                                           && (not $ elem (getTargetId e) nIds)))
+  where
+    --------------------------------------
+    nIds :: [PhyloGroupId]
+    nIds = map getNodeId
+         $ filter (\n -> elem (getNodeBranchId n) bIds)
+         $ getNodesInBranches v
+    --------------------------------------
+    bIds :: [PhyloBranchId]
+    bIds = (getViewBranchIds v) \\ (getViewBranchIds v')
+    --------------------------------------
+
+
+-- | To filter all the lonelyBranches (ie: isolated one in time & with a small number of nodes) of a PhyloView
+filterLonelyBranch :: Int -> Int -> Int -> [PhyloPeriodId] -> PhyloView -> PhyloView
+filterLonelyBranch nbInf nbSup nbNs prds v = cleanNodesEdges v v'
+  where
+    --------------------------------------
+    v' :: PhyloView
+    v' = v & phylo_viewBranches %~ (filter (\b -> let ns = filter (\n -> (getBranchId b)  == (getNodeBranchId n)) 
+                                                         $ getNodesInBranches v
+                                                      prds' = nub $ map (\n -> (fst . fst) $ getNodeId n) ns
+                                                  in not (isLone ns prds')))
+    --------------------------------------
+    isLone :: [PhyloNode] -> [PhyloPeriodId] -> Bool
+    isLone ns prds' = (length ns <= nbNs)
+                      && notElem (head prds') (take nbInf prds)
+                      && notElem (head prds') (take nbSup $ reverse prds)
+    --------------------------------------
+
+
+-- | To process a list of QueryFilter to a PhyloView
+processFilters :: [QueryFilter] -> Phylo -> PhyloView -> PhyloView
+processFilters fs p v = foldl (\v' f -> case f ^. query_filter of
+                                        LonelyBranch -> filterLonelyBranch (round $ (f ^. query_params) !! 0) 
+                                                                           (round $ (f ^. query_params) !! 1) 
+                                                                           (round $ (f ^. query_params) !! 2) (getPhyloPeriods p) v'
+                                        _            -> panic "[ERR][Viz.Phylo.View.Filters.processFilters] filter not found") v fs
\ No newline at end of file

src/Gargantext/Viz/Phylo/View/Metrics.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.View.Metrics
+  where
+
+import Control.Lens     hiding (makeLenses, both, Level)
+
+import Data.List        (notElem,last,head,union,concat,null,nub,(++),init,tail,elemIndex,groupBy,(!!),sortOn,sort,(\\))
+import Data.Map         (Map,elems,adjust,unionWith,intersectionWith,fromList,mapKeys,insert)
+import Data.Maybe       (isNothing)
+import Data.Set         (Set)
+import Data.Text        (Text,unwords)
+import Data.Tuple       (fst, snd)
+import Data.Vector      (Vector)
+
+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
+import qualified Data.Vector as Vector
+
+
+-- | To add a new meta Metric to a PhyloBranch
+addBranchMeta :: PhyloBranchId -> Text -> Double -> PhyloView -> PhyloView
+addBranchMeta id lbl val v = over (phylo_viewBranches
+                                  . traverse) 
+                                  (\b -> if getBranchId b == id
+                                         then b & phylo_branchMeta %~ insert lbl val 
+                                         else b) v
+
+
+-- | To get the age (in year) of all the branches of a PhyloView
+branchAge :: PhyloView -> PhyloView
+branchAge v = foldl (\v' b -> let bId = (fst . head) b
+                                  prds = sortOn fst $ map snd b
+                              in addBranchMeta bId "age" ((abs . fromIntegral) 
+                                                          $ ((snd . last) prds) - ((fst . head) prds)) v') v
+            $ groupBy ((==) `on` fst)
+            $ sortOn fst
+            $ map (\n -> (getNodeBranchId n, (fst . fst) $ getNodeId n))
+            $ getNodesInBranches v
+
+
+-- | To process a list of Metrics to a PhyloView
+processMetrics :: [Metric] -> Phylo -> PhyloView -> PhyloView
+processMetrics ms p v = foldl (\v' m -> case m of
+                                        BranchAge -> branchAge v'
+                                        _         -> panic "[ERR][Viz.Phylo.Example.processMetrics] metric not found") v ms
+
+

src/Gargantext/Viz/Phylo/View/Sort.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.View.Sort
+  where
+
+import Control.Lens     hiding (makeLenses, both, Level)
+
+import Data.List        (notElem,last,head,union,concat,null,nub,(++),init,tail,elemIndex,groupBy,(!!),sortOn,sort,(\\))
+import Data.Map         (Map,elems,adjust,unionWith,intersectionWith,fromList,mapKeys,insert)
+import Data.Maybe       (isNothing)
+import Data.Set         (Set)
+import Data.Text        (Text,unwords)
+import Data.Tuple       (fst, snd)
+import Data.Vector      (Vector)
+
+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
+import qualified Data.Vector as Vector
+
+
+-- | To sort a PhyloView by Age
+sortBranchByAge :: Order -> PhyloView -> PhyloView
+sortBranchByAge o v = v & phylo_viewBranches %~ f
+  where
+    --------------------------------------
+    f :: [PhyloBranch] -> [PhyloBranch] 
+    f xs = case o of 
+           Asc  -> sortOn (getBranchMeta "age") xs
+           Desc -> reverse $ sortOn (getBranchMeta "age") xs
+    --------------------------------------
+
+-- | To process a Sort to a PhyloView
+processSort :: Maybe (Sort,Order) -> Phylo -> PhyloView -> PhyloView 
+processSort s p v = case s of
+                    Nothing -> v
+                    Just s  -> case fst s of
+                               ByBranchAge -> sortBranchByAge (snd s) v
+                               _           -> panic "[ERR][Viz.Phylo.View.Sort.processSort] sort not found"
\ No newline at end of file

src/Gargantext/Viz/Phylo/View/Taggers.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.View.Taggers
+  where
+
+import Control.Lens     hiding (makeLenses, both, Level)
+
+import Data.List        (last,head,union,concat,null,nub,(++),init,tail,elemIndex,groupBy,(!!),sortOn,sort)
+import Data.Map         (Map,elems,adjust,unionWith,intersectionWith,fromList,mapKeys)
+import Data.Set         (Set)
+import Data.Text        (Text,unwords)
+import Data.Tuple       (fst, snd)
+import Data.Vector      (Vector)
+
+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
+import qualified Data.Vector as Vector
+
+
+-- | To transform a list of Ngrams Indexes into a Label
+ngramsToLabel :: Vector Ngrams -> [Int] -> Text 
+ngramsToLabel ngrams l = unwords $ 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
+
+
+-- | To get the nth most frequent Ngrams in a list of PhyloGroups
+mostFreqNgrams :: Int -> [PhyloGroup] -> [Int]
+mostFreqNgrams thr groups = map fst 
+                          $ take thr 
+                          $ reverse 
+                          $ sortOn snd 
+                          $ map (\g -> (head g,length g)) 
+                          $ groupBy (==) 
+                          $ (sort . concat) 
+                          $ map getGroupNgrams groups
+
+
+-- | To transform the nth most frequent Ngrams into a label 
+freqToLabel :: Int -> Vector Ngrams -> [PhyloGroup] -> Text
+freqToLabel thr ngs l = ngramsToLabel ngs $ mostFreqNgrams thr l  
+
+
+-- | To get the (nth `div` 2) most cooccuring Ngrams in a PhyloGroup 
+mostOccNgrams :: Int -> PhyloGroup -> [Int]
+mostOccNgrams thr group = (nub . concat ) 
+                        $ map (\((f,s),d) -> [f,s]) 
+                        $ take (thr `div` 2) 
+                        $ reverse $ sortOn snd $ Map.toList $ getGroupCooc group
+
+
+-- | To alter the label of a PhyloBranch
+alterBranchLabel :: (PhyloBranchId,Text) -> PhyloView -> PhyloView
+alterBranchLabel (id,lbl) v = over (phylo_viewBranches
+                                   . traverse) 
+                                   (\b -> if getBranchId b == id
+                                          then b & phylo_branchLabel .~ lbl 
+                                          else b) v
+
+
+-- | To set the label of a PhyloBranch as the nth most frequent terms of its PhyloNodes
+branchLabelFreq :: PhyloView -> Int -> Phylo -> PhyloView
+branchLabelFreq v thr p = foldl (\v' (id,lbl) -> alterBranchLabel (id,lbl) v') v
+                        $ map (\(id,ns) -> (id, freqToLabel thr (getFoundations p)
+                                              $ getGroupsFromNodes ns p)) 
+                        $ getNodesByBranches v
+
+
+-- | 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 (phylo_viewNodes
+                             . traverse)
+                             (\n -> let lbl = ngramsToLabel (getFoundations p)
+                                            $ mostOccNgrams thr
+                                            $ head $ getGroupsFromIds [getNodeId n] p
+                                    in n & phylo_nodeLabel .~ lbl) v
+
+
+-- | To process a sorted list of Taggers to a PhyloView
+processTaggers :: [Tagger] -> Phylo -> PhyloView -> PhyloView 
+processTaggers ts p v = foldl (\v' t -> case t of
+                                        BranchLabelFreq -> branchLabelFreq v' 2 p
+                                        GroupLabelCooc  -> nodeLabelCooc   v' 2 p
+                                        _               -> panic "[ERR][Viz.Phylo.View.Taggers.processTaggers] tagger not found") v ts
+

src/Gargantext/Viz/Phylo/View/ViewMaker.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.View.ViewMaker
+  where
+
+import Control.Lens     hiding (makeLenses, both, Level)
+
+import Data.List        (notElem,last,head,union,concat,null,nub,(++),init,tail,elemIndex,groupBy,(!!),sortOn,sort,(\\))
+import Data.Map         (Map,elems,adjust,unionWith,intersectionWith,fromList,mapKeys,insert,empty)
+import Data.Maybe       (isNothing)
+import Data.Set         (Set)
+import Data.Text        (Text,unwords)
+import Data.Tuple       (fst, snd)
+import Data.Vector      (Vector)
+
+import Gargantext.Prelude             hiding (head)
+import Gargantext.Viz.Phylo
+import Gargantext.Viz.Phylo.Tools
+import Gargantext.Viz.Phylo.View.Display
+import Gargantext.Viz.Phylo.View.Filters 
+import Gargantext.Viz.Phylo.View.Metrics
+import Gargantext.Viz.Phylo.View.Sort
+import Gargantext.Viz.Phylo.View.Taggers
+
+import qualified Data.List   as List
+import qualified Data.Map    as Map
+import qualified Data.Set    as Set
+import qualified Data.Vector as Vector
+
+
+-- | To init a PhyloBranch
+initPhyloBranch :: PhyloBranchId -> Text -> PhyloBranch
+initPhyloBranch id lbl = PhyloBranch id lbl empty
+
+
+-- | To init a PhyloEdge
+initPhyloEdge :: PhyloGroupId -> [Pointer] -> EdgeType -> [PhyloEdge]
+initPhyloEdge id pts et = map (\pt -> PhyloEdge id (fst pt) et (snd pt)) pts
+
+
+-- | To init a PhyloView
+initPhyloView :: Level -> Text -> Text -> Filiation -> Bool -> Phylo -> PhyloView 
+initPhyloView lvl lbl dsc fl vb p = PhyloView (getPhyloParams p) lbl dsc fl empty
+                                    ([] ++ (phyloToBranches lvl p)) 
+                                    ([] ++ (groupsToNodes True vb (getFoundations p) gs))
+                                    ([] ++ (groupsToEdges fl PeriodEdge gs))
+  where
+    --------------------------------------
+    gs :: [PhyloGroup]
+    gs = getGroupsWithLevel lvl p
+    --------------------------------------
+
+
+-- | To transform a list of PhyloGroups into a list of PhyloNodes
+groupsToNodes :: Bool -> Bool -> Vector Ngrams -> [PhyloGroup] -> [PhyloNode]
+groupsToNodes isR isV ns gs = map (\g -> let idxs = getGroupNgrams g
+                                         in PhyloNode 
+                                              (getGroupId g)
+                                              (getGroupBranchId g) 
+                                              "" idxs
+                                              (if isV 
+                                                then Just (ngramsToText ns idxs)
+                                                else Nothing)
+                                              empty 
+                                              (if (not isR)
+                                                then Just (head $ getGroupLevelParentsId g)
+                                                else Nothing)
+                                              []
+                                  ) gs
+
+
+-- | To transform a list of PhyloGroups into a list of PhyloEdges
+groupsToEdges :: Filiation -> EdgeType -> [PhyloGroup] -> [PhyloEdge]
+groupsToEdges fl et gs = case fl of 
+                         Complete -> (groupsToEdges Ascendant et gs) ++ (groupsToEdges Descendant et gs)
+                         _        -> concat 
+                                   $ map (\g -> case fl of
+                                                Ascendant  -> case et of 
+                                                              PeriodEdge -> initPhyloEdge (getGroupId g) (getGroupPeriodParents g) et
+                                                              LevelEdge  -> initPhyloEdge (getGroupId g) (getGroupLevelParents  g) et
+                                                Descendant -> case et of 
+                                                              PeriodEdge -> initPhyloEdge (getGroupId g) (getGroupPeriodChilds  g) et
+                                                              LevelEdge  -> initPhyloEdge (getGroupId g) (getGroupLevelChilds   g) et 
+                                                ) gs
+
+
+-- | To transform a Phylo into a list of PhyloBranch for a given Level
+phyloToBranches :: Level -> Phylo -> [PhyloBranch]
+phyloToBranches lvl p = map (\id -> initPhyloBranch id "") $ nub $ getBranchIdsWith lvl p
+
+
+-- | To add recursively a list of PhyloNodes and Edges to PhyloView from a given Level and Depth   
+addChildNodes :: Bool -> Level -> Level -> Bool -> Filiation -> Phylo -> PhyloView -> PhyloView
+addChildNodes shouldDo lvl lvlMin vb fl p v = 
+  if (not shouldDo) || (lvl == lvlMin) 
+  then v
+  else addChildNodes shouldDo (lvl - 1) lvlMin vb fl p 
+     $ v & phylo_viewBranches %~ (++ (phyloToBranches (lvl - 1) p))
+         & phylo_viewNodes %~ (++ (groupsToNodes False vb (getFoundations p) gs'))
+         & phylo_viewEdges %~ (++ (groupsToEdges fl PeriodEdge gs'))
+         & phylo_viewEdges %~ (++ (groupsToEdges Descendant LevelEdge gs ))
+         & phylo_viewEdges %~ (++ (groupsToEdges Ascendant LevelEdge  gs'))
+    where
+      --------------------------------------
+      gs :: [PhyloGroup]
+      gs = getGroupsWithLevel lvl p
+      --------------------------------------  
+      gs' :: [PhyloGroup]
+      gs' = getGroupsWithLevel (lvl - 1) p
+      --------------------------------------
+
+
+-- | To transform a PhyloQuery into a PhyloView
+queryToView :: PhyloQuery -> Phylo -> PhyloView
+queryToView q p = processDisplay (q ^. query_display)
+                $ processSort (q ^. query_sort) p
+                $ processTaggers (q ^. query_taggers) p
+                $ processFilters (q ^. query_filters) p
+                $ processMetrics (q ^. query_metrics) p 
+                $ addChildNodes  (q ^. query_childs) (q ^. query_lvl) (q ^. query_childsDepth) (q ^. query_verbose) (q ^. query_filiation) p
+                $ initPhyloView  (q ^. query_lvl) "Phylo2000" "This is a Phylo" (q ^. query_filiation) (q ^. query_verbose) p
+
+
+-- | dirty params
+phyloParams :: PhyloParam
+phyloParams = PhyloParam "v0.1" (Software "Gargantext" "v4") ""
+
+
+-- | To do : effectively get the PhyloParams of a Phylo
+getPhyloParams :: Phylo -> PhyloParam 
+getPhyloParams p = phyloParams
\ No newline at end of file