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

src/Gargantext/Core/Text/List.hs

@@ -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
 

src/Gargantext/Core/Text/List/Group.hs

@@ -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
                                             }
                                  )
-
-
 ------------------------------------------------------------------------

src/Gargantext/Core/Text/List/Group/WithScores.hs

@@ -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
 
-
-
-
-
-
-

src/Gargantext/Core/Text/List/Group/WithStem.hs

@@ -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])
 

src/Gargantext/Core/Text/List/Social.hs

@@ -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,39 +86,39 @@ 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''
-
+        -}
 -----------------------------------------------------------------
-
-
-getHistory :: ( RepoCmdM env err m
+getHistoryScores :: ( RepoCmdM env err m
                     , CmdM     env err m
                     , HasNodeError err
                     , HasTreeError err
                     )
                  => History
                  -> NgramsType
+                 -> FlowCont Text FlowListScores
                  -> [ListId]
-           -> m (Map NgramsType (Map ListId [Map NgramsTerm NgramsPatch]))
-getHistory hist nt listes =
-  history hist [nt] listes  <$> getRepo
-
+                 -> m (FlowCont Text FlowListScores)
+getHistoryScores hist nt fl listes = do
+  hist' <- addScorePatches nt listes fl <$> getHistory hist nt listes
+  -- printDebug "hist" hist'
+  pure hist'
 
-getHistoryScores :: ( RepoCmdM env err m
+getHistory :: ( 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
-
+           -> m (Map NgramsType (Map ListId [Map NgramsTerm NgramsPatch]))
+getHistory hist nt listes =
+  history hist [nt] listes  <$> getRepo
 
 

src/Gargantext/Core/Text/List/Social/History.hs

@@ -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]
 

src/Gargantext/Core/Text/List/Social/Patch.hs

@@ -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))

src/Gargantext/Core/Text/List/Social/Prelude.hs

@@ -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,14 +105,24 @@ 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
+  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
+
+
 ------------------------------------------------------------------------
 unPatchMap :: Ord a => PatchMap a b -> Map a b
 unPatchMap = Map.fromList . PatchMap.toList