src/Gargantext/Database/Action/Metrics/Lists.hs

   1 {-|
   2 Module      : Gargantext.Database.Lists
   3 Description : Main requests of Node to the database
   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 {-# OPTIONS_GHC -fno-warn-name-shadowing #-}
  12 {-# OPTIONS_GHC -fno-warn-orphans        #-}
  13
  14 {-# LANGUAGE Arrows                 #-}
  15 {-# LANGUAGE ConstraintKinds        #-}
  16 {-# LANGUAGE FunctionalDependencies #-}
  17 {-# LANGUAGE TemplateHaskell        #-}
  18
  19 module Gargantext.Database.Action.Metrics.Lists
  20   where
  21
  22 import Gargantext.API.Ngrams (TabType(..))
  23 import Gargantext.Core.Types -- (NodePoly(..), NodeCorpus, ListId)
  24 import Gargantext.Database.Action.Flow (FlowCmdM)
  25 import Gargantext.Prelude hiding (sum, head)
  26 import Gargantext.Core.Text.Metrics (Scored(..))
  27 import Prelude hiding (null, id, map, sum)
  28 import qualified Data.Map as Map
  29 import qualified Data.Vector as Vec
  30 import qualified Gargantext.Database.Action.Metrics as Metrics
  31
  32 {-
  33 trainModel :: FlowCmdM env ServantErr m
  34              => Username -> m Score
  35 trainModel u = do
  36   rootId <- _node_id <$> getRoot u
  37   (id:ids)   <- getCorporaWithParentId rootId
  38   (s,_model) <- case length ids >0 of
  39         True  ->  grid 100 150 (getMetrics
  40         False -> panic "Gargantext.Database.Lists.trainModel : not enough corpora"
  41   --}
  42
  43
  44 getMetrics' :: FlowCmdM env err m
  45              => CorpusId -> Maybe ListId -> TabType -> Maybe Int
  46              -> m (Map.Map ListType [Vec.Vector Double])
  47 getMetrics' cId maybeListId tabType maybeLimit = do
  48   (ngs', scores) <- Metrics.getMetrics cId maybeListId tabType maybeLimit
  49
  50   let
  51     metrics      = map (\(Scored t s1 s2) -> (listType t ngs', [Vec.fromList [s1,s2]])) scores
  52     listType t m = maybe (panic errorMsg) fst $ Map.lookup t m
  53     errorMsg     = "API.Node.metrics: key absent"
  54
  55   {-
  56   _ <- Learn.grid 100 110 metrics' metrics'
  57   --}
  58   pure $ Map.fromListWith (<>) metrics
  59