Trying to add the ability to create a subcorpus

Issues remain:
- When reusing the parent corpus's terms list, subterms are not imported
- When trying to build a new term list, two lists get created, both empty
- A graph is not yet created automatically
- Further down the line, a UI element will have to be integrated to actually let users create subcorpora

gargantext.cabal

@@ -346,6 +346,7 @@ library
       Gargantext.Core.Methods.Similarities.Distributional
       Gargantext.Core.Statistics
       Gargantext.Core.Text.Convert
+      Gargantext.Core.Text.Corpus
       Gargantext.Core.Text.Corpus.API.Hal
       Gargantext.Core.Text.Corpus.API.Isidore
       Gargantext.Core.Text.Corpus.API.Istex

src/Gargantext/Core/Text/Corpus.hs

+module Gargantext.Core.Text.Corpus (makeSubcorpusFromQuery) where
+
+import Data.Set.Internal qualified as Set
+import Gargantext.API.Admin.Types (HasSettings)
+import Gargantext.API.Errors.Types (BackendInternalError)
+import Gargantext.Core.NodeStory.Types (HasNodeStoryEnv)
+import Gargantext.Core.NLP (HasNLPServer)
+import Gargantext.Core.Text.Corpus.Query qualified as Q
+import Gargantext.Core.Text.List (buildNgramsLists)
+import Gargantext.Core.Text.List.Group.WithStem (GroupParams (..))
+import Gargantext.Core.Text.List.Social (FlowSocialListWith (..), FlowSocialListPriority (..))
+import Gargantext.Core.Text.Ngrams (NgramsType (..))
+import Gargantext.Core.Types.Individu (User (..))
+import Gargantext.Core.Types.Main (ListType (..))
+import Gargantext.Database.Action.Flow (getOrMkRootWithCorpus, reIndexWith)
+import Gargantext.Database.Action.Flow.List (flowList_DbRepo)
+import Gargantext.Database.Action.Search (searchInCorpus)
+import Gargantext.Database.Action.User (getUserId)
+import Gargantext.Database.Admin.Types.Hyperdata.Corpus (HyperdataCorpus)
+import Gargantext.Database.Admin.Types.Node (CorpusId, nodeId2ContextId, NodeType (..))
+import Gargantext.Database.Prelude (DBCmd')
+import Gargantext.Database.Query.Facet.Types (facetDoc_id)
+import Gargantext.Database.Query.Table.Node (insertDefaultNode, copyNode)
+import Gargantext.Database.Query.Table.Node.Document.Add qualified as Document (add)
+import Gargantext.Database.Query.Tree.Root (MkCorpusUser (..))
+import Gargantext.Prelude
+
+
+-- | Given a "parent" corpus and a query, search for all docs in the parent
+--   that match the query, and create a corpus from those. The created corpus
+--   is inserted in the tree as a child of the parent corpus.
+--   Creation of subcorpus "Docs" and "Terms" nodes is handled. The terms can be
+--   either copied from the parent corpus or recomputed based on the subcorpus docs.
+makeSubcorpusFromQuery :: ( HasSettings     env
+                          , HasNodeStoryEnv env
+                          , HasNLPServer    env
+                          )
+  => User                                     -- ^ The corpus owner
+  -> CorpusId                                 -- ^ ID of the parent corpus
+  -> Q.Query                                  -- ^ The query to determine the subset of documents that will appear in the subcorpus
+  -> Bool                                     -- ^ Whether to reuse parent term list (True) or compute a new one based only on the documents in the subcorpus (False)
+  -> DBCmd' env BackendInternalError CorpusId -- ^ The child corpus ID
+makeSubcorpusFromQuery user parentId query reuseParentList = do
+  userId      <- getUserId user
+  subcorpusId <- insertDefaultNode NodeCorpus parentId userId
+  (_, _, masterCorpusId) <- getOrMkRootWithCorpus MkCorpusUserMaster (Nothing :: Maybe HyperdataCorpus)
+  -- Get ahold of all documents that match the query
+  facetDocs   <- searchInCorpus parentId False query Nothing Nothing Nothing
+  -- Create a subcorpus node with all the documents
+  _ <- Document.add subcorpusId $ nodeId2ContextId . facetDoc_id <$> facetDocs
+  -- Create nodes for docs and terms as children of the subcorpus
+  void $ insertDefaultNode NodeTexts subcorpusId userId
+  listId <- insertDefaultNode NodeList subcorpusId userId
+  -- Either simply copy parent terms...
+  -- (TODO this does not keep subterms)
+  if reuseParentList then void $ copyNode True listId subcorpusId 
+  -- ... or rebuild a term list from scratch
+  else do
+    ngrams <- buildNgramsLists
+                user
+                subcorpusId
+                masterCorpusId
+                (Just (FlowSocialListWithPriority MySelfFirst) :: Maybe FlowSocialListWith)
+                GroupIdentity
+    -- Save computed list
+    _ <- flowList_DbRepo listId ngrams
+    return ()
+  -- Reindex 
+  _ <- reIndexWith subcorpusId listId NgramsTerms (Set.singleton MapTerm)
+  -- The following two lines (like the one just above) are copypasted from
+  -- the definition of flowCorpusUser, but I'm not sure whether they should be included
+  -- _ <- updateContextScore      userCorpusId listId
+  -- _ <- updateNgramsOccurrences userCorpusId listId
+  return subcorpusId

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

@@ -13,7 +13,6 @@ Portability : POSIX
 
 {-# LANGUAGE BangPatterns        #-}
 {-# LANGUAGE DeriveAnyClass      #-}
-{-# LANGUAGE DerivingStrategies  #-}
 {-# LANGUAGE DerivingVia         #-}
 {-# LANGUAGE LambdaCase          #-}
 {-# LANGUAGE TemplateHaskell     #-}
@@ -36,6 +35,7 @@ import Data.Time (UTCTime)
 import Data.TreeDiff
 import Database.PostgreSQL.Simple.FromField (FromField, fromField, fromJSONField)
 import Database.PostgreSQL.Simple.ToField (ToField, toField, toJSONField)
+import Database.PostgreSQL.Simple.FromRow (FromRow, fromRow, field)
 import Database.PostgreSQL.Simple.ToRow (ToRow, toRow)
 import Fmt ( Buildable(..) )
 import Gargantext.Core.Utils.Prefix (unPrefix, unPrefixSwagger, wellNamedSchema)
@@ -267,10 +267,13 @@ instance ToField NodeId where
   toField (UnsafeMkNodeId n) = toField n
 instance ToRow NodeId where
   toRow (UnsafeMkNodeId i) = [toField i]
+instance FromRow NodeId where
+  fromRow = UnsafeMkNodeId <$> field
+
 
 instance FromField NodeId where
-  fromField field mdata = do
-    n <- UnsafeMkNodeId <$> fromField field mdata
+  fromField fld mdata = do
+    n <- UnsafeMkNodeId <$> fromField fld mdata
     if isPositive n
        then pure n
        else mzero

src/Gargantext/Database/Query/Table/Node.hs

@@ -25,6 +25,7 @@ import Control.Lens (set, view)
 import Data.Aeson ( encode, Value )
 import Database.PostgreSQL.Simple qualified as PGS
 import Database.PostgreSQL.Simple.SqlQQ (sql)
+import Gargantext.API.Errors.Types (BackendInternalError (..))
 import Gargantext.Core ( HasDBid(toDBid) )
 import Gargantext.Core.Types
 import Gargantext.Core.Types.Query (Limit, Offset)
@@ -37,6 +38,7 @@ import Gargantext.Database.Admin.Types.Hyperdata.Prelude ( Hyperdata )
 import Gargantext.Database.Admin.Types.Hyperdata.Default ( defaultHyperdata, DefaultHyperdata(..) )
 import Gargantext.Database.Prelude (DBCmd, JSONB, mkCmd, runPGSQuery, runOpaQuery)
 import Gargantext.Database.Query.Filter (limit', offset')
+import Gargantext.Database.Query.Table.Node.Children (getChildrenById)
 import Gargantext.Database.Query.Table.Node.Error
 import Gargantext.Database.Schema.Node
 import Gargantext.Prelude hiding (sum, head)
@@ -430,3 +432,28 @@ defaultListMaybe cId = headMay <$> map (view node_id ) <$> getListsWithParentId
 
 getListsWithParentId :: HasDBid NodeType => NodeId -> DBCmd err [Node HyperdataList]
 getListsWithParentId n = runOpaQuery $ selectNodesWith' n (Just NodeList)
+
+
+-- | Copy a node somewhere else in the tree
+copyNode :: Bool                              -- ^ Whether to copy whole subtree (True) or just the node (False)
+         -> NodeId                            -- ^ ID of the node to be copied
+         -> NodeId                            -- ^ ID of the node which will become the parent of the copied node
+         -> DBCmd BackendInternalError NodeId -- ^ ID of the copied node
+copyNode copySubtree idToCopy newParentId = if copySubtree
+  then do
+    copiedNode <- copyNode False idToCopy newParentId
+    children   <- getChildrenById idToCopy
+    for_ children $ \child -> copyNode True child copiedNode
+    return copiedNode
+  else do
+    newNodes <- runPGSQuery
+      -- Copy node. Should return exactly one ID, that of the new node:
+      [sql|
+        INSERT INTO public.nodes (typename, user_id, parent_id, name, date, hyperdata)
+        SELECT typename, user_id, ?, name, date, hyperdata FROM public.nodes WHERE id = ?
+        RETURNING id;
+      |] (newParentId, idToCopy)
+    case newNodes of
+      [copiedNode] -> return copiedNode
+      _ -> throwError $ InternalUnexpectedError $ SomeException $ PatternMatchFail $
+             "SQL insert returned zero or more than one node"

src/Gargantext/Database/Query/Table/Node/Children.hs

@@ -9,19 +9,21 @@ Portability : POSIX
 -}
 
 
-{-# OPTIONS_GHC -fno-warn-orphans        #-}
-{-# LANGUAGE Arrows                      #-}
+{-# OPTIONS_GHC -fno-warn-orphans #-}
+{-# LANGUAGE Arrows               #-}
+{-# LANGUAGE QuasiQuotes          #-}
 
 module Gargantext.Database.Query.Table.Node.Children
   where
 
 import Control.Arrow (returnA)
+import Database.PostgreSQL.Simple.SqlQQ (sql)
 import Gargantext.Core ( HasDBid(toDBid) )
 import Gargantext.Core.Types
 import Gargantext.Core.Types.Query (Limit, Offset)
 import Gargantext.Database.Admin.Types.Hyperdata.Contact ( HyperdataContact )
 import Gargantext.Database.Admin.Types.Hyperdata.Document ( HyperdataDocument )
-import Gargantext.Database.Prelude (DBCmd, JSONB, runCountOpaQuery, runOpaQuery)
+import Gargantext.Database.Prelude (DBCmd, JSONB, runCountOpaQuery, runOpaQuery, runPGSQuery)
 import Gargantext.Database.Query.Filter ( limit', offset' )
 import Gargantext.Database.Query.Table.NodeContext ( NodeContextPoly(NodeContext), queryNodeContextTable )
 import Gargantext.Database.Schema.Context
@@ -60,6 +62,14 @@ getChildren pId p t@(Just NodeContact ) maybeOffset maybeLimit = getChildrenCont
 getChildren a b c d e = getChildrenNode a b c d e
 
 
+-- | Get the list of (IDs of) children of a given node (ID)
+getChildrenById :: NodeId             -- ^ ID of the parent node
+                -> DBCmd err [NodeId] -- ^ List of IDs of the children nodes
+getChildrenById parentId = runPGSQuery
+    [sql| SELECT id FROM public.nodes WHERE parent_id = ?; |]
+    parentId
+
+
 getChildrenNode :: (JSONB a, HasDBid NodeType)
             => ParentId
             -> proxy a