Skip to content

H
haskell-gargantext
Commit 98e64947 authored by Nicolas Pouillard's avatar Nicolas Pouillard
Browse files
Options

Continue refactoring...

parent d37798c1
Expand all Show whitespace changes
Inline Side-by-side
Showing with 196 additions and 170 deletions
src/Gargantext/API/Ngrams/Tools.hs
View file @ 98e64947
...@@ -9,13 +9,18 @@ Portability : POSIX ...@@ -9,13 +9,18 @@ Portability : POSIX
-} -}
{-# LANGUAGE TypeFamilies #-}
module Gargantext.API.Ngrams.Tools module Gargantext.API.Ngrams.Tools
where where
import Control.Concurrent import Control.Concurrent
import Control.Lens (_Just, (^.), at, view) 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 qualified Data.HashMap.Strict as HM
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.Map.Strict as Map
import qualified Data.Set as Set import qualified Data.Set as Set
...@@ -31,7 +36,7 @@ import Gargantext.Prelude ...@@ -31,7 +36,7 @@ import Gargantext.Prelude
mergeNgramsElement :: NgramsRepoElement -> NgramsRepoElement -> NgramsRepoElement mergeNgramsElement :: NgramsRepoElement -> NgramsRepoElement -> NgramsRepoElement
mergeNgramsElement _neOld neNew = neNew mergeNgramsElement _neOld neNew = neNew
type RootTerm = Text type RootTerm = NgramsTerm
getRepo :: RepoCmdM env err m => m NgramsRepo getRepo :: RepoCmdM env err m => m NgramsRepo
getRepo = do getRepo = do
...@@ -39,8 +44,8 @@ getRepo = do ...@@ -39,8 +44,8 @@ getRepo = do
liftBase $ readMVar v liftBase $ readMVar v
listNgramsFromRepo :: [ListId] -> NgramsType listNgramsFromRepo :: [ListId] -> NgramsType
-> NgramsRepo -> Map Text NgramsRepoElement -> NgramsRepo -> Map NgramsTerm NgramsRepoElement
listNgramsFromRepo nodeIds ngramsType repo = Map.mapKeys unNgramsTerm ngrams listNgramsFromRepo nodeIds ngramsType repo = ngrams
where where
ngramsMap = repo ^. r_state . at ngramsType . _Just ngramsMap = repo ^. r_state . at ngramsType . _Just
...@@ -53,73 +58,88 @@ listNgramsFromRepo nodeIds ngramsType repo = Map.mapKeys unNgramsTerm ngrams ...@@ -53,73 +58,88 @@ listNgramsFromRepo nodeIds ngramsType repo = Map.mapKeys unNgramsTerm ngrams
-- be properly guarded. -- be properly guarded.
getListNgrams :: RepoCmdM env err m getListNgrams :: RepoCmdM env err m
=> [ListId] -> NgramsType => [ListId] -> NgramsType
-> m (Map Text NgramsRepoElement) -> m (Map NgramsTerm NgramsRepoElement)
getListNgrams nodeIds ngramsType = listNgramsFromRepo nodeIds ngramsType <$> getRepo getListNgrams nodeIds ngramsType = listNgramsFromRepo nodeIds ngramsType <$> getRepo
getTermsWith :: (RepoCmdM env err m, Ord a) getTermsWith :: (RepoCmdM env err m, Eq a, Hashable a)
=> (Text -> a ) -> [ListId] => (NgramsTerm -> a) -> [ListId]
-> NgramsType -> ListType -> NgramsType -> ListType
-> m (Map a [a]) -> m (HashMap a [a])
getTermsWith f ls ngt lt = Map.fromListWith (<>) getTermsWith f ls ngt lt = HM.fromListWith (<>)
<$> map (toTreeWith f) <$> map toTreeWith
<$> Map.toList <$> Map.toList
<$> Map.filter (\f' -> (fst f') == lt) <$> Map.filter (\f' -> fst f' == lt)
<$> mapTermListRoot ls ngt <$> mapTermListRoot ls ngt
<$> getRepo <$> getRepo
where where
toTreeWith f'' (t, (_lt, maybeRoot)) = case maybeRoot of toTreeWith (t, (_lt, maybeRoot)) = case maybeRoot of
Nothing -> (f'' t, []) Nothing -> (f t, [])
Just r -> (f'' r, map f'' [t]) Just r -> (f r, [f t])
mapTermListRoot :: [ListId] mapTermListRoot :: [ListId]
-> NgramsType -> NgramsType
-> NgramsRepo -> NgramsRepo
-> Map Text (ListType, (Maybe Text)) -> Map NgramsTerm (ListType, Maybe NgramsTerm)
mapTermListRoot nodeIds ngramsType repo = mapTermListRoot nodeIds ngramsType repo =
Map.fromList [ (t, (_nre_list nre, unNgramsTerm <$> _nre_root nre)) (\nre -> (_nre_list nre, _nre_root nre)) <$>
| (t, nre) <- Map.toList ngrams listNgramsFromRepo nodeIds ngramsType repo
]
where ngrams = listNgramsFromRepo nodeIds ngramsType repo filterListWithRootHashMap :: ListType
-> HashMap NgramsTerm (ListType, Maybe NgramsTerm)
-> HashMap NgramsTerm (Maybe RootTerm)
filterListWithRootHashMap lt m = snd <$> HM.filter isMapTerm m
where
isMapTerm (l, maybeRoot) = case maybeRoot of
Nothing -> l == lt
Just r -> case HM.lookup r m of
Nothing -> panic $ "Garg.API.Ngrams.Tools: filterWithRoot, unknown key: " <> unNgramsTerm r
Just (l',_) -> l' == lt
filterListWithRoot :: ListType filterListWithRoot :: ListType
-> Map Text (ListType, Maybe Text) -> Map NgramsTerm (ListType, Maybe NgramsTerm)
-> Map Text (Maybe RootTerm) -> Map NgramsTerm (Maybe RootTerm)
filterListWithRoot lt m = Map.fromList filterListWithRoot lt m = snd <$> Map.filter isMapTerm m
$ map (\(t,(_,r)) -> (t,r))
$ filter isMapTerm (Map.toList m)
where where
isMapTerm (_t,(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 Map.lookup r m of
Nothing -> panic $ "Garg.API.Ngrams.Tools: filterWithRoot, unknown key: " <> r Nothing -> panic $ "Garg.API.Ngrams.Tools: filterWithRoot, unknown key: " <> unNgramsTerm r
Just (l',_) -> l' == lt Just (l',_) -> l' == lt
groupNodesByNgrams :: Map Text (Maybe RootTerm) groupNodesByNgrams :: ( At root_map
-> Map Text (Set NodeId) , Index root_map ~ NgramsTerm
-> Map Text (Set NodeId) , IxValue root_map ~ Maybe RootTerm
groupNodesByNgrams syn occs = Map.fromListWith (<>) occs' )
=> root_map
-> HashMap NgramsTerm (Set NodeId)
-> HashMap NgramsTerm (Set NodeId)
groupNodesByNgrams syn occs = HM.fromListWith (<>) occs'
where where
occs' = map toSyn (Map.toList occs) occs' = map toSyn (HM.toList occs)
toSyn (t,ns) = case Map.lookup t syn of toSyn (t,ns) = case syn ^. at t of
Nothing -> panic $ "[Garg.API.Ngrams.Tools.groupNodesByNgrams] unknown key: " <> t Nothing -> panic $ "[Garg.API.Ngrams.Tools.groupNodesByNgrams] unknown key: " <> unNgramsTerm t
Just r -> case r of Just r -> case r of
Nothing -> (t, ns) Nothing -> (t, ns)
Just r' -> (r',ns) Just r' -> (r',ns)
data Diagonal = Diagonal Bool data Diagonal = Diagonal Bool
getCoocByNgrams :: Diagonal -> Map Text (Set NodeId) -> Map (Text, Text) Int getCoocByNgrams :: Diagonal -> HashMap Text (Set NodeId) -> HashMap (Text, Text) Int
getCoocByNgrams = getCoocByNgrams' identity getCoocByNgrams = getCoocByNgrams' identity
getCoocByNgrams' :: (Ord a, Ord c) => (b -> Set c) -> Diagonal -> Map a b -> Map (a, a) Int getCoocByNgrams' :: (Hashable a, Ord a, Ord c) => (b -> Set c) -> Diagonal -> HashMap a b -> HashMap (a, a) Int
getCoocByNgrams' f (Diagonal diag) m = getCoocByNgrams' f (Diagonal diag) m =
Map.fromList [( (t1,t2) HM.fromList [( (t1,t2)
, maybe 0 Set.size $ Set.intersection , maybe 0 Set.size $ Set.intersection
<$> (fmap f $ Map.lookup t1 m) <$> (fmap f $ HM.lookup t1 m)
<*> (fmap f $ Map.lookup t2 m) <*> (fmap f $ HM.lookup t2 m)
) | (t1,t2) <- case diag of )
True -> [ (x,y) | x <- Map.keys m, y <- Map.keys m, x <= y] | (t1,t2) <- if diag then
False -> listToCombi identity (Map.keys m) [ (x,y) | x <- ks, y <- ks, x <= y] -- TODO if we keep a Data.Map here it might be
-- more efficient to enumerate all the y <= x.
else
listToCombi identity ks
] ]
where ks = HM.keys m
\ No newline at end of file
src/Gargantext/API/Ngrams/Types.hs
View file @ 98e64947
...@@ -124,7 +124,7 @@ instance (ToJSONKey a, ToSchema a) => ToSchema (MSet a) where ...@@ -124,7 +124,7 @@ 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) deriving (Ord, Eq, Show, Generic, ToJSONKey, ToJSON, FromJSON, Semigroup, Arbitrary, Serialise, ToSchema, Hashable)
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 @ 98e64947
...@@ -17,6 +17,7 @@ module Gargantext.API.Node.Corpus.Export ...@@ -17,6 +17,7 @@ module Gargantext.API.Node.Corpus.Export
where where
import Data.HashMap.Strict (HashMap)
import Data.Map (Map) import Data.Map (Map)
import Data.Maybe (fromMaybe) import Data.Maybe (fromMaybe)
import Data.Set (Set) import Data.Set (Set)
...@@ -76,7 +77,7 @@ getNodeNgrams :: HasNodeError err ...@@ -76,7 +77,7 @@ getNodeNgrams :: HasNodeError err
-> Maybe ListId -> Maybe ListId
-> NgramsType -> NgramsType
-> NgramsRepo -> NgramsRepo
-> Cmd err (Map NodeId (Set Text)) -> Cmd err (HashMap NodeId (Set Text))
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
......
src/Gargantext/Core/Text/List.hs
View file @ 98e64947
...@@ -182,19 +182,19 @@ buildNgramsTermsList user uCid mCid groupParams (nt, _mapListSize)= do ...@@ -182,19 +182,19 @@ buildNgramsTermsList user uCid mCid groupParams (nt, _mapListSize)= do
selectedTerms selectedTerms
let let
groupedTreeScores_SetNodeId :: Map Text (GroupedTreeScores (Set NodeId)) groupedTreeScores_SetNodeId :: HashMap Text (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 = Map.filter (>2) let mapCooc = HM.filter (>2)
$ Map.fromList [ ((t1, t2), Set.size $ Set.intersection s1 s2) $ HM.fromList [ ((t1, t2), Set.size $ Set.intersection s1 s2)
| (t1, s1) <- mapStemNodeIds | (t1, s1) <- mapStemNodeIds
, (t2, s2) <- mapStemNodeIds , (t2, s2) <- mapStemNodeIds
] ]
where where
mapStemNodeIds = Map.toList mapStemNodeIds = HM.toList
$ Map.map viewScores $ HM.map viewScores
$ groupedTreeScores_SetNodeId $ groupedTreeScores_SetNodeId
let let
-- computing scores -- computing scores
......
src/Gargantext/Core/Viz/Graph/API.hs
View file @ 98e64947
...@@ -150,7 +150,7 @@ computeGraph cId d nt repo = do ...@@ -150,7 +150,7 @@ 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 <- Map.filter (>1) myCooc <- HM.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 (Map.keys ngs)
......
src/Gargantext/Database/Action/Flow/Pairing.hs
View file @ 98e64947
...@@ -17,13 +17,14 @@ module Gargantext.Database.Action.Flow.Pairing ...@@ -17,13 +17,14 @@ module Gargantext.Database.Action.Flow.Pairing
where where
import Control.Lens (_Just, (^.)) import Control.Lens (_Just, (^.))
import Data.Map (Map, fromList, fromListWith) import Data.HashMap.Strict (HashMap)
import qualified Data.HashMap.Strict as HM
import Data.Maybe (catMaybes, fromMaybe) import Data.Maybe (catMaybes, fromMaybe)
import Data.Set (Set) import Data.Set (Set)
import Data.Text (Text)
import Gargantext.API.Ngrams.Tools import Gargantext.API.Ngrams.Tools
import Gargantext.API.Ngrams.Types (NgramsTerm(..))
import Gargantext.API.Prelude (GargNoServer) import Gargantext.API.Prelude (GargNoServer)
import Gargantext.Core.Types (TableResult(..), Term) import Gargantext.Core.Types (TableResult(..))
import Gargantext.Core.Types.Main import Gargantext.Core.Types.Main
import Gargantext.Database import Gargantext.Database
import Gargantext.Database.Action.Metrics.NgramsByNode (getNodesByNgramsOnlyUser) import Gargantext.Database.Action.Metrics.NgramsByNode (getNodesByNgramsOnlyUser)
...@@ -79,7 +80,7 @@ dataPairing :: AnnuaireId ...@@ -79,7 +80,7 @@ dataPairing :: AnnuaireId
-> (CorpusId, ListId, NgramsType) -> (CorpusId, ListId, NgramsType)
-> (ContactName -> Projected) -> (ContactName -> Projected)
-> (DocAuthor -> Projected) -> (DocAuthor -> Projected)
-> GargNoServer (Map ContactId (Set DocId)) -> GargNoServer (HashMap ContactId (Set DocId))
dataPairing aId (cId, lId, ngt) fc fa = do dataPairing aId (cId, lId, ngt) fc fa = do
mc <- getNgramsContactId aId mc <- getNgramsContactId aId
md <- getNgramsDocId cId lId ngt md <- getNgramsDocId cId lId ngt
...@@ -87,14 +88,14 @@ dataPairing aId (cId, lId, ngt) fc fa = do ...@@ -87,14 +88,14 @@ dataPairing aId (cId, lId, ngt) fc fa = do
printDebug "ngramsContactId" mc printDebug "ngramsContactId" mc
printDebug "ngramsDocId" md printDebug "ngramsDocId" md
let let
from = projectionFrom (Set.fromList $ Map.keys mc) fc from = projectionFrom (Set.fromList $ HM.keys mc) fc
to = projectionTo (Set.fromList $ Map.keys md) fa to = projectionTo (Set.fromList $ HM.keys md) fa
pure $ fusion mc $ align from to md pure $ fusion mc $ align from to md
prepareInsert :: Map ContactId (Set DocId) -> [NodeNode] prepareInsert :: HashMap ContactId (Set DocId) -> [NodeNode]
prepareInsert m = map (\(n1,n2) -> NodeNode n1 n2 Nothing Nothing) prepareInsert m = map (\(n1,n2) -> NodeNode n1 n2 Nothing Nothing)
$ List.concat $ List.concat
$ map (\(contactId, setDocIds) $ map (\(contactId, setDocIds)
...@@ -102,21 +103,21 @@ prepareInsert m = map (\(n1,n2) -> NodeNode n1 n2 Nothing Nothing) ...@@ -102,21 +103,21 @@ prepareInsert m = map (\(n1,n2) -> NodeNode n1 n2 Nothing Nothing)
-> (contactId, setDocId) -> (contactId, setDocId)
) $ Set.toList setDocIds ) $ Set.toList setDocIds
) )
$ Map.toList m $ HM.toList m
------------------------------------------------------------------------ ------------------------------------------------------------------------
type ContactName = Text type ContactName = NgramsTerm
type DocAuthor = Text type DocAuthor = NgramsTerm
type Projected = Text type Projected = NgramsTerm
projectionFrom :: Set ContactName -> (ContactName -> Projected) -> Map ContactName Projected projectionFrom :: Set ContactName -> (ContactName -> Projected) -> HashMap ContactName Projected
projectionFrom ss f = fromList $ map (\s -> (s, f s)) (Set.toList ss) projectionFrom ss f = HM.fromList $ map (\s -> (s, f s)) (Set.toList ss) -- use HS.toMap
projectionTo :: Set DocAuthor -> (DocAuthor -> Projected) -> Map Projected (Set DocAuthor) projectionTo :: Set DocAuthor -> (DocAuthor -> Projected) -> HashMap Projected (Set DocAuthor)
projectionTo ss f = fromListWith (<>) $ map (\s -> (f s, Set.singleton s)) (Set.toList ss) projectionTo ss f = HM.fromListWith (<>) $ map (\s -> (f s, Set.singleton s)) (Set.toList ss) -- use HS.toMap
------------------------------------------------------------------------ ------------------------------------------------------------------------
takeName :: Term -> Term takeName :: NgramsTerm -> NgramsTerm
takeName texte = DT.toLower texte' takeName (NgramsTerm texte) = NgramsTerm $ DT.toLower texte'
where where
texte' = maybe texte (\x -> if DT.length x > 3 then x else texte) texte' = maybe texte (\x -> if DT.length x > 3 then x else texte)
(lastName' texte) (lastName' texte)
...@@ -124,51 +125,51 @@ takeName texte = DT.toLower texte' ...@@ -124,51 +125,51 @@ takeName texte = DT.toLower texte'
------------------------------------------------------------------------ ------------------------------------------------------------------------
align :: Map ContactName Projected align :: HashMap ContactName Projected
-> Map Projected (Set DocAuthor) -> HashMap Projected (Set DocAuthor)
-> Map DocAuthor (Set DocId) -> HashMap DocAuthor (Set DocId)
-> Map ContactName (Set DocId) -> HashMap ContactName (Set DocId)
align mc ma md = fromListWith (<>) align mc ma md = HM.fromListWith (<>)
$ map (\c -> (c, getProjection md $ testProjection c mc ma)) $ map (\c -> (c, getProjection md $ testProjection c mc ma))
$ Map.keys mc $ HM.keys mc
where where
getProjection :: Map DocAuthor (Set DocId) -> Set DocAuthor -> Set DocId getProjection :: HashMap DocAuthor (Set DocId) -> Set DocAuthor -> Set DocId
getProjection ma' sa' = getProjection ma' sa' =
if Set.null sa' if Set.null sa'
then Set.empty then Set.empty
else Set.unions $ sets ma' sa' else Set.unions $ sets ma' sa'
where where
sets ma'' sa'' = Set.map (\s -> lookup s ma'') sa'' sets ma'' sa'' = Set.map (\s -> lookup s ma'') sa''
lookup s' ma''= fromMaybe Set.empty (Map.lookup s' ma'') lookup s' ma''= fromMaybe Set.empty (HM.lookup s' ma'')
testProjection :: ContactName testProjection :: ContactName
-> Map ContactName Projected -> HashMap ContactName Projected
-> Map Projected (Set DocAuthor) -> HashMap Projected (Set DocAuthor)
-> Set DocAuthor -> Set DocAuthor
testProjection cn' mc' ma' = case Map.lookup cn' mc' of testProjection cn' mc' ma' = case HM.lookup cn' mc' of
Nothing -> Set.empty Nothing -> Set.empty
Just c -> case Map.lookup c ma' of Just c -> case HM.lookup c ma' of
Nothing -> Set.empty Nothing -> Set.empty
Just a -> a Just a -> a
fusion :: Map ContactName (Set ContactId) fusion :: HashMap ContactName (Set ContactId)
-> Map ContactName (Set DocId) -> HashMap ContactName (Set DocId)
-> Map ContactId (Set DocId) -> HashMap ContactId (Set DocId)
fusion mc md = Map.fromListWith (<>) fusion mc md = HM.fromListWith (<>)
$ catMaybes $ catMaybes
$ [ (,) <$> Just cId <*> Map.lookup cn md $ [ (,) <$> Just cId <*> HM.lookup cn md
| (cn, setContactId) <- Map.toList mc | (cn, setContactId) <- HM.toList mc
, cId <- Set.toList setContactId , cId <- Set.toList setContactId
] ]
------------------------------------------------------------------------ ------------------------------------------------------------------------
getNgramsContactId :: AnnuaireId getNgramsContactId :: AnnuaireId
-> Cmd err (Map ContactName (Set NodeId)) -> Cmd err (HashMap ContactName (Set NodeId))
getNgramsContactId aId = do getNgramsContactId aId = do
contacts <- getAllContacts aId contacts <- getAllContacts aId
pure $ fromListWith (<>) pure $ HM.fromListWith (<>)
$ catMaybes $ catMaybes
$ map (\contact -> (,) <$> contact^.(node_hyperdata . hc_who . _Just . cw_lastName) $ map (\contact -> (,) <$> (NgramsTerm <$> contact^.(node_hyperdata . hc_who . _Just . cw_lastName))
<*> Just ( Set.singleton (contact^.node_id)) <*> Just ( Set.singleton (contact^.node_id))
) (tr_docs contacts) ) (tr_docs contacts)
...@@ -176,7 +177,7 @@ getNgramsContactId aId = do ...@@ -176,7 +177,7 @@ getNgramsContactId aId = do
getNgramsDocId :: CorpusId getNgramsDocId :: CorpusId
-> ListId -> ListId
-> NgramsType -> NgramsType
-> GargNoServer (Map DocAuthor (Set NodeId)) -> GargNoServer (HashMap DocAuthor (Set NodeId))
getNgramsDocId cId lId nt = do getNgramsDocId cId lId nt = do
repo <- getRepo repo <- getRepo
lIds <- selectNodesWithUsername NodeList userMaster lIds <- selectNodesWithUsername NodeList userMaster
......
src/Gargantext/Database/Action/Metrics.hs
View file @ 98e64947
...@@ -44,7 +44,7 @@ getNgramsCooc :: (FlowCmdM env err m) ...@@ -44,7 +44,7 @@ getNgramsCooc :: (FlowCmdM env err m)
=> CorpusId -> Maybe ListId -> TabType -> Maybe Limit => CorpusId -> Maybe ListId -> TabType -> Maybe Limit
-> m ( Map Text (ListType, Maybe Text) -> m ( Map Text (ListType, Maybe Text)
, Map Text (Maybe RootTerm) , Map Text (Maybe RootTerm)
, Map (Text, Text) Int , HashMap (Text, Text) 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
...@@ -56,7 +56,7 @@ getNgramsCooc cId maybeListId tabType maybeLimit = do ...@@ -56,7 +56,7 @@ getNgramsCooc cId maybeListId tabType maybeLimit = do
lId <- defaultList cId lId <- defaultList cId
lIds <- selectNodesWithUsername NodeList userMaster lIds <- selectNodesWithUsername NodeList userMaster
myCooc <- Map.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 $ Map.keys ngs)
......
src/Gargantext/Database/Action/Metrics/TFICF.hs
View file @ 98e64947
...@@ -16,7 +16,8 @@ module Gargantext.Database.Action.Metrics.TFICF ...@@ -16,7 +16,8 @@ module Gargantext.Database.Action.Metrics.TFICF
-- import Debug.Trace (trace) -- import Debug.Trace (trace)
-- import Gargantext.Core (Lang(..)) -- import Gargantext.Core (Lang(..))
import Data.Map.Strict (Map, toList, fromList) import Data.HashMap.Strict (HashMap)
import qualified Data.HashMap.Strict as HM
import Data.Maybe (fromMaybe) import Data.Maybe (fromMaybe)
import Data.Text (Text) import Data.Text (Text)
import Gargantext.Core.Text.Metrics.TFICF import Gargantext.Core.Text.Metrics.TFICF
...@@ -25,31 +26,28 @@ import Gargantext.Database.Admin.Types.Node -- (ListId, CorpusId, NodeId) ...@@ -25,31 +26,28 @@ import Gargantext.Database.Admin.Types.Node -- (ListId, CorpusId, NodeId)
import Gargantext.Database.Prelude (Cmd) import Gargantext.Database.Prelude (Cmd)
import Gargantext.Database.Query.Table.NodeNode (selectCountDocs) import Gargantext.Database.Query.Table.NodeNode (selectCountDocs)
import Gargantext.Database.Schema.Ngrams (NgramsType(..)) import Gargantext.Database.Schema.Ngrams (NgramsType(..))
import Gargantext.API.Ngrams.Types
import Gargantext.Prelude import Gargantext.Prelude
import qualified Data.Map.Strict as Map
import qualified Data.Set as Set import qualified Data.Set as Set
getTficf :: UserCorpusId getTficf :: UserCorpusId
-> MasterCorpusId -> MasterCorpusId
-> NgramsType -> NgramsType
-> Cmd err (Map Text Double) -> Cmd err (HashMap NgramsTerm Double)
getTficf cId mId nt = do getTficf cId mId nt = do
mapTextDoubleLocal <- Map.filter (> 1) mapTextDoubleLocal <- HM.filter (> 1)
<$> Map.map (fromIntegral . Set.size) <$> HM.map (fromIntegral . Set.size)
<$> getNodesByNgramsUser cId nt <$> getNodesByNgramsUser cId nt
mapTextDoubleGlobal <- Map.map fromIntegral mapTextDoubleGlobal <- HM.map fromIntegral
<$> getOccByNgramsOnlyFast mId nt (Map.keys mapTextDoubleLocal) <$> getOccByNgramsOnlyFast mId nt (HM.keys mapTextDoubleLocal)
countLocal <- selectCountDocs cId countLocal <- selectCountDocs cId
countGlobal <- selectCountDocs mId countGlobal <- selectCountDocs mId
pure $ fromList [ ( t pure $ HM.mapWithKey (\t n ->
, tficf (TficfInfra (Count n ) tficf (TficfInfra (Count n )
(Total $ fromIntegral countLocal )) (Total $ fromIntegral countLocal))
(TficfSupra (Count $ fromMaybe 0 $ Map.lookup t mapTextDoubleGlobal) (TficfSupra (Count $ fromMaybe 0 $ HM.lookup t mapTextDoubleGlobal)
(Total $ fromIntegral countGlobal)) (Total $ fromIntegral countGlobal))
) ) mapTextDoubleLocal
| (t, n) <- toList mapTextDoubleLocal \ No newline at end of file
]
src/Gargantext/Database/Admin/Types/Node.hs
View file @ 98e64947
...@@ -24,6 +24,7 @@ import Control.Monad (mzero) ...@@ -24,6 +24,7 @@ import Control.Monad (mzero)
import Data.Aeson import Data.Aeson
import Data.Aeson.TH (deriveJSON) import Data.Aeson.TH (deriveJSON)
import Data.Either import Data.Either
import Data.Hashable (Hashable)
import Data.Swagger import Data.Swagger
import Data.Text (Text, unpack) import Data.Text (Text, unpack)
import Data.Time (UTCTime) import Data.Time (UTCTime)
...@@ -130,7 +131,7 @@ pgNodeId = O.pgInt4 . id2int ...@@ -130,7 +131,7 @@ pgNodeId = O.pgInt4 . id2int
------------------------------------------------------------------------ ------------------------------------------------------------------------
newtype NodeId = NodeId Int newtype NodeId = NodeId Int
deriving (Show, Read, Generic, Num, Eq, Ord, Enum, ToJSONKey, FromJSONKey, ToJSON, FromJSON) deriving (Show, Read, Generic, Num, Eq, Ord, Enum, ToJSONKey, FromJSONKey, ToJSON, FromJSON, Hashable)
unNodeId :: NodeId -> Int unNodeId :: NodeId -> Int
unNodeId (NodeId n) = n unNodeId (NodeId n) = n
......
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