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 type RootTerm = Text
  35
  36 getRepo :: RepoCmdM env err m => m NgramsRepo
  37 getRepo = do
  38   v <- view repoVar
  39   liftBase $ 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