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

   1 {-|
   2 Module      : Gargantext.Viz.Phylo.Tools
   3 Description : Phylomemy Tools to build/manage it
   4 Copyright   : (c) CNRS, 2017-Present
   5 License     : AGPL + CECILL v3
   6 Maintainer  : team@gargantext.org
   7 Stability   : experimental
   8 Portability : POSIX
   9
  10
  11 -}
  12
  13 {-# LANGUAGE NoImplicitPrelude #-}
  14 {-# LANGUAGE FlexibleContexts  #-}
  15 {-# LANGUAGE OverloadedStrings #-}
  16
  17 module Gargantext.Viz.Phylo.View.ViewMaker
  18   where
  19
  20 import Control.Lens     hiding (makeLenses, both, Level)
  21
  22 import Data.List        (notElem,last,head,union,concat,null,nub,(++),init,tail,elemIndex,groupBy,(!!),sortOn,sort,(\\))
  23 import Data.Map         (Map,elems,adjust,unionWith,unionWithKey,intersectionWith,fromList,mapKeys,insert,empty)
  24 import Data.Maybe       (isNothing)
  25 import Data.Set         (Set)
  26 import Data.Text        (Text,unwords)
  27 import Data.Tuple       (fst, snd)
  28 import Data.Vector      (Vector)
  29
  30 import Gargantext.Prelude             hiding (head)
  31 import Gargantext.Viz.Phylo
  32 import Gargantext.Viz.Phylo.Tools
  33 import Gargantext.Viz.Phylo.View.Display
  34 import Gargantext.Viz.Phylo.View.Filters
  35 import Gargantext.Viz.Phylo.View.Metrics
  36 import Gargantext.Viz.Phylo.View.Sort
  37 import Gargantext.Viz.Phylo.View.Taggers
  38
  39 import qualified Data.List   as List
  40 import qualified Data.Map    as Map
  41 import qualified Data.Set    as Set
  42 import qualified Data.Vector as Vector
  43
  44
  45 -- | To init a PhyloBranch
  46 initPhyloBranch :: PhyloBranchId -> Text -> PhyloBranch
  47 initPhyloBranch id lbl = PhyloBranch id lbl empty
  48
  49
  50 -- | To init a PhyloEdge
  51 initPhyloEdge :: PhyloGroupId -> [Pointer] -> EdgeType -> [PhyloEdge]
  52 initPhyloEdge id pts et = map (\pt -> PhyloEdge id (fst pt) et (snd pt)) pts
  53
  54
  55 -- | To init a PhyloView
  56 initPhyloView :: Level -> Text -> Text -> Filiation -> Bool -> Phylo -> PhyloView
  57 initPhyloView lvl lbl dsc fl vb p = PhyloView (getPhyloParams p) lbl dsc fl empty
  58                                     ([] ++ (phyloToBranches lvl p))
  59                                     ([] ++ (groupsToNodes True vb (getFoundations p) gs))
  60                                     ([] ++ (groupsToEdges fl PeriodEdge gs))
  61   where
  62     --------------------------------------
  63     gs :: [PhyloGroup]
  64     gs = getGroupsWithLevel lvl p
  65     --------------------------------------
  66
  67
  68 -- | To transform a list of PhyloGroups into a list of PhyloNodes
  69 groupsToNodes :: Bool -> Bool -> Vector Ngrams -> [PhyloGroup] -> [PhyloNode]
  70 groupsToNodes isR isV ns gs = map (\g -> let idxs = getGroupNgrams g
  71                                          in PhyloNode
  72                                               (getGroupId g)
  73                                               (getGroupBranchId g)
  74                                               "" idxs
  75                                               (if isV
  76                                                 then Just (ngramsToText ns idxs)
  77                                                 else Nothing)
  78                                               empty
  79                                               (if (not isR)
  80                                                 then Just (getGroupLevelParentsId g)
  81                                                 else Nothing)
  82                                               []
  83                                   ) gs
  84
  85
  86 mergeEdges :: [PhyloEdge] -> [PhyloEdge] -> [PhyloEdge]
  87 mergeEdges lAsc lDes = elems
  88                      $ unionWithKey (\k vAsc vDes -> vDes & phylo_edgeWeight .~ (max (vAsc ^. phylo_edgeWeight) (vDes ^. phylo_edgeWeight))) mAsc mDes
  89   where
  90     --------------------------------------
  91     mAsc :: Map (PhyloGroupId,PhyloGroupId) PhyloEdge
  92     mAsc = fromList
  93          $ zip (map (\e -> (e ^. phylo_edgeTarget,e ^. phylo_edgeSource)) lAsc) lAsc
  94     --------------------------------------
  95     mDes :: Map (PhyloGroupId,PhyloGroupId) PhyloEdge
  96     mDes = fromList
  97          $ zip (map (\e -> (e ^. phylo_edgeSource,e ^. phylo_edgeTarget)) lDes) lDes
  98     --------------------------------------
  99
 100
 101 -- | To transform a list of PhyloGroups into a list of PhyloEdges
 102 groupsToEdges :: Filiation -> EdgeType -> [PhyloGroup] -> [PhyloEdge]
 103 groupsToEdges fl et gs = case fl of
 104                          Complete -> (groupsToEdges Ascendant et gs) ++ (groupsToEdges Descendant et gs)
 105                          Merge    -> mergeEdges (groupsToEdges Ascendant et gs) (groupsToEdges Descendant et gs)
 106                          _        -> concat
 107                                    $ map (\g -> case fl of
 108                                                 Ascendant  -> case et of
 109                                                               PeriodEdge -> initPhyloEdge (getGroupId g) (getGroupPeriodParents g) et
 110                                                               LevelEdge  -> initPhyloEdge (getGroupId g) (getGroupLevelParents  g) et
 111                                                 Descendant -> case et of
 112                                                               PeriodEdge -> initPhyloEdge (getGroupId g) (getGroupPeriodChilds  g) et
 113                                                               LevelEdge  -> initPhyloEdge (getGroupId g) (getGroupLevelChilds   g) et
 114                                                 ) gs
 115
 116
 117 -- | To transform a Phylo into a list of PhyloBranch for a given Level
 118 phyloToBranches :: Level -> Phylo -> [PhyloBranch]
 119 phyloToBranches lvl p = map (\id -> initPhyloBranch id "") $ nub $ getBranchIdsWith lvl p
 120
 121
 122 -- | To add recursively a list of PhyloNodes and Edges to PhyloView from a given Level and Depth
 123 addChildNodes :: Bool -> Level -> Level -> Bool -> Filiation -> Phylo -> PhyloView -> PhyloView
 124 addChildNodes shouldDo lvl lvlMin vb fl p v =
 125   if (not shouldDo) || (lvl == lvlMin)
 126   then v
 127   else addChildNodes shouldDo (lvl - 1) lvlMin vb fl p
 128      $ v & phylo_viewBranches %~ (++ (phyloToBranches (lvl - 1) p))
 129          & phylo_viewNodes %~ (++ (groupsToNodes False vb (getFoundations p) gs'))
 130          & phylo_viewEdges %~ (++ (groupsToEdges fl PeriodEdge gs'))
 131          & phylo_viewEdges %~ (++ (groupsToEdges Descendant LevelEdge gs ))
 132          & phylo_viewEdges %~ (++ (groupsToEdges Ascendant LevelEdge  gs'))
 133     where
 134       --------------------------------------
 135       gs :: [PhyloGroup]
 136       gs = getGroupsWithLevel lvl p
 137       --------------------------------------
 138       gs' :: [PhyloGroup]
 139       gs' = getGroupsWithLevel (lvl - 1) p
 140       --------------------------------------
 141
 142
 143 -- | To transform a PhyloQuery into a PhyloView
 144 toPhyloView :: PhyloQueryView -> Phylo -> PhyloView
 145 toPhyloView q p = processDisplay (q ^. qv_display)
 146                 $ processSort (q ^. qv_sort) p
 147                 $ processTaggers (q ^. qv_taggers) p
 148                 $ processFilters (q ^. qv_filters) p
 149                 $ processMetrics (q ^. qv_metrics) p
 150                 $ addChildNodes  (q ^. qv_levelChilds) (q ^. qv_lvl) (q ^. qv_levelChildsDepth) (q ^. qv_verbose) (q ^. qv_filiation) p
 151                 $ initPhyloView  (q ^. qv_lvl) (getPhyloTitle p) (getPhyloDescription p) (q ^. qv_filiation) (q ^. qv_verbose) p
 152
 153
 154
 155 -- | To get the PhyloParam of a Phylo
 156 getPhyloParams :: Phylo -> PhyloParam
 157 getPhyloParams = _phylo_param
 158
 159 -- | To get the title of a Phylo
 160 getPhyloTitle :: Phylo -> Text
 161 getPhyloTitle p = _q_phyloTitle $ _phyloParam_query $ getPhyloParams p
 162
 163 -- | To get the desc of a Phylo
 164 getPhyloDescription :: Phylo -> Text
 165 getPhyloDescription p = _q_phyloTitle $ _phyloParam_query $ getPhyloParams p