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