src/Gargantext/Viz/Phylo/LevelMaker.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.LevelMaker
  18   where
  19
  20 import Control.Lens                 hiding (both, Level)
  21 import Data.List                    ((++), sort, concat, nub, words, zip)
  22 import Data.Map                     (Map, (!), empty, restrictKeys, filterWithKey, singleton)
  23 import Data.Set                     (Set)
  24 import Data.Text                    (Text, words)
  25 import Data.Tuple.Extra
  26
  27 import Gargantext.Prelude                   hiding (head)
  28 import Gargantext.Viz.Phylo.Aggregates.Cooc
  29 import Gargantext.Viz.Phylo
  30 import Gargantext.Viz.Phylo.Tools
  31
  32 import qualified Data.List   as List
  33 import qualified Data.Map    as Map
  34 import qualified Data.Set    as Set
  35 import qualified Data.Text   as Text
  36
  37
  38 -- | A typeClass for polymorphic PhyloLevel functions
  39 class PhyloLevelMaker aggregate
  40     where
  41         -- | To add a new Level of PhyloGroups to a Phylo based on a list of Aggregates
  42         addPhyloLevel :: Level -> Map (Date,Date) [aggregate] -> Phylo -> Phylo
  43         -- | To create a list of PhyloGroups based on a list of aggregates a
  44         toPhyloGroups :: Level -> (Date,Date)  -> [aggregate] -> Map (Date,Date) [aggregate] -> Phylo -> [PhyloGroup]
  45
  46
  47 instance PhyloLevelMaker Cluster
  48   where
  49     --------------------------------------
  50     -- | Level -> Map (Date,Date) [Cluster] -> Phylo -> Phylo
  51     addPhyloLevel lvl m p
  52       | lvl > 1   = toPhyloLevel lvl m p
  53       | otherwise = panic ("[ERR][Viz.Phylo.Example.addPhyloLevel] No process declared for adding Clusters at level < 2")
  54     --------------------------------------
  55     -- | Level -> (Date,Date) -> [Cluster] -> Map (Date,Date) [Cluster] -> Phylo -> [PhyloGroup]
  56     toPhyloGroups lvl (d,d') l m p = map (\(idx,cluster) -> clusterToGroup (d,d') lvl idx "" cluster m p) $ zip [1..] l
  57     --------------------------------------
  58
  59
  60 instance PhyloLevelMaker Fis
  61   where
  62     --------------------------------------
  63     -- | Level -> Map (Date,Date) [Fis] -> Phylo -> Phylo
  64     addPhyloLevel lvl m p
  65       | lvl == 1  = toPhyloLevel lvl m p
  66       | otherwise = panic ("[ERR][Viz.Phylo.Example.addPhyloLevel] No process declared for adding Fis at level <> 1")
  67     --------------------------------------
  68     -- | Level -> (Date,Date) -> [Fis] -> Map (Date,Date) [Fis] -> Phylo -> [PhyloGroup]
  69     toPhyloGroups lvl (d,d') l m p = map (\(idx,fis) -> cliqueToGroup (d,d') lvl idx "" fis m p) $ zip [1..] l
  70     --------------------------------------
  71
  72
  73 instance PhyloLevelMaker Document
  74   where
  75     --------------------------------------
  76     -- | Level -> Map (Date,Date) [Document] -> Phylo -> Phylo
  77     addPhyloLevel lvl m p
  78       | lvl < 0 = toPhyloLevel lvl m p
  79       | otherwise = panic ("[ERR][Viz.Phylo.Example.addPhyloLevel] No process declared for adding Documents at level <> -1")
  80     --------------------------------------
  81     -- | Level -> (Date,Date) -> [Document] -> Map (Date,Date) [Fis] -> Phylo -> [PhyloGroup]
  82     toPhyloGroups lvl (d,d') l m p = map (\(idx,ngram) -> ngramsToGroup (d,d') lvl idx ngram [ngram] p)
  83                                           $ zip [1..]
  84                                           $ (nub . concat)
  85                                           $ map (Text.words . text) l
  86     --------------------------------------
  87
  88
  89 -- | To transform a Cluster into a Phylogroup
  90 clusterToGroup :: PhyloPeriodId -> Level -> Int -> Text -> Cluster -> Map (Date,Date) [Cluster] -> Phylo -> PhyloGroup
  91 clusterToGroup prd lvl idx lbl groups m p =
  92     PhyloGroup ((prd, lvl), idx) lbl ((sort . nub . concat) $ map getGroupNgrams groups) empty empty [] [] [] (map (\g -> (getGroupId g, 1)) groups)
  93
  94
  95 -- | To transform a Clique into a PhyloGroup
  96 cliqueToGroup :: PhyloPeriodId -> Level -> Int -> Text -> (Clique,Support) -> Map (Date, Date) [Fis] -> Phylo -> PhyloGroup
  97 cliqueToGroup prd lvl idx lbl fis m p =
  98     PhyloGroup ((prd, lvl), idx) lbl ngrams (singleton "support" (fromIntegral $ snd fis)) cooc [] [] [] []
  99       where
 100         --------------------------------------
 101         ngrams :: [Int]
 102         ngrams = sort $ map (\x -> ngramsToIdx x p)
 103                       $ Set.toList
 104                       $ fst fis
 105         --------------------------------------
 106         cooc :: Map (Int, Int) Double
 107         cooc =  filterWithKey (\k _ -> elem (fst k) ngrams && elem (snd k) ngrams)
 108                                      $ fisToCooc (restrictKeys m $ Set.fromList [prd]) p
 109         --------------------------------------
 110
 111
 112 -- | To transform a list of Ngrams into a PhyloGroup
 113 ngramsToGroup ::  PhyloPeriodId -> Level -> Int -> Text -> [Ngrams] -> Phylo -> PhyloGroup
 114 ngramsToGroup prd lvl idx lbl ngrams p =
 115     PhyloGroup ((prd, lvl), idx) lbl (sort $ map (\x -> ngramsToIdx x p) ngrams) empty empty [] [] [] []
 116
 117
 118 -- | To traverse a Phylo and add a new PhyloLevel linked to a new list of PhyloGroups
 119 toPhyloLevel :: PhyloLevelMaker a => Level -> Map (Date, Date) [a] -> Phylo -> Phylo
 120 toPhyloLevel lvl m p = alterPhyloPeriods
 121                         (\period -> let pId = _phylo_periodId period
 122                                     in  over (phylo_periodLevels)
 123                                         (\phyloLevels ->
 124                                           let groups = toPhyloGroups lvl pId (m ! pId) m p
 125                                           in  phyloLevels ++ [PhyloLevel (pId, lvl) groups]
 126                                         ) period) p