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                                               (if (not isR)
  77                                                 then Just (getGroupLevelParentsId g)
  78                                                 else Nothing)
  79                                               []
  80                                   ) gs
  81
  82
  83 -- | To merge edges by keeping the maximum weight
  84 mergeEdges :: [PhyloEdge] -> [PhyloEdge] -> [PhyloEdge]
  85 mergeEdges lAsc lDes = elems
  86                      $ unionWithKey (\_k vAsc vDes -> vDes & pe_weight .~ (max (vAsc ^. pe_weight) (vDes ^. pe_weight))) mAsc mDes
  87   where
  88     --------------------------------------
  89     mAsc :: Map (PhyloGroupId,PhyloGroupId) PhyloEdge
  90     mAsc = fromList
  91          $ map (\(k,e) -> (k, e & pe_source .~ fst k
  92                                 & pe_target .~ snd k))
  93          $ zip (map (\e -> (e ^. pe_target,e ^. pe_source)) lAsc) lAsc
  94     --------------------------------------
  95     mDes :: Map (PhyloGroupId,PhyloGroupId) PhyloEdge
  96     mDes = fromList
  97          $ zip (map (\e -> (e ^. pe_source,e ^. pe_target)) lDes) lDes
  98     --------------------------------------
  99
 100
 101 -- | To transform a list of PhyloGroups into a list of PhyloEdges
 102 groupsToEdges :: Filiation -> EdgeType -> [PhyloGroup] -> [PhyloEdge]
 103 groupsToEdges fl et gs = case fl of
 104                          Complete -> (groupsToEdges Ascendant et gs) ++ (groupsToEdges Descendant et gs)
 105                          Merge    -> mergeEdges (groupsToEdges Ascendant et gs) (groupsToEdges Descendant et gs)
 106                          _        -> concat
 107                                    $ map (\g -> case fl of
 108                                                 Ascendant  -> case et of
 109                                                               PeriodEdge -> initPhyloEdge (getGroupId g) (getGroupPeriodParents g) et
 110                                                               LevelEdge  -> initPhyloEdge (getGroupId g) (getGroupLevelParents  g) et
 111                                                 Descendant -> case et of
 112                                                               PeriodEdge -> initPhyloEdge (getGroupId g) (getGroupPeriodChilds  g) et
 113                                                               LevelEdge  -> initPhyloEdge (getGroupId g) (getGroupLevelChilds   g) et
 114                                                 _Type      -> panic "[ERR][Viz.Phylo.View.ViewMaker.groupsToEdges] not implemented"
 115                                                 ) gs
 116
 117
 118 -- | To transform a Phylo into a list of PhyloBranch for a given Level
 119 phyloToBranches :: Level -> Phylo -> [PhyloBranch]
 120 phyloToBranches lvl p = map (\id -> initPhyloBranch id "") $ nub $ getBranchIdsWith lvl p
 121
 122
 123 -- | To add recursively a list of PhyloNodes and Edges to PhyloView from a given Level and Depth
 124 addChildNodes :: Bool -> Level -> Level -> Bool -> Filiation -> Phylo -> PhyloView -> PhyloView
 125 addChildNodes shouldDo lvl lvlMin vb fl p v =
 126   if (not shouldDo) || (lvl == lvlMin)
 127   then v
 128   else addChildNodes shouldDo (lvl - 1) lvlMin vb fl p
 129      $ v & pv_branches %~ (++ (phyloToBranches (lvl - 1) p))
 130          & pv_nodes %~ (++ (groupsToNodes False vb (getFoundationsRoots p) gs'))
 131          & pv_edges %~ (++ (groupsToEdges fl PeriodEdge gs'))
 132          & pv_edges %~ (++ (groupsToEdges Descendant LevelEdge gs ))
 133          & pv_edges %~ (++ (groupsToEdges Ascendant LevelEdge  gs'))
 134     where
 135       --------------------------------------
 136       gs :: [PhyloGroup]
 137       gs = getGroupsWithLevel lvl p
 138       --------------------------------------
 139       gs' :: [PhyloGroup]
 140       gs' = getGroupsWithLevel (lvl - 1) p
 141       --------------------------------------
 142
 143
 144 -- | To transform a PhyloQuery into a PhyloView
 145 toPhyloView :: PhyloQueryView -> Phylo -> PhyloView
 146 toPhyloView q p = traceView
 147                 $ processDisplay (q ^. qv_display) (q ^. qv_export)
 148                 $ processSort    (q ^. qv_sort   ) p
 149                 $ processTaggers (q ^. qv_taggers) p
 150                 $ processDynamics
 151                 $ processFilters (q ^. qv_filters) p
 152                 $ processMetrics (q ^. qv_metrics) p
 153                 $ addChildNodes  (q ^. qv_levelChilds) (q ^. qv_lvl) (q ^. qv_levelChildsDepth) (q ^. qv_verbose) (q ^. qv_filiation) p
 154                 $ initPhyloView  (q ^. qv_lvl) (getPhyloTitle p) (getPhyloDescription p) (q ^. qv_filiation) (q ^. qv_verbose) p
 155
 156
 157
 158 -----------------
 159 -- | Taggers | --
 160 -----------------
 161
 162
 163 traceView :: PhyloView -> PhyloView
 164 traceView pv = trace ("------------\n--| View |--\n------------\n\n"
 165   <> "view level : " <> show (pv ^. pv_level) <> "\n"
 166   <> show (length $ pv ^. pv_branches) <> " exported branches with " <> show (length $ pv ^. pv_nodes) <> " groups\n"
 167   <> "groups by branches : " <> show (percentile 25 (VS.fromList lst)) <> " (25%) "
 168                              <> show (percentile 50 (VS.fromList lst)) <> " (50%) "
 169                              <> show (percentile 75 (VS.fromList lst)) <> " (75%) "
 170                              <> show (percentile 90 (VS.fromList lst)) <> " (90%)\n") pv
 171   where
 172     lst = sort $ map (fromIntegral . length . snd) $ getNodesByBranches pv