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