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

[REFACT] Continuation Type with Monoid instance, connected to flowSocialList

parent aa89001d
...@@ -32,7 +32,6 @@ import qualified Data.Text as Text ...@@ -32,7 +32,6 @@ import qualified Data.Text as Text
import Gargantext.API.Ngrams.Types (NgramsElement, mkNgramsElement, NgramsTerm(..), RootParent(..), mSetFromList) import Gargantext.API.Ngrams.Types (NgramsElement, mkNgramsElement, NgramsTerm(..), RootParent(..), mSetFromList)
import Gargantext.API.Ngrams.Types (RepoCmdM) import Gargantext.API.Ngrams.Types (RepoCmdM)
import Gargantext.Core.Text.List.Social import Gargantext.Core.Text.List.Social
import Gargantext.Core.Text.List.Social.Scores
import Gargantext.Core.Text.List.Social.Prelude import Gargantext.Core.Text.List.Social.Prelude
import Gargantext.Core.Text.List.Group import Gargantext.Core.Text.List.Group
import Gargantext.Core.Text.List.Group.WithStem import Gargantext.Core.Text.List.Group.WithStem
...@@ -87,15 +86,17 @@ buildNgramsOthersList ::( HasNodeError err ...@@ -87,15 +86,17 @@ buildNgramsOthersList ::( HasNodeError err
buildNgramsOthersList user uCid groupIt (nt, MapListSize mapListSize) = do buildNgramsOthersList user uCid groupIt (nt, MapListSize mapListSize) = do
ngs' :: Map Text (Set NodeId) <- getNodesByNgramsUser uCid nt ngs' :: Map Text (Set NodeId) <- getNodesByNgramsUser uCid nt
socialLists' :: Map Text FlowListScores socialLists' :: FlowListCont Text
<- flowSocialList' MySelfFirst user nt (Set.fromList $ Map.keys ngs') <- flowSocialList' MySelfFirst user nt (FlowListCont Map.empty $ Set.fromList $ Map.keys ngs')
-- PrivateFirst for first developments since Public NodeMode is not implemented yet -- PrivateFirst for first developments since Public NodeMode is not implemented yet
printDebug "flowSocialList'" (Map.filter (not . ((==) Map.empty) . view fls_parents) socialLists') printDebug "flowSocialList'"
$ Map.filter (not . ((==) Map.empty) . view fls_parents)
$ view flc_scores socialLists'
let let
groupParams = GroupedTextParams groupIt (Set.size . snd) fst snd {-(size . fst)-} groupParams = GroupedTextParams groupIt (Set.size . snd) fst snd {-(size . fst)-}
groupedWithList = toGroupedText groupParams socialLists' ngs' groupedWithList = toGroupedText groupParams (view flc_scores socialLists') ngs'
printDebug "groupedWithList" printDebug "groupedWithList"
$ Map.map (\v -> (view gt_label v, view gt_children v)) $ Map.map (\v -> (view gt_label v, view gt_children v))
......
...@@ -24,7 +24,7 @@ import Data.Map (Map) ...@@ -24,7 +24,7 @@ import Data.Map (Map)
import Data.Text (Text) import Data.Text (Text)
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.List.Social.Scores (FlowListScores(..)) import Gargantext.Core.Text.List.Social.Prelude (FlowListScores(..))
import Gargantext.Core.Text.List.Group.WithStem import Gargantext.Core.Text.List.Group.WithStem
import Gargantext.Core.Text.List.Group.WithScores import Gargantext.Core.Text.List.Group.WithScores
import Gargantext.Prelude import Gargantext.Prelude
......
...@@ -22,9 +22,7 @@ import Data.Maybe (catMaybes) ...@@ -22,9 +22,7 @@ import Data.Maybe (catMaybes)
import Data.Text (Text) import Data.Text (Text)
import Gargantext.Core.Types (ListType(..)) -- (MasterCorpusId, UserCorpusId) import Gargantext.Core.Types (ListType(..)) -- (MasterCorpusId, UserCorpusId)
import Gargantext.Database.Admin.Types.Node (NodeId) import Gargantext.Database.Admin.Types.Node (NodeId)
-- import Gargantext.Core.Text.List.Learn (Model(..))
import Gargantext.Core.Text.List.Social.Prelude import Gargantext.Core.Text.List.Social.Prelude
import Gargantext.Core.Text.List.Social.Scores
import Gargantext.Prelude import Gargantext.Prelude
import qualified Data.Set as Set import qualified Data.Set as Set
import qualified Data.Map as Map import qualified Data.Map as Map
......
...@@ -13,7 +13,7 @@ module Gargantext.Core.Text.List.Social ...@@ -13,7 +13,7 @@ module Gargantext.Core.Text.List.Social
import Data.Map (Map) import Data.Map (Map)
import Data.Maybe (fromMaybe) import Data.Maybe (fromMaybe)
import Data.Semigroup (Semigroup(..)) import Data.Monoid (mconcat)
import Data.Set (Set) import Data.Set (Set)
import Data.Text (Text) import Data.Text (Text)
import Gargantext.API.Ngrams.Tools -- (getListNgrams) import Gargantext.API.Ngrams.Tools -- (getListNgrams)
...@@ -34,38 +34,10 @@ import qualified Data.Map as Map ...@@ -34,38 +34,10 @@ import qualified Data.Map as Map
import qualified Data.Set as Set import qualified Data.Set as Set
------------------------------------------------------------------------ ------------------------------------------------------------------------
flowSocialList :: ( RepoCmdM env err m
, CmdM env err m
, HasNodeError err
, HasTreeError err
)
=> User -> NgramsType -> Set Text
-> m (Map ListType (Set Text))
flowSocialList user nt ngrams' = do
-- Here preference to privateLists (discutable: let user choice)
privateListIds <- findListsId user Private
privateLists <- flowSocialListByMode privateListIds nt ngrams'
-- printDebug "* privateLists *: \n" privateLists
sharedListIds <- findListsId user Shared
sharedLists <- flowSocialListByMode sharedListIds nt (termsByList CandidateTerm privateLists)
-- printDebug "* sharedLists *: \n" sharedLists
-- TODO publicMapList:
-- Note: if both produce 3 identic repetition => refactor mode
-- publicListIds <- findListsId Public user
-- publicLists <- flowSocialListByMode' publicListIds nt (termsByList CandidateTerm privateLists)
let result = parentUnionsExcl
[ Map.mapKeys (fromMaybe CandidateTerm) privateLists
, Map.mapKeys (fromMaybe CandidateTerm) sharedLists
-- , Map.mapKeys (fromMaybe CandidateTerm) publicLists
]
-- printDebug "* socialLists *: results \n" result
pure result
------------------------------------------------------------------------ ------------------------------------------------------------------------
------------------------------------------------------------------------ ------------------------------------------------------------------------
-- | Main parameters
-- | FlowSocialListPriority -- | FlowSocialListPriority
-- Sociological assumption: either private or others (public) first -- Sociological assumption: either private or others (public) first
-- This parameter depends on the user choice -- This parameter depends on the user choice
...@@ -75,6 +47,13 @@ flowSocialListPriority :: FlowSocialListPriority -> [NodeMode] ...@@ -75,6 +47,13 @@ flowSocialListPriority :: FlowSocialListPriority -> [NodeMode]
flowSocialListPriority MySelfFirst = [Private, Shared{-, Public -}] flowSocialListPriority MySelfFirst = [Private, Shared{-, Public -}]
flowSocialListPriority OthersFirst = reverse $ flowSocialListPriority MySelfFirst flowSocialListPriority OthersFirst = reverse $ flowSocialListPriority MySelfFirst
-- | We keep the parents for all ngrams but terms
keepAllParents :: NgramsType -> KeepAllParents
keepAllParents NgramsTerms = KeepAllParents False
keepAllParents _ = KeepAllParents True
------------------------------------------------------------------------ ------------------------------------------------------------------------
flowSocialList' :: ( RepoCmdM env err m flowSocialList' :: ( RepoCmdM env err m
, CmdM env err m , CmdM env err m
...@@ -82,37 +61,27 @@ flowSocialList' :: ( RepoCmdM env err m ...@@ -82,37 +61,27 @@ flowSocialList' :: ( RepoCmdM env err m
, HasTreeError err , HasTreeError err
) )
=> FlowSocialListPriority => FlowSocialListPriority
-> User -> NgramsType -> Set Text -> User -> NgramsType
-> m (Map Text FlowListScores) -> FlowListCont Text
flowSocialList' flowPriority user nt ngrams' = -> m (FlowListCont Text)
parentUnionsExcl <$> mapM (flowSocialListByMode' user nt ngrams') flowSocialList' flowPriority user nt flc =
(flowSocialListPriority flowPriority) mconcat <$> mapM (flowSocialListByMode' user nt flc)
(flowSocialListPriority flowPriority)
------------------------------------------------------------------------ ------------------------------------------------------------------------
flowSocialListByMode :: ( RepoCmdM env err m
, CmdM env err m
, HasNodeError err
, HasTreeError err
)
=> [NodeId]-> NgramsType -> Set Text
-> m (Map (Maybe ListType) (Set Text))
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
flowSocialListByMode' :: ( RepoCmdM env err m flowSocialListByMode' :: ( RepoCmdM env err m
, CmdM env err m , CmdM env err m
, HasNodeError err , HasNodeError err
, HasTreeError err , HasTreeError err
) )
=> User -> NgramsType -> Set Text -> NodeMode => User -> NgramsType
-> m (Map Text FlowListScores) -> FlowListCont Text
flowSocialListByMode' user nt st mode = -> NodeMode
-> m (FlowListCont Text)
flowSocialListByMode' user nt flc mode =
findListsId user mode findListsId user mode
>>= flowSocialListByModeWith nt st >>= flowSocialListByModeWith nt flc
flowSocialListByModeWith :: ( RepoCmdM env err m flowSocialListByModeWith :: ( RepoCmdM env err m
...@@ -120,20 +89,19 @@ flowSocialListByModeWith :: ( RepoCmdM env err m ...@@ -120,20 +89,19 @@ flowSocialListByModeWith :: ( RepoCmdM env err m
, HasNodeError err , HasNodeError err
, HasTreeError err , HasTreeError err
) )
=> NgramsType -> Set Text -> [NodeId] => NgramsType
-> m (Map Text FlowListScores) -> FlowListCont Text
flowSocialListByModeWith nt st ns = -> [NodeId]
-> m (FlowListCont Text)
flowSocialListByModeWith nt flc ns =
mapM (\l -> getListNgrams [l] nt) ns mapM (\l -> getListNgrams [l] nt) ns
>>= pure >>= pure
. toFlowListScores (keepAllParents nt) st Map.empty . toFlowListScores (keepAllParents nt) flc
-- | We keep the parents for all ngrams but terms
keepAllParents :: NgramsType -> KeepAllParents
keepAllParents NgramsTerms = KeepAllParents False
keepAllParents _ = KeepAllParents True
------------------------------------------------------------------------ ---8<-TODO-ALL BELOW--8<--8<--8<--8<--8<--8<--8<--8<--8<--8<--8<--8<-
-- | Choice depends on Ord instance of ListType -- | Choice depends on Ord instance of ListType
-- for now : data ListType = StopTerm | CandidateTerm | MapTerm -- for now : data ListType = StopTerm | CandidateTerm | MapTerm
-- means MapTerm > CandidateTerm > StopTerm in case of equality of counts -- means MapTerm > CandidateTerm > StopTerm in case of equality of counts
...@@ -167,3 +135,48 @@ toSocialList1_testIsTrue = result == (Just MapTerm, Set.singleton token) ...@@ -167,3 +135,48 @@ toSocialList1_testIsTrue = result == (Just MapTerm, Set.singleton token)
] ]
flowSocialList :: ( RepoCmdM env err m
, CmdM env err m
, HasNodeError err
, HasTreeError err
)
=> User -> NgramsType -> Set Text
-> m (Map ListType (Set Text))
flowSocialList user nt ngrams' = do
-- Here preference to privateLists (discutable: let user choice)
privateListIds <- findListsId user Private
privateLists <- flowSocialListByMode privateListIds nt ngrams'
-- printDebug "* privateLists *: \n" privateLists
sharedListIds <- findListsId user Shared
sharedLists <- flowSocialListByMode sharedListIds nt (termsByList CandidateTerm privateLists)
-- printDebug "* sharedLists *: \n" sharedLists
-- TODO publicMapList:
-- Note: if both produce 3 identic repetition => refactor mode
-- publicListIds <- findListsId Public user
-- publicLists <- flowSocialListByMode' publicListIds nt (termsByList CandidateTerm privateLists)
let result = parentUnionsExcl
[ Map.mapKeys (fromMaybe CandidateTerm) privateLists
, Map.mapKeys (fromMaybe CandidateTerm) sharedLists
-- , Map.mapKeys (fromMaybe CandidateTerm) publicLists
]
-- printDebug "* socialLists *: results \n" result
pure result
-- | TODO remove
flowSocialListByMode :: ( RepoCmdM env err m
, CmdM env err m
, HasNodeError err
, HasTreeError err
)
=> [NodeId]-> NgramsType -> Set Text
-> m (Map (Maybe ListType) (Set Text))
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
...@@ -18,16 +18,66 @@ Portability : POSIX ...@@ -18,16 +18,66 @@ Portability : POSIX
module Gargantext.Core.Text.List.Social.Prelude module Gargantext.Core.Text.List.Social.Prelude
where where
import Control.Lens
import Data.Semigroup (Semigroup(..)) import Data.Semigroup (Semigroup(..))
import Data.Monoid
import Data.Map (Map) import Data.Map (Map)
import Data.Maybe (fromMaybe) import Data.Maybe (fromMaybe)
import Data.Set (Set) import Data.Set (Set)
import Data.Text (Text) import Data.Text (Text)
import Gargantext.Core.Types.Main import Gargantext.Core.Types.Main
import Gargantext.Prelude import Gargantext.Prelude
import GHC.Generics (Generic)
import qualified Data.Map as Map import qualified Data.Map as Map
import qualified Data.Set as Set import qualified Data.Set as Set
------------------------------------------------------------------------
type Parent = Text
------------------------------------------------------------------------
-- | DataType inspired by continuation Monad (but simpler)
data FlowListCont a =
FlowListCont { _flc_scores :: Map a FlowListScores
, _flc_cont :: Set a
}
instance Ord a => Monoid (FlowListCont a) where
mempty = FlowListCont Map.empty Set.empty
instance (Eq a, Ord a) => Semigroup (FlowListCont a) where
(<>) (FlowListCont m1 s1)
(FlowListCont m2 s2)
| s1 == Set.empty = FlowListCont m s2
| s2 == Set.empty = FlowListCont m s1
| otherwise = FlowListCont m (Set.intersection s1 s2)
where
m = Map.union m1 m2
-- | Datatype definition
data FlowListScores =
FlowListScores { _fls_parents :: Map Parent Int
, _fls_listType :: Map ListType Int
-- You can add any score by incrementing this type
-- , _flc_score :: Map Score Int
}
deriving (Show, Generic)
------------------------------------------------------------------------
makeLenses ''FlowListCont
makeLenses ''FlowListScores
-- | Rules to compose 2 datatype FlowListScores
-- About the shape of the Type fun:
-- Triangle de Pascal, nombre d'or ou pi ?
-- Question: how to add a score field and derive such definition
-- without the need to fix it below ?
instance Semigroup FlowListScores where
(<>) (FlowListScores p1 l1)
(FlowListScores p2 l2) =
FlowListScores (p1 <> p2)
(l1 <> l2)
------------------------------------------------------------------------ ------------------------------------------------------------------------
-- | Tools to inherit groupings -- | Tools to inherit groupings
...@@ -49,8 +99,8 @@ parentUnionsExcl :: Ord a ...@@ -49,8 +99,8 @@ parentUnionsExcl :: Ord a
-> Map a b -> Map a b
parentUnionsExcl = Map.unions parentUnionsExcl = Map.unions
------------------------------------------------------------------------ ------------------------------------------------------------------------
type Parent = Text
hasParent :: Text hasParent :: Text
-> Map Text (Map Parent Int) -> Map Text (Map Parent Int)
...@@ -76,9 +126,9 @@ termsByList l m = ...@@ -76,9 +126,9 @@ termsByList l m =
fromMaybe Set.empty $ Map.lookup (Just l) m fromMaybe Set.empty $ Map.lookup (Just l) m
------------------------------------------------------------------------ ------------------------------------------------------------------------
unions :: (Ord a, Semigroup a, Semigroup b, Ord b) unions' :: (Ord a, Semigroup a, Semigroup b, Ord b)
=> [Map a (Set b)] -> Map a (Set b) => [Map a (Set b)] -> Map a (Set b)
unions = invertBack . Map.unionsWith (<>) . map invertForw unions' = invertBack . Map.unionsWith (<>) . map invertForw
invertForw :: (Ord b, Semigroup a) => Map a (Set b) -> Map b a invertForw :: (Ord b, Semigroup a) => Map a (Set b) -> Map b a
invertForw = Map.unionsWith (<>) invertForw = Map.unionsWith (<>)
...@@ -91,7 +141,7 @@ invertBack = Map.fromListWith (<>) ...@@ -91,7 +141,7 @@ invertBack = Map.fromListWith (<>)
. Map.toList . Map.toList
unions_test :: Map ListType (Set Text) unions_test :: Map ListType (Set Text)
unions_test = unions [m1, m2] unions_test = unions' [m1, m2]
where where
m1 = Map.fromList [ (StopTerm , Set.singleton "Candidate")] m1 = Map.fromList [ (StopTerm , Set.singleton "Candidate")]
m2 = Map.fromList [ (CandidateTerm, Set.singleton "Candidate") m2 = Map.fromList [ (CandidateTerm, Set.singleton "Candidate")
......
...@@ -19,10 +19,9 @@ module Gargantext.Core.Text.List.Social.Scores ...@@ -19,10 +19,9 @@ module Gargantext.Core.Text.List.Social.Scores
import Control.Lens import Control.Lens
import Data.Map (Map) import Data.Map (Map)
import Data.Semigroup (Semigroup(..)) import Data.Monoid (mempty)
import Data.Set (Set) import Data.Set (Set)
import Data.Text (Text) import Data.Text (Text)
import GHC.Generics (Generic)
import Gargantext.API.Ngrams.Types import Gargantext.API.Ngrams.Types
import Gargantext.Core.Types.Main import Gargantext.Core.Types.Main
import Gargantext.Core.Text.List.Social.Prelude import Gargantext.Core.Text.List.Social.Prelude
...@@ -30,66 +29,36 @@ import Gargantext.Prelude ...@@ -30,66 +29,36 @@ import Gargantext.Prelude
import qualified Data.Map as Map import qualified Data.Map as Map
import qualified Data.Set as Set import qualified Data.Set as Set
------------------------------------------------------------------------
-- | DataType inspired by continuation Monad (but simpler)
data FlowListCont a =
FlowListCont { _flc_scores :: Map a FlowListScores
, _flc_cont :: Set a
}
-- | Datatype definition
data FlowListScores =
FlowListScores { _fls_parents :: Map Parent Int
, _fls_listType :: Map ListType Int
-- You can add any score by incrementing this type
-- , _flc_score :: Map Score Int
}
deriving (Show, Generic)
------------------------------------------------------------------------
makeLenses ''FlowListCont
makeLenses ''FlowListScores
-- | Rules to compose 2 datatype FlowListScores
-- About the shape of the Type fun:
-- Triangle de Pascal, nombre d'or ou pi ?
-- Question: how to add a score field and derive such definition
-- without the need to fix it below ?
instance Semigroup FlowListScores where
(<>) (FlowListScores p1 l1)
(FlowListScores p2 l2) =
FlowListScores (p1 <> p2)
(l1 <> l2)
------------------------------------------------------------------------
------------------------------------------------------------------------ ------------------------------------------------------------------------
-- | Generates Score from list of Map Text NgramsRepoElement -- | Generates Score from list of Map Text NgramsRepoElement
toFlowListScores :: KeepAllParents toFlowListScores :: KeepAllParents
-> Set Text -> FlowListCont Text
-> Map Text FlowListScores
-> [Map Text NgramsRepoElement] -> [Map Text NgramsRepoElement]
-> Map Text FlowListScores -> FlowListCont Text
toFlowListScores k st = foldl' (toFlowListScores' k st) toFlowListScores k flc = foldl' (toFlowListScores' k flc) mempty
where where
toFlowListScores' :: KeepAllParents toFlowListScores' :: KeepAllParents
-> Set Text -> FlowListCont Text
-> Map Text FlowListScores -> FlowListCont Text
-> Map Text NgramsRepoElement -> Map Text NgramsRepoElement
-> Map Text FlowListScores -> FlowListCont Text
toFlowListScores' k' st' to' ngramsRepo = toFlowListScores' k' flc flc' ngramsRepo =
Set.foldl' (toFlowListScores'' k' st' ngramsRepo) to' st' Set.foldl' (toFlowListScores'' k' ngramsRepo flc) flc' (view flc_cont flc)
toFlowListScores'' :: KeepAllParents toFlowListScores'' :: KeepAllParents
-> Set Text
-> Map Text NgramsRepoElement -> Map Text NgramsRepoElement
-> Map Text FlowListScores -> FlowListCont Text
-> FlowListCont Text
-> Text -> Text
-> Map Text FlowListScores -> FlowListCont Text
toFlowListScores'' k'' st'' ngramsRepo to'' t = toFlowListScores'' k'' ngramsRepo flc to'' t =
case Map.lookup t ngramsRepo of case Map.lookup t ngramsRepo of
Nothing -> to'' Nothing -> over flc_cont (Set.insert t) to''
Just nre -> Map.alter (addParent k'' nre st'') t Just nre -> over flc_scores
$ Map.alter (addList $ _nre_list nre) t to'' ( (Map.alter (addParent k'' nre (view flc_cont flc)) t)
. (Map.alter (addList $ _nre_list nre) t)
) to''
------------------------------------------------------------------------ ------------------------------------------------------------------------
-- | Main addFunctions to groupResolution the FlowListScores -- | Main addFunctions to groupResolution the FlowListScores
......
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