src/Gargantext/Database/Metrics.hs

   1 {-|
   2 Module      : Gargantext.Database.Metrics
   3 Description : Get Metrics from Storage (Database like)
   4 Copyright   : (c) CNRS, 2017-Present
   5 License     : AGPL + CECILL v3
   6 Maintainer  : team@gargantext.org
   7 Stability   : experimental
   8 Portability : POSIX
   9
  10 Node API
  11 -}
  12
  13
  14 {-# LANGUAGE OverloadedStrings #-}
  15 {-# LANGUAGE NoImplicitPrelude #-}
  16 {-# LANGUAGE FlexibleContexts  #-}
  17
  18 module Gargantext.Database.Metrics
  19   where
  20
  21 import Data.Map (Map)
  22 import Data.Text (Text)
  23 import Gargantext.API.Ngrams (TabType(..), ngramsTypeFromTabType)
  24 import Gargantext.API.Ngrams.Tools (filterListWithRoot, groupNodesByNgrams, Diagonal(..), getCoocByNgrams, mapTermListRoot, RootTerm)
  25 import Gargantext.Core.Types (ListType(..), Limit, NodeType(..))
  26 import Gargantext.Database.Flow (FlowCmdM)
  27 import Gargantext.Database.Metrics.NgramsByNode (getNodesByNgramsOnlyUser, getTficfWith)
  28 import Gargantext.Database.Node.Select
  29 import Gargantext.Database.Schema.Node (defaultList)
  30 import Gargantext.Database.Types.Node (ListId, CorpusId, HyperdataCorpus)
  31 import Gargantext.Database.Flow (getOrMkRootWithCorpus)
  32 import Gargantext.Database.Config (userMaster)
  33 import Gargantext.Prelude
  34 import Gargantext.Text.Metrics (scored, Scored(..), localMetrics, toScored)
  35 import qualified Data.Map    as Map
  36 import qualified Data.Vector.Storable as Vec
  37
  38
  39 getMetrics' :: FlowCmdM env err m
  40             => CorpusId -> Maybe ListId -> TabType -> Maybe Limit
  41             -> m (Map Text (ListType, Maybe Text), [Scored Text])
  42 getMetrics' cId maybeListId tabType maybeLimit = do
  43   (ngs, _, myCooc) <- getNgramsCooc cId maybeListId tabType maybeLimit
  44   pure (ngs, scored myCooc)
  45
  46
  47 getMetrics :: FlowCmdM env err m
  48             => CorpusId -> Maybe ListId -> TabType -> Maybe Limit
  49             -> m (Map Text (ListType, Maybe Text), [Scored Text])
  50 getMetrics cId maybeListId tabType maybeLimit = do
  51   (ngs, ngs', metrics)    <- getLocalMetrics cId maybeListId tabType maybeLimit
  52
  53   (_masterUserId, _masterRootId, masterCorpusId) <- getOrMkRootWithCorpus userMaster "" (Nothing :: Maybe HyperdataCorpus)
  54
  55   lId  <- defaultList cId
  56   lIds <- selectNodesWithUsername NodeList userMaster
  57
  58   metrics' <- getTficfWith cId masterCorpusId (lIds <> [lId]) (ngramsTypeFromTabType tabType) ngs'
  59
  60   pure (ngs , toScored [metrics, Map.fromList $ map (\(a,b) -> (a, Vec.fromList [fst b])) $ Map.toList metrics'])
  61
  62
  63 getLocalMetrics  :: (FlowCmdM env err m)
  64             => CorpusId -> Maybe ListId -> TabType -> Maybe Limit
  65           -> m ( Map Text (ListType, Maybe Text)
  66                , Map Text (Maybe RootTerm)
  67                  , Map Text (Vec.Vector Double)
  68                  )
  69 getLocalMetrics cId maybeListId tabType maybeLimit = do
  70   (ngs, ngs', myCooc) <- getNgramsCooc cId maybeListId tabType maybeLimit
  71   pure (ngs, ngs', localMetrics myCooc)
  72
  73
  74 getNgramsCooc :: (FlowCmdM env err m)
  75             => CorpusId -> Maybe ListId -> TabType -> Maybe Limit
  76             -> m ( Map Text (ListType, Maybe Text)
  77                  , Map Text (Maybe RootTerm)
  78                  , Map (Text, Text) Int
  79                  )
  80 getNgramsCooc cId maybeListId tabType maybeLimit = do
  81   (ngs', ngs) <- getNgrams cId maybeListId tabType
  82
  83   let
  84     take' Nothing xs  = xs
  85     take' (Just n) xs = take n xs
  86
  87   lId  <- defaultList cId
  88   lIds <- selectNodesWithUsername NodeList userMaster
  89
  90   myCooc <- Map.filter (>1) <$> getCoocByNgrams (Diagonal True)
  91                             <$> groupNodesByNgrams ngs
  92                             <$> getNodesByNgramsOnlyUser cId (lIds <> [lId]) (ngramsTypeFromTabType tabType)
  93                                                              (take' maybeLimit $ Map.keys ngs)
  94   pure $ (ngs', ngs, myCooc)
  95
  96
  97
  98 getNgrams :: (FlowCmdM env err m)
  99             => CorpusId -> Maybe ListId -> TabType
 100             -> m (Map Text (ListType, Maybe Text), Map Text (Maybe RootTerm))
 101 getNgrams cId maybeListId tabType = do
 102   lId <- case maybeListId of
 103     Nothing   -> defaultList cId
 104     Just lId' -> pure lId'
 105
 106   lists    <- mapTermListRoot [lId] (ngramsTypeFromTabType tabType)
 107   let maybeSyn = Map.unions $ map (\t -> filterListWithRoot t lists)
 108                              [GraphTerm, StopTerm, CandidateTerm]
 109   pure (lists, maybeSyn)
 110