Commit b6b50641 authored by Alexandre Delanoë's avatar Alexandre Delanoë

[FIX] Metrics Charts + Grammar rules + ngrams groups.

parent 1441aa53
Pipeline #287 failed with stage
......@@ -395,18 +395,14 @@ type MetricsAPI = Summary "SepGen IncExc metrics"
getMetrics :: NodeId -> GargServer MetricsAPI
getMetrics cId maybeListId maybeTabType maybeLimit = do
(ngs', scores) <- getMetrics' cId maybeListId maybeTabType
(ngs', scores) <- getMetrics' cId maybeListId maybeTabType maybeLimit
let
metrics = map (\(Scored t s1 s2) -> Metric t s1 s2 (listType t ngs')) scores
errorMsg = "API.Node.metrics: key absent"
listType t m = maybe (panic errorMsg) fst $ Map.lookup t m
metricsFiltered = case maybeLimit of
Nothing -> metrics
Just l -> take l metrics
pure $ Metrics metricsFiltered
pure $ Metrics metrics
......
......@@ -22,7 +22,7 @@ import Data.Map (Map)
import Data.Text (Text)
import Gargantext.API.Ngrams (TabType(..), ngramsTypeFromTabType)
import Gargantext.API.Ngrams.Tools
import Gargantext.Core.Types (ListType(..))
import Gargantext.Core.Types (ListType(..), Limit)
import Gargantext.Database.Flow (FlowCmdM)
import Gargantext.Database.Metrics.NgramsByNode (getNodesByNgramsOnlyUser)
import Gargantext.Database.Schema.Node (defaultList)
......@@ -33,9 +33,9 @@ import Servant (ServantErr)
import qualified Data.Map as Map
getMetrics' :: FlowCmdM env ServantErr m
=> CorpusId -> Maybe ListId -> Maybe TabType
=> CorpusId -> Maybe ListId -> Maybe TabType -> Maybe Limit
-> m (Map Text (ListType, Maybe Text), [Scored Text])
getMetrics' cId maybeListId maybeTabType = do
getMetrics' cId maybeListId maybeTabType maybeLimit = do
lId <- case maybeListId of
Nothing -> defaultList cId
......@@ -46,10 +46,14 @@ getMetrics' cId maybeListId maybeTabType = do
ngs' <- mapTermListRoot [lId] ngramsType
let ngs = Map.unions $ map (\t -> filterListWithRoot t ngs')
[GraphTerm, StopTerm, CandidateTerm]
let
take' Nothing xs = xs
take' (Just n) xs = take n xs
myCooc <- Map.filter (>1) <$> getCoocByNgrams True
<$> groupNodesByNgrams ngs
<$> getNodesByNgramsOnlyUser cId ngramsType (Map.keys ngs)
<$> getNodesByNgramsOnlyUser cId ngramsType (take' maybeLimit $ Map.keys ngs)
pure $ (ngs', scored myCooc)
......
......@@ -43,11 +43,12 @@ import qualified Database.PostgreSQL.Simple as DPS
-- discussed. Main purpose of this is offering
-- a first grouping option to user and get some
-- enriched data to better learn and improve that algo
ngramsGroup :: Lang -> Int -> Text -> Text
ngramsGroup l n = Text.intercalate " "
ngramsGroup :: Lang -> Int -> Int -> Text -> Text
ngramsGroup l m n = Text.intercalate " "
. map (stem l)
. take n
. List.sort
. (List.filter (\t -> Text.length t > m))
. Text.splitOn " "
. Text.replace "-" " "
......
......@@ -56,7 +56,7 @@ buildNgramsOthersList uCid groupIt nt = do
buildNgramsTermsList :: UserCorpusId -> MasterCorpusId
-> Cmd err (Map NgramsType [NgramsElement])
buildNgramsTermsList uCid mCid = do
candidates <- sortTficf <$> getTficf' uCid mCid (ngramsGroup EN 2)
candidates <- sortTficf <$> getTficf' uCid mCid (ngramsGroup EN 4 2)
--printDebug "candidate" (length candidates)
let termList = toTermList (isStopTerm . fst) candidates
......@@ -105,8 +105,7 @@ isStopTerm :: Text -> Bool
isStopTerm x = Text.length x < 3
|| not (all Char.isAlpha (Text.unpack x'))
where
x' = ( Text.replace "-" ""
. Text.replace " " ""
. Text.replace "/" ""
) x
x' = foldl (\t -> Text.replace t "")
x
["-"," ","/","(",")"]
......@@ -27,7 +27,7 @@ group :: [TokenTag] -> [TokenTag]
group [] = []
group ntags = group2 NP NP
$ group2 NP VB
$ group2 NP IN
-- $ group2 NP IN
-- - $ group2 IN DT
$ group2 VB NP
$ group2 JJ NP
......
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment