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