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