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