Stability : experimental
Portability : POSIX
--}
+-- TODO-ACCESS:
+-- check userId CanFillUserCorpus userCorpusId
+-- check masterUserId CanFillMasterCorpus masterCorpusId
-{-# LANGUAGE DeriveGeneric #-}
-{-# LANGUAGE NoImplicitPrelude #-}
-{-# LANGUAGE OverloadedStrings #-}
+-- TODO-ACCESS: check uId CanInsertDoc pId && checkDocType nodeType
+-- TODO-EVENTS: InsertedNodes
+-}
-module Gargantext.Database.Flow (flowDatabase, ngrams2list)
+{-# OPTIONS_GHC -fno-warn-orphans #-}
+
+{-# LANGUAGE ConstraintKinds #-}
+{-# LANGUAGE RankNTypes #-}
+{-# LANGUAGE ConstrainedClassMethods #-}
+{-# LANGUAGE ConstraintKinds #-}
+{-# LANGUAGE DeriveGeneric #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE InstanceSigs #-}
+{-# LANGUAGE NoImplicitPrelude #-}
+{-# LANGUAGE OverloadedStrings #-}
+
+module Gargantext.Database.Flow -- (flowDatabase, ngrams2list)
+ ( FlowCmdM
+ , flowCorpusFile
+ , flowCorpus
+ , flowCorpusSearchInDatabase
+ , getOrMkRoot
+ , getOrMk_RootWithCorpus
+ , flowAnnuaire
+ )
where
-import GHC.Show (Show)
-import System.FilePath (FilePath)
-import Data.Maybe (Maybe(..), catMaybes)
-import Data.Text (Text, splitOn)
+import Prelude (String)
+import Data.Either
+import Data.Tuple.Extra (first, second)
+import Data.Traversable (traverse)
+import Debug.Trace (trace)
+import Control.Lens ((^.), view, _Just)
+import Control.Monad.IO.Class (liftIO)
+import Data.List (concat)
import Data.Map (Map, lookup)
-import Data.Tuple.Extra (both, second)
-import qualified Data.Map as DM
-
-import Gargantext.Core.Types (NodePoly(..), ListType(..), listTypeId)
-import Gargantext.Database.Bashql (runCmd') -- , del)
-import Gargantext.Database.Config (userMaster, userArbitrary, corpusMasterName)
-import Gargantext.Database.Ngrams (insertNgrams, Ngrams(..), NgramsT(..), NgramsIndexed(..), indexNgramsT, ngramsTypeId, NgramsType(..), text2ngrams)
-import Gargantext.Database.Node (getRoot, mkRoot, mkCorpus, Cmd(..), mkList)--, mkGraph, mkDashboard)--, mkAnnuaire)
-import Gargantext.Database.Node.Document.Add (add)
-import Gargantext.Database.Node.Document.Insert (insertDocuments, ReturnId(..), addUniqIds, ToDbData(..))
-import Gargantext.Database.NodeNgram (NodeNgramPoly(..), insertNodeNgrams)
-import Gargantext.Database.NodeNgramsNgrams (NodeNgramsNgramsPoly(..), insertNodeNgramsNgramsNew)
-import Gargantext.Database.Types.Node (HyperdataDocument(..))
--- import Gargantext.Database.Node.Contact (HyperdataContact(..))
-import Gargantext.Database.User (getUser, UserLight(..), Username)
+import Data.Maybe (Maybe(..), catMaybes)
+import Data.Monoid
+import Data.Text (Text, splitOn, intercalate)
+import Gargantext.Core (Lang(..))
+import Gargantext.Core.Types (NodePoly(..), Terms(..))
+import Gargantext.Core.Types.Individu (Username)
+import Gargantext.Core.Flow.Types
+import Gargantext.Core.Types.Main
+import Gargantext.Database.Config (userMaster, corpusMasterName)
+import Gargantext.Database.Flow.Utils (insertDocNgrams)
+import Gargantext.Database.Flow.List
+import Gargantext.Database.Flow.Types
+import Gargantext.Database.Node.Contact -- (HyperdataContact(..), ContactWho(..))
+import Gargantext.Database.Node.Document.Insert -- (insertDocuments, ReturnId(..), addUniqIdsDoc, addUniqIdsContact, ToDbData(..))
+import Gargantext.Database.Root (getRoot)
+
+import Gargantext.Database.Schema.Ngrams -- (insertNgrams, Ngrams(..), NgramsIndexed(..), indexNgrams, NgramsType(..), text2ngrams, ngramsTypeId)
+import Gargantext.Database.Schema.Node -- (mkRoot, mkCorpus, getOrMkList, mkGraph, {-mkPhylo,-} mkDashboard, mkAnnuaire, getCorporaWithParentId, HasNodeError, NodeError(..), nodeError)
+import Gargantext.Database.Schema.NodeNgrams (listInsertDb , getCgramsId)
+import Gargantext.Database.Schema.NodeNodeNgrams2 -- (NodeNodeNgrams2, insertNodeNodeNgrams2)
+import Gargantext.Database.Schema.User (getUser, UserLight(..))
+import Gargantext.Database.TextSearch (searchInDatabase)
+import Gargantext.Database.Types.Node -- (HyperdataDocument(..), NodeType(..), NodeId, UserId, ListId, CorpusId, RootId, MasterCorpusId, MasterUserId)
+import Gargantext.Database.Utils (Cmd)
import Gargantext.Ext.IMT (toSchoolName)
+import Gargantext.Ext.IMTUser (deserialiseImtUsersFromFile)
import Gargantext.Prelude
-import Gargantext.Text.Parsers (parseDocs, FileFormat)
-
-type UserId = Int
-type RootId = Int
-type CorpusId = Int
-
-flowDatabase :: FileFormat -> FilePath -> CorpusName -> IO Int
-flowDatabase ff fp cName = do
-
- -- Corpus Flow
- (masterUserId, _, corpusId) <- subFlowCorpus userMaster corpusMasterName
-
- -- Documents Flow
- hyperdataDocuments <- map addUniqIds <$> parseDocs ff fp
- let hyperdataDocuments' = map (\h -> ToDbDocument h) hyperdataDocuments
- printDebug "hyperdataDocuments" (length hyperdataDocuments)
-
- ids <- runCmd' $ insertDocuments masterUserId corpusId hyperdataDocuments'
- -- printDebug "Docs IDs : " (ids)
- -- idsRepeat <- runCmd' $ insertDocuments masterUserId corpusId hyperdataDocuments'
- -- printDebug "Repeated Docs IDs : " (length idsRepeat)
- let idsNotRepeated = filter (\r -> reInserted r == True) ids
--- {-
- -- Ngrams Flow
- -- todo: flow for new documents only
- let tids = toInserted ids
- printDebug "toInserted ids" (length tids)
-
- let tihs = toInsert hyperdataDocuments
- printDebug "toInsert hyperdataDocuments" (length tihs)
-
- let documentsWithId = mergeData (toInserted idsNotRepeated) (toInsert hyperdataDocuments)
- -- printDebug "documentsWithId" documentsWithId
-
- -- docsWithNgrams <- documentIdWithNgrams documentsWithId extractNgramsT
- let docsWithNgrams = documentIdWithNgrams extractNgramsT documentsWithId
- -- printDebug "docsWithNgrams" docsWithNgrams
-
- let maps = mapNodeIdNgrams docsWithNgrams
- -- printDebug "maps" (maps)
-
- indexedNgrams <- runCmd' $ indexNgrams maps
- -- printDebug "inserted ngrams" indexedNgrams
- _ <- runCmd' $ insertToNodeNgrams indexedNgrams
-
- -- List Flow
- listId2 <- runCmd' $ listFlow masterUserId corpusId indexedNgrams
- printDebug "list id : " listId2
-
- --(userId, rootUserId, corpusId2) <- subFlowCorpus userArbitrary cName
- --}
- (userId, _, corpusId2) <- subFlowCorpus userArbitrary cName
-
- userListId <- runCmd' $ listFlowUser userId corpusId2
- printDebug "UserList : " userListId
- inserted <- runCmd' $ add corpusId2 (map reId ids)
- printDebug "Inserted : " (length inserted)
-
- --_ <- runCmd' $ mkDashboard corpusId2 userId
- --_ <- runCmd' $ mkGraph corpusId2 userId
-
- -- Annuaire Flow
- -- _ <- runCmd' $ mkAnnuaire rootUserId userId
-
- pure corpusId2
- -- runCmd' $ del [corpusId2, corpusId]
-
-type CorpusName = Text
+import Gargantext.Text.Terms.Eleve (buildTries, toToken)
+import Gargantext.Text.List (buildNgramsLists,StopSize(..))
+import Gargantext.Text.Corpus.Parsers (parseFile, FileFormat)
+import qualified Gargantext.Text.Corpus.API.Isidore as Isidore
+import Gargantext.Text.Terms (TermType(..), tt_lang, extractTerms, uniText)
+import Gargantext.Text.Terms.Mono.Stem.En (stemIt)
+import Gargantext.Prelude.Utils hiding (sha)
+import System.FilePath (FilePath)
+import qualified Data.List as List
+import qualified Data.Map as Map
+import qualified Data.Text as Text
+import qualified Gargantext.Database.Node.Document.Add as Doc (add)
+import qualified Gargantext.Text.Corpus.Parsers.GrandDebat as GD
-subFlowCorpus :: Username -> CorpusName -> IO (UserId, RootId, CorpusId)
-subFlowCorpus username cName = do
- maybeUserId <- runCmd' (getUser username)
+------------------------------------------------------------------------
- let userId = case maybeUserId of
- Nothing -> panic "Error: User does not exist (yet)"
- -- mk NodeUser gargantua_id "Node Gargantua"
- Just user -> userLight_id user
+data ApiQuery = ApiIsidoreQuery Text | ApiIsidoreAuth Text
+-- | APIs
+-- TODO instances
+getDataApi :: Lang
+ -> Maybe Limit
+ -> ApiQuery
+ -> IO [HyperdataDocument]
+getDataApi lang limit (ApiIsidoreQuery q) = Isidore.get lang limit (Just q) Nothing
+getDataApi lang limit (ApiIsidoreAuth q) = Isidore.get lang limit Nothing (Just q)
+
+
+-- UNUSED
+_flowCorpusApi :: ( FlowCmdM env err m)
+ => Username -> Either CorpusName [CorpusId]
+ -> TermType Lang
+ -> Maybe Limit
+ -> ApiQuery
+ -> m CorpusId
+_flowCorpusApi u n tt l q = do
+ docs <- liftIO $ splitEvery 500 <$> getDataApi (_tt_lang tt) l q
+ flowCorpus u n tt docs
- rootId' <- map _node_id <$> runCmd' (getRoot userId)
+------------------------------------------------------------------------
- rootId'' <- case rootId' of
- [] -> runCmd' (mkRoot username userId)
- n -> case length n >= 2 of
- True -> panic "Error: more than 1 userNode / user"
- False -> pure rootId'
- let rootId = maybe (panic "error rootId") identity (head rootId'')
+flowAnnuaire :: FlowCmdM env err m
+ => Username
+ -> Either CorpusName [CorpusId]
+ -> (TermType Lang)
+ -> FilePath
+ -> m AnnuaireId
+flowAnnuaire u n l filePath = do
+ docs <- liftIO $ (( splitEvery 500 <$> deserialiseImtUsersFromFile filePath) :: IO [[HyperdataContact]])
+ flow (Nothing :: Maybe HyperdataAnnuaire) u n l docs
+
+-- UNUSED
+_flowCorpusDebat :: FlowCmdM env err m
+ => Username -> Either CorpusName [CorpusId]
+ -> Limit -> FilePath
+ -> m CorpusId
+_flowCorpusDebat u n l fp = do
+ docs <- liftIO ( splitEvery 500
+ <$> take l
+ <$> readFile' fp
+ :: IO [[GD.GrandDebatReference ]]
+ )
+ flowCorpus u n (Multi FR) (map (map toHyperdataDocument) docs)
+
+flowCorpusFile :: FlowCmdM env err m
+ => Username -> Either CorpusName [CorpusId]
+ -> Limit -- Limit the number of docs (for dev purpose)
+ -> TermType Lang -> FileFormat -> FilePath
+ -> m CorpusId
+flowCorpusFile u n l la ff fp = do
+ docs <- liftIO ( splitEvery 500
+ <$> take l
+ <$> parseFile ff fp
+ )
+ flowCorpus u n la (map (map toHyperdataDocument) docs)
+
+-- TODO query with complex query
+flowCorpusSearchInDatabase :: FlowCmdM env err m
+ => Username
+ -> Lang
+ -> Text
+ -> m CorpusId
+flowCorpusSearchInDatabase u la q = do
+ (_masterUserId, _masterRootId, cId) <- getOrMk_RootWithCorpus
+ userMaster
+ (Left "")
+ (Nothing :: Maybe HyperdataCorpus)
+ ids <- map fst <$> searchInDatabase cId (stemIt q)
+ flowCorpusUser la u (Left q) (Nothing :: Maybe HyperdataCorpus) ids
+
+
+-- UNUSED
+_flowCorpusSearchInDatabaseApi :: FlowCmdM env err m
+ => Username
+ -> Lang
+ -> Text
+ -> m CorpusId
+_flowCorpusSearchInDatabaseApi u la q = do
+ (_masterUserId, _masterRootId, cId) <- getOrMk_RootWithCorpus
+ userMaster
+ (Left "")
+ (Nothing :: Maybe HyperdataCorpus)
+ ids <- map fst <$> searchInDatabase cId (stemIt q)
+ flowCorpusUser la u (Left q) (Nothing :: Maybe HyperdataCorpus) ids
- corpusId' <- runCmd' $ mkCorpus (Just cName) Nothing rootId userId
- let corpusId = maybe (panic "error corpusId") identity (head corpusId')
+------------------------------------------------------------------------
+-- | TODO improve the needed type to create/update a corpus
+{- UNUSED
+data UserInfo = Username Text
+ | UserId NodeId
+data CorpusInfo = CorpusName Lang Text
+ | CorpusId Lang NodeId
+-}
- printDebug "(username, userId, rootId, corpusId)"
- (username, userId, rootId, corpusId)
- pure (userId, rootId, corpusId)
+flow :: (FlowCmdM env err m, FlowCorpus a, MkCorpus c)
+ => Maybe c
+ -> Username
+ -> Either CorpusName [CorpusId]
+ -> TermType Lang
+ -> [[a]]
+ -> m CorpusId
+flow c u cn la docs = do
+ ids <- traverse (insertMasterDocs c la ) docs
+ flowCorpusUser (la ^. tt_lang) u cn c (concat ids)
+
+flowCorpus :: (FlowCmdM env err m, FlowCorpus a)
+ => Username
+ -> Either CorpusName [CorpusId]
+ -> TermType Lang
+ -> [[a]]
+ -> m CorpusId
+flowCorpus = flow (Nothing :: Maybe HyperdataCorpus)
------------------------------------------------------------------------
+flowCorpusUser :: (FlowCmdM env err m, MkCorpus c)
+ => Lang
+ -> Username
+ -> Either CorpusName [CorpusId]
+ -> Maybe c
+ -> [NodeId]
+ -> m CorpusId
+flowCorpusUser l userName corpusName ctype ids = do
+ -- User Flow
+ (userId, _rootId, userCorpusId) <- getOrMk_RootWithCorpus userName corpusName ctype
+ listId <- getOrMkList userCorpusId userId
+ _cooc <- mkNode NodeListCooc listId userId
+ -- TODO: check if present already, ignore
+ _ <- Doc.add userCorpusId ids
+
+ _tId <- mkNode NodeTexts userCorpusId userId
+ -- printDebug "Node Text Id" tId
+
+ -- User List Flow
+ (masterUserId, _masterRootId, masterCorpusId) <- getOrMk_RootWithCorpus userMaster (Left "") ctype
+ ngs <- buildNgramsLists l 2 3 (StopSize 3) userCorpusId masterCorpusId
+ _userListId <- flowList_DbRepo listId ngs
+ _mastListId <- getOrMkList masterCorpusId masterUserId
+ -- _ <- insertOccsUpdates userCorpusId mastListId
+ -- printDebug "userListId" userListId
+ -- User Graph Flow
+ _ <- mkDashboard userCorpusId userId
+ _ <- mkGraph userCorpusId userId
+ --_ <- mkPhylo userCorpusId userId
-type HashId = Text
-type NodeId = Int
-type ListId = Int
-
-toInsert :: [HyperdataDocument] -> Map HashId HyperdataDocument
-toInsert = DM.fromList . map (\d -> (hash (_hyperdataDocument_uniqId d), d))
+ -- Annuaire Flow
+ -- _ <- mkAnnuaire rootUserId userId
+ pure userCorpusId
+
+
+insertMasterDocs :: ( FlowCmdM env err m
+ , FlowCorpus a
+ , MkCorpus c
+ )
+ => Maybe c
+ -> TermType Lang
+ -> [a]
+ -> m [DocId]
+insertMasterDocs c lang hs = do
+ (masterUserId, _, masterCorpusId) <- getOrMk_RootWithCorpus userMaster (Left corpusMasterName) c
+
+ -- TODO Type NodeDocumentUnicised
+ let docs = map addUniqId hs
+ ids <- insertDb masterUserId masterCorpusId docs
+ let
+ ids' = map reId ids
+ documentsWithId = mergeData (toInserted ids) (Map.fromList $ map viewUniqId' docs)
+ -- TODO
+ -- create a corpus with database name (CSV or PubMed)
+ -- add documents to the corpus (create node_node link)
+ -- this will enable global database monitoring
+
+ -- maps :: IO Map Ngrams (Map NgramsType (Map NodeId Int))
+ maps <- mapNodeIdNgrams
+ <$> documentIdWithNgrams (extractNgramsT $ withLang lang documentsWithId) documentsWithId
+
+ terms2id <- insertNgrams $ Map.keys maps
+ -- to be removed
+ let indexedNgrams = Map.mapKeys (indexNgrams terms2id) maps
+
+ -- new
+ lId <- getOrMkList masterCorpusId masterUserId
+ mapCgramsId <- listInsertDb lId toNodeNgramsW'
+ $ map (first _ngramsTerms . second Map.keys)
+ $ Map.toList maps
+ -- insertDocNgrams
+ _return <- insertNodeNodeNgrams2
+ $ catMaybes [ NodeNodeNgrams2 <$> Just nId
+ <*> getCgramsId mapCgramsId ngrams_type (_ngramsTerms terms)
+ <*> Just (fromIntegral w :: Double)
+ | (terms, mapNgramsTypes) <- Map.toList maps
+ , (ngrams_type, mapNodeIdWeight) <- Map.toList mapNgramsTypes
+ , (nId, w) <- Map.toList mapNodeIdWeight
+ ]
+
+ _ <- Doc.add masterCorpusId ids'
+ _cooc <- mkNode NodeListCooc lId masterUserId
+ -- to be removed
+ _ <- insertDocNgrams lId indexedNgrams
+
+ pure ids'
+
+
+withLang :: HasText a => TermType Lang
+ -> [DocumentWithId a]
+ -> TermType Lang
+withLang (Unsupervised l n s m) ns = Unsupervised l n s m'
where
- hash = maybe "Error" identity
+ m' = case m of
+ Nothing -> trace ("buildTries here" :: String)
+ $ Just
+ $ buildTries n ( fmap toToken $ uniText
+ $ Text.intercalate " . "
+ $ List.concat
+ $ map hasText ns
+ )
+ just_m -> just_m
+withLang l _ = l
-toInserted :: [ReturnId] -> Map HashId ReturnId
-toInserted rs = DM.fromList $ map (\r -> (reUniqId r, r) )
- $ filter (\r -> reInserted r == True) rs
-data DocumentWithId =
- DocumentWithId { documentId :: NodeId
- , documentData :: HyperdataDocument
- } deriving (Show)
-mergeData :: Map HashId ReturnId -> Map HashId HyperdataDocument -> [DocumentWithId]
-mergeData rs = catMaybes . map toDocumentWithId . DM.toList
- where
- toDocumentWithId (hash,hpd) =
- DocumentWithId <$> fmap reId (lookup hash rs)
- <*> Just hpd
+type CorpusName = Text
-------------------------------------------------------------------------
-data DocumentIdWithNgrams =
- DocumentIdWithNgrams
- { documentWithId :: DocumentWithId
- , document_ngrams :: Map (NgramsT Ngrams) Int
- } deriving (Show)
-
--- TODO add Terms (Title + Abstract)
--- add f :: Text -> Text
--- newtype Ngrams = Ngrams Text
-extractNgramsT :: HyperdataDocument -> Map (NgramsT Ngrams) Int
-extractNgramsT doc = DM.fromList $ [(NgramsT Sources source, 1)]
- <> [(NgramsT Institutes i' , 1)| i' <- institutes ]
- <> [(NgramsT Authors a' , 1)| a' <- authors ]
- where
- source = text2ngrams $ maybe "Nothing" identity $ _hyperdataDocument_source doc
- institutes = map text2ngrams $ maybe ["Nothing"] (map toSchoolName . (splitOn ", ")) $ _hyperdataDocument_institutes doc
- authors = map text2ngrams $ maybe ["Nothing"] (splitOn ", ") $ _hyperdataDocument_authors doc
- -- TODO group terms
-
-documentIdWithNgrams :: (HyperdataDocument -> Map (NgramsT Ngrams) Int)
- -> [DocumentWithId] -> [DocumentIdWithNgrams]
-documentIdWithNgrams f = map (\d -> DocumentIdWithNgrams d ((f . documentData) d))
-
--- | TODO check optimization
-mapNodeIdNgrams :: [DocumentIdWithNgrams] -> Map (NgramsT Ngrams) (Map NodeId Int)
-mapNodeIdNgrams ds = DM.map (DM.fromListWith (+)) $ DM.fromListWith (<>) xs
- where
- xs = [(ng, [(nId, i)]) | (nId, n2i') <- n2i ds, (ng, i) <- DM.toList n2i']
- n2i = map (\d -> ((documentId . documentWithId) d, document_ngrams d))
+getOrMkRoot :: (HasNodeError err)
+ => Username
+ -> Cmd err (UserId, RootId)
+getOrMkRoot username = do
+ maybeUserId <- getUser username
+ userId <- case maybeUserId of
+ Nothing -> nodeError NoUserFound
+ Just user -> pure $ userLight_id user
-indexNgrams :: Map (NgramsT Ngrams ) (Map NodeId Int)
- -> Cmd (Map (NgramsT NgramsIndexed) (Map NodeId Int))
-indexNgrams ng2nId = do
- terms2id <- insertNgrams (map _ngramsT $ DM.keys ng2nId)
- pure $ DM.mapKeys (indexNgramsT terms2id) ng2nId
+ rootId' <- map _node_id <$> getRoot username
+ rootId'' <- case rootId' of
+ [] -> mkRoot username userId
+ n -> case length n >= 2 of
+ True -> nodeError ManyNodeUsers
+ False -> pure rootId'
-insertToNodeNgrams :: Map (NgramsT NgramsIndexed) (Map NodeId Int) -> Cmd Int
-insertToNodeNgrams m = insertNodeNgrams [ NodeNgram Nothing nId ((_ngramsId . _ngramsT ) ng)
- (fromIntegral n) ((ngramsTypeId . _ngramsType) ng)
- | (ng, nId2int) <- DM.toList m
- , (nId, n) <- DM.toList nId2int
- ]
+ rootId <- maybe (nodeError NoRootFound) pure (head rootId'')
+ pure (userId, rootId)
+
+
+getOrMk_RootWithCorpus :: (HasNodeError err, MkCorpus a)
+ => Username
+ -> Either CorpusName [CorpusId]
+ -> Maybe a
+ -> Cmd err (UserId, RootId, CorpusId)
+getOrMk_RootWithCorpus username cName c = do
+ (userId, rootId) <- getOrMkRoot username
+ corpusId'' <- if username == userMaster
+ then do
+ ns <- getCorporaWithParentId rootId
+ pure $ map _node_id ns
+ else
+ pure $ fromRight [] cName
+
+ corpusId' <- if corpusId'' /= []
+ then pure corpusId''
+ else do
+ c' <- mk (Just $ fromLeft "Default" cName) c rootId userId
+ _tId <- case head c' of
+ Nothing -> pure [0]
+ Just c'' -> mkNode NodeTexts c'' userId
+ pure c'
+
+ corpusId <- maybe (nodeError NoCorpusFound) pure (head corpusId')
+ pure (userId, rootId, corpusId)
------------------------------------------------------------------------
-------------------------------------------------------------------------
-listFlow :: UserId -> CorpusId -> Map (NgramsT NgramsIndexed) (Map NodeId Int) -> Cmd ListId
-listFlow uId cId ngs = do
- -- printDebug "ngs:" ngs
- lId <- maybe (panic "mkList error") identity <$> head <$> mkList cId uId
- --printDebug "ngs" (DM.keys ngs)
- -- TODO add stemming equivalence of 2 ngrams
- let groupEd = groupNgramsBy (\(NgramsT t1 n1) (NgramsT t2 n2) -> if (((==) t1 t2) && ((==) n1 n2)) then (Just (n1,n2)) else Nothing) ngs
- _ <- insertGroups lId groupEd
-
--- compute Candidate / Map
- let lists = ngrams2list ngs
- -- printDebug "lists:" lists
-
- is <- insertLists lId lists
- printDebug "listNgrams inserted :" is
-
- pure lId
-
-listFlowUser :: UserId -> CorpusId -> Cmd [Int]
-listFlowUser uId cId = mkList cId uId
+viewUniqId' :: UniqId a
+ => a
+ -> (HashId, a)
+viewUniqId' d = maybe err (\h -> (h,d)) (view uniqId d)
+ where
+ err = panic "[ERROR] Database.Flow.toInsert"
+
+
+toInserted :: [ReturnId]
+ -> Map HashId ReturnId
+toInserted =
+ Map.fromList . map (\r -> (reUniqId r, r) )
+ . filter (\r -> reInserted r == True)
+
+mergeData :: Map HashId ReturnId
+ -> Map HashId a
+ -> [DocumentWithId a]
+mergeData rs = catMaybes . map toDocumentWithId . Map.toList
+ where
+ toDocumentWithId (sha,hpd) =
+ DocumentWithId <$> fmap reId (lookup sha rs)
+ <*> Just hpd
------------------------------------------------------------------------
-groupNgramsBy :: (NgramsT NgramsIndexed -> NgramsT NgramsIndexed -> Maybe (NgramsIndexed, NgramsIndexed))
- -> Map (NgramsT NgramsIndexed) (Map NodeId Int)
- -> Map NgramsIndexed NgramsIndexed
-groupNgramsBy isEqual cId = DM.fromList $ catMaybes [ isEqual n1 n2 | n1 <- DM.keys cId, n2 <- DM.keys cId]
-
-
+instance HasText HyperdataContact
+ where
+ hasText = undefined
--- TODO check: do not insert duplicates
-insertGroups :: ListId -> Map NgramsIndexed NgramsIndexed -> Cmd Int
-insertGroups lId ngrs =
- insertNodeNgramsNgramsNew [ NodeNgramsNgrams lId ng1 ng2 (Just 1)
- | (ng1, ng2) <- map (both _ngramsId) $ DM.toList ngrs
- , ng1 /= ng2
- ]
+instance ExtractNgramsT HyperdataContact
+ where
+ extractNgramsT l hc = filterNgramsT 255 <$> extract l hc
+ where
+ extract :: TermType Lang -> HyperdataContact
+ -> Cmd err (Map Ngrams (Map NgramsType Int))
+ extract _l hc' = do
+ let authors = map text2ngrams
+ $ maybe ["Nothing"] (\a -> [a])
+ $ view (hc_who . _Just . cw_lastName) hc'
+
+ pure $ Map.fromList $ [(a', Map.singleton Authors 1) | a' <- authors ]
+
+instance HasText HyperdataDocument
+ where
+ hasText h = catMaybes [ _hyperdataDocument_title h
+ , _hyperdataDocument_abstract h
+ ]
-------------------------------------------------------------------------
--- TODO: verify NgramsT lost here
-ngrams2list :: Map (NgramsT NgramsIndexed) (Map NodeId Int) -> [(ListType,NgramsIndexed)]
-ngrams2list = zip (repeat CandidateList) . map (\(NgramsT _lost_t ng) -> ng) . DM.keys
+instance ExtractNgramsT HyperdataDocument
+ where
+ extractNgramsT :: TermType Lang
+ -> HyperdataDocument
+ -> Cmd err (Map Ngrams (Map NgramsType Int))
+ extractNgramsT lang hd = filterNgramsT 255 <$> extractNgramsT' lang hd
+ where
+ extractNgramsT' :: TermType Lang
+ -> HyperdataDocument
+ -> Cmd err (Map Ngrams (Map NgramsType Int))
+ extractNgramsT' lang' doc = do
+ let source = text2ngrams
+ $ maybe "Nothing" identity
+ $ _hyperdataDocument_source doc
+
+ institutes = map text2ngrams
+ $ maybe ["Nothing"] (map toSchoolName . (splitOn ", "))
+ $ _hyperdataDocument_institutes doc
+
+ authors = map text2ngrams
+ $ maybe ["Nothing"] (splitOn ", ")
+ $ _hyperdataDocument_authors doc
+
+ terms' <- map text2ngrams
+ <$> map (intercalate " " . _terms_label)
+ <$> concat
+ <$> liftIO (extractTerms lang' $ hasText doc)
+
+ pure $ Map.fromList $ [(source, Map.singleton Sources 1)]
+ <> [(i', Map.singleton Institutes 1) | i' <- institutes ]
+ <> [(a', Map.singleton Authors 1) | a' <- authors ]
+ <> [(t', Map.singleton NgramsTerms 1) | t' <- terms' ]
+
+filterNgramsT :: Int -> Map Ngrams (Map NgramsType Int)
+ -> Map Ngrams (Map NgramsType Int)
+filterNgramsT s ms = Map.fromList $ map (\a -> filter' s a) $ Map.toList ms
+ where
+ filter' s' (ng@(Ngrams t n),y) = case (Text.length t) < s' of
+ True -> (ng,y)
+ False -> (Ngrams (Text.take s' t) n , y)
--- | TODO: weight of the list could be a probability
-insertLists :: ListId -> [(ListType,NgramsIndexed)] -> Cmd Int
-insertLists lId lngs =
- insertNodeNgrams [ NodeNgram Nothing lId ngr (fromIntegral $ listTypeId l) (listTypeId l)
- | (l,ngr) <- map (second _ngramsId) lngs
- ]
-------------------------------------------------------------------------
-------------------------------------------------------------------------
+documentIdWithNgrams :: HasNodeError err
+ => (a
+ -> Cmd err (Map Ngrams (Map NgramsType Int)))
+ -> [DocumentWithId a]
+ -> Cmd err [DocumentIdWithNgrams a]
+documentIdWithNgrams f = traverse toDocumentIdWithNgrams
+ where
+ toDocumentIdWithNgrams d = do
+ e <- f $ documentData d
+ pure $ DocumentIdWithNgrams d e