]> Git — Sourcephile - gargantext.git/blob - src/Gargantext/API/Ngrams/Tools.hs
Merge branch 'dev-phylo' of ssh://gitlab.iscpif.fr:20022/gargantext/haskell-gargantex...
[gargantext.git] / src / Gargantext / API / Ngrams / Tools.hs
1 {-|
2 Module : Gargantext.API.Ngrams.Tools
3 Description : Tools to manage Ngrams Elements (from the API)
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 {-# LANGUAGE NoImplicitPrelude #-}
13 {-# LANGUAGE OverloadedStrings #-}
14 {-# LANGUAGE RankNTypes #-}
15
16 module Gargantext.API.Ngrams.Tools
17 where
18
19 import Control.Concurrent
20 import Control.Lens (_Just, (^.), at, view)
21 import Control.Monad.Reader
22 import Data.Map.Strict (Map)
23 import Data.Set (Set)
24 import Data.Text (Text)
25 import Data.Validity
26 import Gargantext.API.Ngrams
27 import Gargantext.Core.Types (ListType(..), NodeId, ListId)
28 import Gargantext.Database.Schema.Ngrams (NgramsType)
29 import Gargantext.Prelude
30 import qualified Data.Map.Strict as Map
31 import qualified Data.Set as Set
32
33
34 type RootTerm = Text
35
36 getRepo :: RepoCmdM env err m => m NgramsRepo
37 getRepo = do
38 v <- view repoVar
39 liftIO $ readMVar v
40
41 listNgramsFromRepo :: [ListId] -> NgramsType
42 -> NgramsRepo -> Map Text NgramsRepoElement
43 listNgramsFromRepo nodeIds ngramsType repo = ngrams
44 where
45 ngramsMap = repo ^. r_state . at ngramsType . _Just
46
47 ngrams = Map.unionsWith mergeNgramsElement
48 [ ngramsMap ^. at nodeId . _Just | nodeId <- nodeIds ]
49
50 -- TODO-ACCESS: We want to do the security check before entering here.
51 -- Add a static capability parameter would be nice.
52 -- Ideally this is the access to `repoVar` which needs to
53 -- be properly guarded.
54 getListNgrams :: RepoCmdM env err m
55 => [ListId] -> NgramsType
56 -> m (Map Text NgramsRepoElement)
57 getListNgrams nodeIds ngramsType = listNgramsFromRepo nodeIds ngramsType <$> getRepo
58
59 getTermsWith :: (RepoCmdM env err m, Ord a)
60 => (Text -> a ) -> [ListId]
61 -> NgramsType -> ListType
62 -> m (Map a [a])
63 getTermsWith f ls ngt lt = Map.fromListWith (<>)
64 <$> map (toTreeWith f)
65 <$> Map.toList
66 <$> Map.filter (\f' -> (fst f') == lt)
67 <$> mapTermListRoot ls ngt
68 <$> getRepo
69 where
70 toTreeWith f'' (t, (_lt, maybeRoot)) = case maybeRoot of
71 Nothing -> (f'' t, [])
72 Just r -> (f'' r, map f'' [t])
73
74 mapTermListRoot :: [ListId] -> NgramsType
75 -> NgramsRepo -> Map Text (ListType, (Maybe Text))
76 mapTermListRoot nodeIds ngramsType repo =
77 Map.fromList [ (t, (_nre_list nre, _nre_root nre))
78 | (t, nre) <- Map.toList ngrams
79 ]
80 where ngrams = listNgramsFromRepo nodeIds ngramsType repo
81
82 filterListWithRoot :: ListType -> Map Text (ListType, Maybe Text)
83 -> Map Text (Maybe RootTerm)
84 filterListWithRoot lt m = Map.fromList
85 $ map (\(t,(_,r)) -> (t,r))
86 $ filter isGraphTerm (Map.toList m)
87 where
88 isGraphTerm (_t,(l, maybeRoot)) = case maybeRoot of
89 Nothing -> l == lt
90 Just r -> case Map.lookup r m of
91 Nothing -> panic $ "Garg.API.Ngrams.Tools: filterWithRoot, unknown key: " <> r
92 Just (l',_) -> l' == lt
93
94 groupNodesByNgrams :: Map Text (Maybe RootTerm)
95 -> Map Text (Set NodeId)
96 -> Map Text (Set NodeId)
97 groupNodesByNgrams syn occs = Map.fromListWith (<>) occs'
98 where
99 occs' = map toSyn (Map.toList occs)
100 toSyn (t,ns) = case Map.lookup t syn of
101 Nothing -> panic $ "[Garg.API.Ngrams.Tools.groupNodesByNgrams] unknown key: " <> t
102 Just r -> case r of
103 Nothing -> (t, ns)
104 Just r' -> (r',ns)
105
106 data Diagonal = Diagonal Bool
107
108 getCoocByNgrams :: Diagonal -> Map Text (Set NodeId) -> Map (Text, Text) Int
109 getCoocByNgrams = getCoocByNgrams' identity
110
111
112 getCoocByNgrams' :: (Ord a, Ord c) => (b -> Set c) -> Diagonal -> Map a b -> Map (a, a) Int
113 getCoocByNgrams' f (Diagonal diag) m =
114 Map.fromList [( (t1,t2)
115 , maybe 0 Set.size $ Set.intersection
116 <$> (fmap f $ Map.lookup t1 m)
117 <*> (fmap f $ Map.lookup t2 m)
118 ) | (t1,t2) <- case diag of
119 True -> [ (x,y) | x <- Map.keys m, y <- Map.keys m, x <= y]
120 False -> listToCombi identity (Map.keys m)
121 ]
122