Commit 6ed1dc7e authored by Alexandre Delanoë's avatar Alexandre Delanoë

Merge branch 'dev-social-list' into dev-merge

parents 9afb64ca 1e9e4ffd
......@@ -22,8 +22,7 @@ import Data.Ord (Down(..))
import Data.Set (Set)
import Data.Text (Text)
import Data.Tuple.Extra (both)
import Gargantext.API.Ngrams.Types (NgramsElement)
import Gargantext.API.Ngrams.Types (RepoCmdM)
import Gargantext.API.Ngrams.Types (NgramsElement, RepoCmdM, NgramsTerm(..))
import Gargantext.Core.Text (size)
import Gargantext.Core.Text.List.Group
import Gargantext.Core.Text.List.Group.Prelude
......@@ -90,7 +89,7 @@ buildNgramsOthersList ::( HasNodeError err
-> GroupParams
-> (NgramsType, MapListSize)
-> 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
-- | PrivateFirst for first developments since Public NodeMode is not implemented yet
......@@ -100,9 +99,18 @@ buildNgramsOthersList user uCid groupParams (nt, MapListSize mapListSize) = do
$ List.zip (Map.keys allTerms)
(List.cycle [mempty])
)
{-
if nt == Sources -- Authors
then printDebug "flowSocialList" socialLists
else printDebug "flowSocialList" ""
-}
let
groupedWithList = toGroupedTree groupParams socialLists allTerms
groupedWithList = toGroupedTree {- groupParams -} socialLists allTerms
{-
if nt == Sources -- Authors
then printDebug "groupedWithList" groupedWithList
else printDebug "groupedWithList" ""
-}
let
(stopTerms, tailTerms) = Map.partition ((== Just StopTerm) . viewListType)
......@@ -149,7 +157,9 @@ buildNgramsTermsList user uCid mCid groupParams (nt, _mapListSize)= do
(List.cycle [mempty])
)
let groupedWithList = toGroupedTree groupParams socialLists allTerms
let socialLists_Stemmed = addScoreStem groupParams (Set.map NgramsTerm $ Map.keysSet allTerms) socialLists
printDebug "socialLists_Stemmed" socialLists_Stemmed
let groupedWithList = toGroupedTree {- groupParams -} socialLists_Stemmed allTerms
(stopTerms, candidateTerms) = Map.partition ((== Just StopTerm) . viewListType)
$ view flc_scores groupedWithList
......
......@@ -25,29 +25,20 @@ import Data.Monoid (Monoid, mempty)
import Data.Text (Text)
import Gargantext.Core.Text.List.Social.Prelude
import Gargantext.Core.Text.List.Group.Prelude
import Gargantext.Core.Text.List.Group.WithStem
import Gargantext.Core.Text.List.Group.WithScores
import Gargantext.Prelude
import qualified Data.Map as Map
------------------------------------------------------------------------
-- | TODO add group with stemming
toGroupedTree :: (Ord a, Monoid a, GroupWithStem a)
=> GroupParams
-> FlowCont Text FlowListScores
toGroupedTree :: (Ord a, Monoid a)
=> FlowCont Text FlowListScores
-> Map Text a
-- -> Map Text (GroupedTreeScores (Set NodeId))
-> FlowCont Text (GroupedTreeScores a)
toGroupedTree groupParams flc scores = {-view flc_scores-} flow2
toGroupedTree flc scores =
groupWithScores' flc scoring
where
flow1 = groupWithScores' flc scoring
scoring t = fromMaybe mempty $ Map.lookup t scores
flow2 = case (view flc_cont flow1) == Map.empty of
True -> flow1
False -> groupWithStem' groupParams flow1
------------------------------------------------------------------------
setScoresWithMap :: (Ord a, Ord b, Monoid b) => Map Text b
......@@ -74,6 +65,4 @@ setScoresWith f = Map.mapWithKey (\k v -> v { _gts'_score = f k
$ view gts'_children v
}
)
------------------------------------------------------------------------
......@@ -32,23 +32,26 @@ import qualified Data.Map as Map
groupWithScores' :: (Eq a, Ord a, Monoid a)
=> FlowCont Text FlowListScores
-> (Text -> a) -- Map Text (a)
-> FlowCont Text (GroupedTreeScores (a))
-> FlowCont Text (GroupedTreeScores a)
groupWithScores' flc scores = FlowCont groups orphans
where
-- parent/child relation is inherited from social lists
groups = toGroupedTree
$ toMapMaybeParent scores
$ view flc_scores flc
$ (view flc_scores flc <> view flc_cont flc)
-- orphans should be filtered already
orphans = toGroupedTree
orphans = mempty {- toGroupedTree
$ toMapMaybeParent scores
$ view flc_cont flc
-}
------------------------------------------------------------------------
toMapMaybeParent :: (Eq a, Ord a, Monoid a)
=> (Text -> a)
-> Map Text FlowListScores
-> Map (Maybe Parent) (Map Text (GroupedTreeScores (a)))
-> Map (Maybe Parent) (Map Text (GroupedTreeScores a))
toMapMaybeParent f = Map.fromListWith (<>)
. (map (fromScores'' f))
. Map.toList
......@@ -56,7 +59,7 @@ toMapMaybeParent f = Map.fromListWith (<>)
fromScores'' :: (Eq a, Ord a, Monoid a)
=> (Text -> a)
-> (Text, FlowListScores)
-> (Maybe Parent, Map Text (GroupedTreeScores (a)))
-> (Maybe Parent, Map Text (GroupedTreeScores a))
fromScores'' f' (t, fs) = ( maybeParent
, Map.fromList [( t, set gts'_score (f' t)
$ set gts'_listType maybeList mempty
......@@ -66,17 +69,18 @@ fromScores'' f' (t, fs) = ( maybeParent
maybeParent = keyWithMaxValue $ view fls_parents fs
maybeList = keyWithMaxValue $ view fls_listType fs
------------------------------------------------------------------------
toGroupedTree :: Eq a
=> Map (Maybe Parent) (Map Text (GroupedTreeScores (a)))
-> Map Parent (GroupedTreeScores (a))
=> Map (Maybe Parent) (Map Text (GroupedTreeScores a))
-> Map Parent (GroupedTreeScores a)
toGroupedTree m = case Map.lookup Nothing m of
Nothing -> mempty
Just m' -> toGroupedTree' m m'
toGroupedTree' :: Eq a => Map (Maybe Parent) (Map Text (GroupedTreeScores (a)))
-> (Map Text (GroupedTreeScores (a)))
-> Map Parent (GroupedTreeScores (a))
toGroupedTree' :: Eq a => Map (Maybe Parent) (Map Text (GroupedTreeScores a))
-> (Map Text (GroupedTreeScores a))
-> Map Parent (GroupedTreeScores a)
toGroupedTree' m notEmpty
| notEmpty == mempty = mempty
| otherwise = Map.mapWithKey (addGroup m) notEmpty
......@@ -89,9 +93,3 @@ toGroupedTree' m notEmpty
)
v
......@@ -17,21 +17,32 @@ Portability : POSIX
module Gargantext.Core.Text.List.Group.WithStem
where
import Control.Lens (view, over)
import Data.Set (Set)
import Data.Map (Map)
import Data.Monoid (mempty)
import Data.Maybe (catMaybes)
import Data.Set (Set)
import Data.Text (Text)
import Gargantext.API.Ngrams.Types
import Gargantext.Core (Lang(..))
import Gargantext.Database.Admin.Types.Node (NodeId)
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.Terms.Mono.Stem (stem)
import Gargantext.Prelude
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.Patch.Class as Patch (Replace(..))
import qualified Data.Set as Set
import qualified Data.Text as Text
------------------------------------------------------------------------
addScoreStem :: GroupParams
-> Set NgramsTerm
-> FlowCont Text FlowListScores
-> FlowCont Text FlowListScores
addScoreStem groupParams ngrams fl = foldl' addScorePatch fl
$ stemPatches groupParams ngrams
------------------------------------------------------------------------
-- | Main Types
data StopSize = StopSize {unStopSize :: !Int}
......@@ -49,19 +60,6 @@ data GroupParams = GroupParams { unGroupParams_lang :: !Lang
| GroupIdentity
deriving (Eq)
------------------------------------------------------------------------
class GroupWithStem a where
groupWithStem' :: GroupParams
-> FlowCont Text (GroupedTreeScores a)
-> FlowCont Text (GroupedTreeScores a)
-- TODO factorize groupWithStem_*
instance GroupWithStem (Set NodeId) where
groupWithStem' = groupWithStem_SetNodeId
instance GroupWithStem Double where
groupWithStem' = groupWithStem_Double
------------------------------------------------------------------------
groupWith :: GroupParams
-> Text
......@@ -75,151 +73,40 @@ groupWith (GroupParams l _m _n _) =
-- . (List.filter (\t -> Text.length t > m))
. Text.splitOn " "
. Text.replace "-" " "
------------------------------------------------------------------------
groupWithStem_SetNodeId :: GroupParams
-> FlowCont Text (GroupedTreeScores (Set NodeId))
-> FlowCont Text (GroupedTreeScores (Set NodeId))
groupWithStem_SetNodeId g flc
| g == GroupIdentity = FlowCont ( (<>)
(view flc_scores flc)
(view flc_cont flc)
) mempty
| otherwise = mergeWith (groupWith g) flc
groupWithStem_Double :: GroupParams
-> FlowCont Text (GroupedTreeScores Double)
-> FlowCont Text (GroupedTreeScores Double)
groupWithStem_Double g flc
| g == GroupIdentity = FlowCont ( (<>)
(view flc_scores flc)
(view flc_cont flc)
) mempty
| otherwise = mergeWith_Double (groupWith g) flc
-- | MergeWith : with stem, we always have an answer
-- if Maybe lems then we should add it to continuation
mergeWith :: (Text -> Text)
-> FlowCont Text (GroupedTreeScores (Set NodeId))
-> FlowCont Text (GroupedTreeScores (Set NodeId))
mergeWith fun flc = FlowCont scores mempty
--------------------------------------------------------------------
stemPatches :: GroupParams
-> Set NgramsTerm
-> [(NgramsTerm, NgramsPatch)]
stemPatches groupParams = patches
. Map.fromListWith (<>)
. map (\ng@(NgramsTerm t) -> ( groupWith groupParams t
, Set.singleton ng)
)
. Set.toList
-- | For now all NgramsTerm which have same stem
-- are grouped together
-- Parent is taken arbitrarly for now (TODO use a score like occ)
patches :: Map Stem (Set NgramsTerm)
-> [(NgramsTerm, NgramsPatch)]
patches = catMaybes . map patch . Map.elems
patch :: Set NgramsTerm
-> Maybe (NgramsTerm, NgramsPatch)
patch s = case Set.size s > 1 of
False -> Nothing
True -> do
let ngrams = Set.toList s
parent <- headMay ngrams
let children = List.tail ngrams
pure (parent, toNgramsPatch children)
toNgramsPatch :: [NgramsTerm] -> NgramsPatch
toNgramsPatch children = NgramsPatch children' Patch.Keep
where
scores :: Map Text (GroupedTreeScores (Set NodeId))
scores = foldl' (alter (mapStems scores')) scores' cont'
where
scores' = view flc_scores flc
cont' = Map.toList $ view flc_cont flc
-- TODO insert at the right place in group hierarchy
-- adding as child of the parent for now
alter :: Map Stem Text
-> Map Text (GroupedTreeScores (Set NodeId))
-> (Text, GroupedTreeScores (Set NodeId))
-> Map Text (GroupedTreeScores (Set NodeId))
alter st target (t,g) = case Map.lookup t st of
Nothing -> Map.alter (alter' (t,g)) t target
Just t' -> Map.alter (alter' (t,g)) t' target
alter' (_t,g) Nothing = Just g
alter' ( t,g) (Just g') = Just $ over gts'_children
( Map.union (Map.singleton t g))
g'
mapStems :: Map Text (GroupedTreeScores (Set NodeId))
-> Map Stem Text
mapStems = (Map.fromListWith (<>)) . List.concat . (map mapStem) . Map.toList
mapStem :: (Text, GroupedTreeScores (Set NodeId))
-> [(Stem, Text)]
mapStem (s,g) = parent : children
where
parent = (fun s, s)
children = List.concat $ map mapStem (Map.toList $ view gts'_children g)
-- | MergeWith : with stem, we always have an answer
-- if Maybe lems then we should add it to continuation
mergeWith_Double :: (Text -> Text)
-> FlowCont Text (GroupedTreeScores Double)
-> FlowCont Text (GroupedTreeScores Double)
mergeWith_Double fun flc = FlowCont scores mempty
where
scores :: Map Text (GroupedTreeScores Double)
scores = foldl' (alter (mapStems scores')) scores' cont'
where
scores' = view flc_scores flc
cont' = Map.toList $ view flc_cont flc
-- TODO insert at the right place in group hierarchy
-- adding as child of the parent for now
alter :: Map Stem Text
-> Map Text (GroupedTreeScores Double)
-> (Text, GroupedTreeScores Double)
-> Map Text (GroupedTreeScores Double)
alter st target (t,g) = case Map.lookup t st of
Nothing -> Map.alter (alter' (t,g)) t target
Just t' -> Map.alter (alter' (t,g)) t' target
alter' (_t,g) Nothing = Just g
alter' ( t,g) (Just g') = Just $ over gts'_children
( Map.union (Map.singleton t g))
g'
mapStems :: Map Text (GroupedTreeScores Double)
-> Map Stem Text
mapStems = (Map.fromListWith (<>)) . List.concat . (map mapStem) . Map.toList
mapStem :: (Text, GroupedTreeScores Double)
-> [(Stem, Text)]
mapStem (s,g) = parent : children
where
parent = (fun s, s)
children = List.concat $ map mapStem (Map.toList $ view gts'_children g)
{-
-- | TODO fixme
mergeWith_a :: (Text -> Text)
-> FlowCont Text (GroupedTreeScores a)
-> FlowCont Text (GroupedTreeScores a)
mergeWith_a fun flc = FlowCont scores mempty
where
scores :: Map Text (GroupedTreeScores a)
scores = foldl' (alter (mapStems scores')) scores' cont'
where
scores' = view flc_scores flc
cont' = Map.toList $ _flc_cont flc
-- TODO insert at the right place in group hierarchy
-- adding as child of the parent for now
alter :: Map Stem Text
-> Map Text (GroupedTreeScores a)
-> (Text, GroupedTreeScores a)
-> Map Text (GroupedTreeScores a)
alter st target (t,g) = case Map.lookup t st of
Nothing -> Map.alter (alter' (t,g)) t target
Just t' -> Map.alter (alter' (t,g)) t' target
alter' (_t,g) Nothing = Just g
alter' ( t,g) (Just g') = Just $ over gts'_children
( Map.union (Map.singleton t g))
g'
mapStems :: Map Text (GroupedTreeScores a)
-> Map Stem Text
mapStems = (Map.fromListWith (<>)) . List.concat . (map mapStem) . Map.toList
mapStem :: (Text, GroupedTreeScores a)
-> [(Stem, Text)]
mapStem (s,g) = parent : children
where
parent = (fun s, s)
children = List.concat $ map mapStem (Map.toList $ view gts'_children g)
-}
children' :: PatchMSet NgramsTerm
children' = PatchMSet
$ fst
$ PatchMap.fromList
$ List.zip children (List.cycle [addPatch])
......@@ -20,7 +20,6 @@ import Gargantext.Core.Text.List.Social.Find
import Gargantext.Core.Text.List.Social.History
import Gargantext.Core.Text.List.Social.Patch
import Gargantext.Core.Text.List.Social.Prelude
import Gargantext.Core.Text.List.Social.Scores
import Gargantext.Core.Types.Individu
import Gargantext.Database.Admin.Types.Node
import Gargantext.Database.Prelude
......@@ -42,11 +41,12 @@ flowSocialListPriority :: FlowSocialListPriority -> [NodeMode]
flowSocialListPriority MySelfFirst = [Private{-, Shared, Public -}]
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
......@@ -86,13 +86,28 @@ flowSocialList flowPriority user nt flc =
-> FlowCont Text FlowListScores
-> [ListId]
-> m (FlowCont Text FlowListScores)
flowSocialListByModeWith nt'' flc'' ns =
mapM (\l -> getListNgrams [l] nt'') ns
flowSocialListByModeWith nt'' flc'' listes =
getHistoryScores History_User nt'' flc'' listes
{-
mapM (\l -> getListNgrams [l] nt'') listes
>>= pure
. toFlowListScores (keepAllParents nt'') flc''
-}
-----------------------------------------------------------------
getHistoryScores :: ( RepoCmdM env err m
, CmdM env err m
, HasNodeError err
, HasTreeError err
)
=> History
-> NgramsType
-> FlowCont Text FlowListScores
-> [ListId]
-> m (FlowCont Text FlowListScores)
getHistoryScores hist nt fl listes = do
hist' <- addScorePatches nt listes fl <$> getHistory hist nt listes
-- printDebug "hist" hist'
pure hist'
getHistory :: ( RepoCmdM env err m
, CmdM env err m
......@@ -107,18 +122,3 @@ getHistory hist nt listes =
history hist [nt] listes <$> getRepo
getHistoryScores :: ( RepoCmdM env err m
, CmdM env err m
, HasNodeError err
, HasTreeError err
)
=> History
-> NgramsType
-> FlowCont Text FlowListScores
-> [ListId]
-> m (FlowCont Text FlowListScores)
getHistoryScores hist nt fl listes =
addScorePatches nt listes fl <$> getHistory hist nt listes
......@@ -21,7 +21,7 @@ import Gargantext.Prelude
import qualified Data.List as List
import qualified Data.Map.Strict as Map
-- TODO put this in Prelude maybe
-- TODO put this in Prelude
cons :: a -> [a]
cons a = [a]
......
......@@ -65,7 +65,6 @@ Children are not modified in this specific case.
-- | Old list get -1 score
-- New list get +1 score
-- Hence others lists lay around 0 score
-- TODO add children
addScorePatch fl (NgramsTerm t, (NgramsPatch children' (Patch.Replace old_list new_list))) =
-- | Adding New Children score
addScorePatch fl' (NgramsTerm t, NgramsPatch children' Patch.Keep)
......@@ -73,27 +72,30 @@ addScorePatch fl (NgramsTerm t, (NgramsPatch children' (Patch.Replace old_list n
-- | Adding New ListType score
fl' = fl & flc_scores . at t %~ (score fls_listType old_list (-1))
& flc_scores . at t %~ (score fls_listType new_list ( 1))
& flc_cont %~ (Map.delete t)
-- | Patching existing Ngrams with children
addScorePatch fl (NgramsTerm p, NgramsPatch children' Patch.Keep) =
foldl' add' fl $ patchMSet_toList children'
foldl' addChild fl $ patchMSet_toList children'
where
-- | Adding a child
add' fl' (NgramsTerm t, Patch.Replace Nothing (Just _)) = doLink ( 1) p t fl'
addChild fl' (NgramsTerm t, Patch.Replace Nothing (Just _)) = doLink ( 1) p t fl'
-- | Removing a child
add' fl' (NgramsTerm t, Patch.Replace (Just _) Nothing) = doLink (-1) p t fl'
addChild fl' (NgramsTerm t, Patch.Replace (Just _) Nothing) = doLink (-1) p t fl'
-- | This case should not happen: does Nothing
add' fl' _ = fl'
addChild fl' _ = fl'
-- | Inserting a new Ngrams
addScorePatch fl (NgramsTerm t, NgramsReplace Nothing (Just nre)) =
childrenScore 1 t (nre ^. nre_children)
$ fl & flc_scores . at t %~ (score fls_listType $ nre ^. nre_list) 1
& flc_cont %~ (Map.delete t)
addScorePatch fl (NgramsTerm t, NgramsReplace (Just old_nre) maybe_new_nre) =
let fl' = childrenScore (-1) t (old_nre ^. nre_children)
$ fl & flc_scores . at t %~ (score fls_listType $ old_nre ^. nre_list) (-1)
& flc_cont %~ (Map.delete t)
in case maybe_new_nre of
Nothing -> fl'
Just new_nre -> addScorePatch fl' (NgramsTerm t, NgramsReplace Nothing (Just new_nre))
......
......@@ -25,6 +25,7 @@ import Data.Semigroup (Semigroup(..))
import Data.Text (Text)
import GHC.Generics (Generic)
import Gargantext.API.Ngrams.Types
import Gargantext.Core.Text.Metrics.Freq (getMaxFromMap)
import Gargantext.Core.Types.Main
import Gargantext.Prelude
import qualified Data.Map as Map
......@@ -96,16 +97,6 @@ parentUnionsExcl :: Ord a
-> Map a b
parentUnionsExcl = Map.unions
------------------------------------------------------------------------
hasParent :: Text
-> Map Text (Map Parent Int)
-> Maybe Parent
hasParent t m = case Map.lookup t m of
Nothing -> Nothing
Just m' -> keyWithMaxValue m'
------------------------------------------------------------------------
-- | Takes key with max value if and only if value > 0
-- If value <= 0 alors key is not taken at all
......@@ -114,12 +105,22 @@ hasParent t m = case Map.lookup t m of
-- Just 'z'
-- >>> keyWithMaxValue $ DM.fromList $ zip (['a'..'z'] :: [Char]) ([-1,-2..]::[Int])
-- Nothing
keyWithMaxValue :: (Ord b, Num b) => Map a b -> Maybe a
-- TODO duplicate with getMaxFromMap and improve it (lookup value should not be needed)
-- TODO put in custom Prelude
keyWithMaxValue :: (Ord a, Ord b, Num b)
=> Map a b -> Maybe a
keyWithMaxValue m = do
(k,a) <- fst <$> Map.maxViewWithKey m
if a > 0
then Just k
else Nothing
maxKey <- headMay $ getMaxFromMap m
maxValue <- Map.lookup maxKey m
if maxValue > 0
then pure maxKey
else Nothing
findMax :: (Ord b, Num b) => Map a b -> Maybe (a,b)
findMax m = case Map.null m of
True -> Nothing
False -> Just $ Map.findMax m
------------------------------------------------------------------------
......
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