Skip to content

H
haskell-gargantext
Commit 252b3ef9 authored by Alexandre Delanoë's avatar Alexandre Delanoë
Browse files
Options

[FIX] Map Text -> HashMap NgramsTerm

parent 6ed1dc7e
Hide whitespace changes
Inline Side-by-side
Showing with 483 additions and 431 deletions
src/Gargantext/API/Metrics.hs
View file @ 252b3ef9
...@@ -20,16 +20,17 @@ module Gargantext.API.Metrics ...@@ -20,16 +20,17 @@ module Gargantext.API.Metrics
import Control.Lens import Control.Lens
import Data.HashMap.Strict (HashMap) import Data.HashMap.Strict (HashMap)
import qualified Data.HashMap.Strict as HM
import Data.Text (Text) import Data.Text (Text)
import Data.Time (UTCTime) import Data.Time (UTCTime)
import Servant import Data.Vector (Vector)
import Gargantext.API.HashedResponse import Gargantext.API.HashedResponse
import Gargantext.API.Ngrams.NgramsTree import Gargantext.API.Ngrams.NgramsTree
import Gargantext.API.Ngrams.Types import Gargantext.API.Ngrams.Types
import Gargantext.API.Prelude (GargServer) import Gargantext.API.Prelude (GargServer)
import Gargantext.Core.Text.Metrics (Scored(..), {-normalizeGlobal,-} normalizeLocal)
import Gargantext.Core.Types (CorpusId, Limit, ListId, ListType(..)) import Gargantext.Core.Types (CorpusId, Limit, ListId, ListType(..))
import Gargantext.Core.Viz.Chart
import Gargantext.Core.Viz.Types
import Gargantext.Database.Action.Flow import Gargantext.Database.Action.Flow
import Gargantext.Database.Admin.Types.Hyperdata (HyperdataList(..), hl_chart, hl_pie, hl_scatter, hl_tree) import Gargantext.Database.Admin.Types.Hyperdata (HyperdataList(..), hl_chart, hl_pie, hl_scatter, hl_tree)
import Gargantext.Database.Admin.Types.Metrics (ChartMetrics(..), Metric(..), Metrics(..)) import Gargantext.Database.Admin.Types.Metrics (ChartMetrics(..), Metric(..), Metrics(..))
...@@ -40,9 +41,9 @@ import Gargantext.Database.Query.Table.Node.Error (HasNodeError) ...@@ -40,9 +41,9 @@ import Gargantext.Database.Query.Table.Node.Error (HasNodeError)
import Gargantext.Database.Query.Table.Node.UpdateOpaleye (updateHyperdata) import Gargantext.Database.Query.Table.Node.UpdateOpaleye (updateHyperdata)
import Gargantext.Database.Schema.Node (node_hyperdata) import Gargantext.Database.Schema.Node (node_hyperdata)
import Gargantext.Prelude import Gargantext.Prelude
import Gargantext.Core.Text.Metrics (Scored(..), {-normalizeGlobal,-} normalizeLocal) import Servant
import Gargantext.Core.Viz.Chart import qualified Data.HashMap.Strict as HM
import Gargantext.Core.Viz.Types import qualified Data.Vector as Vector
import qualified Gargantext.Database.Action.Metrics as Metrics import qualified Gargantext.Database.Action.Metrics as Metrics
------------------------------------------------------------- -------------------------------------------------------------
...@@ -112,7 +113,7 @@ updateScatter' cId maybeListId tabType maybeLimit = do ...@@ -112,7 +113,7 @@ updateScatter' cId maybeListId tabType maybeLimit = do
(ngs', scores) <- Metrics.getMetrics cId maybeListId tabType maybeLimit (ngs', scores) <- Metrics.getMetrics cId maybeListId tabType maybeLimit
let let
metrics = fmap (\(Scored t s1 s2) -> Metric t s1 s2 (listType t ngs')) metrics = fmap (\(Scored t s1 s2) -> Metric (unNgramsTerm t) s1 s2 (listType t ngs'))
$ fmap normalizeLocal scores $ fmap normalizeLocal scores
listType t m = maybe (panic errorMsg) fst $ HM.lookup t m listType t m = maybe (panic errorMsg) fst $ HM.lookup t m
errorMsg = "API.Node.metrics: key absent" errorMsg = "API.Node.metrics: key absent"
...@@ -318,7 +319,7 @@ type TreeApi = Summary " Tree API" ...@@ -318,7 +319,7 @@ type TreeApi = Summary " Tree API"
:> QueryParam "list" ListId :> QueryParam "list" ListId
:> QueryParamR "ngramsType" TabType :> QueryParamR "ngramsType" TabType
:> QueryParamR "listType" ListType :> QueryParamR "listType" ListType
:> Get '[JSON] (HashedResponse (ChartMetrics [NgramsTree])) :> Get '[JSON] (HashedResponse (ChartMetrics (Vector NgramsTree)))
:<|> Summary "Tree Chart update" :<|> Summary "Tree Chart update"
:> QueryParam "list" ListId :> QueryParam "list" ListId
:> QueryParamR "ngramsType" TabType :> QueryParamR "ngramsType" TabType
...@@ -342,7 +343,7 @@ getTree :: FlowCmdM env err m ...@@ -342,7 +343,7 @@ getTree :: FlowCmdM env err m
-> Maybe ListId -> Maybe ListId
-> TabType -> TabType
-> ListType -> ListType
-> m (HashedResponse (ChartMetrics [NgramsTree])) -> m (HashedResponse (ChartMetrics (Vector NgramsTree)))
getTree cId _start _end maybeListId tabType listType = do getTree cId _start _end maybeListId tabType listType = do
listId <- case maybeListId of listId <- case maybeListId of
Just lid -> pure lid Just lid -> pure lid
...@@ -378,15 +379,15 @@ updateTree' :: FlowCmdM env err m => ...@@ -378,15 +379,15 @@ updateTree' :: FlowCmdM env err m =>
-> Maybe ListId -> Maybe ListId
-> TabType -> TabType
-> ListType -> ListType
-> m (ChartMetrics [NgramsTree]) -> m (ChartMetrics (Vector NgramsTree))
updateTree' cId maybeListId tabType listType = do updateTree' cId maybeListId tabType listType = do
listId <- case maybeListId of listId <- case maybeListId of
Just lid -> pure lid Just lid -> pure lid
Nothing -> defaultList cId Nothing -> defaultList cId
node <- getNodeWith listId (Proxy :: Proxy HyperdataList) node <- getNodeWith listId (Proxy :: Proxy HyperdataList)
let hl = node ^. node_hyperdata let hl = node ^. node_hyperdata
treeMap = hl ^. hl_tree treeMap = hl ^. hl_tree
t <- treeData cId (ngramsTypeFromTabType tabType) listType t <- treeData cId (ngramsTypeFromTabType tabType) listType
_ <- updateHyperdata listId $ hl { _hl_tree = HM.insert tabType (ChartMetrics t) treeMap } _ <- updateHyperdata listId $ hl { _hl_tree = HM.insert tabType (ChartMetrics t) treeMap }
......
src/Gargantext/API/Ngrams.hs
View file @ 252b3ef9
...@@ -535,7 +535,7 @@ getTableNgrams _nType nId tabType listId limit_ offset ...@@ -535,7 +535,7 @@ getTableNgrams _nType nId tabType listId limit_ offset
setScores :: forall t. Each t t NgramsElement NgramsElement => Bool -> t -> m t setScores :: forall t. Each t t NgramsElement NgramsElement => Bool -> t -> m t
setScores False table = pure table setScores False table = pure table
setScores True table = do setScores True table = do
let ngrams_terms = unNgramsTerm <$> (table ^.. each . ne_ngrams) let ngrams_terms = table ^.. each . ne_ngrams
t1 <- getTime' t1 <- getTime'
occurrences <- getOccByNgramsOnlyFast' nId occurrences <- getOccByNgramsOnlyFast' nId
listId listId
...@@ -552,7 +552,7 @@ getTableNgrams _nType nId tabType listId limit_ offset ...@@ -552,7 +552,7 @@ getTableNgrams _nType nId tabType listId limit_ offset
ngrams_terms ngrams_terms
-} -}
let let
setOcc ne = ne & ne_occurrences .~ sumOf (at (unNgramsTerm (ne ^. ne_ngrams)) . _Just) occurrences setOcc ne = ne & ne_occurrences .~ sumOf (at (ne ^. ne_ngrams) . _Just) occurrences
pure $ table & each %~ setOcc pure $ table & each %~ setOcc
--------------------------------------- ---------------------------------------
...@@ -594,13 +594,13 @@ scoresRecomputeTableNgrams nId tabType listId = do ...@@ -594,13 +594,13 @@ scoresRecomputeTableNgrams nId tabType listId = do
setScores :: forall t. Each t t NgramsElement NgramsElement => t -> m t setScores :: forall t. Each t t NgramsElement NgramsElement => t -> m t
setScores table = do setScores table = do
let ngrams_terms = unNgramsTerm <$> (table ^.. each . ne_ngrams) let ngrams_terms = table ^.. each . ne_ngrams
occurrences <- getOccByNgramsOnlyFast' nId occurrences <- getOccByNgramsOnlyFast' nId
listId listId
ngramsType ngramsType
ngrams_terms ngrams_terms
let let
setOcc ne = ne & ne_occurrences .~ sumOf (at (unNgramsTerm (ne ^. ne_ngrams)) . _Just) occurrences setOcc ne = ne & ne_occurrences .~ sumOf (at (ne ^. ne_ngrams) . _Just) occurrences
pure $ table & each %~ setOcc pure $ table & each %~ setOcc
......
src/Gargantext/API/Ngrams/NgramsTree.hs
View file @ 252b3ef9
...@@ -15,23 +15,23 @@ module Gargantext.API.Ngrams.NgramsTree ...@@ -15,23 +15,23 @@ module Gargantext.API.Ngrams.NgramsTree
where where
import Data.Aeson.TH (deriveJSON) import Data.Aeson.TH (deriveJSON)
import Data.Text (Text) import Data.HashMap.Strict (HashMap)
import Data.Tree
import Data.Maybe (catMaybes)
import Data.Map (Map) import Data.Map (Map)
import Data.Maybe (catMaybes)
import Data.Set (Set) import Data.Set (Set)
import Data.Swagger import Data.Swagger
import qualified Data.Set as Set import Data.Text (Text)
import qualified Data.Map as Map import Data.Tree
import qualified Data.List as List
import GHC.Generics (Generic) import GHC.Generics (Generic)
import Test.QuickCheck
import Gargantext.Prelude
import Gargantext.API.Ngrams.Types import Gargantext.API.Ngrams.Types
import Gargantext.Core.Types (ListType(..), NodeId) import Gargantext.Core.Types (ListType(..), NodeId)
import Gargantext.Core.Utils.Prefix (unPrefix, unPrefixSwagger) import Gargantext.Core.Utils.Prefix (unPrefix, unPrefixSwagger)
import Gargantext.Prelude
import Test.QuickCheck
import qualified Data.HashMap.Strict as HashMap
import qualified Data.List as List
import qualified Data.Map as Map
import qualified Data.Set as Set
type Children = Text type Children = Text
type Root = Text type Root = Text
...@@ -42,8 +42,8 @@ data NgramsTree = NgramsTree { mt_label :: Text ...@@ -42,8 +42,8 @@ data NgramsTree = NgramsTree { mt_label :: Text
} }
deriving (Generic, Show) deriving (Generic, Show)
toNgramsTree :: Tree (Text,Double) -> NgramsTree toNgramsTree :: Tree (NgramsTerm,Double) -> NgramsTree
toNgramsTree (Node (l,v) xs) = NgramsTree l v (map toNgramsTree xs) toNgramsTree (Node (NgramsTerm l,v) xs) = NgramsTree l v (map toNgramsTree xs)
deriveJSON (unPrefix "mt_") ''NgramsTree deriveJSON (unPrefix "mt_") ''NgramsTree
...@@ -53,24 +53,27 @@ instance Arbitrary NgramsTree ...@@ -53,24 +53,27 @@ instance Arbitrary NgramsTree
where where
arbitrary = NgramsTree <$> arbitrary <*> arbitrary <*> arbitrary arbitrary = NgramsTree <$> arbitrary <*> arbitrary <*> arbitrary
toTree :: ListType -> Map Text (Set NodeId) -> Map Text NgramsRepoElement -> [NgramsTree] toTree :: ListType
-> HashMap NgramsTerm (Set NodeId)
-> HashMap NgramsTerm NgramsRepoElement
-> [NgramsTree]
toTree lt vs m = map toNgramsTree $ unfoldForest buildNode roots toTree lt vs m = map toNgramsTree $ unfoldForest buildNode roots
where where
buildNode r = maybe ((r, value r),[]) buildNode r = maybe ((r, value r),[])
(\x -> ((r, value r), unNgramsTerm <$> (mSetToList $ _nre_children x))) (\x -> ((r, value r), mSetToList $ _nre_children x))
(Map.lookup r m) (HashMap.lookup r m)
value l = maybe 0 (fromIntegral . Set.size) $ Map.lookup l vs value l = maybe 0 (fromIntegral . Set.size) $ HashMap.lookup l vs
rootsCandidates :: [NgramsTerm] rootsCandidates :: [NgramsTerm]
rootsCandidates = catMaybes rootsCandidates = catMaybes
$ List.nub $ List.nub
$ map (\(c, c') -> case _nre_root c' of $ map (\(c, c') -> case _nre_root c' of
Nothing -> Just $ NgramsTerm c Nothing -> Just c
_ -> _nre_root c') (Map.toList m) _ -> _nre_root c') (HashMap.toList m)
roots = map fst roots = map fst
$ filter (\(_,l) -> l == lt) $ filter (\(_,l) -> l == lt)
$ catMaybes $ catMaybes
$ map (\c -> (,) <$> Just c <*> (_nre_list <$> Map.lookup c m)) $ map (\c -> (,) <$> Just c <*> (_nre_list <$> HashMap.lookup c m))
$ (unNgramsTerm <$> rootsCandidates) $ rootsCandidates
src/Gargantext/API/Ngrams/Tools.hs
View file @ 252b3ef9
...@@ -17,21 +17,20 @@ module Gargantext.API.Ngrams.Tools ...@@ -17,21 +17,20 @@ module Gargantext.API.Ngrams.Tools
import Control.Concurrent import Control.Concurrent
import Control.Lens (_Just, (^.), at, view, At, Index, IxValue) import Control.Lens (_Just, (^.), at, view, At, Index, IxValue)
import Control.Monad.Reader import Control.Monad.Reader
import Data.Hashable (Hashable)
import Data.HashMap.Strict (HashMap) import Data.HashMap.Strict (HashMap)
import qualified Data.HashMap.Strict as HM import Data.Hashable (Hashable)
import Gargantext.Data.HashMap.Strict.Utils as HM
import Data.Map.Strict (Map) import Data.Map.Strict (Map)
import qualified Data.Map.Strict as Map
import qualified Data.Set as Set
import Data.Set (Set) import Data.Set (Set)
import Data.Text (Text) import Data.Text (Text)
import Data.Validity import Data.Validity
import Gargantext.API.Ngrams.Types import Gargantext.API.Ngrams.Types
import Gargantext.Core.Types (ListType(..), NodeId, ListId) import Gargantext.Core.Types (ListType(..), NodeId, ListId)
import Gargantext.Database.Schema.Ngrams (NgramsType) import Gargantext.Database.Schema.Ngrams (NgramsType)
import Gargantext.Prelude import Gargantext.Prelude
import qualified Data.HashMap.Strict as HM
import qualified Data.Map.Strict as Map
import qualified Data.Set as Set
import qualified Gargantext.Data.HashMap.Strict.Utils as HM
mergeNgramsElement :: NgramsRepoElement -> NgramsRepoElement -> NgramsRepoElement mergeNgramsElement :: NgramsRepoElement -> NgramsRepoElement -> NgramsRepoElement
mergeNgramsElement _neOld neNew = neNew mergeNgramsElement _neOld neNew = neNew
...@@ -44,12 +43,13 @@ getRepo = do ...@@ -44,12 +43,13 @@ getRepo = do
liftBase $ readMVar v liftBase $ readMVar v
listNgramsFromRepo :: [ListId] -> NgramsType listNgramsFromRepo :: [ListId] -> NgramsType
-> NgramsRepo -> Map NgramsTerm NgramsRepoElement -> NgramsRepo -> HashMap NgramsTerm NgramsRepoElement
listNgramsFromRepo nodeIds ngramsType repo = ngrams listNgramsFromRepo nodeIds ngramsType repo = ngrams
where where
ngramsMap = repo ^. r_state . at ngramsType . _Just ngramsMap = repo ^. r_state . at ngramsType . _Just
ngrams = Map.unionsWith mergeNgramsElement -- TODO HashMap linked
ngrams = HM.fromList $ Map.toList $ Map.unionsWith mergeNgramsElement
[ ngramsMap ^. at nodeId . _Just | nodeId <- nodeIds ] [ ngramsMap ^. at nodeId . _Just | nodeId <- nodeIds ]
...@@ -60,7 +60,7 @@ listNgramsFromRepo nodeIds ngramsType repo = ngrams ...@@ -60,7 +60,7 @@ listNgramsFromRepo nodeIds ngramsType repo = ngrams
-- be properly guarded. -- be properly guarded.
getListNgrams :: RepoCmdM env err m getListNgrams :: RepoCmdM env err m
=> [ListId] -> NgramsType => [ListId] -> NgramsType
-> m (Map NgramsTerm NgramsRepoElement) -> m (HashMap NgramsTerm NgramsRepoElement)
getListNgrams nodeIds ngramsType = listNgramsFromRepo nodeIds ngramsType <$> getRepo getListNgrams nodeIds ngramsType = listNgramsFromRepo nodeIds ngramsType <$> getRepo
getTermsWith :: (RepoCmdM env err m, Eq a, Hashable a) getTermsWith :: (RepoCmdM env err m, Eq a, Hashable a)
...@@ -69,8 +69,8 @@ getTermsWith :: (RepoCmdM env err m, Eq a, Hashable a) ...@@ -69,8 +69,8 @@ getTermsWith :: (RepoCmdM env err m, Eq a, Hashable a)
-> m (HashMap a [a]) -> m (HashMap a [a])
getTermsWith f ls ngt lt = HM.fromListWith (<>) getTermsWith f ls ngt lt = HM.fromListWith (<>)
<$> map toTreeWith <$> map toTreeWith
<$> Map.toList <$> HM.toList
<$> Map.filter (\f' -> fst f' == lt) <$> HM.filter (\f' -> fst f' == lt)
<$> mapTermListRoot ls ngt <$> mapTermListRoot ls ngt
<$> getRepo <$> getRepo
where where
...@@ -81,10 +81,10 @@ getTermsWith f ls ngt lt = HM.fromListWith (<>) ...@@ -81,10 +81,10 @@ getTermsWith f ls ngt lt = HM.fromListWith (<>)
mapTermListRoot :: [ListId] mapTermListRoot :: [ListId]
-> NgramsType -> NgramsType
-> NgramsRepo -> NgramsRepo
-> Map NgramsTerm (ListType, Maybe NgramsTerm) -> HashMap NgramsTerm (ListType, Maybe NgramsTerm)
mapTermListRoot nodeIds ngramsType repo = mapTermListRoot nodeIds ngramsType repo =
(\nre -> (_nre_list nre, _nre_root nre)) <$> (\nre -> (_nre_list nre, _nre_root nre))
listNgramsFromRepo nodeIds ngramsType repo <$> listNgramsFromRepo nodeIds ngramsType repo
filterListWithRootHashMap :: ListType filterListWithRootHashMap :: ListType
-> HashMap NgramsTerm (ListType, Maybe NgramsTerm) -> HashMap NgramsTerm (ListType, Maybe NgramsTerm)
...@@ -98,13 +98,13 @@ filterListWithRootHashMap lt m = snd <$> HM.filter isMapTerm m ...@@ -98,13 +98,13 @@ filterListWithRootHashMap lt m = snd <$> HM.filter isMapTerm m
Just (l',_) -> l' == lt Just (l',_) -> l' == lt
filterListWithRoot :: ListType filterListWithRoot :: ListType
-> Map NgramsTerm (ListType, Maybe NgramsTerm) -> HashMap NgramsTerm (ListType, Maybe NgramsTerm)
-> Map NgramsTerm (Maybe RootTerm) -> HashMap NgramsTerm (Maybe RootTerm)
filterListWithRoot lt m = snd <$> Map.filter isMapTerm m filterListWithRoot lt m = snd <$> HM.filter isMapTerm m
where where
isMapTerm (l, maybeRoot) = case maybeRoot of isMapTerm (l, maybeRoot) = case maybeRoot of
Nothing -> l == lt Nothing -> l == lt
Just r -> case Map.lookup r m of Just r -> case HM.lookup r m of
Nothing -> panic $ "Garg.API.Ngrams.Tools: filterWithRoot, unknown key: " <> unNgramsTerm r Nothing -> panic $ "Garg.API.Ngrams.Tools: filterWithRoot, unknown key: " <> unNgramsTerm r
Just (l',_) -> l' == lt Just (l',_) -> l' == lt
...@@ -126,7 +126,7 @@ groupNodesByNgrams syn occs = HM.fromListWith (<>) occs' ...@@ -126,7 +126,7 @@ groupNodesByNgrams syn occs = HM.fromListWith (<>) occs'
data Diagonal = Diagonal Bool data Diagonal = Diagonal Bool
getCoocByNgrams :: Diagonal -> HashMap Text (Set NodeId) -> HashMap (Text, Text) Int getCoocByNgrams :: Diagonal -> HashMap NgramsTerm (Set NodeId) -> HashMap (NgramsTerm, NgramsTerm) Int
getCoocByNgrams = getCoocByNgrams' identity getCoocByNgrams = getCoocByNgrams' identity
...@@ -144,4 +144,4 @@ getCoocByNgrams' f (Diagonal diag) m = ...@@ -144,4 +144,4 @@ getCoocByNgrams' f (Diagonal diag) m =
listToCombi identity ks listToCombi identity ks
] ]
where ks = HM.keys m where ks = HM.keys m
\ No newline at end of file
src/Gargantext/API/Ngrams/Types.hs
View file @ 252b3ef9
...@@ -47,6 +47,7 @@ import Test.QuickCheck.Arbitrary (Arbitrary, arbitrary) ...@@ -47,6 +47,7 @@ import Test.QuickCheck.Arbitrary (Arbitrary, arbitrary)
import Protolude (maybeToEither) import Protolude (maybeToEither)
import Gargantext.Prelude import Gargantext.Prelude
import Gargantext.Prelude.Crypto.Hash (IsHashable(..))
import Gargantext.Core.Text (size) import Gargantext.Core.Text (size)
import Gargantext.Core.Types (ListType(..), ListId, NodeId) import Gargantext.Core.Types (ListType(..), ListId, NodeId)
import Gargantext.Core.Types (TODO) import Gargantext.Core.Types (TODO)
...@@ -126,6 +127,12 @@ instance (ToJSONKey a, ToSchema a) => ToSchema (MSet a) where ...@@ -126,6 +127,12 @@ instance (ToJSONKey a, ToSchema a) => ToSchema (MSet a) where
newtype NgramsTerm = NgramsTerm { unNgramsTerm :: Text } newtype NgramsTerm = NgramsTerm { unNgramsTerm :: Text }
deriving (Ord, Eq, Show, Generic, ToJSONKey, ToJSON, FromJSON, Semigroup, Arbitrary, Serialise, ToSchema, Hashable) deriving (Ord, Eq, Show, Generic, ToJSONKey, ToJSON, FromJSON, Semigroup, Arbitrary, Serialise, ToSchema, Hashable)
instance IsHashable NgramsTerm where
hash (NgramsTerm t) = hash t
instance Monoid NgramsTerm where
mempty = NgramsTerm ""
instance FromJSONKey NgramsTerm where instance FromJSONKey NgramsTerm where
fromJSONKey = FromJSONKeyTextParser $ \t -> pure $ NgramsTerm $ strip t fromJSONKey = FromJSONKeyTextParser $ \t -> pure $ NgramsTerm $ strip t
......
src/Gargantext/API/Node/Corpus/Export.hs
View file @ 252b3ef9
...@@ -42,6 +42,7 @@ import Gargantext.Prelude ...@@ -42,6 +42,7 @@ import Gargantext.Prelude
import qualified Data.List as List import qualified Data.List as List
import qualified Data.Map as Map import qualified Data.Map as Map
import qualified Data.Set as Set import qualified Data.Set as Set
import qualified Data.HashMap.Strict as HashMap
-------------------------------------------------- --------------------------------------------------
-- | Hashes are ordered by Set -- | Hashes are ordered by Set
...@@ -63,13 +64,13 @@ getCorpus cId lId nt' = do ...@@ -63,13 +64,13 @@ getCorpus cId lId nt' = do
ngs <- getNodeNgrams cId lId nt repo ngs <- getNodeNgrams cId lId nt repo
let -- uniqId is hash computed already for each document imported in database let -- uniqId is hash computed already for each document imported in database
r = Map.intersectionWith (\a b -> Document a (Ngrams (Set.toList b) (hash b)) (d_hash a b) r = Map.intersectionWith (\a b -> Document a (Ngrams (Set.toList b) (hash b)) (d_hash a b)
) ns ngs ) ns (Map.map (Set.map unNgramsTerm) ngs)
where where
d_hash a b = hash [ fromMaybe "" (_hd_uniqId $ _node_hyperdata a) d_hash a b = hash [ fromMaybe "" (_hd_uniqId $ _node_hyperdata a)
, hash b , hash b
] ]
pure $ Corpus (Map.elems r) (hash $ List.map _d_hash pure $ Corpus (Map.elems r) (hash $ List.map _d_hash
$ Map.elems r $ Map.elems r
) )
getNodeNgrams :: HasNodeError err getNodeNgrams :: HasNodeError err
...@@ -77,7 +78,7 @@ getNodeNgrams :: HasNodeError err ...@@ -77,7 +78,7 @@ getNodeNgrams :: HasNodeError err
-> Maybe ListId -> Maybe ListId
-> NgramsType -> NgramsType
-> NgramsRepo -> NgramsRepo
-> Cmd err (HashMap NodeId (Set Text)) -> Cmd err (Map NodeId (Set NgramsTerm))
getNodeNgrams cId lId' nt repo = do getNodeNgrams cId lId' nt repo = do
lId <- case lId' of lId <- case lId' of
Nothing -> defaultList cId Nothing -> defaultList cId
...@@ -85,9 +86,10 @@ getNodeNgrams cId lId' nt repo = do ...@@ -85,9 +86,10 @@ getNodeNgrams cId lId' nt repo = do
lIds <- selectNodesWithUsername NodeList userMaster lIds <- selectNodesWithUsername NodeList userMaster
let ngs = filterListWithRoot MapTerm $ mapTermListRoot [lId] nt repo let ngs = filterListWithRoot MapTerm $ mapTermListRoot [lId] nt repo
r <- getNgramsByNodeOnlyUser cId (lIds <> [lId]) nt (Map.keys ngs) -- TODO HashMap
r <- getNgramsByNodeOnlyUser cId (lIds <> [lId]) nt (HashMap.keys ngs)
pure r pure r
-- TODO -- TODO
-- Exports List -- Exports List
-- Version number of the list -- Version number of the list
\ No newline at end of file
src/Gargantext/Core/Text/List.hs
View file @ 252b3ef9
...@@ -16,6 +16,7 @@ module Gargantext.Core.Text.List ...@@ -16,6 +16,7 @@ module Gargantext.Core.Text.List
where where
import Control.Lens hiding (both) -- ((^.), view, over, set, (_1), (_2)) import Control.Lens hiding (both) -- ((^.), view, over, set, (_1), (_2))
import Data.HashMap.Strict (HashMap)
import Data.Map (Map) import Data.Map (Map)
import Data.Monoid (mempty) import Data.Monoid (mempty)
import Data.Ord (Down(..)) import Data.Ord (Down(..))
...@@ -41,10 +42,11 @@ import Gargantext.Database.Query.Table.Node.Error (HasNodeError()) ...@@ -41,10 +42,11 @@ import Gargantext.Database.Query.Table.Node.Error (HasNodeError())
import Gargantext.Database.Query.Tree.Error (HasTreeError) import Gargantext.Database.Query.Tree.Error (HasTreeError)
import Gargantext.Database.Schema.Ngrams (NgramsType(..)) import Gargantext.Database.Schema.Ngrams (NgramsType(..))
import Gargantext.Prelude import Gargantext.Prelude
import qualified Data.HashMap.Strict as HashMap
import qualified Data.List as List import qualified Data.List as List
import qualified Data.Map as Map import qualified Data.Map as Map
import qualified Data.Set as Set import qualified Data.Set as Set
import qualified Gargantext.Data.HashMap.Strict.Utils as HashMap
{- {-
-- TODO maybe useful for later -- TODO maybe useful for later
...@@ -90,13 +92,13 @@ buildNgramsOthersList ::( HasNodeError err ...@@ -90,13 +92,13 @@ buildNgramsOthersList ::( HasNodeError err
-> (NgramsType, MapListSize) -> (NgramsType, MapListSize)
-> m (Map NgramsType [NgramsElement]) -> m (Map NgramsType [NgramsElement])
buildNgramsOthersList user uCid _groupParams (nt, MapListSize mapListSize) = do buildNgramsOthersList user uCid _groupParams (nt, MapListSize mapListSize) = do
allTerms :: Map Text (Set NodeId) <- getNodesByNgramsUser uCid nt allTerms :: HashMap NgramsTerm (Set NodeId) <- getNodesByNgramsUser uCid nt
-- | PrivateFirst for first developments since Public NodeMode is not implemented yet -- | PrivateFirst for first developments since Public NodeMode is not implemented yet
socialLists :: FlowCont Text FlowListScores socialLists :: FlowCont NgramsTerm FlowListScores
<- flowSocialList MySelfFirst user nt ( FlowCont Map.empty <- flowSocialList MySelfFirst user nt ( FlowCont HashMap.empty
$ Map.fromList $ HashMap.fromList
$ List.zip (Map.keys allTerms) $ List.zip (HashMap.keys allTerms)
(List.cycle [mempty]) (List.cycle [mempty])
) )
{- {-
...@@ -113,22 +115,22 @@ buildNgramsOthersList user uCid _groupParams (nt, MapListSize mapListSize) = do ...@@ -113,22 +115,22 @@ buildNgramsOthersList user uCid _groupParams (nt, MapListSize mapListSize) = do
-} -}
let let
(stopTerms, tailTerms) = Map.partition ((== Just StopTerm) . viewListType) (stopTerms, tailTerms) = HashMap.partition ((== Just StopTerm) . viewListType)
$ view flc_scores groupedWithList $ view flc_scores groupedWithList
(mapTerms, tailTerms') = Map.partition ((== Just MapTerm) . viewListType) tailTerms (mapTerms, tailTerms') = HashMap.partition ((== Just MapTerm) . viewListType) tailTerms
listSize = mapListSize - (List.length mapTerms) listSize = mapListSize - (List.length mapTerms)
(mapTerms', candiTerms) = both Map.fromList (mapTerms', candiTerms) = both HashMap.fromList
$ List.splitAt listSize $ List.splitAt listSize
$ List.sortOn (Down . viewScore . snd) $ List.sortOn (Down . viewScore . snd)
$ Map.toList tailTerms' $ HashMap.toList tailTerms'
pure $ Map.fromList [( nt, (toNgramsElement stopTerms) pure $ Map.fromList [( nt, (toNgramsElement stopTerms)
<> (toNgramsElement mapTerms ) <> (toNgramsElement mapTerms )
<> (toNgramsElement $ setListType (Just MapTerm ) mapTerms' ) <> (toNgramsElement $ setListType (Just MapTerm ) mapTerms' )
<> (toNgramsElement $ setListType (Just CandidateTerm) candiTerms) <> (toNgramsElement $ setListType (Just CandidateTerm) candiTerms)
)] )]
-- TODO use ListIds -- TODO use ListIds
...@@ -147,23 +149,23 @@ buildNgramsTermsList user uCid mCid groupParams (nt, _mapListSize)= do ...@@ -147,23 +149,23 @@ buildNgramsTermsList user uCid mCid groupParams (nt, _mapListSize)= do
-- | Filter 0 With Double -- | Filter 0 With Double
-- Computing global speGen score -- Computing global speGen score
allTerms :: Map Text Double <- getTficf uCid mCid nt allTerms :: HashMap NgramsTerm Double <- getTficf uCid mCid nt
-- | PrivateFirst for first developments since Public NodeMode is not implemented yet -- | PrivateFirst for first developments since Public NodeMode is not implemented yet
socialLists :: FlowCont Text FlowListScores socialLists :: FlowCont NgramsTerm FlowListScores
<- flowSocialList MySelfFirst user nt ( FlowCont Map.empty <- flowSocialList MySelfFirst user nt ( FlowCont HashMap.empty
$ Map.fromList $ HashMap.fromList
$ List.zip (Map.keys allTerms) $ List.zip (HashMap.keys allTerms)
(List.cycle [mempty]) (List.cycle [mempty])
) )
let socialLists_Stemmed = addScoreStem groupParams (Set.map NgramsTerm $ Map.keysSet allTerms) socialLists let socialLists_Stemmed = addScoreStem groupParams (HashMap.keysSet allTerms) socialLists
printDebug "socialLists_Stemmed" socialLists_Stemmed printDebug "socialLists_Stemmed" socialLists_Stemmed
let groupedWithList = toGroupedTree {- groupParams -} socialLists_Stemmed allTerms let groupedWithList = toGroupedTree {- groupParams -} socialLists_Stemmed allTerms
(stopTerms, candidateTerms) = Map.partition ((== Just StopTerm) . viewListType) (stopTerms, candidateTerms) = HashMap.partition ((== Just StopTerm) . viewListType)
$ view flc_scores groupedWithList $ view flc_scores groupedWithList
(groupedMono, groupedMult) = Map.partitionWithKey (\t _v -> size t < 2) candidateTerms (groupedMono, groupedMult) = HashMap.partitionWithKey (\(NgramsTerm t) _v -> size t < 2) candidateTerms
-- printDebug "stopTerms" stopTerms -- printDebug "stopTerms" stopTerms
...@@ -174,10 +176,10 @@ buildNgramsTermsList user uCid mCid groupParams (nt, _mapListSize)= do ...@@ -174,10 +176,10 @@ buildNgramsTermsList user uCid mCid groupParams (nt, _mapListSize)= do
monoSize = 0.4 :: Double monoSize = 0.4 :: Double
multSize = 1 - monoSize multSize = 1 - monoSize
splitAt n' ns = both (Map.fromListWith (<>)) splitAt n' ns = both (HashMap.fromListWith (<>))
$ List.splitAt (round $ n' * listSizeGlobal) $ List.splitAt (round $ n' * listSizeGlobal)
$ List.sortOn (viewScore . snd) $ List.sortOn (viewScore . snd)
$ Map.toList ns $ HashMap.toList ns
(groupedMonoHead, groupedMonoTail) = splitAt monoSize groupedMono (groupedMonoHead, groupedMonoTail) = splitAt monoSize groupedMono
(groupedMultHead, groupedMultTail) = splitAt multSize groupedMult (groupedMultHead, groupedMultTail) = splitAt multSize groupedMult
...@@ -198,30 +200,32 @@ buildNgramsTermsList user uCid mCid groupParams (nt, _mapListSize)= do ...@@ -198,30 +200,32 @@ buildNgramsTermsList user uCid mCid groupParams (nt, _mapListSize)= do
selectedTerms selectedTerms
let let
groupedTreeScores_SetNodeId :: HashMap Text (GroupedTreeScores (Set NodeId)) groupedTreeScores_SetNodeId :: HashMap NgramsTerm (GroupedTreeScores (Set NodeId))
groupedTreeScores_SetNodeId = setScoresWithMap mapTextDocIds (groupedMonoHead <> groupedMultHead) groupedTreeScores_SetNodeId = setScoresWithMap mapTextDocIds (groupedMonoHead <> groupedMultHead)
-- | Coocurrences computation -- | Coocurrences computation
--, t1 >= t2 -- permute byAxis diag -- since matrix symmetric --, t1 >= t2 -- permute byAxis diag -- since matrix symmetric
let mapCooc = HM.filter (>2) let mapCooc = HashMap.filter (>2)
$ HM.fromList [ ((t1, t2), Set.size $ Set.intersection s1 s2) $ HashMap.fromList [ ((t1, t2), Set.size $ Set.intersection s1 s2)
| (t1, s1) <- mapStemNodeIds | (t1, s1) <- mapStemNodeIds
, (t2, s2) <- mapStemNodeIds , (t2, s2) <- mapStemNodeIds
] ]
where where
mapStemNodeIds = HM.toList mapStemNodeIds = HashMap.toList
$ HM.map viewScores $ HashMap.map viewScores
$ groupedTreeScores_SetNodeId $ groupedTreeScores_SetNodeId
let let
-- computing scores -- computing scores
mapScores f = Map.fromList mapScores f = HashMap.fromList
$ map (\g -> (view scored_terms g, f g)) $ map (\g -> (view scored_terms g, f g))
$ normalizeGlobal $ normalizeGlobal
$ map normalizeLocal $ map normalizeLocal
$ scored' mapCooc $ scored'
$ Map.fromList -- TODO remove this
$ HashMap.toList mapCooc
let let
groupedTreeScores_SpeGen :: Map Text (GroupedTreeScores (Scored Text)) groupedTreeScores_SpeGen :: HashMap NgramsTerm (GroupedTreeScores (Scored NgramsTerm))
groupedTreeScores_SpeGen = setScoresWithMap (mapScores identity) groupedTreeScores_SpeGen = setScoresWithMap (mapScores identity)
( groupedMonoHead ( groupedMonoHead
<> groupedMultHead <> groupedMultHead
...@@ -230,10 +234,10 @@ buildNgramsTermsList user uCid mCid groupParams (nt, _mapListSize)= do ...@@ -230,10 +234,10 @@ buildNgramsTermsList user uCid mCid groupParams (nt, _mapListSize)= do
let let
-- sort / partition / split -- sort / partition / split
-- filter mono/multi again -- filter mono/multi again
(monoScored, multScored) = Map.partitionWithKey (\t _v -> size t < 2) groupedTreeScores_SpeGen (monoScored, multScored) = HashMap.partitionWithKey (\(NgramsTerm t) _v -> size t < 2) groupedTreeScores_SpeGen
-- filter with max score -- filter with max score
partitionWithMaxScore = Map.partition (\g -> (view scored_genInc $ view gts'_score g) partitionWithMaxScore = HashMap.partition (\g -> (view scored_genInc $ view gts'_score g)
> (view scored_speExc $ view gts'_score g) > (view scored_speExc $ view gts'_score g)
) )
...@@ -247,8 +251,8 @@ buildNgramsTermsList user uCid mCid groupParams (nt, _mapListSize)= do ...@@ -247,8 +251,8 @@ buildNgramsTermsList user uCid mCid groupParams (nt, _mapListSize)= do
inclSize = 0.4 :: Double inclSize = 0.4 :: Double
exclSize = 1 - inclSize exclSize = 1 - inclSize
splitAt' n' = (both (Map.fromList)) . (List.splitAt (round $ n' * listSizeLocal)) splitAt' n' = (both (HashMap.fromList)) . (List.splitAt (round $ n' * listSizeLocal))
sortOn f = (List.sortOn (Down . (view (gts'_score . f)) . snd)) . Map.toList sortOn f = (List.sortOn (Down . (view (gts'_score . f)) . snd)) . HashMap.toList
monoInc_size = splitAt' $ monoSize * inclSize / 2 monoInc_size = splitAt' $ monoSize * inclSize / 2
...@@ -259,9 +263,7 @@ buildNgramsTermsList user uCid mCid groupParams (nt, _mapListSize)= do ...@@ -259,9 +263,7 @@ buildNgramsTermsList user uCid mCid groupParams (nt, _mapListSize)= do
(multScoredInclHead, multScoredInclTail) = multExc_size $ (sortOn scored_genInc) multScoredIncl (multScoredInclHead, multScoredInclTail) = multExc_size $ (sortOn scored_genInc) multScoredIncl
(multScoredExclHead, multScoredExclTail) = multExc_size $ (sortOn scored_speExc) multScoredExcl (multScoredExclHead, multScoredExclTail) = multExc_size $ (sortOn scored_speExc) multScoredExcl
------------------------------------------------------------ ------------------------------------------------------------
-- Final Step building the Typed list -- Final Step building the Typed list
termListHead = maps <> cands termListHead = maps <> cands
where where
......
src/Gargantext/Core/Text/List/Group.hs
View file @ 252b3ef9
...@@ -19,48 +19,50 @@ module Gargantext.Core.Text.List.Group ...@@ -19,48 +19,50 @@ module Gargantext.Core.Text.List.Group
where where
import Control.Lens (view) import Control.Lens (view)
import Data.HashMap.Strict (HashMap)
import Data.Map (Map) import Data.Map (Map)
import Data.Maybe (fromMaybe) import Data.Maybe (fromMaybe)
import Data.Monoid (Monoid, mempty) import Data.Monoid (Monoid, mempty)
import Data.Text (Text) import Data.Text (Text)
import Gargantext.Core.Text.List.Social.Prelude import Gargantext.API.Ngrams.Types (NgramsTerm(..))
import Gargantext.Core.Text.List.Group.Prelude import Gargantext.Core.Text.List.Group.Prelude
import Gargantext.Core.Text.List.Group.WithScores import Gargantext.Core.Text.List.Group.WithScores
import Gargantext.Core.Text.List.Social.Prelude
import Gargantext.Prelude import Gargantext.Prelude
import qualified Data.Map as Map import qualified Data.HashMap.Strict as HashMap
import qualified Data.Map as Map
------------------------------------------------------------------------ ------------------------------------------------------------------------
toGroupedTree :: (Ord a, Monoid a) toGroupedTree :: (Ord a, Monoid a)
=> FlowCont Text FlowListScores => FlowCont NgramsTerm FlowListScores
-> Map Text a -> HashMap NgramsTerm a
-> FlowCont Text (GroupedTreeScores a) -> FlowCont NgramsTerm (GroupedTreeScores a)
toGroupedTree flc scores = toGroupedTree flc scores =
groupWithScores' flc scoring groupWithScores' flc scoring
where where
scoring t = fromMaybe mempty $ Map.lookup t scores scoring t = fromMaybe mempty $ HashMap.lookup t scores
------------------------------------------------------------------------ ------------------------------------------------------------------------
setScoresWithMap :: (Ord a, Ord b, Monoid b) => Map Text b setScoresWithMap :: (Ord a, Ord b, Monoid b) => HashMap NgramsTerm b
-> Map Text (GroupedTreeScores a) -> HashMap NgramsTerm (GroupedTreeScores a)
-> Map Text (GroupedTreeScores b) -> HashMap NgramsTerm (GroupedTreeScores b)
setScoresWithMap m = setScoresWith (score m) setScoresWithMap m = setScoresWith (score m)
where where
score m' t = case Map.lookup t m' of score m' t = case HashMap.lookup t m' of
Nothing -> mempty Nothing -> mempty
Just r -> r Just r -> r
setScoresWith :: (Ord a, Ord b) setScoresWith :: (Ord a, Ord b)
=> (Text -> b) => (NgramsTerm -> b)
-> Map Text (GroupedTreeScores a) -> HashMap NgramsTerm (GroupedTreeScores a)
-> Map Text (GroupedTreeScores b) -> HashMap NgramsTerm (GroupedTreeScores b)
{- {-
-- | This Type level lenses solution does not work -- | This Type level lenses solution does not work
setScoresWith f = Map.mapWithKey (\k v -> over gts'_children (setScoresWith f) setScoresWith f = Map.mapWithKey (\k v -> over gts'_children (setScoresWith f)
$ set gts'_score (f k) v $ set gts'_score (f k) v
) )
-} -}
setScoresWith f = Map.mapWithKey (\k v -> v { _gts'_score = f k setScoresWith f = HashMap.mapWithKey (\k v -> v { _gts'_score = f k
, _gts'_children = setScoresWith f , _gts'_children = setScoresWith f
$ view gts'_children v $ view gts'_children v
} }
......
src/Gargantext/Core/Text/List/Group/Prelude.hs
View file @ 252b3ef9
...@@ -17,29 +17,30 @@ module Gargantext.Core.Text.List.Group.Prelude ...@@ -17,29 +17,30 @@ module Gargantext.Core.Text.List.Group.Prelude
where where
import Control.Lens (makeLenses, view, set, over) import Control.Lens (makeLenses, view, set, over)
import Data.HashMap.Strict (HashMap)
import Data.Map (Map)
import Data.Maybe (fromMaybe)
import Data.Monoid import Data.Monoid
import Data.Semigroup import Data.Semigroup
import Data.Set (Set) import Data.Set (Set)
import Data.Text (Text) import Gargantext.API.Ngrams.Types (NgramsElement, mkNgramsElement, NgramsTerm(..), RootParent(..), mSetFromList)
import Data.Maybe (fromMaybe) import Gargantext.Core.Text.Metrics (Scored(..), scored_genInc)
import Data.Map (Map)
import Gargantext.Core.Types (ListType(..)) import Gargantext.Core.Types (ListType(..))
import Gargantext.Database.Admin.Types.Node (NodeId) import Gargantext.Database.Admin.Types.Node (NodeId)
import Gargantext.Core.Text.Metrics (Scored(..), scored_genInc)
import Gargantext.API.Ngrams.Types (NgramsElement, mkNgramsElement, NgramsTerm(..), RootParent(..), mSetFromList)
import Gargantext.Prelude import Gargantext.Prelude
import qualified Data.Set as Set import qualified Data.HashMap.Strict as HashMap
import qualified Data.Map as Map
import qualified Data.List as List import qualified Data.List as List
import qualified Data.Map as Map
import qualified Data.Set as Set
type Stem = Text type Stem = NgramsTerm
------------------------------------------------------------------------ ------------------------------------------------------------------------
-- | Main Types to group With Scores but preserving Tree dependencies -- | Main Types to group With Scores but preserving Tree dependencies
-- Therefore there is a need of Tree of GroupedTextScores -- Therefore there is a need of Tree of GroupedTextScores
-- to target continuation type for the flow (FlowCont Text GroupedTreeScores) -- to target continuation type for the flow (FlowCont Text GroupedTreeScores)
data GroupedTreeScores score = data GroupedTreeScores score =
GroupedTreeScores { _gts'_listType :: !(Maybe ListType) GroupedTreeScores { _gts'_listType :: !(Maybe ListType)
, _gts'_children :: !(Map Text (GroupedTreeScores score)) , _gts'_children :: !(HashMap NgramsTerm (GroupedTreeScores score))
, _gts'_score :: !score , _gts'_score :: !score
} deriving (Show, Ord, Eq) } deriving (Show, Ord, Eq)
...@@ -76,7 +77,7 @@ class ToNgramsElement a where ...@@ -76,7 +77,7 @@ class ToNgramsElement a where
toNgramsElement :: a -> [NgramsElement] toNgramsElement :: a -> [NgramsElement]
class HasTerms a where class HasTerms a where
hasTerms :: a -> Set Text hasTerms :: a -> Set NgramsTerm
------------------------------------------------------------------------ ------------------------------------------------------------------------
-- | Instances declartion for (GroupedTreeScores a) -- | Instances declartion for (GroupedTreeScores a)
...@@ -87,8 +88,8 @@ instance SetListType (GroupedTreeScores a) where ...@@ -87,8 +88,8 @@ instance SetListType (GroupedTreeScores a) where
setListType lt g = over gts'_children (setListType lt) setListType lt g = over gts'_children (setListType lt)
$ set gts'_listType lt g $ set gts'_listType lt g
instance SetListType (Map Text (GroupedTreeScores a)) where instance SetListType (HashMap NgramsTerm (GroupedTreeScores a)) where
setListType lt = Map.map (set gts'_listType lt) setListType lt = HashMap.map (set gts'_listType lt)
------ ------
...@@ -99,7 +100,7 @@ instance ViewScores (GroupedTreeScores Double) Double where ...@@ -99,7 +100,7 @@ instance ViewScores (GroupedTreeScores Double) Double where
viewScores g = sum $ parent : children viewScores g = sum $ parent : children
where where
parent = view gts'_score g parent = view gts'_score g
children = map viewScores $ Map.elems $ view gts'_children g children = map viewScores $ HashMap.elems $ view gts'_children g
instance ViewScore (GroupedTreeScores (Set NodeId)) Int where instance ViewScore (GroupedTreeScores (Set NodeId)) Int where
...@@ -109,57 +110,55 @@ instance ViewScores (GroupedTreeScores (Set NodeId)) (Set NodeId) where ...@@ -109,57 +110,55 @@ instance ViewScores (GroupedTreeScores (Set NodeId)) (Set NodeId) where
viewScores g = Set.unions $ parent : children viewScores g = Set.unions $ parent : children
where where
parent = view gts'_score g parent = view gts'_score g
children = map viewScores $ Map.elems $ view gts'_children g children = map viewScores $ HashMap.elems $ view gts'_children g
instance ViewScore (GroupedTreeScores (Scored Text)) Double where instance ViewScore (GroupedTreeScores (Scored NgramsTerm)) Double where
viewScore = view (gts'_score . scored_genInc) viewScore = view (gts'_score . scored_genInc)
------ ------
instance HasTerms (Map Text (GroupedTreeScores a)) where instance HasTerms (HashMap NgramsTerm (GroupedTreeScores a)) where
hasTerms = Set.unions . (map hasTerms) . Map.toList hasTerms = Set.unions . (map hasTerms) . HashMap.toList
instance HasTerms (Text, GroupedTreeScores a) where instance HasTerms (NgramsTerm, GroupedTreeScores a) where
hasTerms (t, g) = Set.singleton t <> children hasTerms (t, g) = Set.singleton t <> children
where where
children = Set.unions children = Set.unions
$ map hasTerms $ map hasTerms
$ Map.toList $ HashMap.toList
$ view gts'_children g $ view gts'_children g
------ ------
instance ToNgramsElement (Map Text (GroupedTreeScores a)) where instance ToNgramsElement (HashMap NgramsTerm (GroupedTreeScores a)) where
toNgramsElement = List.concat . (map toNgramsElement) . Map.toList toNgramsElement = List.concat . (map toNgramsElement) . HashMap.toList
instance ToNgramsElement (Text, GroupedTreeScores a) where instance ToNgramsElement (NgramsTerm, GroupedTreeScores a) where
toNgramsElement (t, gts) = parent : children toNgramsElement (t, gts) = parent : children
where where
parent = mkNgramsElement (NgramsTerm t) parent = mkNgramsElement t
(fromMaybe CandidateTerm $ viewListType gts) (fromMaybe CandidateTerm $ viewListType gts)
Nothing Nothing
(mSetFromList $ map NgramsTerm (mSetFromList $ HashMap.keys
$ Map.keys
$ view gts'_children gts $ view gts'_children gts
) )
children = List.concat children = List.concat
$ map (childrenWith (NgramsTerm t) (NgramsTerm t) ) $ map (childrenWith t t)
$ Map.toList $ HashMap.toList
$ view gts'_children gts $ view gts'_children gts
childrenWith root parent' (t', gts') = parent'' : children' childrenWith root parent' (t', gts') = parent'' : children'
where where
parent'' = mkNgramsElement (NgramsTerm t') parent'' = mkNgramsElement t'
(fromMaybe CandidateTerm $ viewListType gts') (fromMaybe CandidateTerm $ viewListType gts')
(Just $ RootParent root parent') (Just $ RootParent root parent')
(mSetFromList $ map NgramsTerm (mSetFromList $ HashMap.keys
$ Map.keys
$ view gts'_children gts' $ view gts'_children gts'
) )
children' = List.concat children' = List.concat
$ map (childrenWith root (NgramsTerm t') ) $ map (childrenWith root t' )
$ Map.toList $ HashMap.toList
$ view gts'_children gts' $ view gts'_children gts'
src/Gargantext/Core/Text/List/Group/WithScores.hs
View file @ 252b3ef9
...@@ -16,23 +16,24 @@ module Gargantext.Core.Text.List.Group.WithScores ...@@ -16,23 +16,24 @@ module Gargantext.Core.Text.List.Group.WithScores
where where
import Control.Lens (view, set, over) import Control.Lens (view, set, over)
import Data.Semigroup import Data.HashMap.Strict (HashMap)
import Data.Map (Map) import Data.Map (Map)
import Data.Monoid (Monoid, mempty)
import Data.Maybe (fromMaybe) import Data.Maybe (fromMaybe)
import Data.Text (Text) import Data.Monoid (Monoid, mempty)
import Gargantext.Core.Text.List.Social.Prelude import Data.Semigroup
import Gargantext.API.Ngrams.Types (NgramsTerm(..))
import Gargantext.Core.Text.List.Group.Prelude import Gargantext.Core.Text.List.Group.Prelude
import Gargantext.Core.Text.List.Social.Prelude
import Gargantext.Prelude import Gargantext.Prelude
import qualified Data.Map as Map import qualified Data.Map as Map
import qualified Data.HashMap.Strict as HashMap
------------------------------------------------------------------------
------------------------------------------------------------------------ ------------------------------------------------------------------------
-- | Main function -- | Main function
groupWithScores' :: (Eq a, Ord a, Monoid a) groupWithScores' :: (Eq a, Ord a, Monoid a)
=> FlowCont Text FlowListScores => FlowCont NgramsTerm FlowListScores
-> (Text -> a) -- Map Text (a) -> (NgramsTerm -> a)
-> FlowCont Text (GroupedTreeScores a) -> FlowCont NgramsTerm (GroupedTreeScores a)
groupWithScores' flc scores = FlowCont groups orphans groupWithScores' flc scores = FlowCont groups orphans
where where
-- parent/child relation is inherited from social lists -- parent/child relation is inherited from social lists
...@@ -40,28 +41,25 @@ groupWithScores' flc scores = FlowCont groups orphans ...@@ -40,28 +41,25 @@ groupWithScores' flc scores = FlowCont groups orphans
$ toMapMaybeParent scores $ toMapMaybeParent scores
$ (view flc_scores flc <> view flc_cont flc) $ (view flc_scores flc <> view flc_cont flc)
-- orphans should be filtered already -- orphans should be filtered already then becomes empty
orphans = mempty {- toGroupedTree orphans = mempty
$ toMapMaybeParent scores
$ view flc_cont flc
-}
------------------------------------------------------------------------ ------------------------------------------------------------------------
toMapMaybeParent :: (Eq a, Ord a, Monoid a) toMapMaybeParent :: (Eq a, Ord a, Monoid a)
=> (Text -> a) => (NgramsTerm -> a)
-> Map Text FlowListScores -> HashMap NgramsTerm FlowListScores
-> Map (Maybe Parent) (Map Text (GroupedTreeScores a)) -> HashMap (Maybe Parent) (HashMap NgramsTerm (GroupedTreeScores a))
toMapMaybeParent f = Map.fromListWith (<>) toMapMaybeParent f = HashMap.fromListWith (<>)
. (map (fromScores'' f)) . (map (fromScores'' f))
. Map.toList . HashMap.toList
fromScores'' :: (Eq a, Ord a, Monoid a) fromScores'' :: (Eq a, Ord a, Monoid a)
=> (Text -> a) => (NgramsTerm -> a)
-> (Text, FlowListScores) -> (NgramsTerm, FlowListScores)
-> (Maybe Parent, Map Text (GroupedTreeScores a)) -> (Maybe Parent, HashMap NgramsTerm (GroupedTreeScores a))
fromScores'' f' (t, fs) = ( maybeParent fromScores'' f' (t, fs) = ( maybeParent
, Map.fromList [( t, set gts'_score (f' t) , HashMap.fromList [( t, set gts'_score (f' t)
$ set gts'_listType maybeList mempty $ set gts'_listType maybeList mempty
)] )]
) )
...@@ -71,23 +69,23 @@ fromScores'' f' (t, fs) = ( maybeParent ...@@ -71,23 +69,23 @@ fromScores'' f' (t, fs) = ( maybeParent
------------------------------------------------------------------------ ------------------------------------------------------------------------
toGroupedTree :: Eq a toGroupedTree :: Eq a
=> Map (Maybe Parent) (Map Text (GroupedTreeScores a)) => HashMap (Maybe Parent) (HashMap NgramsTerm (GroupedTreeScores a))
-> Map Parent (GroupedTreeScores a) -> HashMap Parent (GroupedTreeScores a)
toGroupedTree m = case Map.lookup Nothing m of toGroupedTree m = case HashMap.lookup Nothing m of
Nothing -> mempty Nothing -> mempty
Just m' -> toGroupedTree' m m' Just m' -> toGroupedTree' m m'
toGroupedTree' :: Eq a => Map (Maybe Parent) (Map Text (GroupedTreeScores a)) toGroupedTree' :: Eq a => HashMap (Maybe Parent) (HashMap NgramsTerm (GroupedTreeScores a))
-> (Map Text (GroupedTreeScores a)) -> (HashMap NgramsTerm (GroupedTreeScores a))
-> Map Parent (GroupedTreeScores a) -> HashMap Parent (GroupedTreeScores a)
toGroupedTree' m notEmpty toGroupedTree' m notEmpty
| notEmpty == mempty = mempty | notEmpty == mempty = mempty
| otherwise = Map.mapWithKey (addGroup m) notEmpty | otherwise = HashMap.mapWithKey (addGroup m) notEmpty
where where
addGroup m' k v = over gts'_children ( (toGroupedTree' m') addGroup m' k v = over gts'_children ( (toGroupedTree' m')
. (Map.union ( fromMaybe mempty . (HashMap.union ( fromMaybe mempty
$ Map.lookup (Just k) m' $ HashMap.lookup (Just k) m'
) )
) )
) )
......
src/Gargantext/Core/Text/List/Group/WithStem.hs
View file @ 252b3ef9
...@@ -17,29 +17,29 @@ Portability : POSIX ...@@ -17,29 +17,29 @@ Portability : POSIX
module Gargantext.Core.Text.List.Group.WithStem module Gargantext.Core.Text.List.Group.WithStem
where where
import Data.HashSet (HashSet)
import Data.Map (Map) import Data.Map (Map)
import Data.Maybe (catMaybes) import Data.Maybe (catMaybes)
import Data.Set (Set)
import Data.Text (Text) import Data.Text (Text)
import Gargantext.API.Ngrams.Types import Gargantext.API.Ngrams.Types
import Gargantext.Core (Lang(..)) import Gargantext.Core (Lang(..))
import Gargantext.Core.Text.List.Group.Prelude import Gargantext.Core.Text.List.Group.Prelude
import Gargantext.Core.Text.List.Social.Prelude
import Gargantext.Core.Text.List.Social.Patch import Gargantext.Core.Text.List.Social.Patch
import Gargantext.Core.Text.List.Social.Prelude
import Gargantext.Core.Text.Terms.Mono.Stem (stem) import Gargantext.Core.Text.Terms.Mono.Stem (stem)
import Gargantext.Prelude import Gargantext.Prelude
import qualified Data.List as List import qualified Data.HashSet as Set
import qualified Data.Map as Map import qualified Data.List as List
import qualified Data.Map as Map
import qualified Data.Map.Strict.Patch as PatchMap import qualified Data.Map.Strict.Patch as PatchMap
import qualified Data.Patch.Class as Patch (Replace(..)) import qualified Data.Patch.Class as Patch (Replace(..))
import qualified Data.Set as Set import qualified Data.Text as Text
import qualified Data.Text as Text
------------------------------------------------------------------------ ------------------------------------------------------------------------
addScoreStem :: GroupParams addScoreStem :: GroupParams
-> Set NgramsTerm -> HashSet NgramsTerm
-> FlowCont Text FlowListScores -> FlowCont NgramsTerm FlowListScores
-> FlowCont Text FlowListScores -> FlowCont NgramsTerm FlowListScores
addScoreStem groupParams ngrams fl = foldl' addScorePatch fl addScoreStem groupParams ngrams fl = foldl' addScorePatch fl
$ stemPatches groupParams ngrams $ stemPatches groupParams ngrams
...@@ -62,36 +62,38 @@ data GroupParams = GroupParams { unGroupParams_lang :: !Lang ...@@ -62,36 +62,38 @@ data GroupParams = GroupParams { unGroupParams_lang :: !Lang
------------------------------------------------------------------------ ------------------------------------------------------------------------
groupWith :: GroupParams groupWith :: GroupParams
-> Text -> NgramsTerm
-> Text -> NgramsTerm
groupWith GroupIdentity = identity groupWith GroupIdentity = identity
groupWith (GroupParams l _m _n _) = groupWith (GroupParams l _m _n _) =
Text.intercalate " " NgramsTerm
. Text.intercalate " "
. map (stem l) . map (stem l)
-- . take n -- . take n
. List.sort . List.sort
-- . (List.filter (\t -> Text.length t > m)) -- . (List.filter (\t -> Text.length t > m))
. Text.splitOn " " . Text.splitOn " "
. Text.replace "-" " " . Text.replace "-" " "
. unNgramsTerm
-------------------------------------------------------------------- --------------------------------------------------------------------
stemPatches :: GroupParams stemPatches :: GroupParams
-> Set NgramsTerm -> HashSet NgramsTerm
-> [(NgramsTerm, NgramsPatch)] -> [(NgramsTerm, NgramsPatch)]
stemPatches groupParams = patches stemPatches groupParams = patches
. Map.fromListWith (<>) . Map.fromListWith (<>)
. map (\ng@(NgramsTerm t) -> ( groupWith groupParams t . map (\ng -> ( groupWith groupParams ng
, Set.singleton ng) , Set.singleton ng)
) )
. Set.toList . Set.toList
-- | For now all NgramsTerm which have same stem -- | For now all NgramsTerm which have same stem
-- are grouped together -- are grouped together
-- Parent is taken arbitrarly for now (TODO use a score like occ) -- Parent is taken arbitrarly for now (TODO use a score like occ)
patches :: Map Stem (Set NgramsTerm) patches :: Map Stem (HashSet NgramsTerm)
-> [(NgramsTerm, NgramsPatch)] -> [(NgramsTerm, NgramsPatch)]
patches = catMaybes . map patch . Map.elems patches = catMaybes . map patch . Map.elems
patch :: Set NgramsTerm patch :: HashSet NgramsTerm
-> Maybe (NgramsTerm, NgramsPatch) -> Maybe (NgramsTerm, NgramsPatch)
patch s = case Set.size s > 1 of patch s = case Set.size s > 1 of
False -> Nothing False -> Nothing
......
src/Gargantext/Core/Text/List/Merge.hs
View file @ 252b3ef9
...@@ -26,8 +26,8 @@ import Gargantext.API.Ngrams.Types ...@@ -26,8 +26,8 @@ import Gargantext.API.Ngrams.Types
import Gargantext.Prelude import Gargantext.Prelude
import Data.Map.Strict.Patch hiding (PatchMap) import Data.Map.Strict.Patch hiding (PatchMap)
type List = Map Text NgramsRepoElement type List = Map NgramsTerm NgramsRepoElement
type Patch = PatchMap Text (Replace (Maybe NgramsRepoElement)) type Patch = PatchMap NgramsTerm (Replace (Maybe NgramsRepoElement))
-- Question: which version of Patching increment is using the FrontEnd ? -- Question: which version of Patching increment is using the FrontEnd ?
diffList :: Versioned List -> Versioned List -> Versioned Patch diffList :: Versioned List -> Versioned List -> Versioned Patch
......
src/Gargantext/Core/Text/List/Social.hs
View file @ 252b3ef9
...@@ -11,6 +11,7 @@ Portability : POSIX ...@@ -11,6 +11,7 @@ Portability : POSIX
module Gargantext.Core.Text.List.Social module Gargantext.Core.Text.List.Social
where where
import Data.HashMap.Strict (HashMap)
import Data.Map (Map) import Data.Map (Map)
import Data.Monoid (mconcat) import Data.Monoid (mconcat)
import Data.Text (Text) import Data.Text (Text)
...@@ -56,8 +57,8 @@ flowSocialList :: ( RepoCmdM env err m ...@@ -56,8 +57,8 @@ flowSocialList :: ( RepoCmdM env err m
) )
=> FlowSocialListPriority => FlowSocialListPriority
-> User -> NgramsType -> User -> NgramsType
-> FlowCont Text FlowListScores -> FlowCont NgramsTerm FlowListScores
-> m (FlowCont Text FlowListScores) -> m (FlowCont NgramsTerm FlowListScores)
flowSocialList flowPriority user nt flc = flowSocialList flowPriority user nt flc =
mconcat <$> mapM (flowSocialListByMode' user nt flc) mconcat <$> mapM (flowSocialListByMode' user nt flc)
(flowSocialListPriority flowPriority) (flowSocialListPriority flowPriority)
...@@ -69,9 +70,9 @@ flowSocialList flowPriority user nt flc = ...@@ -69,9 +70,9 @@ flowSocialList flowPriority user nt flc =
, HasTreeError err , HasTreeError err
) )
=> User -> NgramsType => User -> NgramsType
-> FlowCont Text FlowListScores -> FlowCont NgramsTerm FlowListScores
-> NodeMode -> NodeMode
-> m (FlowCont Text FlowListScores) -> m (FlowCont NgramsTerm FlowListScores)
flowSocialListByMode' user' nt' flc' mode = flowSocialListByMode' user' nt' flc' mode =
findListsId user' mode findListsId user' mode
>>= flowSocialListByModeWith nt' flc' >>= flowSocialListByModeWith nt' flc'
...@@ -83,9 +84,9 @@ flowSocialList flowPriority user nt flc = ...@@ -83,9 +84,9 @@ flowSocialList flowPriority user nt flc =
, HasTreeError err , HasTreeError err
) )
=> NgramsType => NgramsType
-> FlowCont Text FlowListScores -> FlowCont NgramsTerm FlowListScores
-> [ListId] -> [ListId]
-> m (FlowCont Text FlowListScores) -> m (FlowCont NgramsTerm FlowListScores)
flowSocialListByModeWith nt'' flc'' listes = flowSocialListByModeWith nt'' flc'' listes =
getHistoryScores History_User nt'' flc'' listes getHistoryScores History_User nt'' flc'' listes
{- {-
...@@ -101,13 +102,11 @@ getHistoryScores :: ( RepoCmdM env err m ...@@ -101,13 +102,11 @@ getHistoryScores :: ( RepoCmdM env err m
) )
=> History => History
-> NgramsType -> NgramsType
-> FlowCont Text FlowListScores -> FlowCont NgramsTerm FlowListScores
-> [ListId] -> [ListId]
-> m (FlowCont Text FlowListScores) -> m (FlowCont NgramsTerm FlowListScores)
getHistoryScores hist nt fl listes = do getHistoryScores hist nt fl listes =
hist' <- addScorePatches nt listes fl <$> getHistory hist nt listes addScorePatches nt listes fl <$> getHistory hist nt listes
-- printDebug "hist" hist'
pure hist'
getHistory :: ( RepoCmdM env err m getHistory :: ( RepoCmdM env err m
, CmdM env err m , CmdM env err m
...@@ -117,8 +116,7 @@ getHistory :: ( RepoCmdM env err m ...@@ -117,8 +116,7 @@ getHistory :: ( RepoCmdM env err m
=> History => History
-> NgramsType -> NgramsType
-> [ListId] -> [ListId]
-> m (Map NgramsType (Map ListId [Map NgramsTerm NgramsPatch])) -> m (Map NgramsType (Map ListId [HashMap NgramsTerm NgramsPatch]))
getHistory hist nt listes = getHistory hist nt listes =
history hist [nt] listes <$> getRepo history hist [nt] listes <$> getRepo
src/Gargantext/Core/Text/List/Social/History.hs
View file @ 252b3ef9
...@@ -12,14 +12,16 @@ module Gargantext.Core.Text.List.Social.History ...@@ -12,14 +12,16 @@ module Gargantext.Core.Text.List.Social.History
where where
import Control.Lens hiding (cons) import Control.Lens hiding (cons)
import Data.HashMap.Strict (HashMap)
import Data.Map (Map) import Data.Map (Map)
import Gargantext.API.Ngrams.Types import Gargantext.API.Ngrams.Types
import Gargantext.Core.Text.List.Social.Prelude import Gargantext.Core.Text.List.Social.Prelude
import Gargantext.Core.Types (ListId) import Gargantext.Core.Types (ListId)
import Gargantext.Database.Schema.Ngrams (NgramsType(..)) import Gargantext.Database.Schema.Ngrams (NgramsType(..))
import Gargantext.Prelude import Gargantext.Prelude
import qualified Data.List as List import qualified Data.List as List
import qualified Data.Map.Strict as Map import qualified Data.Map.Strict as Map
import qualified Data.HashMap.Strict as HashMap
-- TODO put this in Prelude -- TODO put this in Prelude
cons :: a -> [a] cons :: a -> [a]
...@@ -37,7 +39,7 @@ history :: History ...@@ -37,7 +39,7 @@ history :: History
-> [NgramsType] -> [NgramsType]
-> [ListId] -> [ListId]
-> Repo s NgramsStatePatch -> Repo s NgramsStatePatch
-> Map NgramsType (Map ListId [Map NgramsTerm NgramsPatch]) -> Map NgramsType (Map ListId [HashMap NgramsTerm NgramsPatch])
history History_User t l = clean . (history' t l) history History_User t l = clean . (history' t l)
where where
clean = Map.map (Map.map List.init) clean = Map.map (Map.map List.init)
...@@ -50,11 +52,10 @@ history History_NotUser t l = clean . (history' t l) ...@@ -50,11 +52,10 @@ history History_NotUser t l = clean . (history' t l)
history _ t l = history' t l history _ t l = history' t l
------------------------------------------------------------------------ ------------------------------------------------------------------------
history' :: [NgramsType] history' :: [NgramsType]
-> [ListId] -> [ListId]
-> Repo s NgramsStatePatch -> Repo s NgramsStatePatch
-> Map NgramsType (Map ListId [Map NgramsTerm NgramsPatch]) -> Map NgramsType (Map ListId [HashMap NgramsTerm NgramsPatch])
history' types lists = merge history' types lists = merge
. map (Map.map ( Map.map cons)) . map (Map.map ( Map.map cons))
. map (Map.map ((Map.filterWithKey (\k _ -> List.elem k lists)))) . map (Map.map ((Map.filterWithKey (\k _ -> List.elem k lists))))
...@@ -63,13 +64,13 @@ history' types lists = merge ...@@ -63,13 +64,13 @@ history' types lists = merge
. view r_history . view r_history
merge :: [Map NgramsType (Map ListId [Map NgramsTerm NgramsPatch])] merge :: [Map NgramsType (Map ListId [HashMap NgramsTerm NgramsPatch])]
-> Map NgramsType (Map ListId [Map NgramsTerm NgramsPatch]) -> Map NgramsType (Map ListId [HashMap NgramsTerm NgramsPatch])
merge = Map.unionsWith merge' merge = Map.unionsWith merge'
where where
merge' :: Map ListId [Map NgramsTerm NgramsPatch] merge' :: Map ListId [HashMap NgramsTerm NgramsPatch]
-> Map ListId [Map NgramsTerm NgramsPatch] -> Map ListId [HashMap NgramsTerm NgramsPatch]
-> Map ListId [Map NgramsTerm NgramsPatch] -> Map ListId [HashMap NgramsTerm NgramsPatch]
merge' = Map.unionWith (<>) merge' = Map.unionWith (<>)
...@@ -80,9 +81,8 @@ toMap :: PatchMap NgramsType ...@@ -80,9 +81,8 @@ toMap :: PatchMap NgramsType
) )
-> Map NgramsType -> Map NgramsType
(Map ListId (Map ListId
(Map NgramsTerm NgramsPatch (HashMap NgramsTerm NgramsPatch
) )
) )
toMap = Map.map (Map.map unNgramsTablePatch) . (Map.map unPatchMap) . unPatchMap toMap = Map.map (Map.map unNgramsTablePatch) . (Map.map unPatchMapToMap) . unPatchMapToMap
src/Gargantext/Core/Text/List/Social/Patch.hs
View file @ 252b3ef9
...@@ -13,6 +13,8 @@ module Gargantext.Core.Text.List.Social.Patch ...@@ -13,6 +13,8 @@ module Gargantext.Core.Text.List.Social.Patch
import Control.Lens hiding (cons) import Control.Lens hiding (cons)
import Data.Map (Map) import Data.Map (Map)
import Data.Hashable (Hashable)
import Data.HashMap.Strict (HashMap)
import Data.Monoid import Data.Monoid
import Data.Semigroup import Data.Semigroup
import Data.Text (Text) import Data.Text (Text)
...@@ -21,25 +23,26 @@ import Gargantext.Core.Text.List.Social.Prelude ...@@ -21,25 +23,26 @@ import Gargantext.Core.Text.List.Social.Prelude
import Gargantext.Core.Types (ListId) import Gargantext.Core.Types (ListId)
import Gargantext.Database.Schema.Ngrams (NgramsType(..)) import Gargantext.Database.Schema.Ngrams (NgramsType(..))
import Gargantext.Prelude import Gargantext.Prelude
import qualified Data.Map as Map
import qualified Data.List as List import qualified Data.List as List
import qualified Data.Map as Map import qualified Data.HashMap.Strict as HashMap
import qualified Data.Patch.Class as Patch (Replace(..)) import qualified Data.Patch.Class as Patch (Replace(..))
addScorePatches :: NgramsType -> [ListId] addScorePatches :: NgramsType -> [ListId]
-> FlowCont Text FlowListScores -> FlowCont NgramsTerm FlowListScores
-> Map NgramsType (Map ListId [Map NgramsTerm NgramsPatch]) -> Map NgramsType (Map ListId [HashMap NgramsTerm NgramsPatch])
-> FlowCont Text FlowListScores -> FlowCont NgramsTerm FlowListScores
addScorePatches nt listes fl repo = foldl' (addScorePatchesList nt repo) fl listes addScorePatches nt listes fl repo = foldl' (addScorePatchesList nt repo) fl listes
addScorePatchesList :: NgramsType addScorePatchesList :: NgramsType
-> Map NgramsType (Map ListId [Map NgramsTerm NgramsPatch]) -> Map NgramsType (Map ListId [HashMap NgramsTerm NgramsPatch])
-> FlowCont Text FlowListScores -> FlowCont NgramsTerm FlowListScores
-> ListId -> ListId
-> FlowCont Text FlowListScores -> FlowCont NgramsTerm FlowListScores
addScorePatchesList nt repo fl lid = foldl' addScorePatch fl patches addScorePatchesList nt repo fl lid = foldl' addScorePatch fl patches
where where
patches = maybe [] (List.concat . (map Map.toList)) patches' patches = maybe [] (List.concat . (map HashMap.toList)) patches'
patches' = do patches' = do
lists <- Map.lookup nt repo lists <- Map.lookup nt repo
...@@ -48,9 +51,9 @@ addScorePatchesList nt repo fl lid = foldl' addScorePatch fl patches ...@@ -48,9 +51,9 @@ addScorePatchesList nt repo fl lid = foldl' addScorePatch fl patches
addScorePatch :: FlowCont Text FlowListScores addScorePatch :: FlowCont NgramsTerm FlowListScores
-> (NgramsTerm , NgramsPatch) -> (NgramsTerm , NgramsPatch)
-> FlowCont Text FlowListScores -> FlowCont NgramsTerm FlowListScores
{- | Case of changing listType only. Patches look like: {- | Case of changing listType only. Patches look like:
...@@ -65,59 +68,59 @@ Children are not modified in this specific case. ...@@ -65,59 +68,59 @@ Children are not modified in this specific case.
-- | Old list get -1 score -- | Old list get -1 score
-- New list get +1 score -- New list get +1 score
-- Hence others lists lay around 0 score -- Hence others lists lay around 0 score
addScorePatch fl (NgramsTerm t, (NgramsPatch children' (Patch.Replace old_list new_list))) = addScorePatch fl (t, (NgramsPatch children' (Patch.Replace old_list new_list))) =
-- | Adding New Children score -- | Adding New Children score
addScorePatch fl' (NgramsTerm t, NgramsPatch children' Patch.Keep) addScorePatch fl' (t, NgramsPatch children' Patch.Keep)
where where
-- | Adding New ListType score -- | Adding New ListType score
fl' = fl & flc_scores . at t %~ (score fls_listType old_list (-1)) fl' = fl & flc_scores . at t %~ (score fls_listType old_list (-1))
& flc_scores . at t %~ (score fls_listType new_list ( 1)) & flc_scores . at t %~ (score fls_listType new_list ( 1))
& flc_cont %~ (Map.delete t) & flc_cont %~ (HashMap.delete t)
-- | Patching existing Ngrams with children -- | Patching existing Ngrams with children
addScorePatch fl (NgramsTerm p, NgramsPatch children' Patch.Keep) = addScorePatch fl (p, NgramsPatch children' Patch.Keep) =
foldl' addChild fl $ patchMSet_toList children' foldl' addChild fl $ patchMSet_toList children'
where where
-- | Adding a child -- | Adding a child
addChild fl' (NgramsTerm t, Patch.Replace Nothing (Just _)) = doLink ( 1) p t fl' addChild fl' (t, Patch.Replace Nothing (Just _)) = doLink ( 1) p t fl'
-- | Removing a child -- | Removing a child
addChild fl' (NgramsTerm t, Patch.Replace (Just _) Nothing) = doLink (-1) p t fl' addChild fl' (t, Patch.Replace (Just _) Nothing) = doLink (-1) p t fl'
-- | This case should not happen: does Nothing -- | This case should not happen: does Nothing
addChild fl' _ = fl' addChild fl' _ = fl'
-- | Inserting a new Ngrams -- | Inserting a new Ngrams
addScorePatch fl (NgramsTerm t, NgramsReplace Nothing (Just nre)) = addScorePatch fl (t, NgramsReplace Nothing (Just nre)) =
childrenScore 1 t (nre ^. nre_children) childrenScore 1 t (nre ^. nre_children)
$ fl & flc_scores . at t %~ (score fls_listType $ nre ^. nre_list) 1 $ fl & flc_scores . at t %~ (score fls_listType $ nre ^. nre_list) 1
& flc_cont %~ (Map.delete t) & flc_cont %~ (HashMap.delete t)
addScorePatch fl (NgramsTerm t, NgramsReplace (Just old_nre) maybe_new_nre) = addScorePatch fl (t, NgramsReplace (Just old_nre) maybe_new_nre) =
let fl' = childrenScore (-1) t (old_nre ^. nre_children) let fl' = childrenScore (-1) t (old_nre ^. nre_children)
$ fl & flc_scores . at t %~ (score fls_listType $ old_nre ^. nre_list) (-1) $ fl & flc_scores . at t %~ (score fls_listType $ old_nre ^. nre_list) (-1)
& flc_cont %~ (Map.delete t) & flc_cont %~ (HashMap.delete t)
in case maybe_new_nre of in case maybe_new_nre of
Nothing -> fl' Nothing -> fl'
Just new_nre -> addScorePatch fl' (NgramsTerm t, NgramsReplace Nothing (Just new_nre)) Just new_nre -> addScorePatch fl' (t, NgramsReplace Nothing (Just new_nre))
addScorePatch fl (NgramsTerm _, NgramsReplace Nothing Nothing) = fl addScorePatch fl (_, NgramsReplace Nothing Nothing) = fl
------------------------------------------------------------------------------- -------------------------------------------------------------------------------
-- | Utils -- | Utils
childrenScore :: Int childrenScore :: Int
-> Text -> NgramsTerm
-> MSet NgramsTerm -> MSet NgramsTerm
-> FlowCont Text FlowListScores -> FlowCont NgramsTerm FlowListScores
-> FlowCont Text FlowListScores -> FlowCont NgramsTerm FlowListScores
childrenScore n parent children' fl = childrenScore n parent children' fl =
foldl' add' fl $ unMSet children' foldl' add' fl $ unMSet children'
where where
add' fl' (NgramsTerm t) = doLink n parent t fl' add' fl' t = doLink n parent t fl'
------------------------------------------------------------------------ ------------------------------------------------------------------------
doLink :: Ord a doLink :: (Ord a, Hashable a)
=> Int => Int
-> Text -> NgramsTerm
-> a -> a
-> FlowCont a FlowListScores -> FlowCont a FlowListScores
-> FlowCont a FlowListScores -> FlowCont a FlowListScores
...@@ -134,8 +137,8 @@ score field list n m = (Just mempty <> m) ...@@ -134,8 +137,8 @@ score field list n m = (Just mempty <> m)
%~ (<> Just n) %~ (<> Just n)
------------------------------------------------------------------------ ------------------------------------------------------------------------
patchMSet_toList :: Ord a => PatchMSet a -> [(a,AddRem)] patchMSet_toList :: (Ord a, Hashable a) => PatchMSet a -> [(a,AddRem)]
patchMSet_toList = Map.toList . unPatchMap . unPatchMSet patchMSet_toList = HashMap.toList . unPatchMapToHashMap . unPatchMSet
unMSet :: MSet a -> [a] unMSet :: MSet a -> [a]
unMSet (MSet a) = Map.keys a unMSet (MSet a) = Map.keys a
......
src/Gargantext/Core/Text/List/Social/Prelude.hs
View file @ 252b3ef9
...@@ -20,6 +20,8 @@ module Gargantext.Core.Text.List.Social.Prelude ...@@ -20,6 +20,8 @@ module Gargantext.Core.Text.List.Social.Prelude
import Control.Lens import Control.Lens
import Data.Map (Map) import Data.Map (Map)
import Data.HashMap.Strict (HashMap)
import Data.Hashable (Hashable)
import Data.Monoid import Data.Monoid
import Data.Semigroup (Semigroup(..)) import Data.Semigroup (Semigroup(..))
import Data.Text (Text) import Data.Text (Text)
...@@ -28,23 +30,25 @@ import Gargantext.API.Ngrams.Types ...@@ -28,23 +30,25 @@ import Gargantext.API.Ngrams.Types
import Gargantext.Core.Text.Metrics.Freq (getMaxFromMap) import Gargantext.Core.Text.Metrics.Freq (getMaxFromMap)
import Gargantext.Core.Types.Main import Gargantext.Core.Types.Main
import Gargantext.Prelude import Gargantext.Prelude
import qualified Data.Map as Map import qualified Gargantext.Data.HashMap.Strict.Utils as HashMap
import qualified Data.Map.Strict as Map
import qualified Data.HashMap.Strict as HashMap
import qualified Data.Map.Strict.Patch as PatchMap import qualified Data.Map.Strict.Patch as PatchMap
------------------------------------------------------------------------ ------------------------------------------------------------------------
type Parent = Text type Parent = NgramsTerm
------------------------------------------------------------------------ ------------------------------------------------------------------------
-- | DataType inspired by continuation Monad (but simpler) -- | DataType inspired by continuation Monad (but simpler)
data FlowCont a b = data FlowCont a b =
FlowCont { _flc_scores :: Map a b FlowCont { _flc_scores :: HashMap a b
, _flc_cont :: Map a b , _flc_cont :: HashMap a b
} }
deriving (Show) deriving (Show)
instance (Ord a, Eq b) => Monoid (FlowCont a b) where instance (Ord a, Eq b, Hashable a) => Monoid (FlowCont a b) where
mempty = FlowCont mempty mempty mempty = FlowCont mempty mempty
instance (Eq a, Ord a, Eq b) => Semigroup (FlowCont a b) where instance (Eq a, Ord a, Eq b, Hashable a) => Semigroup (FlowCont a b) where
(<>) (FlowCont m1 s1) (<>) (FlowCont m1 s1)
(FlowCont m2 s2) (FlowCont m2 s2)
= FlowCont (m1 <> m2) = FlowCont (m1 <> m2)
...@@ -54,10 +58,10 @@ makeLenses ''FlowCont ...@@ -54,10 +58,10 @@ makeLenses ''FlowCont
-- | Datatype definition -- | Datatype definition
data FlowListScores = data FlowListScores =
FlowListScores { _fls_listType :: Map ListType Int FlowListScores { _fls_listType :: HashMap ListType Int
, _fls_parents :: Map Parent Int , _fls_parents :: HashMap Parent Int
-- You can add any score by incrementing this type -- You can add any score by incrementing this type
-- , _flc_score :: Map Score Int -- , _flc_score :: HashMap Score Int
} }
deriving (Show, Generic, Eq) deriving (Show, Generic, Eq)
...@@ -75,16 +79,16 @@ instance Semigroup FlowListScores where ...@@ -75,16 +79,16 @@ instance Semigroup FlowListScores where
(l1 <> l2) (l1 <> l2)
instance Monoid FlowListScores where instance Monoid FlowListScores where
mempty = FlowListScores Map.empty Map.empty mempty = FlowListScores HashMap.empty HashMap.empty
------------------------------------------------------------------------ ------------------------------------------------------------------------
-- | Tools to inherit groupings -- | Tools to inherit groupings
------------------------------------------------------------------------ ------------------------------------------------------------------------
-- | Tools -- | Tools
parentUnionsMerge :: (Ord a, Ord b, Num c) parentUnionsMerge :: (Ord a, Ord b, Num c, Hashable a, Hashable b)
=> [Map a (Map b c)] => [HashMap a (HashMap b c)]
-> Map a (Map b c) -> HashMap a (HashMap b c)
parentUnionsMerge = Map.unionsWith (Map.unionWith (+)) parentUnionsMerge = HashMap.unionsWith (HashMap.unionWith (+))
-- This Parent union is specific -- This Parent union is specific
-- [Private, Shared, Public] -- [Private, Shared, Public]
...@@ -92,10 +96,10 @@ parentUnionsMerge = Map.unionsWith (Map.unionWith (+)) ...@@ -92,10 +96,10 @@ parentUnionsMerge = Map.unionsWith (Map.unionWith (+))
-- Private > Shared > Public -- Private > Shared > Public
-- if data have not been tagged privately, then use others tags -- if data have not been tagged privately, then use others tags
-- This unions behavior takes first key only and ignore others -- This unions behavior takes first key only and ignore others
parentUnionsExcl :: Ord a parentUnionsExcl :: (Ord a, Hashable a)
=> [Map a b] => [HashMap a b]
-> Map a b -> HashMap a b
parentUnionsExcl = Map.unions parentUnionsExcl = HashMap.unions
------------------------------------------------------------------------ ------------------------------------------------------------------------
-- | Takes key with max value if and only if value > 0 -- | Takes key with max value if and only if value > 0
...@@ -107,27 +111,29 @@ parentUnionsExcl = Map.unions ...@@ -107,27 +111,29 @@ parentUnionsExcl = Map.unions
-- Nothing -- Nothing
-- TODO duplicate with getMaxFromMap and improve it (lookup value should not be needed) -- TODO duplicate with getMaxFromMap and improve it (lookup value should not be needed)
-- TODO put in custom Prelude -- TODO put in custom Prelude
keyWithMaxValue :: (Ord a, Ord b, Num b) keyWithMaxValue :: (Ord a, Ord b, Num b, Hashable a)
=> Map a b -> Maybe a => HashMap a b -> Maybe a
keyWithMaxValue m = do keyWithMaxValue m = do
maxKey <- headMay $ getMaxFromMap m maxKey <- headMay $ HashMap.getKeyWithMaxValue m
maxValue <- Map.lookup maxKey m maxValue <- HashMap.lookup maxKey m
if maxValue > 0 if maxValue > 0
then pure maxKey then pure maxKey
else Nothing else Nothing
findMax :: (Ord b, Num b) => Map a b -> Maybe (a,b) findMax :: (Ord b, Num b, Hashable a) => HashMap a b -> Maybe (a,b)
findMax m = case Map.null m of findMax m = case HashMap.null m of
True -> Nothing True -> Nothing
False -> Just $ Map.findMax m False -> Just $ HashMap.findMax m
------------------------------------------------------------------------ ------------------------------------------------------------------------
unPatchMap :: Ord a => PatchMap a b -> Map a b unPatchMapToHashMap :: (Ord a, Hashable a) => PatchMap a b -> HashMap a b
unPatchMap = Map.fromList . PatchMap.toList unPatchMapToHashMap = HashMap.fromList . PatchMap.toList
unNgramsTablePatch :: NgramsTablePatch -> Map NgramsTerm NgramsPatch unPatchMapToMap :: Ord a => PatchMap a b -> Map a b
unNgramsTablePatch (NgramsTablePatch p) = unPatchMap p unPatchMapToMap = Map.fromList . PatchMap.toList
unNgramsTablePatch :: NgramsTablePatch -> HashMap NgramsTerm NgramsPatch
unNgramsTablePatch (NgramsTablePatch p) = unPatchMapToHashMap p
src/Gargantext/Core/Text/List/Social/Scores.hs
View file @ 252b3ef9
...@@ -18,73 +18,74 @@ module Gargantext.Core.Text.List.Social.Scores ...@@ -18,73 +18,74 @@ module Gargantext.Core.Text.List.Social.Scores
where where
import Control.Lens import Control.Lens
import Data.Map (Map) import Data.HashMap.Strict (HashMap)
import Data.Monoid (mempty) import Data.Monoid (mempty)
import Data.Set (Set) import Data.Set (Set)
import Data.Text (Text) import Data.Text (Text)
import Gargantext.API.Ngrams.Types import Gargantext.API.Ngrams.Types
import Gargantext.Core.Types.Main
import Gargantext.Core.Text.List.Social.Prelude import Gargantext.Core.Text.List.Social.Prelude
import Gargantext.Core.Types.Main
import Gargantext.Prelude import Gargantext.Prelude
import qualified Data.Map as Map import qualified Gargantext.Data.HashMap.Strict.Utils as HashMap
import qualified Data.HashMap.Strict as HashMap
import qualified Data.Set as Set import qualified Data.Set as Set
------------------------------------------------------------------------ ------------------------------------------------------------------------
-- | Generates Score from list of Map Text NgramsRepoElement -- | Generates Score from list of HashMap Text NgramsRepoElement
toFlowListScores :: KeepAllParents toFlowListScores :: KeepAllParents
-> FlowCont Text FlowListScores -> FlowCont NgramsTerm FlowListScores
-> [Map Text NgramsRepoElement] -> [HashMap NgramsTerm NgramsRepoElement]
-> FlowCont Text FlowListScores -> FlowCont NgramsTerm FlowListScores
toFlowListScores k flc_origin = foldl' (toFlowListScores_Level1 k flc_origin) mempty toFlowListScores k flc_origin = foldl' (toFlowListScores_Level1 k flc_origin) mempty
where where
toFlowListScores_Level1 :: KeepAllParents toFlowListScores_Level1 :: KeepAllParents
-> FlowCont Text FlowListScores -> FlowCont NgramsTerm FlowListScores
-> FlowCont Text FlowListScores -> FlowCont NgramsTerm FlowListScores
-> Map Text NgramsRepoElement -> HashMap NgramsTerm NgramsRepoElement
-> FlowCont Text FlowListScores -> FlowCont NgramsTerm FlowListScores
toFlowListScores_Level1 k' flc_origin' flc_dest ngramsRepo = toFlowListScores_Level1 k' flc_origin' flc_dest ngramsRepo =
Set.foldl' (toFlowListScores_Level2 k' ngramsRepo flc_origin') Set.foldl' (toFlowListScores_Level2 k' ngramsRepo flc_origin')
flc_dest flc_dest
(Set.fromList $ Map.keys $ view flc_cont flc_origin') (Set.fromList $ HashMap.keys $ view flc_cont flc_origin')
toFlowListScores_Level2 :: KeepAllParents toFlowListScores_Level2 :: KeepAllParents
-> Map Text NgramsRepoElement -> HashMap NgramsTerm NgramsRepoElement
-> FlowCont Text FlowListScores -> FlowCont NgramsTerm FlowListScores
-> FlowCont Text FlowListScores -> FlowCont NgramsTerm FlowListScores
-> Text -> NgramsTerm
-> FlowCont Text FlowListScores -> FlowCont NgramsTerm FlowListScores
toFlowListScores_Level2 k'' ngramsRepo flc_origin'' flc_dest' t = toFlowListScores_Level2 k'' ngramsRepo flc_origin'' flc_dest' t =
case Map.lookup t ngramsRepo of case HashMap.lookup t ngramsRepo of
Nothing -> over flc_cont (Map.union $ Map.singleton t mempty) flc_dest' Nothing -> over flc_cont (HashMap.union $ HashMap.singleton t mempty) flc_dest'
Just nre -> updateScoresParent k'' ngramsRepo nre flc_origin'' Just nre -> updateScoresParent k'' ngramsRepo nre flc_origin''
$ updateScores k'' t nre setText flc_dest' $ updateScores k'' t nre setText flc_dest'
where where
setText = Set.fromList setText = Set.fromList
$ Map.keys $ HashMap.keys
$ view flc_cont flc_origin'' $ view flc_cont flc_origin''
updateScoresParent :: KeepAllParents -> Map Text NgramsRepoElement -> NgramsRepoElement updateScoresParent :: KeepAllParents -> HashMap NgramsTerm NgramsRepoElement -> NgramsRepoElement
-> FlowCont Text FlowListScores -> FlowCont NgramsTerm FlowListScores
-> FlowCont Text FlowListScores -> FlowCont NgramsTerm FlowListScores
-> FlowCont Text FlowListScores -> FlowCont NgramsTerm FlowListScores
updateScoresParent keep@(KeepAllParents k''') ngramsRepo nre flc_origin'' flc_dest'' = case k''' of updateScoresParent keep@(KeepAllParents k''') ngramsRepo nre flc_origin'' flc_dest'' = case k''' of
False -> flc_dest'' False -> flc_dest''
True -> case view nre_parent nre of True -> case view nre_parent nre of
Nothing -> flc_dest'' Nothing -> flc_dest''
Just (NgramsTerm parent) -> toFlowListScores_Level2 keep ngramsRepo flc_origin'' flc_dest'' parent Just parent -> toFlowListScores_Level2 keep ngramsRepo flc_origin'' flc_dest'' parent
------------------------------------------------------------------------ ------------------------------------------------------------------------
updateScores :: KeepAllParents updateScores :: KeepAllParents
-> Text -> NgramsRepoElement -> Set Text -> NgramsTerm -> NgramsRepoElement -> Set NgramsTerm
-> FlowCont Text FlowListScores -> FlowCont NgramsTerm FlowListScores
-> FlowCont Text FlowListScores -> FlowCont NgramsTerm FlowListScores
updateScores k t nre setText mtf = updateScores k t nre setText mtf =
over flc_cont ( Map.delete t) over flc_cont ( HashMap.delete t)
$ over flc_scores ((Map.alter (addParent k nre setText ) t) $ over flc_scores ((HashMap.alter (addParent k nre setText ) t)
.(Map.alter (addList $ view nre_list nre) t) .(HashMap.alter (addList $ view nre_list nre) t)
) mtf ) mtf
------------------------------------------------------------------------ ------------------------------------------------------------------------
...@@ -103,8 +104,8 @@ addList l (Just fls) = ...@@ -103,8 +104,8 @@ addList l (Just fls) =
-- "the addList function looks like an ASCII bird" -- "the addList function looks like an ASCII bird"
-- | Concrete function to pass to PatchMap -- | Concrete function to pass to PatchMap
addListScore :: ListType -> Map ListType Int -> Map ListType Int addListScore :: ListType -> HashMap ListType Int -> HashMap ListType Int
addListScore l m = Map.alter (plus l) l m addListScore l m = HashMap.alter (plus l) l m
where where
plus CandidateTerm Nothing = Just 1 plus CandidateTerm Nothing = Just 1
plus CandidateTerm (Just x) = Just $ x + 1 plus CandidateTerm (Just x) = Just $ x + 1
...@@ -118,7 +119,7 @@ addListScore l m = Map.alter (plus l) l m ...@@ -118,7 +119,7 @@ addListScore l m = Map.alter (plus l) l m
------------------------------------------------------------------------ ------------------------------------------------------------------------
data KeepAllParents = KeepAllParents Bool data KeepAllParents = KeepAllParents Bool
addParent :: KeepAllParents -> NgramsRepoElement -> Set Text addParent :: KeepAllParents -> NgramsRepoElement -> Set NgramsTerm
-> Maybe FlowListScores -> Maybe FlowListScores
-> Maybe FlowListScores -> Maybe FlowListScores
...@@ -133,16 +134,16 @@ addParent k nre ss (Just fls{-(FlowListScores mapList mapParent)-}) = ...@@ -133,16 +134,16 @@ addParent k nre ss (Just fls{-(FlowListScores mapList mapParent)-}) =
addParentScore :: Num a addParentScore :: Num a
=> KeepAllParents => KeepAllParents
-> Maybe NgramsTerm -> Maybe NgramsTerm
-> Set Text -> Set NgramsTerm
-> Map Text a -> HashMap NgramsTerm a
-> Map Text a -> HashMap NgramsTerm a
addParentScore _ Nothing _ss mapParent = mapParent addParentScore _ Nothing _ss mapParent = mapParent
addParentScore (KeepAllParents keep) (Just (NgramsTerm p')) ss mapParent = addParentScore (KeepAllParents keep) (Just p') ss mapParent =
case keep of case keep of
True -> Map.alter addCount p' mapParent True -> HashMap.alter addCount p' mapParent
False -> case Set.member p' ss of False -> case Set.member p' ss of
False -> mapParent False -> mapParent
True -> Map.alter addCount p' mapParent True -> HashMap.alter addCount p' mapParent
where where
addCount Nothing = Just 1 addCount Nothing = Just 1
addCount (Just n) = Just $ n + 1 addCount (Just n) = Just $ n + 1
......
src/Gargantext/Core/Text/Metrics.hs
View file @ 252b3ef9
...@@ -20,24 +20,26 @@ module Gargantext.Core.Text.Metrics ...@@ -20,24 +20,26 @@ module Gargantext.Core.Text.Metrics
--import Math.KMeans (kmeans, euclidSq, elements) --import Math.KMeans (kmeans, euclidSq, elements)
import Control.Lens (makeLenses) import Control.Lens (makeLenses)
import Data.Map (Map) import Data.Map (Map)
import Data.Semigroup (Semigroup)
import Data.Monoid (Monoid, mempty) import Data.Monoid (Monoid, mempty)
import Gargantext.Prelude import Data.HashMap.Strict (HashMap)
import Data.Semigroup (Semigroup)
import Gargantext.Core.Methods.Distances.Accelerate.SpeGen import Gargantext.Core.Methods.Distances.Accelerate.SpeGen
import Gargantext.Core.Viz.Graph.Index
import Gargantext.Core.Statistics (pcaReduceTo, Dimension(..)) import Gargantext.Core.Statistics (pcaReduceTo, Dimension(..))
import Gargantext.Core.Viz.Graph.Index
import Gargantext.Prelude
import qualified Data.Array.Accelerate as DAA import qualified Data.Array.Accelerate as DAA
import qualified Data.Array.Accelerate.Interpreter as DAA import qualified Data.Array.Accelerate.Interpreter as DAA
import qualified Data.Map as Map import qualified Data.Map as Map
import qualified Data.Vector as V import qualified Data.Vector as V
import qualified Data.Vector.Storable as Vec import qualified Data.Vector.Storable as Vec
import qualified Data.HashMap.Strict as HashMap
type MapListSize = Int type MapListSize = Int
type InclusionSize = Int type InclusionSize = Int
scored :: Ord t => Map (t,t) Int -> V.Vector (Scored t) scored :: Ord t => HashMap (t,t) Int -> V.Vector (Scored t)
scored = map2scored . (pcaReduceTo (Dimension 2)) . scored2map scored = map2scored . (pcaReduceTo (Dimension 2)) . scored2map . Map.fromList . HashMap.toList
where where
scored2map :: Ord t => Map (t,t) Int -> Map t (Vec.Vector Double) scored2map :: Ord t => Map (t,t) Int -> Map t (Vec.Vector Double)
scored2map m = Map.fromList $ map (\(Scored t i s) -> (t, Vec.fromList [i,s])) $ scored' m scored2map m = Map.fromList $ map (\(Scored t i s) -> (t, Vec.fromList [i,s])) $ scored' m
......
src/Gargantext/Core/Text/Terms/Multi/PosTagging.hs
View file @ 252b3ef9
...@@ -107,8 +107,6 @@ $(deriveJSON (unPrefix "_") ''PosSentences) ...@@ -107,8 +107,6 @@ $(deriveJSON (unPrefix "_") ''PosSentences)
-- }, -- },
-- --
corenlp' :: ( FromJSON a corenlp' :: ( FromJSON a
, ConvertibleStrings p ByteString , ConvertibleStrings p ByteString
) )
......
src/Gargantext/Core/Types/Main.hs
View file @ 252b3ef9
...@@ -20,6 +20,7 @@ module Gargantext.Core.Types.Main where ...@@ -20,6 +20,7 @@ module Gargantext.Core.Types.Main where
import Data.Aeson (FromJSON, ToJSON) import Data.Aeson (FromJSON, ToJSON)
import Data.Aeson.TH (deriveJSON) import Data.Aeson.TH (deriveJSON)
import Data.Either (Either(..)) import Data.Either (Either(..))
import Data.Hashable (Hashable)
import Data.Map (fromList, lookup) import Data.Map (fromList, lookup)
import Data.Semigroup (Semigroup(..)) import Data.Semigroup (Semigroup(..))
import Data.Swagger import Data.Swagger
...@@ -59,6 +60,7 @@ instance ToSchema ListType ...@@ -59,6 +60,7 @@ instance ToSchema ListType
instance ToParamSchema ListType instance ToParamSchema ListType
instance Arbitrary ListType where instance Arbitrary ListType where
arbitrary = elements [minBound..maxBound] arbitrary = elements [minBound..maxBound]
instance Hashable ListType
instance Semigroup ListType instance Semigroup ListType
where where
......
src/Gargantext/Core/Viz/Chart.hs
View file @ 252b3ef9
...@@ -34,11 +34,14 @@ import Gargantext.Core.Text.Metrics.Count (occurrencesWith) ...@@ -34,11 +34,14 @@ import Gargantext.Core.Text.Metrics.Count (occurrencesWith)
-- Pie Chart -- Pie Chart
import Gargantext.API.Ngrams.NgramsTree import Gargantext.API.Ngrams.NgramsTree
import Gargantext.API.Ngrams.Tools import Gargantext.API.Ngrams.Tools
import Gargantext.API.Ngrams.Types
import Gargantext.Core.Types import Gargantext.Core.Types
import Gargantext.Database.Action.Flow import Gargantext.Database.Action.Flow
import Gargantext.Database.Action.Metrics.NgramsByNode import Gargantext.Database.Action.Metrics.NgramsByNode
import Gargantext.Database.Schema.Ngrams import Gargantext.Database.Schema.Ngrams
import Gargantext.Core.Viz.Types import Gargantext.Core.Viz.Types
import qualified Data.HashMap.Strict as HashMap
histoData :: CorpusId -> Cmd err Histo histoData :: CorpusId -> Cmd err Histo
histoData cId = do histoData cId = do
...@@ -60,20 +63,20 @@ chartData cId nt lt = do ...@@ -60,20 +63,20 @@ chartData cId nt lt = do
ts <- mapTermListRoot ls nt <$> getRepo ts <- mapTermListRoot ls nt <$> getRepo
let let
dico = filterListWithRoot lt ts dico = filterListWithRoot lt ts
terms = catMaybes $ List.concat $ map (\(a,b) -> [Just a, b]) $ Map.toList dico terms = catMaybes $ List.concat $ map (\(a,b) -> [Just a, b]) $ HashMap.toList dico
group dico' x = case Map.lookup x dico' of group dico' x = case HashMap.lookup x dico' of
Nothing -> x Nothing -> x
Just x' -> maybe x identity x' Just x' -> maybe x identity x'
(_total,mapTerms) <- countNodesByNgramsWith (group dico) (_total,mapTerms) <- countNodesByNgramsWith (group dico)
<$> getNodesByNgramsOnlyUser cId (ls' <> ls) nt terms <$> getNodesByNgramsOnlyUser cId (ls' <> ls) nt terms
let (dates, count) = V.unzip $ fmap (\(t,(d,_)) -> (t, d)) $ V.fromList $ Map.toList mapTerms let (dates, count) = V.unzip $ fmap (\(NgramsTerm t,(d,_)) -> (t, d)) $ V.fromList $ HashMap.toList mapTerms
pure (Histo (dates) (round <$> count)) pure (Histo dates (round <$> count))
treeData :: FlowCmdM env err m treeData :: FlowCmdM env err m
=> CorpusId -> NgramsType -> ListType => CorpusId -> NgramsType -> ListType
-> m [NgramsTree] -> m (V.Vector NgramsTree)
treeData cId nt lt = do treeData cId nt lt = do
ls' <- selectNodesWithUsername NodeList userMaster ls' <- selectNodesWithUsername NodeList userMaster
ls <- map (_node_id) <$> getListsWithParentId cId ls <- map (_node_id) <$> getListsWithParentId cId
...@@ -81,10 +84,10 @@ treeData cId nt lt = do ...@@ -81,10 +84,10 @@ treeData cId nt lt = do
let let
dico = filterListWithRoot lt ts dico = filterListWithRoot lt ts
terms = catMaybes $ List.concat $ map (\(a,b) -> [Just a, b]) $ Map.toList dico terms = catMaybes $ List.concat $ map (\(a,b) -> [Just a, b]) $ HashMap.toList dico
cs' <- getNodesByNgramsOnlyUser cId (ls' <> ls) nt terms cs' <- getNodesByNgramsOnlyUser cId (ls' <> ls) nt terms
m <- getListNgrams ls nt m <- getListNgrams ls nt
pure $ toTree lt cs' m pure $ V.fromList $ toTree lt cs' m
src/Gargantext/Core/Viz/Graph/API.hs
View file @ 252b3ef9
...@@ -18,38 +18,37 @@ module Gargantext.Core.Viz.Graph.API ...@@ -18,38 +18,37 @@ module Gargantext.Core.Viz.Graph.API
import Control.Lens (set, (^.), _Just, (^?)) import Control.Lens (set, (^.), _Just, (^?))
import Data.Aeson import Data.Aeson
import qualified Data.Map as Map
import Data.Swagger import Data.Swagger
import Data.Text import Data.Text
import Debug.Trace (trace) import Debug.Trace (trace)
import GHC.Generics (Generic) import GHC.Generics (Generic)
import Servant
import Servant.Job.Async
import Servant.XML
import Gargantext.API.Admin.Orchestrator.Types import Gargantext.API.Admin.Orchestrator.Types
import Gargantext.API.Ngrams.Types (NgramsRepo, r_version)
import Gargantext.API.Ngrams.Tools import Gargantext.API.Ngrams.Tools
import Gargantext.API.Ngrams.Types (NgramsRepo, r_version)
import Gargantext.API.Prelude import Gargantext.API.Prelude
import Gargantext.Core.Methods.Distances (Distance(..), GraphMetric(..))
import Gargantext.Core.Types.Main import Gargantext.Core.Types.Main
import Gargantext.Core.Viz.Graph
import Gargantext.Core.Viz.Graph.GEXF ()
import Gargantext.Core.Viz.Graph.Tools -- (cooc2graph)
import Gargantext.Database.Action.Metrics.NgramsByNode (getNodesByNgramsOnlyUser) import Gargantext.Database.Action.Metrics.NgramsByNode (getNodesByNgramsOnlyUser)
import Gargantext.Database.Action.Node (mkNodeWithParent) import Gargantext.Database.Action.Node (mkNodeWithParent)
import Gargantext.Database.Admin.Config import Gargantext.Database.Admin.Config
import Gargantext.Database.Admin.Types.Node import Gargantext.Database.Admin.Types.Node
import Gargantext.Database.Prelude (Cmd) import Gargantext.Database.Prelude (Cmd)
import Gargantext.Database.Query.Table.Node import Gargantext.Database.Query.Table.Node
import Gargantext.Database.Query.Table.Node.User (getNodeUser)
import Gargantext.Database.Query.Table.Node.Error (HasNodeError) import Gargantext.Database.Query.Table.Node.Error (HasNodeError)
import Gargantext.Database.Query.Table.Node.Select import Gargantext.Database.Query.Table.Node.Select
import Gargantext.Database.Query.Table.Node.UpdateOpaleye (updateHyperdata) import Gargantext.Database.Query.Table.Node.UpdateOpaleye (updateHyperdata)
import Gargantext.Database.Query.Table.Node.User (getNodeUser)
import Gargantext.Database.Schema.Ngrams import Gargantext.Database.Schema.Ngrams
import Gargantext.Database.Schema.Node (node_parentId, node_hyperdata, node_name, node_userId) import Gargantext.Database.Schema.Node (node_parentId, node_hyperdata, node_name, node_userId)
import Gargantext.Prelude import Gargantext.Prelude
import Gargantext.Core.Viz.Graph import Servant
import Gargantext.Core.Viz.Graph.GEXF () import Servant.Job.Async
import Gargantext.Core.Viz.Graph.Tools -- (cooc2graph) import Servant.XML
import Gargantext.Core.Methods.Distances (Distance(..), GraphMetric(..)) import qualified Data.HashMap.Strict as HashMap
import qualified Data.Map as Map
------------------------------------------------------------------------ ------------------------------------------------------------------------
-- | There is no Delete specific API for Graph since it can be deleted -- | There is no Delete specific API for Graph since it can be deleted
-- as simple Node. -- as simple Node.
...@@ -150,10 +149,10 @@ computeGraph cId d nt repo = do ...@@ -150,10 +149,10 @@ computeGraph cId d nt repo = do
let ngs = filterListWithRoot MapTerm $ mapTermListRoot [lId] nt repo let ngs = filterListWithRoot MapTerm $ mapTermListRoot [lId] nt repo
-- TODO split diagonal -- TODO split diagonal
myCooc <- HM.filter (>1) myCooc <- HashMap.filter (>1)
<$> getCoocByNgrams (Diagonal True) <$> getCoocByNgrams (Diagonal True)
<$> groupNodesByNgrams ngs <$> groupNodesByNgrams ngs
<$> getNodesByNgramsOnlyUser cId (lIds <> [lId]) nt (Map.keys ngs) <$> getNodesByNgramsOnlyUser cId (lIds <> [lId]) nt (HashMap.keys ngs)
graph <- liftBase $ cooc2graph d 0 myCooc graph <- liftBase $ cooc2graph d 0 myCooc
......
src/Gargantext/Core/Viz/Graph/Tools.hs
View file @ 252b3ef9
...@@ -13,28 +13,31 @@ Portability : POSIX ...@@ -13,28 +13,31 @@ Portability : POSIX
module Gargantext.Core.Viz.Graph.Tools module Gargantext.Core.Viz.Graph.Tools
where where
import Debug.Trace (trace)
import Data.Graph.Clustering.Louvain.Utils (LouvainNode(..))
-- import Data.Graph.Clustering.Louvain (hLouvain, {-iLouvainMap-}) -- import Data.Graph.Clustering.Louvain (hLouvain, {-iLouvainMap-})
import Data.Graph.Clustering.Louvain.CplusPlus (cLouvain) import Data.Graph.Clustering.Louvain.CplusPlus (cLouvain)
import Data.Graph.Clustering.Louvain.Utils (LouvainNode(..))
import Data.Map (Map) import Data.Map (Map)
import qualified Data.Set as Set import Data.HashMap.Strict (HashMap)
import Data.Text (Text) import Data.Text (Text)
import Gargantext.Prelude import Debug.Trace (trace)
import GHC.Float (sin, cos)
import Gargantext.API.Ngrams.Types (NgramsTerm(..))
import Gargantext.Core.Methods.Distances (Distance(..), measure)
import Gargantext.Core.Methods.Graph.BAC.Proxemy (confluence)
import Gargantext.Core.Statistics import Gargantext.Core.Statistics
import Gargantext.Core.Viz.Graph import Gargantext.Core.Viz.Graph
import Gargantext.Core.Viz.Graph.Bridgeness (bridgeness) import Gargantext.Core.Viz.Graph.Bridgeness (bridgeness)
import Gargantext.Core.Methods.Distances (Distance(..), measure)
import Gargantext.Core.Viz.Graph.Index (createIndices, toIndex, map2mat, mat2map, Index)
import Gargantext.Core.Viz.Graph.IGraph (mkGraphUfromEdges) import Gargantext.Core.Viz.Graph.IGraph (mkGraphUfromEdges)
import Gargantext.Core.Methods.Graph.BAC.Proxemy (confluence) import Gargantext.Core.Viz.Graph.Index (createIndices, toIndex, map2mat, mat2map, Index)
import GHC.Float (sin, cos) import Gargantext.Prelude
import qualified IGraph as Igraph
import IGraph.Random -- (Gen(..)) import IGraph.Random -- (Gen(..))
import qualified Data.List as List
import qualified Data.Map as Map
import qualified Data.Set as Set
import qualified Data.Vector.Storable as Vec
import qualified IGraph as Igraph
import qualified IGraph.Algorithms.Layout as Layout import qualified IGraph.Algorithms.Layout as Layout
import qualified Data.Vector.Storable as Vec import qualified Data.HashMap.Strict as HashMap
import qualified Data.Map as Map
import qualified Data.List as List
type Threshold = Double type Threshold = Double
...@@ -54,13 +57,15 @@ cooc2graph' distance threshold myCooc = distanceMap ...@@ -54,13 +57,15 @@ cooc2graph' distance threshold myCooc = distanceMap
cooc2graph :: Distance cooc2graph :: Distance
-> Threshold -> Threshold
-> (Map (Text, Text) Int) -> HashMap (NgramsTerm, NgramsTerm) Int
-> IO Graph -> IO Graph
cooc2graph distance threshold myCooc = do cooc2graph distance threshold myCooc = do
printDebug "cooc2graph" distance printDebug "cooc2graph" distance
let let
(ti, _) = createIndices myCooc -- TODO remove below
myCooc' = toIndex ti myCooc theMatrix = Map.fromList $ HashMap.toList myCooc
(ti, _) = createIndices theMatrix
myCooc' = toIndex ti theMatrix
matCooc = map2mat 0 (Map.size ti) matCooc = map2mat 0 (Map.size ti)
$ Map.filterWithKey (\(a,b) _ -> a /= b) $ Map.filterWithKey (\(a,b) _ -> a /= b)
$ Map.filter (> 1) myCooc' $ Map.filter (> 1) myCooc'
...@@ -87,7 +92,7 @@ cooc2graph distance threshold myCooc = do ...@@ -87,7 +92,7 @@ cooc2graph distance threshold myCooc = do
$ bridgeness rivers partitions distanceMap $ bridgeness rivers partitions distanceMap
confluence' = confluence (Map.keys bridgeness') 3 True False confluence' = confluence (Map.keys bridgeness') 3 True False
pure $ data2graph (Map.toList ti) myCooc' bridgeness' confluence' partitions pure $ data2graph (Map.toList $ Map.mapKeys unNgramsTerm ti) myCooc' bridgeness' confluence' partitions
......
src/Gargantext/Core/Viz/Phylo/Main.hs
View file @ 252b3ef9
...@@ -14,34 +14,32 @@ Portability : POSIX ...@@ -14,34 +14,32 @@ Portability : POSIX
module Gargantext.Core.Viz.Phylo.Main module Gargantext.Core.Viz.Phylo.Main
where where
import Data.GraphViz import Data.GraphViz
import qualified Data.ByteString as DB
import qualified Data.List as List
import qualified Data.Map as Map
import Data.Maybe import Data.Maybe
import qualified Data.Text as Text
import Data.Text (Text) import Data.Text (Text)
import Debug.Trace (trace) import Debug.Trace (trace)
import GHC.IO (FilePath) import GHC.IO (FilePath)
import Gargantext.API.Ngrams.Tools (getTermsWith) import Gargantext.API.Ngrams.Tools (getTermsWith)
import Gargantext.Core.Types import Gargantext.API.Ngrams.Types
import Gargantext.Database.Action.Flow
import Gargantext.Database.Admin.Types.Hyperdata
import Gargantext.Database.Query.Table.Node(defaultList)
import Gargantext.Database.Query.Table.NodeNode (selectDocs)
import Gargantext.Database.Schema.Ngrams (NgramsType(..))
import Gargantext.Prelude
import Gargantext.Core.Text.Context (TermList) import Gargantext.Core.Text.Context (TermList)
import Gargantext.Core.Text.Terms.WithList import Gargantext.Core.Text.Terms.WithList
import Gargantext.Core.Types
import Gargantext.Core.Viz.Phylo hiding (Svg, Dot) import Gargantext.Core.Viz.Phylo hiding (Svg, Dot)
import Gargantext.Core.Viz.Phylo.LevelMaker (toPhylo) import Gargantext.Core.Viz.Phylo.LevelMaker (toPhylo)
import Gargantext.Core.Viz.Phylo.Tools import Gargantext.Core.Viz.Phylo.Tools
import Gargantext.Core.Viz.Phylo.View.Export import Gargantext.Core.Viz.Phylo.View.Export
import Gargantext.Core.Viz.Phylo.View.ViewMaker -- TODO Just Maker is fine import Gargantext.Core.Viz.Phylo.View.ViewMaker -- TODO Just Maker is fine
import Gargantext.Database.Action.Flow
import Gargantext.Database.Admin.Types.Hyperdata
import Gargantext.Database.Query.Table.Node(defaultList)
import Gargantext.Database.Query.Table.NodeNode (selectDocs)
import Gargantext.Database.Schema.Ngrams (NgramsType(..))
import Gargantext.Prelude
import qualified Data.ByteString as DB
import qualified Data.List as List
import qualified Data.Map as Map
import qualified Data.Text as Text
import qualified Data.HashMap.Strict as HashMap
type MinSizeBranch = Int type MinSizeBranch = Int
...@@ -51,7 +49,7 @@ flowPhylo :: FlowCmdM env err m ...@@ -51,7 +49,7 @@ flowPhylo :: FlowCmdM env err m
flowPhylo cId = do flowPhylo cId = do
list <- defaultList cId list <- defaultList cId
termList <- Map.toList <$> getTermsWith Text.words [list] NgramsTerms MapTerm termList <- HashMap.toList <$> getTermsWith (Text.words . unNgramsTerm) [list] NgramsTerms MapTerm
docs' <- catMaybes docs' <- catMaybes
<$> map (\h -> (,) <$> _hd_publication_year h <$> map (\h -> (,) <$> _hd_publication_year h
......
src/Gargantext/Data/HashMap/Strict/Utils.hs
View file @ 252b3ef9
...@@ -5,5 +5,21 @@ import Data.HashMap.Strict (HashMap) ...@@ -5,5 +5,21 @@ import Data.HashMap.Strict (HashMap)
import qualified Data.HashMap.Strict as HM import qualified Data.HashMap.Strict as HM
import Gargantext.Prelude import Gargantext.Prelude
unionsWith :: (Foldable f, Eq k, Hashable k) => (a->a->a) -> f (HashMap k a) -> HashMap k a unionsWith :: (Foldable f, Eq k, Hashable k) => (a->a->a) -> f (HashMap k a) -> HashMap k a
unionsWith f = foldl' (HM.unionWith f) HM.empty unionsWith f = foldl' (HM.unionWith f) HM.empty
partition :: Hashable k => (a -> Bool) -> HashMap k a -> (HashMap k a, HashMap k a)
partition = undefined
partitionWithKey :: Hashable k => (k -> a -> Bool) -> HashMap k a -> (HashMap k a, HashMap k a)
partitionWithKey = undefined
findMax :: Hashable k => HashMap k a -> (k, a)
findMax = undefined
-- getKeyWithMaxValue :: Hashable k => HashMap k a -> Maybe k
getKeyWithMaxValue :: Hashable k => HashMap k a -> [k]
getKeyWithMaxValue = undefined
src/Gargantext/Database/Action/Flow/Pairing.hs
View file @ 252b3ef9
...@@ -40,11 +40,11 @@ import Gargantext.Database.Schema.Ngrams -- (NgramsType(..)) ...@@ -40,11 +40,11 @@ import Gargantext.Database.Schema.Ngrams -- (NgramsType(..))
import Gargantext.Database.Schema.Node import Gargantext.Database.Schema.Node
import Gargantext.Prelude hiding (sum) import Gargantext.Prelude hiding (sum)
import Opaleye import Opaleye
import qualified Data.List as List import qualified Data.HashMap.Strict as HashMap
import qualified Data.Map as Map import qualified Data.List as List
import qualified Data.Set as Set import qualified Data.Map as Map
import qualified Data.Text as DT import qualified Data.Set as Set
import qualified Data.Text as DT
-- | isPairedWith -- | isPairedWith
-- All NodeAnnuaire paired with a Corpus of NodeId nId: -- All NodeAnnuaire paired with a Corpus of NodeId nId:
...@@ -184,4 +184,4 @@ getNgramsDocId cId lId nt = do ...@@ -184,4 +184,4 @@ getNgramsDocId cId lId nt = do
let ngs = filterListWithRoot MapTerm $ mapTermListRoot [lId] nt repo let ngs = filterListWithRoot MapTerm $ mapTermListRoot [lId] nt repo
groupNodesByNgrams ngs groupNodesByNgrams ngs
<$> getNodesByNgramsOnlyUser cId (lIds <> [lId]) nt (Map.keys ngs) <$> getNodesByNgramsOnlyUser cId (lIds <> [lId]) nt (HashMap.keys ngs)
src/Gargantext/Database/Action/Metrics.hs
View file @ 252b3ef9
...@@ -10,18 +10,16 @@ Portability : POSIX ...@@ -10,18 +10,16 @@ Portability : POSIX
Node API Node API
-} -}
module Gargantext.Database.Action.Metrics module Gargantext.Database.Action.Metrics
where where
import Data.HashMap.Strict (HashMap)
import Data.Map (Map) import Data.Map (Map)
import qualified Data.Map as Map
import Data.Text (Text) import Data.Text (Text)
import Data.Vector (Vector) import Data.Vector (Vector)
import Gargantext.API.Ngrams.Types (TabType(..), ngramsTypeFromTabType)
import Gargantext.API.Ngrams.Tools (filterListWithRoot, groupNodesByNgrams, Diagonal(..), getCoocByNgrams, mapTermListRoot, RootTerm, getRepo) import Gargantext.API.Ngrams.Tools (filterListWithRoot, groupNodesByNgrams, Diagonal(..), getCoocByNgrams, mapTermListRoot, RootTerm, getRepo)
import Gargantext.API.Ngrams.Types (TabType(..), ngramsTypeFromTabType, NgramsTerm)
import Gargantext.Core.Text.Metrics (scored, Scored(..), {-localMetrics, toScored-})
import Gargantext.Core.Types (ListType(..), Limit, NodeType(..)) import Gargantext.Core.Types (ListType(..), Limit, NodeType(..))
import Gargantext.Database.Action.Flow.Types (FlowCmdM) import Gargantext.Database.Action.Flow.Types (FlowCmdM)
import Gargantext.Database.Action.Metrics.NgramsByNode (getNodesByNgramsOnlyUser{-, getTficfWith-}) import Gargantext.Database.Action.Metrics.NgramsByNode (getNodesByNgramsOnlyUser{-, getTficfWith-})
...@@ -30,21 +28,23 @@ import Gargantext.Database.Admin.Types.Node (ListId, CorpusId) ...@@ -30,21 +28,23 @@ import Gargantext.Database.Admin.Types.Node (ListId, CorpusId)
import Gargantext.Database.Query.Table.Node (defaultList) import Gargantext.Database.Query.Table.Node (defaultList)
import Gargantext.Database.Query.Table.Node.Select import Gargantext.Database.Query.Table.Node.Select
import Gargantext.Prelude import Gargantext.Prelude
import Gargantext.Core.Text.Metrics (scored, Scored(..), {-localMetrics, toScored-}) import qualified Data.HashMap.Strict as HM
import qualified Data.Map as Map
getMetrics :: FlowCmdM env err m getMetrics :: FlowCmdM env err m
=> CorpusId -> Maybe ListId -> TabType -> Maybe Limit => CorpusId -> Maybe ListId -> TabType -> Maybe Limit
-> m (Map Text (ListType, Maybe Text), Vector (Scored Text)) -> m (HashMap NgramsTerm (ListType, Maybe NgramsTerm), Vector (Scored NgramsTerm))
getMetrics cId maybeListId tabType maybeLimit = do getMetrics cId maybeListId tabType maybeLimit = do
(ngs, _, myCooc) <- getNgramsCooc cId maybeListId tabType maybeLimit (ngs, _, myCooc) <- getNgramsCooc cId maybeListId tabType maybeLimit
-- TODO HashMap
pure (ngs, scored myCooc) pure (ngs, scored myCooc)
getNgramsCooc :: (FlowCmdM env err m) getNgramsCooc :: (FlowCmdM env err m)
=> CorpusId -> Maybe ListId -> TabType -> Maybe Limit => CorpusId -> Maybe ListId -> TabType -> Maybe Limit
-> m ( Map Text (ListType, Maybe Text) -> m ( HashMap NgramsTerm (ListType, Maybe NgramsTerm)
, Map Text (Maybe RootTerm) , HashMap NgramsTerm (Maybe RootTerm)
, HashMap (Text, Text) Int , HashMap (NgramsTerm, NgramsTerm) Int
) )
getNgramsCooc cId maybeListId tabType maybeLimit = do getNgramsCooc cId maybeListId tabType maybeLimit = do
(ngs', ngs) <- getNgrams cId maybeListId tabType (ngs', ngs) <- getNgrams cId maybeListId tabType
...@@ -59,14 +59,16 @@ getNgramsCooc cId maybeListId tabType maybeLimit = do ...@@ -59,14 +59,16 @@ getNgramsCooc cId maybeListId tabType maybeLimit = do
myCooc <- HM.filter (>1) <$> getCoocByNgrams (Diagonal True) myCooc <- HM.filter (>1) <$> getCoocByNgrams (Diagonal True)
<$> groupNodesByNgrams ngs <$> groupNodesByNgrams ngs
<$> getNodesByNgramsOnlyUser cId (lIds <> [lId]) (ngramsTypeFromTabType tabType) <$> getNodesByNgramsOnlyUser cId (lIds <> [lId]) (ngramsTypeFromTabType tabType)
(take' maybeLimit $ Map.keys ngs) (take' maybeLimit $ HM.keys ngs)
pure $ (ngs', ngs, myCooc) pure $ (ngs', ngs, myCooc)
getNgrams :: (FlowCmdM env err m) getNgrams :: (FlowCmdM env err m)
=> CorpusId -> Maybe ListId -> TabType => CorpusId -> Maybe ListId -> TabType
-> m (Map Text (ListType, Maybe Text), Map Text (Maybe RootTerm)) -> m ( HashMap NgramsTerm (ListType, Maybe NgramsTerm)
, HashMap NgramsTerm (Maybe RootTerm)
)
getNgrams cId maybeListId tabType = do getNgrams cId maybeListId tabType = do
lId <- case maybeListId of lId <- case maybeListId of
...@@ -74,7 +76,7 @@ getNgrams cId maybeListId tabType = do ...@@ -74,7 +76,7 @@ getNgrams cId maybeListId tabType = do
Just lId' -> pure lId' Just lId' -> pure lId'
lists <- mapTermListRoot [lId] (ngramsTypeFromTabType tabType) <$> getRepo lists <- mapTermListRoot [lId] (ngramsTypeFromTabType tabType) <$> getRepo
let maybeSyn = Map.unions $ map (\t -> filterListWithRoot t lists) let maybeSyn = HM.unions $ map (\t -> filterListWithRoot t lists)
[MapTerm, StopTerm, CandidateTerm] [MapTerm, StopTerm, CandidateTerm]
pure (lists, maybeSyn) pure (lists, maybeSyn)
src/Gargantext/Database/Action/Metrics/Lists.hs
View file @ 252b3ef9
...@@ -19,17 +19,16 @@ Portability : POSIX ...@@ -19,17 +19,16 @@ Portability : POSIX
module Gargantext.Database.Action.Metrics.Lists module Gargantext.Database.Action.Metrics.Lists
where where
import Gargantext.API.Ngrams.Types (TabType(..), NgramsTerm(..))
import Gargantext.Core.Text.Metrics (Scored(..))
import Gargantext.Core.Types -- (NodePoly(..), NodeCorpus, ListId)
import Gargantext.Database.Action.Flow.Types (FlowCmdM)
import Gargantext.Prelude hiding (sum, head)
import Prelude hiding (null, id, map, sum) import Prelude hiding (null, id, map, sum)
import qualified Data.Map as Map import qualified Data.Map as Map
import qualified Data.Vector as Vec import qualified Data.Vector as Vec
import qualified Gargantext.Database.Action.Metrics as Metrics import qualified Gargantext.Database.Action.Metrics as Metrics
import Gargantext.API.Ngrams.Types (TabType(..)) import qualified Data.HashMap.Strict as HashMap
import Gargantext.Core.Types -- (NodePoly(..), NodeCorpus, ListId)
import Gargantext.Database.Action.Flow.Types (FlowCmdM)
import Gargantext.Prelude hiding (sum, head)
import Gargantext.Core.Text.Metrics (Scored(..))
{- {-
trainModel :: FlowCmdM env ServantErr m trainModel :: FlowCmdM env ServantErr m
=> Username -> m Score => Username -> m Score
...@@ -50,7 +49,7 @@ getMetrics' cId maybeListId tabType maybeLimit = do ...@@ -50,7 +49,7 @@ getMetrics' cId maybeListId tabType maybeLimit = do
let let
metrics = map (\(Scored t s1 s2) -> (listType t ngs', [Vec.fromList [s1,s2]])) scores metrics = map (\(Scored t s1 s2) -> (listType t ngs', [Vec.fromList [s1,s2]])) scores
listType t m = maybe (panic errorMsg) fst $ Map.lookup t m listType t m = maybe (panic errorMsg) fst $ HashMap.lookup t m
errorMsg = "API.Node.metrics: key absent" errorMsg = "API.Node.metrics: key absent"
{- {-
......
src/Gargantext/Database/Action/Metrics/NgramsByNode.hs
View file @ 252b3ef9
...@@ -16,10 +16,9 @@ Ngrams by node enable contextual metrics. ...@@ -16,10 +16,9 @@ Ngrams by node enable contextual metrics.
module Gargantext.Database.Action.Metrics.NgramsByNode module Gargantext.Database.Action.Metrics.NgramsByNode
where where
import Data.HashMap.Strict (HashMap)
import qualified Data.HashMap.Strict as HM
--import Data.Map.Strict.Patch (PatchMap, Replace, diff) --import Data.Map.Strict.Patch (PatchMap, Replace, diff)
import Data.HashMap.Strict (HashMap)
import Data.Map (Map)
import Data.Set (Set) import Data.Set (Set)
import Data.Text (Text) import Data.Text (Text)
import Data.Tuple.Extra (first, second, swap) import Data.Tuple.Extra (first, second, swap)
...@@ -27,16 +26,17 @@ import Database.PostgreSQL.Simple.SqlQQ (sql) ...@@ -27,16 +26,17 @@ import Database.PostgreSQL.Simple.SqlQQ (sql)
import Database.PostgreSQL.Simple.Types (Values(..), QualifiedIdentifier(..)) import Database.PostgreSQL.Simple.Types (Values(..), QualifiedIdentifier(..))
import Debug.Trace (trace) import Debug.Trace (trace)
import Gargantext.API.Ngrams.Types (NgramsTerm(..)) import Gargantext.API.Ngrams.Types (NgramsTerm(..))
import Gargantext.Data.HashMap.Strict.Utils as HM
import Gargantext.Database.Admin.Config (nodeTypeId) import Gargantext.Database.Admin.Config (nodeTypeId)
import Gargantext.Database.Admin.Types.Node -- (ListId, CorpusId, NodeId) import Gargantext.Database.Admin.Types.Node -- (ListId, CorpusId, NodeId)
import Gargantext.Database.Prelude (Cmd, runPGSQuery) import Gargantext.Database.Prelude (Cmd, runPGSQuery)
import Gargantext.Database.Schema.Ngrams (ngramsTypeId, NgramsType(..)) import Gargantext.Database.Schema.Ngrams (ngramsTypeId, NgramsType(..))
import Gargantext.Data.HashMap.Strict.Utils as HM
import Gargantext.Prelude import Gargantext.Prelude
import qualified Data.HashMap.Strict as HM
import qualified Data.Map as Map
import qualified Data.Set as Set import qualified Data.Set as Set
import qualified Database.PostgreSQL.Simple as DPS import qualified Database.PostgreSQL.Simple as DPS
-- | fst is size of Supra Corpus -- | fst is size of Supra Corpus
-- snd is Texts and size of Occurrences (different docs) -- snd is Texts and size of Occurrences (different docs)
countNodesByNgramsWith :: (NgramsTerm -> NgramsTerm) countNodesByNgramsWith :: (NgramsTerm -> NgramsTerm)
...@@ -224,7 +224,7 @@ getNodesByNgramsOnlyUser :: CorpusId ...@@ -224,7 +224,7 @@ getNodesByNgramsOnlyUser :: CorpusId
-> [NgramsTerm] -> [NgramsTerm]
-> Cmd err (HashMap NgramsTerm (Set NodeId)) -> Cmd err (HashMap NgramsTerm (Set NodeId))
getNodesByNgramsOnlyUser cId ls nt ngs = getNodesByNgramsOnlyUser cId ls nt ngs =
unionsWith (<>) HM.unionsWith (<>)
. map (HM.fromListWith (<>) . map (HM.fromListWith (<>)
. map (second Set.singleton)) . map (second Set.singleton))
<$> mapM (selectNgramsOnlyByNodeUser cId ls nt) <$> mapM (selectNgramsOnlyByNodeUser cId ls nt)
...@@ -235,11 +235,12 @@ getNgramsByNodeOnlyUser :: NodeId ...@@ -235,11 +235,12 @@ getNgramsByNodeOnlyUser :: NodeId
-> [ListId] -> [ListId]
-> NgramsType -> NgramsType
-> [NgramsTerm] -> [NgramsTerm]
-> Cmd err (HashMap NodeId (Set NgramsTerm)) -> Cmd err (Map NodeId (Set NgramsTerm))
getNgramsByNodeOnlyUser cId ls nt ngs = getNgramsByNodeOnlyUser cId ls nt ngs =
unionsWith (<>) Map.unionsWith (<>)
. map (HM.fromListWith (<>) . map ( Map.fromListWith (<>)
. map (second Set.singleton)) . map (second Set.singleton)
)
. map (map swap) . map (map swap)
<$> mapM (selectNgramsOnlyByNodeUser cId ls nt) <$> mapM (selectNgramsOnlyByNodeUser cId ls nt)
(splitEvery 1000 ngs) (splitEvery 1000 ngs)
...@@ -319,7 +320,7 @@ getNgramsByDocOnlyUser :: DocId ...@@ -319,7 +320,7 @@ getNgramsByDocOnlyUser :: DocId
-> [NgramsTerm] -> [NgramsTerm]
-> Cmd err (HashMap NgramsTerm (Set NodeId)) -> Cmd err (HashMap NgramsTerm (Set NodeId))
getNgramsByDocOnlyUser cId ls nt ngs = getNgramsByDocOnlyUser cId ls nt ngs =
unionsWith (<>) HM.unionsWith (<>)
. map (HM.fromListWith (<>) . map (second Set.singleton)) . map (HM.fromListWith (<>) . map (second Set.singleton))
<$> mapM (selectNgramsOnlyByDocUser cId ls nt) (splitEvery 1000 ngs) <$> mapM (selectNgramsOnlyByDocUser cId ls nt) (splitEvery 1000 ngs)
......
src/Gargantext/Database/Action/Metrics/TFICF.hs
View file @ 252b3ef9
...@@ -19,7 +19,6 @@ module Gargantext.Database.Action.Metrics.TFICF ...@@ -19,7 +19,6 @@ module Gargantext.Database.Action.Metrics.TFICF
import Data.HashMap.Strict (HashMap) import Data.HashMap.Strict (HashMap)
import qualified Data.HashMap.Strict as HM import qualified Data.HashMap.Strict as HM
import Data.Maybe (fromMaybe) import Data.Maybe (fromMaybe)
import Data.Text (Text)
import Gargantext.Core.Text.Metrics.TFICF import Gargantext.Core.Text.Metrics.TFICF
import Gargantext.Database.Action.Metrics.NgramsByNode (getNodesByNgramsUser, getOccByNgramsOnlyFast) import Gargantext.Database.Action.Metrics.NgramsByNode (getNodesByNgramsUser, getOccByNgramsOnlyFast)
import Gargantext.Database.Admin.Types.Node -- (ListId, CorpusId, NodeId) import Gargantext.Database.Admin.Types.Node -- (ListId, CorpusId, NodeId)
...@@ -50,4 +49,4 @@ getTficf cId mId nt = do ...@@ -50,4 +49,4 @@ getTficf cId mId nt = do
(Total $ fromIntegral countLocal)) (Total $ fromIntegral countLocal))
(TficfSupra (Count $ fromMaybe 0 $ HM.lookup t mapTextDoubleGlobal) (TficfSupra (Count $ fromMaybe 0 $ HM.lookup t mapTextDoubleGlobal)
(Total $ fromIntegral countGlobal)) (Total $ fromIntegral countGlobal))
) mapTextDoubleLocal ) mapTextDoubleLocal
\ No newline at end of file
src/Gargantext/Database/Schema/Ngrams.hs
View file @ 252b3ef9
...@@ -19,6 +19,7 @@ Ngrams connection to the Database. ...@@ -19,6 +19,7 @@ Ngrams connection to the Database.
module Gargantext.Database.Schema.Ngrams module Gargantext.Database.Schema.Ngrams
where where
import Data.Hashable (Hashable)
import Codec.Serialise (Serialise()) import Codec.Serialise (Serialise())
import Control.Lens (over) import Control.Lens (over)
import Control.Monad (mzero) import Control.Monad (mzero)
...@@ -81,6 +82,7 @@ data NgramsType = Authors | Institutes | Sources | NgramsTerms ...@@ -81,6 +82,7 @@ data NgramsType = Authors | Institutes | Sources | NgramsTerms
deriving (Eq, Show, Read, Ord, Enum, Bounded, Generic) deriving (Eq, Show, Read, Ord, Enum, Bounded, Generic)
instance Serialise NgramsType instance Serialise NgramsType
instance Hashable NgramsType
ngramsTypes :: [NgramsType] ngramsTypes :: [NgramsType]
ngramsTypes = [minBound..] ngramsTypes = [minBound..]
...@@ -153,6 +155,7 @@ text2ngrams txt = UnsafeNgrams txt' $ length $ splitOn " " txt' ...@@ -153,6 +155,7 @@ text2ngrams txt = UnsafeNgrams txt' $ length $ splitOn " " txt'
where where
txt' = strip txt txt' = strip txt
------------------------------------------------------------------------- -------------------------------------------------------------------------
-- | TODO put it in Gargantext.Core.Text.Ngrams -- | TODO put it in Gargantext.Core.Text.Ngrams
-- Named entity are typed ngrams of Terms Ngrams -- Named entity are typed ngrams of Terms Ngrams
......
src/Gargantext/Prelude/Crypto/Hash.hs
View file @ 252b3ef9
...@@ -45,6 +45,7 @@ instance {-# OVERLAPPING #-} IsHashable String where ...@@ -45,6 +45,7 @@ instance {-# OVERLAPPING #-} IsHashable String where
instance IsHashable Text where instance IsHashable Text where
hash = hash . Text.unpack hash = hash . Text.unpack
instance IsHashable (Set Hash) where instance IsHashable (Set Hash) where
hash = hash . foldl (<>) "" . Set.toList hash = hash . foldl (<>) "" . Set.toList
......
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