src/Gargantext/Core/Viz/Phylo/View/ViewMaker.hs

   1 {-|
   2 Module      : Gargantext.Core.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
  14 module Gargantext.Core.Viz.Phylo.View.ViewMaker
  15   where
  16
  17 import Control.Lens     hiding (makeLenses, both, Level)
  18 import Data.List        (concat,nub,(++),sort)
  19 import Data.Text        (Text)
  20 import Data.Map         (Map, empty, elems, unionWithKey, fromList)
  21 import Data.Tuple       (fst, snd)
  22 import Data.Vector      (Vector)
  23 import Gargantext.Prelude
  24 import Gargantext.Core.Viz.Phylo
  25 import Gargantext.Core.Viz.Phylo.Tools
  26 import Gargantext.Core.Viz.Phylo.Metrics
  27 import Gargantext.Core.Viz.Phylo.View.Display
  28 import Gargantext.Core.Viz.Phylo.View.Filters
  29 import Gargantext.Core.Viz.Phylo.View.Metrics
  30 import Gargantext.Core.Viz.Phylo.View.Sort
  31 import Gargantext.Core.Viz.Phylo.View.Taggers
  32
  33 import qualified Data.Vector.Storable as VS
  34 import Debug.Trace (trace)
  35 import Numeric.Statistics (percentile)
  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 lvl
  50                                     (getPhyloPeriods p)
  51                                     empty
  52                                     ([] ++ (phyloToBranches lvl p))
  53                                     ([] ++ (groupsToNodes True vb (getFoundationsRoots p) gs))
  54                                     ([] ++ (groupsToEdges fl PeriodEdge gs))
  55   where
  56     --------------------------------------
  57     gs :: [PhyloGroup]
  58     gs = getGroupsWithLevel lvl p
  59     --------------------------------------
  60
  61
  62 -- | To transform a list of PhyloGroups into a list of PhyloNodes
  63 groupsToNodes :: Bool -> Bool -> Vector Ngrams -> [PhyloGroup] -> [PhyloNode]
  64 groupsToNodes isR isV ns gs = map (\g -> let idxs = getGroupNgrams g
  65                                          in PhyloNode
  66                                               (getGroupId g)
  67                                               (getGroupBranchId g)
  68                                               "" idxs
  69                                               (if isV
  70                                                 then Just (ngramsToText ns idxs)
  71                                                 else Nothing)
  72                                               (g ^. phylo_groupNgramsMeta)
  73                                               (g ^. phylo_groupCooc)
  74                                               (if (not isR)
  75                                                 then Just (getGroupLevelParentsId g)
  76                                                 else Nothing)
  77                                               []
  78                                   ) gs
  79
  80
  81 -- | To merge edges by keeping the maximum weight
  82 mergeEdges :: [PhyloEdge] -> [PhyloEdge] -> [PhyloEdge]
  83 mergeEdges lAsc lDes = elems
  84                      $ unionWithKey (\_k vAsc vDes -> vDes & pe_weight .~ (max (vAsc ^. pe_weight) (vDes ^. pe_weight))) mAsc mDes
  85   where
  86     --------------------------------------
  87     mAsc :: Map (PhyloGroupId,PhyloGroupId) PhyloEdge
  88     mAsc = fromList
  89          $ map (\(k,e) -> (k, e & pe_source .~ fst k
  90                                 & pe_target .~ snd k))
  91          $ zip (map (\e -> (e ^. pe_target,e ^. pe_source)) lAsc) lAsc
  92     --------------------------------------
  93     mDes :: Map (PhyloGroupId,PhyloGroupId) PhyloEdge
  94     mDes = fromList
  95          $ zip (map (\e -> (e ^. pe_source,e ^. pe_target)) lDes) lDes
  96     --------------------------------------
  97
  98
  99 -- | To transform a list of PhyloGroups into a list of PhyloEdges
 100 groupsToEdges :: Filiation -> EdgeType -> [PhyloGroup] -> [PhyloEdge]
 101 groupsToEdges fl et gs = case fl of
 102                          Complete -> (groupsToEdges Ascendant et gs) ++ (groupsToEdges Descendant et gs)
 103                          Merge    -> mergeEdges (groupsToEdges Ascendant et gs) (groupsToEdges Descendant et gs)
 104                          _        -> concat
 105                                    $ map (\g -> case fl of
 106                                                 Ascendant  -> case et of
 107                                                               PeriodEdge -> initPhyloEdge (getGroupId g) (getGroupPeriodParents g) et
 108                                                               LevelEdge  -> initPhyloEdge (getGroupId g) (getGroupLevelParents  g) et
 109                                                 Descendant -> case et of
 110                                                               PeriodEdge -> initPhyloEdge (getGroupId g) (getGroupPeriodChilds  g) et
 111                                                               LevelEdge  -> initPhyloEdge (getGroupId g) (getGroupLevelChilds   g) et
 112                                                 _Type      -> panic "[ERR][Viz.Phylo.View.ViewMaker.groupsToEdges] not implemented"
 113                                                 ) gs
 114
 115
 116 -- | To transform a Phylo into a list of PhyloBranch for a given Level
 117 phyloToBranches :: Level -> Phylo -> [PhyloBranch]
 118 phyloToBranches lvl p = map (\id -> initPhyloBranch id "") $ nub $ getBranchIdsWith lvl p
 119
 120
 121 -- | To add recursively a list of PhyloNodes and Edges to PhyloView from a given Level and Depth
 122 addChildNodes :: Bool -> Level -> Level -> Bool -> Filiation -> Phylo -> PhyloView -> PhyloView
 123 addChildNodes shouldDo lvl lvlMin vb fl p v =
 124   if (not shouldDo) || (lvl == lvlMin)
 125   then v
 126   else addChildNodes shouldDo (lvl - 1) lvlMin vb fl p
 127      $ v & pv_branches %~ (++ (phyloToBranches (lvl - 1) p))
 128          & pv_nodes %~ (++ (groupsToNodes False vb (getFoundationsRoots p) gs'))
 129          & pv_edges %~ (++ (groupsToEdges fl PeriodEdge gs'))
 130          & pv_edges %~ (++ (groupsToEdges Descendant LevelEdge gs ))
 131          & pv_edges %~ (++ (groupsToEdges Ascendant LevelEdge  gs'))
 132     where
 133       --------------------------------------
 134       gs :: [PhyloGroup]
 135       gs = getGroupsWithLevel lvl p
 136       --------------------------------------
 137       gs' :: [PhyloGroup]
 138       gs' = getGroupsWithLevel (lvl - 1) p
 139       --------------------------------------
 140
 141
 142 -- | To transform a PhyloQuery into a PhyloView
 143 toPhyloView :: PhyloQueryView -> Phylo -> PhyloView
 144 toPhyloView q p = traceView
 145                 $ processDisplay (q ^. qv_display) (q ^. qv_export)
 146                 $ processSort    (q ^. qv_sort   ) p
 147                 $ processTaggers (q ^. qv_taggers) p
 148                 $ processDynamics
 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 -----------------
 157 -- | Taggers | --
 158 -----------------
 159
 160
 161 traceView :: PhyloView -> PhyloView
 162 traceView pv = trace ("------------\n--| View |--\n------------\n\n"
 163   <> "view level : " <> show (pv ^. pv_level) <> "\n"
 164   <> show (length $ pv ^. pv_branches) <> " exported branches with " <> show (length $ pv ^. pv_nodes) <> " groups\n"
 165   <> "groups by branches : " <> show (percentile 25 (VS.fromList lst)) <> " (25%) "
 166                              <> show (percentile 50 (VS.fromList lst)) <> " (50%) "
 167                              <> show (percentile 75 (VS.fromList lst)) <> " (75%) "
 168                              <> show (percentile 90 (VS.fromList lst)) <> " (90%)\n") pv
 169   where
 170     lst = sort $ map (fromIntegral . length . snd) $ getNodesByBranches pv