Skip to content

haskell-gargantext
haskell-gargantext
Commit c3a9237b authored by Alexandre Delanoë's avatar Alexandre Delanoë
Browse files
Options

[REFACT] SocialLists: merging scores

parent 6160cc34
Hide whitespace changes
Inline Side-by-side
Showing with 150 additions and 95 deletions
src/Gargantext/Core/Text/List/Social.hs
View file @ c3a9237b
......@@ -11,30 +11,23 @@ Portability : POSIX
module Gargantext.Core.Text.List.Social
where
-- findList imports
import Gargantext.Core.Types.Individu
import Gargantext.Database.Admin.Config
import Gargantext.Database.Admin.Types.Node
import Gargantext.Database.Prelude
import Gargantext.Database.Query.Table.Node.Error
import Gargantext.Database.Query.Tree
import Gargantext.Database.Query.Tree.Root (getRootId)
import Gargantext.Prelude
-- filterList imports
import Data.Maybe (fromMaybe)
import Data.Map (Map)
import Data.Set (Set)
import Data.Maybe (fromMaybe)
import Data.Semigroup (Semigroup(..))
import Data.Set (Set)
import Data.Text (Text)
import Gargantext.API.Ngrams.Tools -- (getListNgrams)
import Gargantext.API.Ngrams.Types
import Gargantext.Core.Types.Main
import Gargantext.Database.Schema.Ngrams
import Gargantext.Core.Text.List.Social.Find
import Gargantext.Core.Text.List.Social.Group
import Gargantext.Core.Text.List.Social.ListType
import qualified Data.List as List
import Gargantext.Core.Types.Individu
import Gargantext.Core.Types.Main
import Gargantext.Database.Admin.Types.Node
import Gargantext.Database.Prelude
import Gargantext.Database.Query.Table.Node.Error
import Gargantext.Database.Query.Tree
import Gargantext.Database.Schema.Ngrams
import Gargantext.Prelude
import qualified Data.Map as Map
import qualified Data.Set as Set
......@@ -76,8 +69,8 @@ flowSocialListByMode :: ( RepoCmdM env err m
)
=> [NodeId]-> NgramsType -> Set Text
-> m (Map (Maybe ListType) (Set Text))
flowSocialListByMode [] nt ngrams' = pure $ Map.fromList [(Nothing, ngrams')]
flowSocialListByMode listIds nt ngrams' = do
flowSocialListByMode [] _nt ngrams' = pure $ Map.fromList [(Nothing, ngrams')]
flowSocialListByMode listIds nt ngrams' = do
counts <- countFilterList ngrams' nt listIds Map.empty
let r = toSocialList counts ngrams'
pure r
......
src/Gargantext/Core/Text/List/Social/Group.hs
View file @ c3a9237b
......@@ -8,38 +8,39 @@ Stability : experimental
Portability : POSIX
-}
{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE TypeFamilies #-}
module Gargantext.Core.Text.List.Social.Group
where
-- findList imports
import Control.Lens
import Data.Map (Map)
import Data.Maybe (fromMaybe)
import Data.Semigroup (Semigroup(..))
import Data.Set (Set)
import Data.Text (Text)
import GHC.Generics (Generic)
import Gargantext.API.Ngrams.Types
import Gargantext.Core.Types.Individu
import Gargantext.Core.Types.Main
import Gargantext.Database.Admin.Config
import Gargantext.Database.Admin.Types.Node
import Gargantext.Database.Prelude
import Gargantext.Database.Query.Table.Node.Error
import Gargantext.Database.Query.Tree
import Gargantext.Database.Query.Tree.Root (getRootId)
import Gargantext.Prelude
-- filterList imports
import Data.Maybe (fromMaybe)
import Data.Map (Map)
import Data.Set (Set)
import Data.Semigroup (Semigroup(..))
import Data.Text (Text)
import Gargantext.API.Ngrams.Tools -- (getListNgrams)
import Gargantext.API.Ngrams.Types
import Gargantext.Core.Types.Main
import Gargantext.Database.Schema.Ngrams
import qualified Data.List as List
import qualified Data.Map as Map
import qualified Data.Set as Set
----------------------
------------------------------------------------------------------------
-- | Tools to inherit groupings
----------------------
type Parent = Text
------------------------------------------------------------------------
-- | Tools
parentUnionsMerge :: (Ord a, Ord b, Num c)
=> [Map a (Map b c)]
-> Map a (Map b c)
......@@ -56,6 +57,9 @@ parentUnionsExcl :: Ord a
-> Map a b
parentUnionsExcl = Map.unions
------------------------------------------------------------------------
type Parent = Text
hasParent :: Text
-> Map Text (Map Parent Int)
......@@ -64,43 +68,100 @@ hasParent t m = case Map.lookup t m of
Nothing -> Nothing
Just m' -> (fst . fst) <$> Map.maxViewWithKey m'
------------------------------------------------------------------------
toMapTextParent :: Set Text
-> Map Text (Map Parent Int)
-> [Map Text NgramsRepoElement]
-> Map Text (Map Parent Int)
toMapTextParent ts = foldl' (toMapTextParent' ts)
where
data FlowListScores =
FlowListScores { _flc_parents :: Map Parent Int
, _flc_lists :: Map ListType Int
-- You can add any score by incrementing this type
-- , _flc_score :: Map Score Int
}
deriving (Generic)
toMapTextParent' :: Set Text
-> Map Text (Map Parent Int)
-> Map Text NgramsRepoElement
-> Map Text (Map Parent Int)
toMapTextParent' ts' to from = Set.foldl' (toMapTextParent'' ts' from) to ts'
makeLenses ''FlowListScores
------------------------------------------------------------------------
-- | toFlowListScores which generate Score from list of Map Text NgramsRepoElement
toMapTextParent'' :: Set Text
toFlowListScores :: Set Text
-> Map Text FlowListScores
-> [Map Text NgramsRepoElement]
-> Map Text FlowListScores
toFlowListScores ts = foldl' (toFlowListScores' ts)
where
toFlowListScores' :: Set Text
-> Map Text FlowListScores
-> Map Text NgramsRepoElement
-> Map Text FlowListScores
toFlowListScores' ts' to' ngramsRepo =
Set.foldl' (toFlowListScores'' ts' ngramsRepo) to' ts'
toFlowListScores'' :: Set Text
-> Map Text NgramsRepoElement
-> Map Text (Map Parent Int)
-> Map Text FlowListScores
-> Text
-> Map Text (Map Parent Int)
toMapTextParent'' ss from to t = case Map.lookup t from of
Nothing -> to
Just nre -> case _nre_parent nre of
Just (NgramsTerm p') -> if Set.member p' ss
then Map.alter (addParent p') t to
else to
where
addParent p'' Nothing = Just $ addCountParent p'' Map.empty
addParent p'' (Just ps) = Just $ addCountParent p'' ps
addCountParent :: Parent -> Map Parent Int -> Map Parent Int
addCountParent p m = Map.alter addCount p m
where
addCount Nothing = Just 1
addCount (Just n) = Just $ n + 1
_ -> to
-> Map Text FlowListScores
toFlowListScores'' ss ngramsRepo to'' t =
case Map.lookup t ngramsRepo of
Nothing -> to''
Just nre -> Map.alter (addParent nre ss) t
$ Map.alter (addList $ _nre_list nre) t to''
------------------------------------------------------------------------
-- | Main addFunctions to FlowListScores
------------------------------------------------------------------------
-- | Very unseful but nice comment:
-- "this function looks like an ASCII bird"
addList :: ListType
-> Maybe FlowListScores
-> Maybe FlowListScores
addList l Nothing =
Just $ FlowListScores Map.empty (addList' l Map.empty)
addList l (Just (FlowListScores mapParent mapList)) =
Just $ FlowListScores mapParent mapList'
where
mapList' = addList' l mapList
addList' :: ListType -> Map ListType Int -> Map ListType Int
addList' l m = Map.alter (plus l) l m
where
plus CandidateTerm Nothing = Just 1
plus CandidateTerm (Just x) = Just $ x + 1
plus _ Nothing = Just 3
plus _ (Just x) = Just $ x + 3
------------------------------------------------------------------------
------------------------------------------------------------------------
addParent :: NgramsRepoElement -> Set Text
-> Maybe FlowListScores
-> Maybe FlowListScores
addParent nre ss Nothing =
Just $ FlowListScores mapParent Map.empty
where
mapParent = addParent' (_nre_parent nre) ss Map.empty
addParent nre ss (Just (FlowListScores mapParent mapList)) =
Just $ FlowListScores mapParent' mapList
where
mapParent' = addParent' (_nre_parent nre) ss mapParent
addParent' :: Num a
=> Maybe NgramsTerm
-> Set Text
-> Map Text a
-> Map Text a
addParent' Nothing _ss mapParent = mapParent
addParent' (Just (NgramsTerm p')) ss mapParent =
if not (Set.member p' ss)
then mapParent
else Map.alter addCount p' mapParent
where
addCount Nothing = Just 1
addCount (Just n) = Just $ n + 1
------------------------------------------------------------------------
src/Gargantext/Core/Text/List/Social/ListType.hs
View file @ c3a9237b
......@@ -40,14 +40,14 @@ import qualified Data.Set as Set
-- here we need UserList only
countFilterList :: RepoCmdM env err m
=> Set Text -> NgramsType -> [ListId]
-> Map Text (Map ListType Int)
-> Map Text (Map ListType Int)
-> m (Map Text (Map ListType Int))
countFilterList st nt ls input =
foldM' (\m l -> countFilterList' st nt [l] m) input ls
where
countFilterList' :: RepoCmdM env err m
=> Set Text -> NgramsType -> [ListId]
-> Map Text (Map ListType Int)
-> Map Text (Map ListType Int)
-> m (Map Text (Map ListType Int))
countFilterList' st nt ls input = do
ml <- toMapTextListType <$> getListNgrams ls nt
......@@ -60,25 +60,24 @@ toMapTextListType m = Map.fromListWith (<>)
$ List.concat
$ map (toList m)
$ Map.toList m
where
toList :: Map Text NgramsRepoElement -> (Text, NgramsRepoElement) -> [(Text, ListType)]
toList m (t, nre@(NgramsRepoElement _ _ _ _ (MSet children))) =
List.zip terms (List.cycle [lt'])
where
terms = [t]
-- <> maybe [] (\n -> [unNgramsTerm n]) root
-- <> maybe [] (\n -> [unNgramsTerm n]) parent
<> (map unNgramsTerm $ Map.keys children)
lt' = listOf m nre
------------------------------------------------------------------------
toList :: Map Text NgramsRepoElement -> (Text, NgramsRepoElement) -> [(Text, ListType)]
toList m (t, nre@(NgramsRepoElement _ _ _ _ (MSet children))) =
List.zip terms (List.cycle [lt'])
where
terms = [t]
-- <> maybe [] (\n -> [unNgramsTerm n]) root
-- <> maybe [] (\n -> [unNgramsTerm n]) parent
<> (map unNgramsTerm $ Map.keys children)
lt' = listOf m nre
listOf :: Map Text NgramsRepoElement -> NgramsRepoElement -> ListType
listOf m ng = case _nre_parent ng of
Nothing -> _nre_list ng
Just p -> case Map.lookup (unNgramsTerm p) m of
Just ng' -> listOf m ng'
Nothing -> CandidateTerm
-- panic "[G.C.T.L.Social.listOf] Nothing: Should Not happen"
listOf :: Map Text NgramsRepoElement -> NgramsRepoElement -> ListType
listOf m ng = case _nre_parent ng of
Nothing -> _nre_list ng
Just p -> case Map.lookup (unNgramsTerm p) m of
Just ng' -> listOf m ng'
Nothing -> CandidateTerm
-- panic "[G.C.T.L.Social.listOf] Nothing: Should Not happen"
------------------------------------------------------------------------
countList :: Text
......@@ -89,14 +88,16 @@ countList t m input = case Map.lookup t m of
Nothing -> input
Just l -> Map.alter addList t input
where
addList Nothing = Just $ addCountList l Map.empty
addList (Just lm) = Just $ addCountList l lm
addCountList :: ListType -> Map ListType Int -> Map ListType Int
addCountList l m = Map.alter (plus l) l m
where
plus CandidateTerm Nothing = Just 1
plus CandidateTerm (Just x) = Just $ x + 1
addCountList :: ListType -> Map ListType Int -> Map ListType Int
addCountList l m = Map.alter (plus l) l m
where
plus CandidateTerm Nothing = Just 1
plus CandidateTerm (Just x) = Just $ x + 1
plus _ Nothing = Just 3
plus _ (Just x) = Just $ x + 3
plus _ Nothing = Just 3
plus _ (Just x) = Just $ x + 3
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