Commit 4a5e83c1 authored by Alexandre Delanoë's avatar Alexandre Delanoë

[FEAT] Social Lists : option for PrivateFirst or OthersFirst

parent c4e94103
...@@ -99,9 +99,6 @@ toGroupedText fun_stem fun_score fun_texts fun_nodeIds from = groupStems' $ map ...@@ -99,9 +99,6 @@ toGroupedText fun_stem fun_score fun_texts fun_nodeIds from = groupStems' $ map
(fun_nodeIds d) (fun_nodeIds d)
) )
groupStems :: [(Stem, GroupedText Double)] -> [GroupedText Double]
groupStems = Map.elems . groupStems'
groupStems' :: Ord a => [(Stem, GroupedText a)] -> Map Stem (GroupedText a) groupStems' :: Ord a => [(Stem, GroupedText a)] -> Map Stem (GroupedText a)
groupStems' = Map.fromListWith grouping groupStems' = Map.fromListWith grouping
where where
......
...@@ -81,24 +81,32 @@ buildNgramsOthersList ::( HasNodeError err ...@@ -81,24 +81,32 @@ buildNgramsOthersList ::( HasNodeError err
buildNgramsOthersList user uCid groupIt (nt, MapListSize mapListSize) = do buildNgramsOthersList user uCid groupIt (nt, MapListSize mapListSize) = do
ngs <- groupNodesByNgramsWith groupIt <$> getNodesByNgramsUser uCid nt ngs <- groupNodesByNgramsWith groupIt <$> getNodesByNgramsUser uCid nt
let let
grouped = toGroupedText groupIt (Set.size . snd) fst snd grouped = toGroupedText groupIt (Set.size . snd) fst snd
(Map.toList $ Map.mapWithKey (\k (a,b) -> (Set.delete k a, b)) $ ngs) $ Map.toList
$ Map.mapWithKey (\k (a,b) -> (Set.delete k a, b))
$ ngs
socialLists <- flowSocialList user nt (Set.fromList $ Map.keys ngs) socialLists <- flowSocialList user nt (Set.fromList $ Map.keys ngs)
let let
groupedWithList = map (addListType (invertForw socialLists)) grouped groupedWithList = map (addListType (invertForw socialLists)) grouped
(stopTerms, tailTerms) = Map.partition (\t -> t ^. gt_listType == Just StopTerm) groupedWithList (stopTerms, tailTerms) = Map.partition (\t -> t ^. gt_listType == Just StopTerm)
(mapTerms, tailTerms') = Map.partition (\t -> t ^. gt_listType == Just MapTerm) tailTerms groupedWithList
(mapTerms, tailTerms') = Map.partition (\t -> t ^. gt_listType == Just MapTerm)
tailTerms
listSize = mapListSize - (List.length mapTerms) listSize = mapListSize - (List.length mapTerms)
(mapTerms', candiTerms) = List.splitAt listSize $ List.sortOn (Down . _gt_score) $ Map.elems tailTerms' (mapTerms', candiTerms) = List.splitAt listSize
$ List.sortOn (Down . _gt_score)
pure $ Map.fromList [( nt, (List.concat $ map toNgramsElement stopTerms) $ Map.elems tailTerms'
<> (List.concat $ map toNgramsElement mapTerms)
<> (List.concat $ map toNgramsElement $ map (set gt_listType (Just MapTerm)) mapTerms') pure $ Map.fromList [( nt, (List.concat $ map toNgramsElement stopTerms)
<> (List.concat $ map toNgramsElement $ map (set gt_listType (Just CandidateTerm)) candiTerms) <> (List.concat $ map toNgramsElement mapTerms )
<> (List.concat $ map toNgramsElement
$ map (set gt_listType (Just MapTerm )) mapTerms' )
<> (List.concat $ map toNgramsElement
$ map (set gt_listType (Just CandidateTerm)) candiTerms)
)] )]
-- TODO use ListIds -- TODO use ListIds
......
...@@ -42,11 +42,11 @@ flowSocialList :: ( RepoCmdM env err m ...@@ -42,11 +42,11 @@ flowSocialList :: ( RepoCmdM env err m
-> m (Map ListType (Set Text)) -> m (Map ListType (Set Text))
flowSocialList user nt ngrams' = do flowSocialList user nt ngrams' = do
-- Here preference to privateLists (discutable: let user choice) -- Here preference to privateLists (discutable: let user choice)
privateListIds <- findListsId Private user privateListIds <- findListsId user Private
privateLists <- flowSocialListByMode privateListIds nt ngrams' privateLists <- flowSocialListByMode privateListIds nt ngrams'
-- printDebug "* privateLists *: \n" privateLists -- printDebug "* privateLists *: \n" privateLists
sharedListIds <- findListsId Shared user sharedListIds <- findListsId user Shared
sharedLists <- flowSocialListByMode sharedListIds nt (termsByList CandidateTerm privateLists) sharedLists <- flowSocialListByMode sharedListIds nt (termsByList CandidateTerm privateLists)
-- printDebug "* sharedLists *: \n" sharedLists -- printDebug "* sharedLists *: \n" sharedLists
...@@ -63,6 +63,29 @@ flowSocialList user nt ngrams' = do ...@@ -63,6 +63,29 @@ flowSocialList user nt ngrams' = do
-- printDebug "* socialLists *: results \n" result -- printDebug "* socialLists *: results \n" result
pure result pure result
------------------------------------------------------------------------
-- | FlowSocialListPriority
-- Sociological assumption: either private or others (public) first
-- This parameter depends on the user choice
data FlowSocialListPriority = PrivateFirst | OthersFirst
flowSocialListPriority :: FlowSocialListPriority -> [NodeMode]
flowSocialListPriority PrivateFirst = [Private, Shared{-, Public -}]
flowSocialListPriority OthersFirst = reverse $ flowSocialListPriority PrivateFirst
flowSocialList' :: ( RepoCmdM env err m
, CmdM env err m
, HasNodeError err
, HasTreeError err
)
=> FlowSocialListPriority
-> User -> NgramsType -> Set Text
-> m (Map Text FlowListScores)
flowSocialList' flowPriority user nt ngrams' =
parentUnionsExcl <$> mapM (\m -> flowSocialListByMode' user m nt ngrams')
(flowSocialListPriority flowPriority)
------------------------------------------------------------------------ ------------------------------------------------------------------------
flowSocialListByMode :: ( RepoCmdM env err m flowSocialListByMode :: ( RepoCmdM env err m
, CmdM env err m , CmdM env err m
...@@ -83,9 +106,21 @@ flowSocialListByMode' :: ( RepoCmdM env err m ...@@ -83,9 +106,21 @@ flowSocialListByMode' :: ( RepoCmdM env err m
, HasNodeError err , HasNodeError err
, HasTreeError err , HasTreeError err
) )
=> User -> NodeMode -> NgramsType -> Set Text
-> m (Map Text FlowListScores)
flowSocialListByMode' user mode nt st = do
listIds <- findListsId user mode
flowSocialListByModeWith listIds nt st
flowSocialListByModeWith :: ( RepoCmdM env err m
, CmdM env err m
, HasNodeError err
, HasTreeError err
)
=> [NodeId]-> NgramsType -> Set Text => [NodeId]-> NgramsType -> Set Text
-> m (Map Text FlowListScores) -> m (Map Text FlowListScores)
flowSocialListByMode' ns nt st = do flowSocialListByModeWith ns nt st = do
ngramsRepos <- mapM (\l -> getListNgrams [l] nt) ns ngramsRepos <- mapM (\l -> getListNgrams [l] nt) ns
pure $ toFlowListScores (keepAllParents nt) st Map.empty ngramsRepos pure $ toFlowListScores (keepAllParents nt) st Map.empty ngramsRepos
......
...@@ -23,12 +23,11 @@ import Gargantext.Prelude ...@@ -23,12 +23,11 @@ import Gargantext.Prelude
------------------------------------------------------------------------ ------------------------------------------------------------------------
findListsId :: (HasNodeError err, HasTreeError err) findListsId :: (HasNodeError err, HasTreeError err)
=> NodeMode -> User -> Cmd err [NodeId] => User -> NodeMode -> Cmd err [NodeId]
findListsId mode u = do findListsId u mode = do
r <- getRootId u r <- getRootId u
ns <- map _dt_nodeId <$> filter (\n -> _dt_typeId n == nodeTypeId NodeList) ns <- map _dt_nodeId <$> filter (\n -> _dt_typeId n == nodeTypeId NodeList)
<$> findNodes' mode r <$> findNodes' mode r
-- printDebug "findListsIds" ns
pure ns pure ns
......
...@@ -80,12 +80,11 @@ instance Semigroup FlowListScores where ...@@ -80,12 +80,11 @@ instance Semigroup FlowListScores where
------------------------------------------------------------------------ ------------------------------------------------------------------------
-- | toFlowListScores which generate Score from list of Map Text -- | toFlowListScores which generate Score from list of Map Text
-- NgramsRepoElement -- NgramsRepoElement
toFlowListScores :: KeepAllParents toFlowListScores :: KeepAllParents
-> Set Text -> Set Text
-> Map Text FlowListScores -> Map Text FlowListScores
-> [Map Text NgramsRepoElement] -> [Map Text NgramsRepoElement]
-> Map Text FlowListScores -> Map Text FlowListScores
toFlowListScores k ts = foldl' (toFlowListScores' k ts) toFlowListScores k ts = foldl' (toFlowListScores' k ts)
where where
toFlowListScores' :: KeepAllParents toFlowListScores' :: KeepAllParents
...@@ -123,16 +122,7 @@ addList l (Just (FlowListScores mapParent mapList)) = ...@@ -123,16 +122,7 @@ addList l (Just (FlowListScores mapParent mapList)) =
where where
mapList' = addList' l mapList mapList' = addList' l mapList
-- * Unseful but nice comment: -- * Unseful but nice comment:
-- "the addList function looks like an ASCII bird in a blue sky" -- "the addList function looks like an ASCII bird"
-- _
-- ___| | ___ _
-- / __| |/ / | | |
-- \__ \ <| |_| |
-- |___/_|\_\\__, |
-- |___/
--
--
--
-- | Concrete function to pass to PatchMap -- | Concrete function to pass to PatchMap
addList' :: ListType -> Map ListType Int -> Map ListType Int addList' :: ListType -> Map ListType Int -> Map ListType Int
......
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