[FIX] List Learning is back

gargantext.cabal

@@ -203,7 +203,6 @@ library
       Gargantext.Core.Text.List.Merge
       Gargantext.Core.Text.List.Social
       Gargantext.Core.Text.List.Social.Find
-      Gargantext.Core.Text.List.Social.History
       Gargantext.Core.Text.List.Social.Patch
       Gargantext.Core.Text.List.Social.Prelude
       Gargantext.Core.Text.Metrics.FrequentItemSet

src/Gargantext/Core/NodeStory.hs

@@ -71,6 +71,7 @@ module Gargantext.Core.NodeStory
   , nse_var
   , unNodeStory
   , getNodeArchiveHistory
+  , getNodesArchiveHistory
   , Archive(..)
   , initArchive
   , a_history
@@ -111,6 +112,9 @@ import Database.PostgreSQL.Simple.SqlQQ (sql)
 import Database.PostgreSQL.Simple.FromField (FromField(fromField), fromJSONField)
 import Data.Profunctor.Product.TH (makeAdaptorAndInstance)
 import GHC.Generics (Generic)
+import Data.HashMap.Strict (HashMap)
+import qualified Data.HashMap.Strict as HashMap
+import Gargantext.Database.Schema.Ngrams (NgramsType)
 import Gargantext.API.Ngrams.Types
 import Gargantext.Core.Types (ListId, NodeId(..), NodeType)
 import Gargantext.Core.Utils.Prefix (unPrefix)
@@ -119,6 +123,7 @@ import Gargantext.Database.Prelude (CmdM', HasConnectionPool(..), HasConfig)
 import Gargantext.Database.Query.Table.Node.Error (HasNodeError())
 import Gargantext.Prelude
 import Opaleye (DefaultFromField(..), SqlJsonb, fromPGSFromField)
+import Database.PostgreSQL.Simple.Types (Values(..), QualifiedIdentifier(..))
 import System.IO (stderr)
 import qualified Data.Map.Strict                        as Map
 import qualified Data.Map.Strict.Patch                  as PM
@@ -373,6 +378,27 @@ getNodeArchiveHistory c nodeId = do
                     WHERE node_id = ?
                     ORDER BY (version, node_story_archive_history.id) DESC |]
 
+-- getNodesArchiveHistory :: PGS.Connection -> [NodeId] -> IO [(Int, NgramsStatePatch')]
+getNodesArchiveHistory :: PGS.Connection -> [NodeId] -> IO [(NodeId, (Map NgramsType [HashMap NgramsTerm NgramsPatch]))]
+getNodesArchiveHistory c nodesId = do
+  as <- runPGSQuery c query (PGS.Only $ Values fields nodesId) :: IO [(Int, TableNgrams.NgramsType, NgramsTerm, NgramsPatch)]
+  pure $ map (\(nId, ngramsType, terms, patch) -> (NodeId nId, Map.singleton ngramsType [HashMap.singleton terms patch])) as
+  where
+
+    fields = [QualifiedIdentifier Nothing "int4"]
+    query :: PGS.Query
+    query = [sql| WITH nodes_id(nid) as (?)
+                    SELECT node_id, ngrams_type_id, terms, patch
+                    FROM node_story_archive_history
+                    JOIN ngrams ON ngrams.id = ngrams_id
+                    JOIN nodes_id n ON node_id = n.nid
+                    WHERE version > 5
+                    ORDER BY (version, node_story_archive_history.id) DESC
+            |]
+
+-- Version > 5 is hard coded because by default
+-- first version of history of manual change is 6
+
 ngramsIdQuery :: PGS.Query
 ngramsIdQuery = [sql| SELECT id FROM ngrams WHERE terms = ? |]
 

src/Gargantext/Core/Text/List.hs

@@ -179,7 +179,10 @@ buildNgramsTermsList user uCid mCid mfslw groupParams (nt, MapListSize mapListSi
                                     )
   printDebug "[buildNgramsTermsList: Flow Social List / end]" nt
 
-  let !ngramsKeys = HashSet.fromList $ List.take mapListSize $ HashSet.toList $ HashMap.keysSet allTerms
+  let !ngramsKeys = HashSet.fromList
+                  $ List.take mapListSize
+                  $ HashSet.toList
+                  $ HashMap.keysSet allTerms
 
   printDebug "[buildNgramsTermsList: ngramsKeys]" (HashSet.size ngramsKeys)
 
@@ -189,7 +192,6 @@ buildNgramsTermsList user uCid mCid mfslw groupParams (nt, MapListSize mapListSi
 
   let
     !socialLists_Stemmed = addScoreStem groupParams' ngramsKeys socialLists
-  --printDebug "socialLists_Stemmed" socialLists_Stemmed
     !groupedWithList = toGroupedTree socialLists_Stemmed allTerms
     !(stopTerms, candidateTerms) = HashMap.partition ((== Just StopTerm) . viewListType)
                                  $ HashMap.filter (\g -> (view gts'_score g) > 1)
@@ -197,6 +199,9 @@ buildNgramsTermsList user uCid mCid mfslw groupParams (nt, MapListSize mapListSi
 
     !(groupedMono, groupedMult)  = HashMap.partitionWithKey (\(NgramsTerm t) _v -> size t < 2) candidateTerms
 
+  printDebug "[buildNgramsTermsList] socialLists" socialLists
+  printDebug "[buildNgramsTermsList] socialLists with scores" socialLists_Stemmed
+  printDebug "[buildNgramsTermsList] groupedWithList" groupedWithList
   printDebug "[buildNgramsTermsList] stopTerms" stopTerms
 
   -- splitting monterms and multiterms to take proportional candidates

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

@@ -13,35 +13,34 @@ Portability : POSIX
 module Gargantext.Core.Text.List.Social
   where
 
+import Control.Lens (view)
 import Control.Monad (mzero)
 import Data.Aeson
 import Data.HashMap.Strict (HashMap)
 import Data.Map (Map)
 import Data.Monoid (mconcat)
+import Data.Pool
 import Data.Swagger
 import GHC.Generics
-
-import Web.Internal.HttpApiData (ToHttpApiData, FromHttpApiData, parseUrlPiece, toUrlPiece)
-import qualified Data.Scientific as Scientific
-import qualified Data.Text       as T
-import qualified Data.Vector     as V
-
-import Gargantext.API.Ngrams.Tools (getRepo)
 import Gargantext.API.Ngrams.Types (NgramsTerm, NgramsPatch)
-import Gargantext.Core.NodeStory (HasNodeStory)
+import Gargantext.Core.NodeStory (HasNodeStory, getNodesArchiveHistory)
 import Gargantext.Core.Text.List.Social.Find (findListsId)
-import Gargantext.Core.Text.List.Social.History (History(..), history)
 import Gargantext.Core.Text.List.Social.Patch (addScorePatches)
 import Gargantext.Core.Text.List.Social.Prelude (FlowCont, FlowListScores)
 import Gargantext.Core.Types.Individu (User)
 import Gargantext.Database.Admin.Types.Node (ListId, NodeId(..))
-import Gargantext.Database.Prelude (CmdM)
+import Gargantext.Database.Prelude
 import Gargantext.Database.Query.Table.Node.Error (HasNodeError)
 import Gargantext.Database.Query.Tree (NodeMode(Private), HasTreeError)
 import Gargantext.Database.Schema.Ngrams (NgramsType)
 import Gargantext.Prelude
+import Web.Internal.HttpApiData (ToHttpApiData, FromHttpApiData, parseUrlPiece, toUrlPiece)
+import qualified Data.List as List
+import qualified Data.Map        as Map
+import qualified Data.Scientific as Scientific
+import qualified Data.Text       as T
+import qualified Data.Vector     as V
 import qualified Prelude
-
 ------------------------------------------------------------------------
 ------------------------------------------------------------------------
 -- | Main parameters
@@ -115,7 +114,7 @@ flowSocialList :: ( HasNodeStory env err m
                   -> m (FlowCont NgramsTerm FlowListScores)
 flowSocialList Nothing u = flowSocialList' MySelfFirst u
 flowSocialList (Just (FlowSocialListWithPriority p)) u = flowSocialList' p u
-flowSocialList (Just (FlowSocialListWithLists    ls)) _ = getHistoryScores ls History_User
+flowSocialList (Just (FlowSocialListWithLists    ls)) _ = getHistoryScores ls
 flowSocialList (Just (NoList _)) _u = panic "[G.C.T.L.Social] Should not be executed"
 
 flowSocialList' :: ( HasNodeStory env err m
@@ -156,7 +155,7 @@ flowSocialList' flowPriority user nt flc =
                                -> [ListId]
                                -> m (FlowCont NgramsTerm FlowListScores)
       flowSocialListByModeWith nt'' flc'' listes =
-        getHistoryScores listes History_User nt'' flc''
+        getHistoryScores listes nt'' flc''
 
 
 -----------------------------------------------------------------
@@ -166,21 +165,25 @@ getHistoryScores :: ( HasNodeStory env err m
                     , HasTreeError     err
                     )
                  => [ListId]
-                 -> History
                  -> NgramsType
                  -> FlowCont NgramsTerm FlowListScores
                  -> m (FlowCont NgramsTerm FlowListScores)
-getHistoryScores lists hist nt fl =
-  addScorePatches nt lists fl <$> getHistory hist nt lists
+getHistoryScores lists nt fl =
+  addScorePatches nt lists fl <$> getHistory [nt] lists
+
 
 getHistory :: ( HasNodeStory env err m
               , CmdM     env err m
               , HasNodeError err
               , HasTreeError err
               )
-           => History
-           -> NgramsType
+         => [NgramsType]
          -> [ListId]
          -> m (Map ListId (Map NgramsType [HashMap NgramsTerm NgramsPatch]))
-getHistory hist nt listes =
-  history hist [nt] listes  <$> getRepo listes
+getHistory types listsId = do
+  pool <- view connPool
+  nsp <- liftBase $ withResource pool $ \c -> getNodesArchiveHistory c listsId
+  pure $ Map.map (Map.filterWithKey (\k _ -> List.elem k types))
+       $ Map.filterWithKey (\k _ -> List.elem k listsId)
+       $ Map.fromListWith (Map.unionWith (<>)) nsp
+

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

-{-|
-Module      : Gargantext.Core.Text.List.Social.History
-Description :
-Copyright   : (c) CNRS, 2018-Present
-License     : AGPL + CECILL v3
-Maintainer  : team@gargantext.org
-Stability   : experimental
-Portability : POSIX
--}
-
-module Gargantext.Core.Text.List.Social.History
-  where
-
-import Control.Lens hiding (cons)
-import Data.HashMap.Strict (HashMap)
-import Data.Map (Map)
-import Gargantext.API.Ngrams.Types
-import Gargantext.Core.NodeStory
-import Gargantext.Core.Text.List.Social.Prelude
-import Gargantext.Core.Types (ListId)
-import Gargantext.Database.Schema.Ngrams (NgramsType(..))
-import Gargantext.Prelude
-import qualified Data.List           as List
-import qualified Data.Map.Strict     as Map
-
--- TODO put this in Prelude
-cons :: a -> [a]
-cons a = [a]
-
-------------------------------------------------------------------------
--- | History control
-data History = History_User
-             | History_NotUser
-             | History_All
-
-------------------------------------------------------------------------
--- | Main Function
-history :: History
-        -> [NgramsType]
-        -> [ListId]
-        -> NodeStory s NgramsStatePatch'
-        -> Map ListId (Map NgramsType [HashMap NgramsTerm NgramsPatch])
-history History_User t l = clean . (history' t l)
-  where
-    clean = Map.map (Map.map List.init)
-
-history History_NotUser t l = clean . (history' t l)
-  where
-    clean = Map.map (Map.map last)
-    last = (maybe [] cons) . lastMay
-
-history _ t l = history' t l
-
-------------------------------------------------------------------------
-history' :: [NgramsType]
-        -> [ListId]
-        -> NodeStory s NgramsStatePatch'
-        -> Map ListId (Map NgramsType [HashMap NgramsTerm NgramsPatch])
-history' types lists = (Map.map (Map.unionsWith (<>)))
-                    . (Map.map (map (Map.filterWithKey (\k _ -> List.elem k types))))
-                    . (Map.map (map toMap))
-                    . (Map.map (view a_history))
-                    . (Map.filterWithKey (\k _ -> List.elem k lists))
-                    . (view unNodeStory)
-  where
-
-    toMap :: PatchMap NgramsType NgramsTablePatch
-          -> Map NgramsType [HashMap NgramsTerm NgramsPatch]
-    toMap m = Map.map (cons . unNgramsTablePatch)
-            $ unPatchMapToMap m

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

@@ -37,7 +37,6 @@ addScorePatches nt listes fl repo =
 
 
 addScorePatchesList :: NgramsType
-                   -- -> Map NgramsType (Map ListId [HashMap NgramsTerm NgramsPatch])
                    -> Map ListId (Map NgramsType [HashMap NgramsTerm NgramsPatch])
                    -> FlowCont NgramsTerm FlowListScores
                    -> ListId

src/Gargantext/Database/Admin/Types/Node.hs

@@ -19,6 +19,7 @@ Portability : POSIX
 module Gargantext.Database.Admin.Types.Node
   where
 
+import Database.PostgreSQL.Simple.ToRow (ToRow, toRow)
 import Codec.Serialise (Serialise())
 import Control.Monad (mzero)
 import Data.Aeson
@@ -217,6 +218,9 @@ instance Show NodeId where
 instance Serialise NodeId
 instance ToField NodeId where
   toField (NodeId n) = toField n
+instance ToRow NodeId where
+  toRow (NodeId i) = [toField i]
+
 instance FromField NodeId where
   fromField field mdata = do
     n <- fromField field mdata