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,(++),sort)
  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 import qualified Data.Vector.Storable as VS
  36 import Debug.Trace (trace)
  37 import Numeric.Statistics (percentile)
  38
  39 -- | To init a PhyloBranch
  40 initPhyloBranch :: PhyloBranchId -> Text -> PhyloBranch
  41 initPhyloBranch id lbl = PhyloBranch id lbl empty
  42
  43
  44 -- | To init a PhyloEdge
  45 initPhyloEdge :: PhyloGroupId -> [Pointer] -> EdgeType -> [PhyloEdge]
  46 initPhyloEdge id pts et = map (\pt -> PhyloEdge id (fst pt) et (snd pt)) pts
  47
  48
  49 -- | To init a PhyloView
  50 initPhyloView :: Level -> Text -> Text -> Filiation -> Bool -> Phylo -> PhyloView
  51 initPhyloView lvl lbl dsc fl vb p = PhyloView (getPhyloParams p) lbl dsc fl lvl
  52                                     (getPhyloPeriods p)
  53                                     empty
  54                                     ([] ++ (phyloToBranches lvl p))
  55                                     ([] ++ (groupsToNodes True vb (getFoundationsRoots p) gs))
  56                                     ([] ++ (groupsToEdges fl PeriodEdge gs))
  57   where
  58     --------------------------------------
  59     gs :: [PhyloGroup]
  60     gs = getGroupsWithLevel lvl p
  61     --------------------------------------
  62
  63
  64 -- | To transform a list of PhyloGroups into a list of PhyloNodes
  65 groupsToNodes :: Bool -> Bool -> Vector Ngrams -> [PhyloGroup] -> [PhyloNode]
  66 groupsToNodes isR isV ns gs = map (\g -> let idxs = getGroupNgrams g
  67                                          in PhyloNode
  68                                               (getGroupId g)
  69                                               (getGroupBranchId g)
  70                                               "" idxs
  71                                               (if isV
  72                                                 then Just (ngramsToText ns idxs)
  73                                                 else Nothing)
  74                                               empty
  75                                               (if (not isR)
  76                                                 then Just (getGroupLevelParentsId g)
  77                                                 else Nothing)
  78                                               []
  79                                   ) gs
  80
  81
  82 -- | To merge edges by keeping the maximum weight
  83 mergeEdges :: [PhyloEdge] -> [PhyloEdge] -> [PhyloEdge]
  84 mergeEdges lAsc lDes = elems
  85                      $ unionWithKey (\_k vAsc vDes -> vDes & pe_weight .~ (max (vAsc ^. pe_weight) (vDes ^. pe_weight))) mAsc mDes
  86   where
  87     --------------------------------------
  88     mAsc :: Map (PhyloGroupId,PhyloGroupId) PhyloEdge
  89     mAsc = fromList
  90          $ map (\(k,e) -> (k, e & pe_source .~ fst k
  91                                 & pe_target .~ snd k))
  92          $ zip (map (\e -> (e ^. pe_target,e ^. pe_source)) lAsc) lAsc
  93     --------------------------------------
  94     mDes :: Map (PhyloGroupId,PhyloGroupId) PhyloEdge
  95     mDes = fromList
  96          $ zip (map (\e -> (e ^. pe_source,e ^. pe_target)) lDes) lDes
  97     --------------------------------------
  98
  99
 100 -- | To transform a list of PhyloGroups into a list of PhyloEdges
 101 groupsToEdges :: Filiation -> EdgeType -> [PhyloGroup] -> [PhyloEdge]
 102 groupsToEdges fl et gs = case fl of
 103                          Complete -> (groupsToEdges Ascendant et gs) ++ (groupsToEdges Descendant et gs)
 104                          Merge    -> mergeEdges (groupsToEdges Ascendant et gs) (groupsToEdges Descendant et gs)
 105                          _        -> concat
 106                                    $ map (\g -> case fl of
 107                                                 Ascendant  -> case et of
 108                                                               PeriodEdge -> initPhyloEdge (getGroupId g) (getGroupPeriodParents g) et
 109                                                               LevelEdge  -> initPhyloEdge (getGroupId g) (getGroupLevelParents  g) et
 110                                                 Descendant -> case et of
 111                                                               PeriodEdge -> initPhyloEdge (getGroupId g) (getGroupPeriodChilds  g) et
 112                                                               LevelEdge  -> initPhyloEdge (getGroupId g) (getGroupLevelChilds   g) et
 113                                                 _Type      -> panic "[ERR][Viz.Phylo.View.ViewMaker.groupsToEdges] not implemented"
 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 & pv_branches %~ (++ (phyloToBranches (lvl - 1) p))
 129          & pv_nodes %~ (++ (groupsToNodes False vb (getFoundationsRoots p) gs'))
 130          & pv_edges %~ (++ (groupsToEdges fl PeriodEdge gs'))
 131          & pv_edges %~ (++ (groupsToEdges Descendant LevelEdge gs ))
 132          & pv_edges %~ (++ (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 = traceView
 146                 $ processDisplay (q ^. qv_display) (q ^. qv_export)
 147                 $ processSort    (q ^. qv_sort   ) p
 148                 $ processTaggers (q ^. qv_taggers) p
 149                 $ processFilters (q ^. qv_filters) p
 150                 $ processMetrics (q ^. qv_metrics) p
 151                 $ addChildNodes  (q ^. qv_levelChilds) (q ^. qv_lvl) (q ^. qv_levelChildsDepth) (q ^. qv_verbose) (q ^. qv_filiation) p
 152                 $ initPhyloView  (q ^. qv_lvl) (getPhyloTitle p) (getPhyloDescription p) (q ^. qv_filiation) (q ^. qv_verbose) p
 153
 154
 155
 156 -- | To get the PhyloParam of a Phylo
 157 getPhyloParams :: Phylo -> PhyloParam
 158 getPhyloParams = _phylo_param
 159
 160 -- | To get the title of a Phylo
 161 getPhyloTitle :: Phylo -> Text
 162 getPhyloTitle p = _q_phyloTitle $ _phyloParam_query $ getPhyloParams p
 163
 164 -- | To get the desc of a Phylo
 165 getPhyloDescription :: Phylo -> Text
 166 getPhyloDescription p = _q_phyloTitle $ _phyloParam_query $ getPhyloParams p
 167
 168
 169 -----------------
 170 -- | Taggers | --
 171 -----------------
 172
 173
 174 traceView :: PhyloView -> PhyloView
 175 traceView pv = trace ("------------\n--| View |--\n------------\n\n"
 176   <> "view level : " <> show (pv ^. pv_level) <> "\n"
 177   <> show (length $ pv ^. pv_branches) <> " exported branches with " <> show (length $ pv ^. pv_nodes) <> " groups\n"
 178   <> "groups by branches : " <> show (percentile 25 (VS.fromList lst)) <> " (25%) "
 179                              <> show (percentile 50 (VS.fromList lst)) <> " (50%) "
 180                              <> show (percentile 75 (VS.fromList lst)) <> " (75%) "
 181                              <> show (percentile 90 (VS.fromList lst)) <> " (90%)\n") pv
 182   where
 183     lst = sort $ map (fromIntegral . length . snd) $ getNodesByBranches pv