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