[FIX] warnings
[gargantext.git] / src / Gargantext / Core / Text / List.hs
index 6453afa3ebb7191d90c0c9d52e69ec9e9f9321d8..8902fa74cc6ab055c5c70bcc412102582cb1998b 100644 (file)
@@ -9,168 +9,302 @@ Portability : POSIX
 
 -}
 
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE TemplateHaskell     #-}
 
 module Gargantext.Core.Text.List
   where
 
--- import Data.Either (partitionEithers, Either(..))
+
+import Control.Lens ((^.), set, view)
+import Data.Maybe (fromMaybe, catMaybes)
+import Data.Ord (Down(..))
 import Data.Map (Map)
 import Data.Set (Set)
 import Data.Text (Text)
-import Gargantext.API.Ngrams (NgramsElement, mkNgramsElement, RootParent(..), mSetFromList)
--- import Gargantext.API.Ngrams.Tools (getCoocByNgrams', Diagonal(..))
-import Gargantext.Core (Lang(..))
-import Gargantext.Core.Types (ListType(..), MasterCorpusId, UserCorpusId, Ordering(..))
-import Gargantext.Database.Action.Metrics.NgramsByNode (ngramsGroup, getNodesByNgramsUser, groupNodesByNgramsWith)
-import Gargantext.Database.Action.Metrics.TFICF (getTficf)
-import Gargantext.Core.Text.Metrics.TFICF (sortTficf)
-import Gargantext.Database.Prelude (Cmd)
-import Gargantext.Database.Schema.Ngrams (NgramsType(..))
-import Gargantext.Prelude
-import Gargantext.Core.Text (size)
-import Gargantext.Core.Text.List.Learn (Model(..))
--- import Gargantext.Core.Text.Metrics (takeScored)
 import qualified Data.Char as Char
 import qualified Data.List as List
 import qualified Data.Map  as Map
 import qualified Data.Set  as Set
 import qualified Data.Text as Text
 
+-- import Gargantext.API.Ngrams.Tools (getCoocByNgrams', Diagonal(..))
+import Gargantext.API.Ngrams.Types (NgramsElement, mkNgramsElement, NgramsTerm(..), RootParent(..), mSetFromList)
+import Gargantext.API.Ngrams.Types (RepoCmdM)
+import Gargantext.Core.Text.List.Social (flowSocialList, flowSocialList', FlowSocialListPriority(..), invertForw)
+import Gargantext.Core.Text.List.Social.Scores -- (FlowListScores)
+import Gargantext.Core.Text.List.Group
+import Gargantext.Core.Text.List.Group.WithStem
+import Gargantext.Core.Text.Metrics (scored', Scored(..), normalizeGlobal, normalizeLocal)
+import Gargantext.Core.Types (ListType(..), MasterCorpusId, UserCorpusId)
+import Gargantext.Core.Types.Individu (User(..))
+import Gargantext.Database.Admin.Types.Node (NodeId)
+import Gargantext.Database.Action.Metrics.NgramsByNode (getNodesByNgramsUser, getNodesByNgramsOnlyUser)
+import Gargantext.Database.Action.Metrics.TFICF (getTficf)
+import Gargantext.Database.Prelude (CmdM)
+import Gargantext.Database.Query.Table.Node (defaultList)
+import Gargantext.Database.Query.Table.Node.Error (HasNodeError())
+import Gargantext.Database.Query.Tree.Error (HasTreeError)
+import Gargantext.Database.Schema.Ngrams (NgramsType(..))
+import Gargantext.Prelude
 
-data NgramsListBuilder = BuilderStepO { stemSize :: Int
-                                      , stemX    :: Int
-                                      , stopSize :: Int
-                                      }
-                       | BuilderStep1 { withModel :: Model }
-                       | BuilderStepN { withModel :: Model }
-                       | Tficf { nlb_lang           :: Lang
-                               , nlb_group1         :: Int
-                               , nlb_group2         :: Int
-                               , nlb_stopSize       :: StopSize
-                               , nlb_userCorpusId   :: UserCorpusId
-                               , nlb_masterCorpusId :: MasterCorpusId
-                               }
-
-
-data StopSize = StopSize {unStopSize :: Int}
 
 -- | TODO improve grouping functions of Authors, Sources, Institutes..
-buildNgramsLists :: Lang
-                 -> Int
-                 -> Int
-                 -> StopSize
+buildNgramsLists :: ( RepoCmdM env err m
+                    , CmdM     env err m
+                    , HasTreeError err
+                    , HasNodeError err
+                    )
+                 => User
+                 -> GroupParams
                  -> UserCorpusId
                  -> MasterCorpusId
-                 -> Cmd err (Map NgramsType [NgramsElement])
-buildNgramsLists l n m s uCid mCid = do
-  ngTerms     <- buildNgramsTermsList l n m s uCid mCid
-  othersTerms <- mapM (buildNgramsOthersList uCid identity)
-                      [Authors, Sources, Institutes]
-  pure $ Map.unions $ othersTerms <> [ngTerms]
+                 -> m (Map NgramsType [NgramsElement])
+buildNgramsLists user gp uCid mCid = do
+  ngTerms     <- buildNgramsTermsList user uCid mCid gp
+  othersTerms <- mapM (buildNgramsOthersList user uCid (ngramsGroup GroupIdentity))
+                      [ (Authors   , MapListSize 9)
+                      , (Sources   , MapListSize 9)
+                      , (Institutes, MapListSize 9)
+                      ]
+
+  pure $ Map.unions $ [ngTerms] <> othersTerms
+
+
+data MapListSize = MapListSize { unMapListSize :: !Int }
+
+buildNgramsOthersList ::( HasNodeError err
+                        , CmdM     env err m
+                        , RepoCmdM env err m
+                        , HasTreeError err
+                        )
+                        => User
+                        -> UserCorpusId
+                        -> (Text -> Text)
+                        -> (NgramsType, MapListSize)
+                        -> m (Map NgramsType [NgramsElement])
+buildNgramsOthersList user uCid groupIt (nt, MapListSize mapListSize) = do
+  ngs'  :: Map Text (Set NodeId) <- getNodesByNgramsUser uCid nt
 
+  socialLists' :: Map Text FlowListScores
+    <- flowSocialList' MySelfFirst user nt (Set.fromList $ Map.keys ngs')
+    -- PrivateFirst for first developments since Public NodeMode is not implemented yet
 
-buildNgramsOthersList :: UserCorpusId
-                      -> (Text -> Text)
-                      -> NgramsType
-                      -> Cmd err (Map NgramsType [NgramsElement])
-buildNgramsOthersList uCid groupIt nt = do
-  ngs <- groupNodesByNgramsWith groupIt <$> getNodesByNgramsUser uCid nt
+  printDebug "flowSocialList'" (Map.filter (not . ((==) Map.empty) . view fls_parents) socialLists')
 
   let
-    listSize = 9
-    all'     = List.reverse
-             $ List.sortOn (Set.size . snd . snd)
-             $ Map.toList ngs
+    groupParams     = GroupedTextParams groupIt (Set.size . snd) fst snd {-(size . fst)-}
+    groupedWithList = toGroupedText groupParams socialLists' ngs'
 
-    graphTerms = List.take listSize all'
-    candiTerms = List.drop listSize all'
+  printDebug "groupedWithList" (Map.map (\v -> (view gt_label v, view gt_children v)) $ Map.filter (\v -> (Set.size $ view gt_children v) > 0) groupedWithList)
 
-  pure $ Map.unionsWith (<>) [ toElements MapTerm     graphTerms
-                             , toElements CandidateTerm candiTerms
-                             ]
-    where
-      toElements nType x =
-        Map.fromList [(nt, [ mkNgramsElement t nType Nothing (mSetFromList [])
-                           | (t,_ns) <- x
+  let
+    (stopTerms, tailTerms) = Map.partition (\t -> t ^. gt_listType == Just StopTerm) groupedWithList
+    (mapTerms, tailTerms') = Map.partition (\t -> t ^. gt_listType == Just MapTerm)  tailTerms
+
+    listSize = mapListSize - (List.length mapTerms)
+    (mapTerms', candiTerms) = List.splitAt listSize
+                            $ List.sortOn (Down . _gt_score)
+                            $ Map.elems tailTerms'
+
+  pure $ Map.fromList [( nt,  (List.concat $ map toNgramsElement stopTerms)
+                           <> (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
+buildNgramsTermsList :: ( HasNodeError err
+                        , CmdM     env err m
+                        , RepoCmdM env err m
+                        , HasTreeError err
+                        )
+                        => User
+                        -> UserCorpusId
+                        -> MasterCorpusId
+                        -> GroupParams
+                        -> m (Map NgramsType [NgramsElement])
+buildNgramsTermsList user uCid mCid groupParams = do
+
+-- Computing global speGen score
+  allTerms :: Map Text Double <- getTficf uCid mCid NgramsTerms
+
+  -- printDebug "head candidates" (List.take 10 $ allTerms)
+  -- printDebug "tail candidates" (List.take 10 $ List.reverse $ allTerms)
+
+  -- First remove stops terms
+  socialLists <- flowSocialList user NgramsTerms (Set.fromList $ map fst $ Map.toList allTerms)
+  -- printDebug "\n * socialLists * \n" socialLists
+
+  -- Grouping the ngrams and keeping the maximum score for label
+  let grouped = groupedTextWithStem ( GroupedTextParams (ngramsGroup groupParams) identity (const Set.empty) (const Set.empty) {-(size . _gt_label)-} ) allTerms
+
+      groupedWithList = map (addListType (invertForw socialLists)) grouped
+
+      (stopTerms, candidateTerms) = Map.partition (\t -> t ^. gt_listType == Just StopTerm) groupedWithList
+      (groupedMono, groupedMult)  = Map.partition (\t -> t ^. gt_size                  < 2) candidateTerms
+
+  -- printDebug "\n * stopTerms * \n" stopTerms
+  -- splitting monterms and multiterms to take proportional candidates
+  let
+    listSizeGlobal = 2000 :: Double -- use % of list if to big, or Int if too small
+    monoSize = 0.4  :: Double
+    multSize = 1 - monoSize
+
+    splitAt n' ns = List.splitAt (round $ n' * listSizeGlobal) $ List.sort $ Map.elems ns
+
+    (groupedMonoHead, groupedMonoTail) = splitAt monoSize groupedMono
+    (groupedMultHead, groupedMultTail) = splitAt multSize groupedMult
+
+  -- printDebug "groupedMonoHead" (List.length groupedMonoHead)
+  -- printDebug "groupedMonoTail" (List.length groupedMonoHead)
+  -- printDebug "groupedMultHead" (List.length groupedMultHead)
+  -- printDebug "groupedMultTail" (List.length groupedMultTail)
+
+  let
+    -- Get Local Scores now for selected grouped ngrams
+    selectedTerms = Set.toList $ List.foldl'
+                      (\set' (GroupedText _ l' _ g _ _ _ ) -> Set.union set'
+                                                            $ Set.insert l' g
+                      )
+                      Set.empty
+                      (groupedMonoHead <> groupedMultHead)
+
+  -- TO remove (and remove HasNodeError instance)
+  userListId    <- defaultList uCid
+  masterListId  <- defaultList mCid
+
+  mapTextDocIds <- getNodesByNgramsOnlyUser uCid [userListId, masterListId] NgramsTerms selectedTerms
+
+  let
+    mapGroups   = Map.fromList
+                $ map (\g -> (g ^. gt_stem, g))
+                $ groupedMonoHead <> groupedMultHead
+
+    -- grouping with Set NodeId
+    contextsAdded = foldl' (\mapGroups' k ->
+                                    let k' = ngramsGroup groupParams k in
+                                        case Map.lookup k' mapGroups'  of
+                                          Nothing -> mapGroups'
+                                          Just g  -> case Map.lookup k mapTextDocIds of
+                                            Nothing -> mapGroups'
+                                            Just ns -> Map.insert k' ( g { _gt_nodes = Set.union ns (_gt_nodes g)}) mapGroups'
+                           )
+                  mapGroups
+                  $ Map.keys mapTextDocIds
+
+    -- compute cooccurrences
+    mapCooc = Map.filter (>2)
+            $ Map.fromList [ ((t1, t2), Set.size $ Set.intersection s1 s2)
+                           | (t1, s1) <- mapStemNodeIds
+                           , (t2, s2) <- mapStemNodeIds
+                           --, t1 >= t2 -- permute byAxis diag  -- since matrix symmetric
                            ]
-                     )]
-
-buildNgramsTermsList :: Lang
-                     -> Int
-                     -> Int
-                     -> StopSize
-                     -> UserCorpusId
-                     -> MasterCorpusId
-                     -> Cmd err (Map NgramsType [NgramsElement])
-buildNgramsTermsList l n m s uCid mCid = do
-  candidates <- sortTficf Up <$> getTficf uCid mCid NgramsTerms
-  -- printDebug "head candidates" (List.take 10 $ candidates)
-  -- printDebug "tail candidates" (List.take 10 $ List.reverse $ candidates)
+      where
+        mapStemNodeIds = Map.toList $ Map.map (_gt_nodes) contextsAdded
+  -- printDebug "mapCooc" mapCooc
 
   let
-    listSize = 400 :: Double
-    (candidatesHead, candidatesTail0)    = List.splitAt 3 candidates
-
-    (mono, multi)          = List.partition (\t -> (size . fst) t < 2) candidatesTail0
-    (monoHead , monoTail ) = List.splitAt (round $ 0.60 * listSize) mono
-    (multiHead, multiTail) = List.splitAt (round $ 0.40 * listSize) multi
-
-    termList = (map (toGargList ((isStopTerm s) . fst) CandidateTerm) candidatesHead)
-            <> (map (toGargList ((isStopTerm s) . fst) MapTerm)       (monoHead <> multiHead))
-            <> (map (toGargList ((isStopTerm s) . fst) CandidateTerm) (monoTail <> multiTail))
-
-    ngs = List.concat
-        $ map toNgramsElement
-        $ groupStems
-        $ map (\(listType, (t,d)) -> ( ngramsGroup l n m t
-                                     , GroupedText listType t d Set.empty
-                                     )
-              ) termList
-
-  pure $ Map.fromList [(NgramsTerms, ngs)]
-
-type Group = Lang -> Int -> Int -> Text -> Text
-type Stem  = Text
-type Label = Text
-data GroupedText = GroupedText { _gt_listType :: ListType
-                               , _gt_label    :: Label
-                               , _gt_score    :: Double
-                               , _gt_group    :: Set Text
-                               }
-groupStems :: [(Stem, GroupedText)] -> [GroupedText]
-groupStems = Map.elems . Map.fromListWith grouping
-  where
-    grouping (GroupedText lt1 label1 score1 group1)
-             (GroupedText lt2 label2 score2 group2)
-             | score1 >= score2 = GroupedText lt label1 score1 (Set.insert label2 gr)
-             | otherwise        = GroupedText lt label2 score2 (Set.insert label1 gr)
-        where
-          lt = lt1 <> lt2
-          gr = Set.union group1 group2
-
-toNgramsElement :: GroupedText -> [NgramsElement]
-toNgramsElement (GroupedText listType label _ setNgrams) =
+    -- computing scores
+    mapScores f = Map.fromList
+                $ map (\(Scored t g s') -> (t, f (g,s')))
+                $ normalizeGlobal
+                $ map normalizeLocal
+                $ scored' mapCooc
+
+    groupsWithScores = catMaybes
+                     $ map (\(stem, g)
+                             -> case Map.lookup stem mapScores' of
+                                 Nothing -> Nothing
+                                 Just s'  -> Just $ g { _gt_score = s'}
+                            ) $ Map.toList contextsAdded
+      where
+        mapScores' = mapScores identity
+        -- adapt2 TOCHECK with DC
+  -- printDebug "groupsWithScores" groupsWithScores
+  let
+    -- sort / partition / split
+      -- filter mono/multi again
+    (monoScored, multScored) = List.partition (\g -> _gt_size g < 2) groupsWithScores
+      -- filter with max score
+    partitionWithMaxScore = List.partition (\g -> let (s1,s2) = _gt_score g in s1 > s2 )
+
+    (monoScoredIncl, monoScoredExcl) = partitionWithMaxScore monoScored
+    (multScoredIncl, multScoredExcl) = partitionWithMaxScore multScored
+
+      -- splitAt
+  let
+    listSizeLocal = 1000 :: Double -- use % of list if to big, or Int if to small
+    inclSize = 0.4  :: Double
+    exclSize = 1 - inclSize
+    splitAt' n' = List.splitAt (round $ n' * listSizeLocal)
+
+    (monoScoredInclHead, monoScoredInclTail) = splitAt' (monoSize * inclSize / 2) $ List.sortOn (Down . _gt_score) monoScoredIncl
+    (monoScoredExclHead, monoScoredExclTail) = splitAt' (monoSize * inclSize / 2) $ List.sortOn (Down . _gt_score) monoScoredExcl
+
+    (multScoredInclHead, multScoredInclTail) = splitAt' (multSize * exclSize / 2) $ List.sortOn (Down . _gt_score) multScoredIncl
+    (multScoredExclHead, multScoredExclTail) = splitAt' (multSize * exclSize / 2) $ List.sortOn (Down . _gt_score) multScoredExcl
+
+
+    -- Final Step building the Typed list
+    termListHead = maps <> cands
+      where
+        maps = set gt_listType (Just MapTerm)
+            <$> monoScoredInclHead
+             <> monoScoredExclHead
+             <> multScoredInclHead
+             <> multScoredExclHead
+
+        cands = set gt_listType (Just CandidateTerm)
+             <$> monoScoredInclTail
+              <> monoScoredExclTail
+              <> multScoredInclTail
+              <> multScoredExclTail
+
+    termListTail = map (set gt_listType (Just CandidateTerm)) ( groupedMonoTail <> groupedMultTail)
+
+--  printDebug "monoScoredInclHead" monoScoredInclHead
+--  printDebug "monoScoredExclHead" monoScoredExclTail
+--  printDebug "multScoredInclHead" multScoredInclHead
+--  printDebug "multScoredExclTail" multScoredExclTail
+
+  let result = Map.unionsWith (<>)
+       [ Map.fromList [( NgramsTerms, (List.concat $ map toNgramsElement $ termListHead)
+                                   <> (List.concat $ map toNgramsElement $ termListTail)
+                                   <> (List.concat $ map toNgramsElement $ stopTerms)
+                      )]
+       ]
+  -- printDebug "\n result \n" r
+  pure result
+
+
+
+toNgramsElement :: GroupedText a -> [NgramsElement]
+toNgramsElement (GroupedText listType label _ setNgrams _ _ _) =
   [parentElem] <> childrenElems
     where
       parent = label
       children = Set.toList setNgrams
-      parentElem    = mkNgramsElement parent
-                                      listType
+      parentElem    = mkNgramsElement (NgramsTerm parent)
+                                      (fromMaybe CandidateTerm listType)
                                       Nothing
-                                      (mSetFromList children)
-      childrenElems = map (\t -> mkNgramsElement t listType
-                                                 (Just $ RootParent parent parent)
+                                      (mSetFromList (NgramsTerm <$> children))
+      childrenElems = map (\t -> mkNgramsElement t (fromMaybe CandidateTerm $ listType)
+                                                 (Just $ RootParent (NgramsTerm parent) (NgramsTerm parent))
                                                  (mSetFromList [])
-                          ) children
+                          ) (NgramsTerm <$> children)
 
 
-toGargList :: (b -> Bool) -> ListType -> b -> (ListType, b)
-toGargList isStop l n = case isStop n of
-    True  -> (StopTerm, n)
-    False -> (l, n)
+toGargList :: Maybe ListType -> b -> (Maybe ListType, b)
+toGargList l n = (l,n)
 
 
 isStopTerm :: StopSize -> Text -> Bool
 isStopTerm (StopSize n) x = Text.length x < n || any isStopChar (Text.unpack x)
   where
     isStopChar c = not (c `elem` ("- /()%" :: [Char]) || Char.isAlpha c)
+
+------------------------------------------------------------------------------