diff --git a/src/Gargantext/API/Metrics.hs b/src/Gargantext/API/Metrics.hs
index 015d7d25e97a1ae0f88139be6a5fc6290e714ef9..fd4b0a58160b2815b4d8ff7ea6dca5fd7bcaecb1 100644
--- a/src/Gargantext/API/Metrics.hs
+++ b/src/Gargantext/API/Metrics.hs
@@ -25,7 +25,7 @@ import Data.Time (UTCTime)
import Servant
import Gargantext.API.HashedResponse
-import Gargantext.API.Ngrams.NTree
+import Gargantext.API.Ngrams.NgramsTree
import Gargantext.API.Ngrams.Types
import Gargantext.API.Prelude (GargServer)
import Gargantext.Core.Types (CorpusId, Limit, ListId, ListType(..))
@@ -317,7 +317,7 @@ type TreeApi = Summary " Tree API"
:> QueryParam "list" ListId
:> QueryParamR "ngramsType" TabType
:> QueryParamR "listType" ListType
- :> Get '[JSON] (HashedResponse (ChartMetrics [MyTree]))
+ :> Get '[JSON] (HashedResponse (ChartMetrics [NgramsTree]))
:<|> Summary "Tree Chart update"
:> QueryParam "list" ListId
:> QueryParamR "ngramsType" TabType
@@ -347,7 +347,7 @@ getTree :: FlowCmdM env err m
-> Maybe ListId
-> TabType
-> ListType
- -> m (HashedResponse (ChartMetrics [MyTree]))
+ -> m (HashedResponse (ChartMetrics [NgramsTree]))
getTree cId _start _end maybeListId tabType listType = do
listId <- case maybeListId of
Just lid -> pure lid
@@ -383,7 +383,7 @@ updateTree' :: FlowCmdM env err m =>
-> Maybe ListId
-> TabType
-> ListType
- -> m (ChartMetrics [MyTree])
+ -> m (ChartMetrics [NgramsTree])
updateTree' cId maybeListId tabType listType = do
listId <- case maybeListId of
Just lid -> pure lid
diff --git a/src/Gargantext/API/Ngrams.hs b/src/Gargantext/API/Ngrams.hs
index 21269d5f4274ce78888564b5549e63f9c0ae2005..3720cce414ca0e66d2a42b8cd48858a775983cb6 100644
--- a/src/Gargantext/API/Ngrams.hs
+++ b/src/Gargantext/API/Ngrams.hs
@@ -1,4 +1,3 @@
-{-# OPTIONS_GHC -fno-warn-unused-top-binds #-}
{-|
Module : Gargantext.API.Ngrams
Description : Server API
@@ -16,6 +15,8 @@ add get
-}
+{-# OPTIONS_GHC -fno-warn-unused-top-binds #-}
+
{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeOperators #-}
diff --git a/src/Gargantext/API/Ngrams/NTree.hs b/src/Gargantext/API/Ngrams/NgramsTree.hs
similarity index 71%
rename from src/Gargantext/API/Ngrams/NTree.hs
rename to src/Gargantext/API/Ngrams/NgramsTree.hs
index c1df9062d2a5c42f2a56c6aac4f61af7ab54d750..3701f00527669d212f304b336e5c4469292e95aa 100644
--- a/src/Gargantext/API/Ngrams/NTree.hs
+++ b/src/Gargantext/API/Ngrams/NgramsTree.hs
@@ -1,5 +1,5 @@
{-|
-Module : Gargantext.API.Ngrams.NTree
+Module : Gargantext.API.Ngrams.NgramsTree
Description : Tree of Ngrams
Copyright : (c) CNRS, 2017-Present
License : AGPL + CECILL v3
@@ -11,7 +11,7 @@ Portability : POSIX
{-# LANGUAGE TemplateHaskell #-}
-module Gargantext.API.Ngrams.NTree
+module Gargantext.API.Ngrams.NgramsTree
where
import Data.Aeson.TH (deriveJSON)
@@ -36,24 +36,25 @@ import Gargantext.Core.Utils.Prefix (unPrefix, unPrefixSwagger)
type Children = Text
type Root = Text
-data MyTree = MyTree { mt_label :: Text
- , mt_value :: Double
- , mt_children :: [MyTree]
- } deriving (Generic, Show)
+data NgramsTree = NgramsTree { mt_label :: Text
+ , mt_value :: Double
+ , mt_children :: [NgramsTree]
+ }
+ deriving (Generic, Show)
-toMyTree :: Tree (Text,Double) -> MyTree
-toMyTree (Node (l,v) xs) = MyTree l v (map toMyTree xs)
+toNgramsTree :: Tree (Text,Double) -> NgramsTree
+toNgramsTree (Node (l,v) xs) = NgramsTree l v (map toNgramsTree xs)
-deriveJSON (unPrefix "mt_") ''MyTree
+deriveJSON (unPrefix "mt_") ''NgramsTree
-instance ToSchema MyTree where
+instance ToSchema NgramsTree where
declareNamedSchema = genericDeclareNamedSchema (unPrefixSwagger "mt_")
-instance Arbitrary MyTree
+instance Arbitrary NgramsTree
where
- arbitrary = MyTree <$> arbitrary <*> arbitrary <*> arbitrary
+ arbitrary = NgramsTree <$> arbitrary <*> arbitrary <*> arbitrary
-toTree :: ListType -> Map Text (Set NodeId) -> Map Text NgramsRepoElement -> [MyTree]
-toTree lt vs m = map toMyTree $ unfoldForest buildNode roots
+toTree :: ListType -> Map Text (Set NodeId) -> Map Text NgramsRepoElement -> [NgramsTree]
+toTree lt vs m = map toNgramsTree $ unfoldForest buildNode roots
where
buildNode r = maybe ((r, value r),[])
(\x -> ((r, value r), unNgramsTerm <$> (mSetToList $ _nre_children x)))
diff --git a/src/Gargantext/Core/Text/List/Social.hs b/src/Gargantext/Core/Text/List/Social.hs
index 00d82709e987cccafd32da9f813db12ade99f197..7ab3d7a6f9753f3a5d4ae544b83e8bcaf34b22ed 100644
--- a/src/Gargantext/Core/Text/List/Social.hs
+++ b/src/Gargantext/Core/Text/List/Social.hs
@@ -13,7 +13,7 @@ module Gargantext.Core.Text.List.Social
import Data.Monoid (mconcat)
import Data.Text (Text)
-import Gargantext.API.Ngrams.Tools -- (getListNgrams)
+import Gargantext.API.Ngrams.Tools
import Gargantext.API.Ngrams.Types
import Gargantext.Core.Text.List.Social.Find
import Gargantext.Core.Text.List.Social.Prelude
@@ -26,7 +26,6 @@ import Gargantext.Database.Query.Tree
import Gargantext.Database.Schema.Ngrams
import Gargantext.Prelude
-------------------------------------------------------------------------
------------------------------------------------------------------------
------------------------------------------------------------------------
-- | Main parameters
@@ -46,7 +45,6 @@ keepAllParents :: NgramsType -> KeepAllParents
keepAllParents NgramsTerms = KeepAllParents False
keepAllParents _ = KeepAllParents True
-
------------------------------------------------------------------------
flowSocialList' :: ( RepoCmdM env err m
, CmdM env err m
@@ -89,5 +87,3 @@ flowSocialList' flowPriority user nt flc =
mapM (\l -> getListNgrams [l] nt'') ns
>>= pure
. toFlowListScores (keepAllParents nt'') flc''
-
-
diff --git a/src/Gargantext/Core/Text/List/Social/ListType.hs b/src/Gargantext/Core/Text/List/Social/ListType.hs
deleted file mode 100644
index 3374d8f30d5d26bcb9dfca1e33e58c0fc9b7e967..0000000000000000000000000000000000000000
--- a/src/Gargantext/Core/Text/List/Social/ListType.hs
+++ /dev/null
@@ -1,95 +0,0 @@
-{-|
-Module : Gargantext.Core.Text.List.Social.ListType
-Description :
-Copyright : (c) CNRS, 2018-Present
-License : AGPL + CECILL v3
-Maintainer : team@gargantext.org
-Stability : experimental
-Portability : POSIX
--}
-
-module Gargantext.Core.Text.List.Social.ListType
- where
-
-import Gargantext.Database.Admin.Types.Node
-import Data.Map (Map)
-import Data.Set (Set)
-import Data.Text (Text)
-import Gargantext.Prelude
-import Gargantext.API.Ngrams.Tools -- (getListNgrams)
-import Gargantext.API.Ngrams.Types
-import Gargantext.Core.Types.Main
-import Gargantext.Database.Schema.Ngrams
-import qualified Data.List as List
-import qualified Data.Map as Map
-import qualified Data.Set as Set
-
-------------------------------------------------------------------------
--- | [ListId] does not merge the lists (it is for Master and User lists
--- here we need UserList only
-countFilterList :: RepoCmdM env err m
- => Set Text -> NgramsType -> [ListId]
- -> Map Text (Map ListType Int)
- -> m (Map Text (Map ListType Int))
-countFilterList st nt ls input =
- foldM' (\m l -> countFilterList' st nt [l] m) input ls
- where
- countFilterList' :: RepoCmdM env err m
- => Set Text -> NgramsType -> [ListId]
- -> Map Text (Map ListType Int)
- -> m (Map Text (Map ListType Int))
- countFilterList' st' nt' ls' input' = do
- ml <- toMapTextListType <$> getListNgrams ls' nt'
- pure $ Set.foldl' (\m t -> countList t ml m) input' st'
-
-------------------------------------------------------------------------
--- FIXME children have to herit the ListType of the parent
-toMapTextListType :: Map Text NgramsRepoElement -> Map Text ListType
-toMapTextListType m = Map.fromListWith (<>)
- $ List.concat
- $ map (toList m)
- $ Map.toList m
- where
- toList :: Map Text NgramsRepoElement -> (Text, NgramsRepoElement) -> [(Text, ListType)]
- toList m' (t, nre@(NgramsRepoElement _ _ _ _ (MSet children))) =
- List.zip terms (List.cycle [lt'])
- where
- terms = [t]
- -- <> maybe [] (\n -> [unNgramsTerm n]) root
- -- <> maybe [] (\n -> [unNgramsTerm n]) parent
- <> (map unNgramsTerm $ Map.keys children)
- lt' = listOf m' nre
-
- listOf :: Map Text NgramsRepoElement -> NgramsRepoElement -> ListType
- listOf m'' ng = case _nre_parent ng of
- Nothing -> _nre_list ng
- Just p -> case Map.lookup (unNgramsTerm p) m'' of
- Just ng' -> listOf m'' ng'
- Nothing -> CandidateTerm
- -- panic "[G.C.T.L.Social.listOf] Nothing: Should Not happen"
-
-------------------------------------------------------------------------
-countList :: Text
- -> Map Text ListType
- -> Map Text (Map ListType Int)
- -> Map Text (Map ListType Int)
-countList t m input = case Map.lookup t m of
- Nothing -> input
- Just l -> Map.alter addList t input
- where
-
- addList Nothing = Just $ addCountList l Map.empty
- addList (Just lm) = Just $ addCountList l lm
-
- addCountList :: ListType -> Map ListType Int -> Map ListType Int
- addCountList l' m' = Map.alter (plus l') l' m'
- where
- plus CandidateTerm Nothing = Just 1
- plus CandidateTerm (Just x) = Just $ x + 1
-
- plus MapTerm Nothing = Just 2
- plus MapTerm (Just x) = Just $ x + 2
-
- plus StopTerm Nothing = Just 3
- plus StopTerm (Just x) = Just $ x + 3
-
diff --git a/src/Gargantext/Core/Text/List/Social/Scores.hs b/src/Gargantext/Core/Text/List/Social/Scores.hs
index 50c7f39b8b00ab4214191aef40e11e2dc9bf977b..ee67ae4f1597f65e0bb25435f605aced3f757c8b 100644
--- a/src/Gargantext/Core/Text/List/Social/Scores.hs
+++ b/src/Gargantext/Core/Text/List/Social/Scores.hs
@@ -39,34 +39,35 @@ toFlowListScores k flc_origin = foldl' (toFlowListScores_Level1 k flc_origin) me
where
toFlowListScores_Level1 :: KeepAllParents
- -> FlowCont Text FlowListScores
- -> FlowCont Text FlowListScores
- -> Map Text NgramsRepoElement
- -> FlowCont Text FlowListScores
+ -> FlowCont Text FlowListScores
+ -> FlowCont Text FlowListScores
+ -> Map Text NgramsRepoElement
+ -> FlowCont Text FlowListScores
toFlowListScores_Level1 k' flc_origin' flc_dest ngramsRepo =
Set.foldl' (toFlowListScores_Level2 k' ngramsRepo flc_origin')
flc_dest
(Set.fromList $ Map.keys $ view flc_cont flc_origin')
toFlowListScores_Level2 :: KeepAllParents
- -> Map Text NgramsRepoElement
- -> FlowCont Text FlowListScores
- -> FlowCont Text FlowListScores
- -> Text
- -> FlowCont Text FlowListScores
+ -> Map Text NgramsRepoElement
+ -> FlowCont Text FlowListScores
+ -> FlowCont Text FlowListScores
+ -> Text
+ -> FlowCont Text FlowListScores
toFlowListScores_Level2 k'' ngramsRepo flc_origin'' flc_dest' t =
case Map.lookup t ngramsRepo of
- Nothing -> over flc_cont (Map.union $ Map.singleton t mempty) flc_dest'
- Just nre -> over flc_cont (Map.delete t)
- $ over flc_scores
- ( (Map.alter (addParent k'' nre ( Set.fromList
- $ Map.keys
- $ view flc_cont flc_origin''
- )
- ) t
- )
- . (Map.alter (addList $ _nre_list nre) t)
- ) flc_dest'
+ Nothing -> over flc_cont (Map.union $ Map.singleton t mempty) flc_dest'
+ Just nre -> over flc_cont (Map.delete t)
+ $ over flc_scores
+ ( (Map.alter (addParent k'' nre ( Set.fromList
+ $ Map.keys
+ $ view flc_cont flc_origin''
+ )
+ ) t
+ )
+ . (Map.alter (addList $ _nre_list nre) t)
+ )
+ flc_dest'
------------------------------------------------------------------------
-- | Main addFunctions to groupResolution the FlowListScores
@@ -118,9 +119,9 @@ addParentScore :: Num a
-> Set Text
-> Map Text a
-> Map Text a
-addParentScore _ Nothing _ss mapParent = mapParent
-addParentScore (KeepAllParents k) (Just (NgramsTerm p')) ss mapParent =
- case k of
+addParentScore _ Nothing _ss mapParent = mapParent
+addParentScore (KeepAllParents keep) (Just (NgramsTerm p')) ss mapParent =
+ case keep of
True -> Map.alter addCount p' mapParent
False -> case Set.member p' ss of
False -> mapParent
diff --git a/src/Gargantext/Core/Viz/Chart.hs b/src/Gargantext/Core/Viz/Chart.hs
index b3854f66c0282ab46a3758e4d27ba9dfec686052..2480174fffa41367ac9739523156c7c00cc013fa 100644
--- a/src/Gargantext/Core/Viz/Chart.hs
+++ b/src/Gargantext/Core/Viz/Chart.hs
@@ -31,7 +31,7 @@ import Gargantext.Prelude
import Gargantext.Core.Text.Metrics.Count (occurrencesWith)
-- Pie Chart
-import Gargantext.API.Ngrams.NTree
+import Gargantext.API.Ngrams.NgramsTree
import Gargantext.API.Ngrams.Tools
import Gargantext.Core.Types
import Gargantext.Database.Action.Flow
@@ -71,7 +71,7 @@ chartData cId nt lt = do
treeData :: FlowCmdM env err m
=> CorpusId -> NgramsType -> ListType
- -> m [MyTree]
+ -> m [NgramsTree]
treeData cId nt lt = do
ls' <- selectNodesWithUsername NodeList userMaster
ls <- map (_node_id) <$> getListsWithParentId cId
diff --git a/src/Gargantext/Database/Admin/Types/Hyperdata/List.hs b/src/Gargantext/Database/Admin/Types/Hyperdata/List.hs
index b238de2fbdc4f8c662a47a93191c6225347514ab..3879b81a17a03f0db0312c91bc87bc9f9ee55619 100644
--- a/src/Gargantext/Database/Admin/Types/Hyperdata/List.hs
+++ b/src/Gargantext/Database/Admin/Types/Hyperdata/List.hs
@@ -27,7 +27,7 @@ import Control.Applicative
import Gargantext.Prelude
import Gargantext.Core.Viz.Types (Histo(..))
-import Gargantext.API.Ngrams.NTree (MyTree)
+import Gargantext.API.Ngrams.NgramsTree (NgramsTree)
import Gargantext.API.Ngrams.Types (TabType)
import Gargantext.Database.Admin.Types.Hyperdata.Prelude
import Gargantext.Database.Admin.Types.Metrics (ChartMetrics(..), Metrics)
@@ -38,13 +38,13 @@ data HyperdataList =
, _hl_list :: !(Maybe Text)
, _hl_pie :: !(Map TabType (ChartMetrics Histo))
, _hl_scatter :: !(Map TabType Metrics)
- , _hl_tree :: !(Map TabType (ChartMetrics [MyTree]))
+ , _hl_tree :: !(Map TabType (ChartMetrics [NgramsTree]))
} deriving (Show, Generic)
-- HyperdataList { _hl_chart :: !(Maybe (ChartMetrics Histo))
-- , _hl_list :: !(Maybe Text)
-- , _hl_pie :: !(Maybe (ChartMetrics Histo))
-- , _hl_scatter :: !(Maybe Metrics)
- -- , _hl_tree :: !(Maybe (ChartMetrics [MyTree]))
+ -- , _hl_tree :: !(Maybe (ChartMetrics [NgramsTree]))
-- } deriving (Show, Generic)
defaultHyperdataList :: HyperdataList