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 {- | TODO remove unused function
  48 getMetrics :: FlowCmdM env err m
  49             => CorpusId -> Maybe ListId -> TabType -> Maybe Limit
  50             -> m (Map Text (ListType, Maybe Text), [Scored Text])
  51 getMetrics cId maybeListId tabType maybeLimit = do
  52   (ngs, ngs', metrics)    <- getLocalMetrics cId maybeListId tabType maybeLimit
  53
  54   (_masterUserId, _masterRootId, masterCorpusId) <- getOrMkRootWithCorpus userMaster "" (Nothing :: Maybe HyperdataCorpus)
  55
  56   lId  <- defaultList cId
  57   lIds <- selectNodesWithUsername NodeList userMaster
  58
  59   metrics' <- getTficfWith cId masterCorpusId (lIds <> [lId]) (ngramsTypeFromTabType tabType) ngs'
  60
  61   pure (ngs , toScored [metrics, Map.fromList $ map (\(a,b) -> (a, Vec.fromList [fst b])) $ Map.toList metrics'])
  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
  75 getNgramsCooc :: (FlowCmdM env err m)
  76             => CorpusId -> Maybe ListId -> TabType -> Maybe Limit
  77             -> m ( Map Text (ListType, Maybe Text)
  78                  , Map Text (Maybe RootTerm)
  79                  , Map (Text, Text) Int
  80                  )
  81 getNgramsCooc cId maybeListId tabType maybeLimit = do
  82   (ngs', ngs) <- getNgrams cId maybeListId tabType
  83
  84   let
  85     take' Nothing xs  = xs
  86     take' (Just n) xs = take n xs
  87
  88   lId  <- defaultList cId
  89   lIds <- selectNodesWithUsername NodeList userMaster
  90
  91   myCooc <- Map.filter (>1) <$> getCoocByNgrams (Diagonal True)
  92                             <$> groupNodesByNgrams ngs
  93                             <$> getNodesByNgramsOnlyUser cId (lIds <> [lId]) (ngramsTypeFromTabType tabType)
  94                                                              (take' maybeLimit $ Map.keys ngs)
  95   pure $ (ngs', ngs, myCooc)
  96
  97
  98
  99 getNgrams :: (FlowCmdM env err m)
 100             => CorpusId -> Maybe ListId -> TabType
 101             -> m (Map Text (ListType, Maybe Text), Map Text (Maybe RootTerm))
 102 getNgrams cId maybeListId tabType = do
 103   lId <- case maybeListId of
 104     Nothing   -> defaultList cId
 105     Just lId' -> pure lId'
 106
 107   lists    <- mapTermListRoot [lId] (ngramsTypeFromTabType tabType)
 108   let maybeSyn = Map.unions $ map (\t -> filterListWithRoot t lists)
 109                              [GraphTerm, StopTerm, CandidateTerm]
 110   pure (lists, maybeSyn)
 111