src/Gargantext/Database/Action/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 module Gargantext.Database.Action.Metrics
  14   where
  15
  16 import Data.HashMap.Strict (HashMap)
  17 import Data.Vector (Vector)
  18 import Gargantext.API.Ngrams.Tools (filterListWithRoot, groupNodesByNgrams, Diagonal(..), getCoocByNgrams, mapTermListRoot, RootTerm, getRepo')
  19 import Gargantext.API.Ngrams.Types (TabType(..), ngramsTypeFromTabType, NgramsTerm)
  20 import Gargantext.Core.Text.Metrics (scored, Scored(..), {-localMetrics, toScored-})
  21 import Gargantext.Core.Types (ListType(..), Limit, NodeType(..))
  22 import Gargantext.Core.NodeStory
  23 import Gargantext.Database.Action.Flow.Types (FlowCmdM)
  24 import Gargantext.Database.Action.Metrics.NgramsByNode (getNodesByNgramsOnlyUser{-, getTficfWith-})
  25 import Gargantext.Database.Admin.Config (userMaster)
  26 import Gargantext.Database.Admin.Types.Node (ListId, CorpusId)
  27 import Gargantext.Database.Query.Table.Node (defaultList)
  28 import Gargantext.Database.Query.Table.Node.Select
  29 import Gargantext.Prelude
  30 import qualified Data.HashMap.Strict as HM
  31
  32 getMetrics :: FlowCmdM env err m
  33             => CorpusId -> Maybe ListId -> TabType -> Maybe Limit
  34             -> m (HashMap NgramsTerm (ListType, Maybe NgramsTerm), Vector (Scored NgramsTerm))
  35 getMetrics cId maybeListId tabType maybeLimit = do
  36   (ngs, _, myCooc) <- getNgramsCooc cId maybeListId tabType maybeLimit
  37   -- TODO HashMap
  38   pure (ngs, scored myCooc)
  39
  40
  41 getNgramsCooc :: (FlowCmdM env err m)
  42             => CorpusId -> Maybe ListId -> TabType -> Maybe Limit
  43             -> m ( HashMap NgramsTerm (ListType, Maybe NgramsTerm)
  44                  , HashMap NgramsTerm (Maybe RootTerm)
  45                  , HashMap (NgramsTerm, NgramsTerm) Int
  46                  )
  47 getNgramsCooc cId maybeListId tabType maybeLimit = do
  48   (ngs', ngs) <- getNgrams cId maybeListId tabType
  49
  50   let
  51     take' Nothing  xs = xs
  52     take' (Just n) xs = take n xs
  53
  54   lId  <- defaultList cId
  55   lIds <- selectNodesWithUsername NodeList userMaster
  56
  57   myCooc <- HM.filter (>1) <$> getCoocByNgrams (Diagonal True)
  58                            <$> groupNodesByNgrams ngs
  59                            <$> getNodesByNgramsOnlyUser cId (lIds <> [lId]) (ngramsTypeFromTabType tabType)
  60                                                             (take' maybeLimit $ HM.keys ngs)
  61   pure $ (ngs', ngs, myCooc)
  62
  63
  64
  65 getNgrams :: (HasNodeStory env err m)
  66             => CorpusId -> Maybe ListId -> TabType
  67             -> m ( HashMap NgramsTerm (ListType, Maybe NgramsTerm)
  68                  , HashMap NgramsTerm (Maybe RootTerm)
  69                  )
  70 getNgrams cId maybeListId tabType = do
  71
  72   lId <- case maybeListId of
  73     Nothing   -> defaultList cId
  74     Just lId' -> pure lId'
  75
  76   lists <- mapTermListRoot [lId] (ngramsTypeFromTabType tabType) <$> getRepo' [lId]
  77   let maybeSyn = HM.unions $ map (\t -> filterListWithRoot t lists)
  78                              [MapTerm, StopTerm, CandidateTerm]
  79   pure (lists, maybeSyn)
  80
  81
  82
  83