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