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 import Data.List        (concat,nub,(++))
  22 import Data.Text        (Text)
  23 import Data.Map         (Map, empty, elems, unionWithKey, fromList)
  24 import Data.Tuple       (fst, snd)
  25 import Data.Vector      (Vector)
  26 import Gargantext.Prelude
  27 import Gargantext.Viz.Phylo
  28 import Gargantext.Viz.Phylo.Tools
  29 import Gargantext.Viz.Phylo.View.Display
  30 import Gargantext.Viz.Phylo.View.Filters
  31 import Gargantext.Viz.Phylo.View.Metrics
  32 import Gargantext.Viz.Phylo.View.Sort
  33 import Gargantext.Viz.Phylo.View.Taggers
  34
  35
  36 -- | To init a PhyloBranch
  37 initPhyloBranch :: PhyloBranchId -> Text -> PhyloBranch
  38 initPhyloBranch id lbl = PhyloBranch id lbl empty
  39
  40
  41 -- | To init a PhyloEdge
  42 initPhyloEdge :: PhyloGroupId -> [Pointer] -> EdgeType -> [PhyloEdge]
  43 initPhyloEdge id pts et = map (\pt -> PhyloEdge id (fst pt) et (snd pt)) pts
  44
  45
  46 -- | To init a PhyloView
  47 initPhyloView :: Level -> Text -> Text -> Filiation -> Bool -> Phylo -> PhyloView
  48 initPhyloView lvl lbl dsc fl vb p = PhyloView (getPhyloParams p) lbl dsc fl empty
  49                                     ([] ++ (phyloToBranches lvl p))
  50                                     ([] ++ (groupsToNodes True vb (getPeaksLabels p) gs))
  51                                     ([] ++ (groupsToEdges fl PeriodEdge gs))
  52   where
  53     --------------------------------------
  54     gs :: [PhyloGroup]
  55     gs = getGroupsWithLevel lvl p
  56     --------------------------------------
  57
  58
  59 -- | To transform a list of PhyloGroups into a list of PhyloNodes
  60 groupsToNodes :: Bool -> Bool -> Vector Ngrams -> [PhyloGroup] -> [PhyloNode]
  61 groupsToNodes isR isV ns gs = map (\g -> let idxs = getGroupNgrams g
  62                                          in PhyloNode
  63                                               (getGroupId g)
  64                                               (getGroupBranchId g)
  65                                               "" idxs
  66                                               (if isV
  67                                                 then Just (ngramsToText ns idxs)
  68                                                 else Nothing)
  69                                               empty
  70                                               (if (not isR)
  71                                                 then Just (getGroupLevelParentsId g)
  72                                                 else Nothing)
  73                                               []
  74                                   ) gs
  75
  76
  77 mergeEdges :: [PhyloEdge] -> [PhyloEdge] -> [PhyloEdge]
  78 mergeEdges lAsc lDes = elems
  79                      $ unionWithKey (\_k vAsc vDes -> vDes & pe_weight .~ (max (vAsc ^. pe_weight) (vDes ^. pe_weight))) mAsc mDes
  80   where
  81     --------------------------------------
  82     mAsc :: Map (PhyloGroupId,PhyloGroupId) PhyloEdge
  83     mAsc = fromList
  84          $ zip (map (\e -> (e ^. pe_target,e ^. pe_source)) lAsc) lAsc
  85     --------------------------------------
  86     mDes :: Map (PhyloGroupId,PhyloGroupId) PhyloEdge
  87     mDes = fromList
  88          $ zip (map (\e -> (e ^. pe_source,e ^. pe_target)) lDes) lDes
  89     --------------------------------------
  90
  91
  92 -- | To transform a list of PhyloGroups into a list of PhyloEdges
  93 groupsToEdges :: Filiation -> EdgeType -> [PhyloGroup] -> [PhyloEdge]
  94 groupsToEdges fl et gs = case fl of
  95                          Complete -> (groupsToEdges Ascendant et gs) ++ (groupsToEdges Descendant et gs)
  96                          Merge    -> mergeEdges (groupsToEdges Ascendant et gs) (groupsToEdges Descendant et gs)
  97                          _        -> concat
  98                                    $ map (\g -> case fl of
  99                                                 Ascendant  -> case et of
 100                                                               PeriodEdge -> initPhyloEdge (getGroupId g) (getGroupPeriodParents g) et
 101                                                               LevelEdge  -> initPhyloEdge (getGroupId g) (getGroupLevelParents  g) et
 102                                                 Descendant -> case et of
 103                                                               PeriodEdge -> initPhyloEdge (getGroupId g) (getGroupPeriodChilds  g) et
 104                                                               LevelEdge  -> initPhyloEdge (getGroupId g) (getGroupLevelChilds   g) et
 105                                                 _Type      -> panic "[ERR][Viz.Phylo.View.ViewMaker.groupsToEdges] not implemented"
 106                                                 ) gs
 107
 108
 109 -- | To transform a Phylo into a list of PhyloBranch for a given Level
 110 phyloToBranches :: Level -> Phylo -> [PhyloBranch]
 111 phyloToBranches lvl p = map (\id -> initPhyloBranch id "") $ nub $ getBranchIdsWith lvl p
 112
 113
 114 -- | To add recursively a list of PhyloNodes and Edges to PhyloView from a given Level and Depth
 115 addChildNodes :: Bool -> Level -> Level -> Bool -> Filiation -> Phylo -> PhyloView -> PhyloView
 116 addChildNodes shouldDo lvl lvlMin vb fl p v =
 117   if (not shouldDo) || (lvl == lvlMin)
 118   then v
 119   else addChildNodes shouldDo (lvl - 1) lvlMin vb fl p
 120      $ v & pv_branches %~ (++ (phyloToBranches (lvl - 1) p))
 121          & pv_nodes %~ (++ (groupsToNodes False vb (getPeaksLabels p) gs'))
 122          & pv_edges %~ (++ (groupsToEdges fl PeriodEdge gs'))
 123          & pv_edges %~ (++ (groupsToEdges Descendant LevelEdge gs ))
 124          & pv_edges %~ (++ (groupsToEdges Ascendant LevelEdge  gs'))
 125     where
 126       --------------------------------------
 127       gs :: [PhyloGroup]
 128       gs = getGroupsWithLevel lvl p
 129       --------------------------------------
 130       gs' :: [PhyloGroup]
 131       gs' = getGroupsWithLevel (lvl - 1) p
 132       --------------------------------------
 133
 134
 135 -- | To transform a PhyloQuery into a PhyloView
 136 toPhyloView' :: Maybe Level
 137                       -> Maybe Filiation
 138                       -> Maybe Bool
 139                       -> Maybe Level
 140                       -> Maybe [Metric]
 141                       -> Maybe [Filter]
 142                       -> Maybe [Tagger]
 143                       -> Maybe (Sort, Order)
 144                       -> Maybe DisplayMode
 145                       -> Maybe Bool
 146                       -> PhyloQueryView
 147 toPhyloView' = initPhyloQueryView
 148
 149 toPhyloView :: PhyloQueryView -> Phylo -> PhyloView
 150 toPhyloView q p = processDisplay (q ^. qv_display)
 151                 $ processSort    (q ^. qv_sort   ) p
 152                 $ processTaggers (q ^. qv_taggers) p
 153                 $ processFilters (q ^. qv_filters) p
 154                 $ processMetrics (q ^. qv_metrics) p
 155                 $ addChildNodes  (q ^. qv_levelChilds) (q ^. qv_lvl) (q ^. qv_levelChildsDepth) (q ^. qv_verbose) (q ^. qv_filiation) p
 156                 $ initPhyloView  (q ^. qv_lvl) (getPhyloTitle p) (getPhyloDescription p) (q ^. qv_filiation) (q ^. qv_verbose) p
 157
 158
 159
 160 -- | To get the PhyloParam of a Phylo
 161 getPhyloParams :: Phylo -> PhyloParam
 162 getPhyloParams = _phylo_param
 163
 164 -- | To get the title of a Phylo
 165 getPhyloTitle :: Phylo -> Text
 166 getPhyloTitle p = _q_phyloTitle $ _phyloParam_query $ getPhyloParams p
 167
 168 -- | To get the desc of a Phylo
 169 getPhyloDescription :: Phylo -> Text
 170 getPhyloDescription p = _q_phyloTitle $ _phyloParam_query $ getPhyloParams p