Skip to content

haskell-gargantext
haskell-gargantext
Commit 7782c515 authored by Alexandre Delanoë's avatar Alexandre Delanoë
Browse files
Options

[FEAT] enabling FlowSocialList With preferences

parent 4e134509
Hide whitespace changes
Inline Side-by-side
Showing with 65 additions and 37 deletions
bin/gargantext-import/Main.hs
View file @ 7782c515
......@@ -47,10 +47,10 @@ main = do
tt = (Multi EN)
format = CsvGargV3 -- CsvHal --WOS
corpus :: forall m. FlowCmdM DevEnv GargError m => m CorpusId
corpus = flowCorpusFile (UserName $ cs user) (Left (cs name :: Text)) (read limit :: Int) tt format corpusPath
corpus = flowCorpusFile (UserName $ cs user) (Left (cs name :: Text)) (read limit :: Int) tt format corpusPath Nothing
corpusCsvHal :: forall m. FlowCmdM DevEnv GargError m => m CorpusId
corpusCsvHal = flowCorpusFile (UserName $ cs user) (Left (cs name :: Text)) (read limit :: Int) tt CsvHal corpusPath
corpusCsvHal = flowCorpusFile (UserName $ cs user) (Left (cs name :: Text)) (read limit :: Int) tt CsvHal corpusPath Nothing
annuaire :: forall m. FlowCmdM DevEnv GargError m => m CorpusId
annuaire = flowAnnuaire (UserName $ cs user) (Left "Annuaire") (Multi EN) corpusPath
......
src/Gargantext/API/Node/Contact.hs
View file @ 7782c515
......@@ -92,7 +92,7 @@ addContact u nId (AddContactParams fn ln) logStatus = do
, _scst_remaining = Just 1
, _scst_events = Just []
}
_ <- flow (Nothing :: Maybe HyperdataAnnuaire) u (Right [nId]) (Multi EN) [[hyperdataContact fn ln]]
_ <- flow (Nothing :: Maybe HyperdataAnnuaire) u (Right [nId]) (Multi EN) Nothing [[hyperdataContact fn ln]]
pure JobLog { _scst_succeeded = Just 2
, _scst_failed = Just 0
......
src/Gargantext/API/Node/Corpus/New.hs
View file @ 7782c515
......@@ -137,6 +137,7 @@ data WithQuery = WithQuery
, _wq_datafield :: !Datafield
, _wq_lang :: !Lang
, _wq_node_id :: !Int
-- , _wq_flowListWith :: !FlowSocialListWith
}
deriving Generic
......@@ -213,7 +214,7 @@ addToCorpusWithQuery user cid (WithQuery q dbs datafield l _nid) maybeLimit logS
, _scst_events = Just []
}
cids <- mapM (\txt -> flowDataText user txt (Multi l) cid) txts
cids <- mapM (\txt -> flowDataText user txt (Multi l) cid Nothing) txts
printDebug "corpus id" cids
printDebug "sending email" ("xxxxxxxxxxxxxxxxxxxxx" :: Text)
sendMail user
......@@ -265,6 +266,7 @@ addToCorpusWithForm user cid (NewWithForm ft d l _n) logStatus jobLog = do
_cid' <- flowCorpus user
(Right [cid])
(Multi $ fromMaybe EN l)
Nothing
(map (map toHyperdataDocument) docs)
printDebug "Extraction finished : " cid
......
src/Gargantext/API/Search.hs
View file @ 7782c515
......@@ -66,7 +66,7 @@ api nId (SearchQuery q SearchContact) o l order = do
<$> SearchResultContact
<$> map (toRow aId)
<$> searchInCorpusWithContacts nId aId q o l order
api _ _ _ _ _ = undefined
api _ _ _ _ _ = panic "[G.A.Search.api] undefined"
-----------------------------------------------------------------------
-----------------------------------------------------------------------
......
src/Gargantext/Core/Text/List.hs
View file @ 7782c515
......@@ -67,14 +67,15 @@ buildNgramsLists :: ( HasNodeStory env err m
, HasTreeError err
, HasNodeError err
)
=> GroupParams
-> User
=> User
-> UserCorpusId
-> MasterCorpusId
-> Maybe FlowSocialListWith
-> GroupParams
-> m (Map NgramsType [NgramsElement])
buildNgramsLists gp user uCid mCid = do
ngTerms <- buildNgramsTermsList user uCid mCid gp (NgramsTerms, MapListSize 350)
othersTerms <- mapM (buildNgramsOthersList user uCid GroupIdentity)
buildNgramsLists user uCid mCid mfslw gp = do
ngTerms <- buildNgramsTermsList user uCid mCid mfslw gp (NgramsTerms, MapListSize 350)
othersTerms <- mapM (buildNgramsOthersList user uCid mfslw GroupIdentity)
[ (Authors , MapListSize 9)
, (Sources , MapListSize 9)
, (Institutes, MapListSize 9)
......@@ -92,15 +93,16 @@ buildNgramsOthersList ::( HasNodeError err
)
=> User
-> UserCorpusId
-> Maybe FlowSocialListWith
-> GroupParams
-> (NgramsType, MapListSize)
-> m (Map NgramsType [NgramsElement])
buildNgramsOthersList user uCid _groupParams (nt, MapListSize mapListSize) = do
buildNgramsOthersList user uCid mfslw _groupParams (nt, MapListSize mapListSize) = do
allTerms :: HashMap NgramsTerm (Set NodeId) <- getNodesByNgramsUser uCid nt
-- PrivateFirst for first developments since Public NodeMode is not implemented yet
socialLists :: FlowCont NgramsTerm FlowListScores
<- flowSocialList MySelfFirst user nt ( FlowCont HashMap.empty
<- flowSocialList mfslw user nt ( FlowCont HashMap.empty
$ HashMap.fromList
$ List.zip (HashMap.keys allTerms)
(List.cycle [mempty])
......@@ -149,10 +151,11 @@ buildNgramsTermsList :: ( HasNodeError err
=> User
-> UserCorpusId
-> MasterCorpusId
-> Maybe FlowSocialListWith
-> GroupParams
-> (NgramsType, MapListSize)
-> m (Map NgramsType [NgramsElement])
buildNgramsTermsList user uCid mCid groupParams (nt, _mapListSize)= do
buildNgramsTermsList user uCid mCid mfslw groupParams (nt, _mapListSize)= do
-- Filter 0 With Double
-- Computing global speGen score
......@@ -163,7 +166,7 @@ buildNgramsTermsList user uCid mCid groupParams (nt, _mapListSize)= do
printDebug "[buldNgramsTermsList: Flow Social List / start]" nt
-- PrivateFirst for first developments since Public NodeMode is not implemented yet
socialLists :: FlowCont NgramsTerm FlowListScores
<- flowSocialList MySelfFirst user nt ( FlowCont HashMap.empty
<- flowSocialList mfslw user nt ( FlowCont HashMap.empty
$ HashMap.fromList
$ List.zip (HashMap.keys allTerms)
(List.cycle [mempty])
......
src/Gargantext/Core/Text/List/Social.hs
View file @ 7782c515
......@@ -36,8 +36,12 @@ import Gargantext.Prelude
-- | FlowSocialListPriority
-- Sociological assumption: either private or others (public) first
-- This parameter depends on the user choice
data FlowSocialListPriority = MySelfFirst | OthersFirst
data FlowSocialListWith = FlowSocialListWithPriority { fslw_priority :: FlowSocialListPriority }
| FlowSocialListWithLists { fslw_lists :: [ListId] }
data FlowSocialListPriority = MySelfFirst | OthersFirst
flowSocialListPriority :: FlowSocialListPriority -> [NodeMode]
flowSocialListPriority MySelfFirst = [Private{-, Shared, Public -}]
flowSocialListPriority OthersFirst = reverse $ flowSocialListPriority MySelfFirst
......@@ -55,11 +59,25 @@ flowSocialList :: ( HasNodeStory env err m
, HasNodeError err
, HasTreeError err
)
=> Maybe FlowSocialListWith
-> User
-> NgramsType
-> FlowCont NgramsTerm FlowListScores
-> 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' :: ( HasNodeStory env err m
, CmdM env err m
, HasNodeError err
, HasTreeError err
)
=> FlowSocialListPriority
-> User -> NgramsType
-> FlowCont NgramsTerm FlowListScores
-> m (FlowCont NgramsTerm FlowListScores)
flowSocialList flowPriority user nt flc =
flowSocialList' flowPriority user nt flc =
mconcat <$> mapM (flowSocialListByMode' user nt flc)
(flowSocialListPriority flowPriority)
where
......@@ -88,25 +106,22 @@ flowSocialList flowPriority user nt flc =
-> [ListId]
-> m (FlowCont NgramsTerm FlowListScores)
flowSocialListByModeWith nt'' flc'' listes =
getHistoryScores History_User nt'' flc'' listes
{-
mapM (\l -> getListNgrams [l] nt'') listes
>>= pure
. toFlowListScores (keepAllParents nt'') flc''
-}
getHistoryScores listes History_User nt'' flc''
-----------------------------------------------------------------
getHistoryScores :: ( HasNodeStory env err m
, CmdM env err m
, HasNodeError err
, HasTreeError err
)
=> History
=> [ListId]
-> History
-> NgramsType
-> FlowCont NgramsTerm FlowListScores
-> [ListId]
-> m (FlowCont NgramsTerm FlowListScores)
getHistoryScores hist nt fl listes =
addScorePatches nt listes fl <$> getHistory hist nt listes
getHistoryScores lists hist nt fl =
addScorePatches nt lists fl <$> getHistory hist nt lists
getHistory :: ( HasNodeStory env err m
, CmdM env err m
......
src/Gargantext/Database/Action/Delete.hs
View file @ 7782c515
......@@ -36,7 +36,9 @@ import Gargantext.Prelude
import qualified Gargantext.Database.GargDB as GargDB
------------------------------------------------------------------------
-- TODO
-- Delete Corpus children accoring its types
-- Delete NodeList (NodeStory + cbor file)
deleteNode :: (HasConfig env, HasConnectionPool env, HasNodeError err)
=> User
-> NodeId
......@@ -44,7 +46,7 @@ deleteNode :: (HasConfig env, HasConnectionPool env, HasNodeError err)
deleteNode u nodeId = do
node' <- N.getNode nodeId
case (view node_typename node') of
nt | nt == toDBid NodeUser -> panic "Not allowed to delete NodeUser (yet)"
nt | nt == toDBid NodeUser -> panic "[G.D.A.D.deleteNode] Not allowed to delete NodeUser (yet)"
nt | nt == toDBid NodeTeam -> do
uId <- getUserId u
if _node_user_id node' == uId
......
src/Gargantext/Database/Action/Flow.hs
View file @ 7782c515
......@@ -72,6 +72,7 @@ import Gargantext.Core.Text
import Gargantext.Core.Text.List.Group.WithStem ({-StopSize(..),-} GroupParams(..))
import Gargantext.Core.Text.Corpus.Parsers (parseFile, FileFormat)
import Gargantext.Core.Text.List (buildNgramsLists)
import Gargantext.Core.Text.List.Social (FlowSocialListWith)
import Gargantext.Core.Text.Terms
import Gargantext.Core.Text.Terms.Mono.Stem.En (stemIt)
import Gargantext.Core.Types (POS(NP))
......@@ -151,11 +152,12 @@ flowDataText :: ( FlowCmdM env err m
-> DataText
-> TermType Lang
-> CorpusId
-> Maybe FlowSocialListWith
-> m CorpusId
flowDataText u (DataOld ids) tt cid = flowCorpusUser (_tt_lang tt) u (Right [cid]) corpusType ids
flowDataText u (DataOld ids) tt cid mfslw = flowCorpusUser (_tt_lang tt) u (Right [cid]) corpusType ids mfslw
where
corpusType = (Nothing :: Maybe HyperdataCorpus)
flowDataText u (DataNew txt) tt cid = flowCorpus u (Right [cid]) tt txt
flowDataText u (DataNew txt) tt cid mfslw = flowCorpus u (Right [cid]) tt mfslw txt
------------------------------------------------------------------------
-- TODO use proxy
......@@ -167,7 +169,7 @@ flowAnnuaire :: (FlowCmdM env err m)
-> m AnnuaireId
flowAnnuaire u n l filePath = do
docs <- liftBase $ (( splitEvery 500 <$> readFile_Annuaire filePath) :: IO [[HyperdataContact]])
flow (Nothing :: Maybe HyperdataAnnuaire) u n l docs
flow (Nothing :: Maybe HyperdataAnnuaire) u n l Nothing docs
------------------------------------------------------------------------
flowCorpusFile :: (FlowCmdM env err m)
......@@ -175,13 +177,14 @@ flowCorpusFile :: (FlowCmdM env err m)
-> Either CorpusName [CorpusId]
-> Limit -- Limit the number of docs (for dev purpose)
-> TermType Lang -> FileFormat -> FilePath
-> Maybe FlowSocialListWith
-> m CorpusId
flowCorpusFile u n l la ff fp = do
flowCorpusFile u n l la ff fp mfslw = do
eParsed <- liftBase $ parseFile ff fp
case eParsed of
Right parsed -> do
let docs = splitEvery 500 $ take l parsed
flowCorpus u n la (map (map toHyperdataDocument) docs)
flowCorpus u n la mfslw (map (map toHyperdataDocument) docs)
Left e -> panic $ "Error: " <> (T.pack e)
------------------------------------------------------------------------
......@@ -191,6 +194,7 @@ flowCorpus :: (FlowCmdM env err m, FlowCorpus a)
=> User
-> Either CorpusName [CorpusId]
-> TermType Lang
-> Maybe FlowSocialListWith
-> [[a]]
-> m CorpusId
flowCorpus = flow (Nothing :: Maybe HyperdataCorpus)
......@@ -204,12 +208,13 @@ flow :: ( FlowCmdM env err m
-> User
-> Either CorpusName [CorpusId]
-> TermType Lang
-> Maybe FlowSocialListWith
-> [[a]]
-> m CorpusId
flow c u cn la docs = do
flow c u cn la mfslw docs = do
-- TODO if public insertMasterDocs else insertUserDocs
ids <- traverse (insertMasterDocs c la) docs
flowCorpusUser (la ^. tt_lang) u cn c (concat ids)
flowCorpusUser (la ^. tt_lang) u cn c (concat ids) mfslw
------------------------------------------------------------------------
flowCorpusUser :: ( FlowCmdM env err m
......@@ -220,8 +225,9 @@ flowCorpusUser :: ( FlowCmdM env err m
-> Either CorpusName [CorpusId]
-> Maybe c
-> [NodeId]
-> Maybe FlowSocialListWith
-> m CorpusId
flowCorpusUser l user corpusName ctype ids = do
flowCorpusUser l user corpusName ctype ids mfslw = do
-- User Flow
(userId, _rootId, userCorpusId) <- getOrMk_RootWithCorpus user corpusName ctype
-- NodeTexts is first
......@@ -242,7 +248,7 @@ flowCorpusUser l user corpusName ctype ids = do
--let gp = (GroupParams l 2 3 (StopSize 3))
let gp = GroupWithPosTag l CoreNLP HashMap.empty
ngs <- buildNgramsLists gp user userCorpusId masterCorpusId
ngs <- buildNgramsLists user userCorpusId masterCorpusId mfslw gp
_userListId <- flowList_DbRepo listId ngs
_mastListId <- getOrMkList masterCorpusId masterUserId
......
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment