[refactor] more typeclass refactorings

FlowCmdM -> DBCmd or HasNodeStory is usually enough
parent 8d3f7def
Pipeline #5232 failed with stages
in 130 minutes and 25 seconds
......@@ -26,6 +26,7 @@ import Gargantext.API.HashedResponse
import Gargantext.API.Ngrams.NgramsTree
import Gargantext.API.Ngrams.Types
import Gargantext.API.Prelude (GargServer)
import Gargantext.Core.NodeStory (HasNodeStory)
import Gargantext.Core.Text.Metrics (Scored(..), {-normalizeGlobal,-} normalizeLocal)
import Gargantext.Core.Types (CorpusId, ListId, ListType(..))
import Gargantext.Core.Types.Query (Limit)
......@@ -34,7 +35,6 @@ import Gargantext.Core.Viz.Types
import Gargantext.Database.Admin.Types.Hyperdata (HyperdataList(..), hl_chart, hl_pie, hl_scatter, hl_tree)
import Gargantext.Database.Admin.Types.Metrics (ChartMetrics(..), Metric(..), Metrics(..))
import Gargantext.Database.Admin.Types.Node (NodeId)
import Gargantext.Database.Action.Flow.Types (FlowCmdM)
import Gargantext.Database.Prelude
import Gargantext.Database.Query.Table.Node (defaultList, getNodeWith)
import Gargantext.Database.Query.Table.Node.Error (HasNodeError)
......@@ -67,12 +67,12 @@ scatterApi id' = getScatter id'
:<|> updateScatter id'
:<|> getScatterHash id'
getScatter :: FlowCmdM env err m =>
CorpusId
-> Maybe ListId
-> TabType
-> Maybe Limit
-> m (HashedResponse Metrics)
getScatter :: HasNodeStory env err m
=> CorpusId
-> Maybe ListId
-> TabType
-> Maybe Limit
-> m (HashedResponse Metrics)
getScatter cId maybeListId tabType _maybeLimit = do
listId <- case maybeListId of
Just lid -> pure lid
......@@ -84,32 +84,35 @@ getScatter cId maybeListId tabType _maybeLimit = do
chart <- case mChart of
Just chart -> pure chart
Nothing -> do
updateScatter' cId maybeListId tabType Nothing
updateScatter' cId listId tabType Nothing
pure $ constructHashedResponse chart
updateScatter :: FlowCmdM env err m =>
CorpusId
-> Maybe ListId
-> TabType
-> Maybe Limit
-> m ()
updateScatter :: HasNodeStory env err m
=> CorpusId
-> Maybe ListId
-> TabType
-> Maybe Limit
-> m ()
updateScatter cId maybeListId tabType maybeLimit = do
listId <- case maybeListId of
Just lid -> pure lid
Nothing -> defaultList cId
-- printDebug "[updateScatter] cId" cId
-- printDebug "[updateScatter] maybeListId" maybeListId
-- printDebug "[updateScatter] tabType" tabType
-- printDebug "[updateScatter] maybeLimit" maybeLimit
_ <- updateScatter' cId maybeListId tabType maybeLimit
_ <- updateScatter' cId listId tabType maybeLimit
pure ()
updateScatter' :: FlowCmdM env err m =>
CorpusId
-> Maybe ListId
-> TabType
-> Maybe Limit
-> m Metrics
updateScatter' cId maybeListId tabType maybeLimit = do
(ngs', scores) <- Metrics.getMetrics cId maybeListId tabType maybeLimit
updateScatter' :: HasNodeStory env err m
=> CorpusId
-> ListId
-> TabType
-> Maybe Limit
-> m Metrics
updateScatter' cId listId tabType maybeLimit = do
(ngs', scores) <- Metrics.getMetrics cId listId tabType maybeLimit
let
metrics = fmap (\(Scored t s1 s2) -> Metric { m_label = unNgramsTerm t
......@@ -120,9 +123,6 @@ updateScatter' cId maybeListId tabType maybeLimit = do
listType t m = maybe (panic errorMsg) fst $ HashMap.lookup t m
errorMsg = "API.Node.metrics: key absent"
listId <- case maybeListId of
Just lid -> pure lid
Nothing -> defaultList cId
node <- getNodeWith listId (Proxy :: Proxy HyperdataList)
let hl = node ^. node_hyperdata
scatterMap = hl ^. hl_scatter
......@@ -130,11 +130,11 @@ updateScatter' cId maybeListId tabType maybeLimit = do
pure $ Metrics metrics
getScatterHash :: FlowCmdM env err m =>
CorpusId
-> Maybe ListId
-> TabType
-> m Text
getScatterHash :: HasNodeStory env err m
=> CorpusId
-> Maybe ListId
-> TabType
-> m Text
getScatterHash cId maybeListId tabType = do
hash <$> getScatter cId maybeListId tabType Nothing
......@@ -163,8 +163,8 @@ chartApi id' = getChart id'
:<|> getChartHash id'
-- TODO add start / end
getChart :: FlowCmdM env err m =>
CorpusId
getChart :: HasNodeStory env err m
=> CorpusId
-> Maybe UTCTime
-> Maybe UTCTime
-> Maybe ListId
......@@ -181,7 +181,7 @@ getChart cId _start _end maybeListId tabType = do
chart <- case mChart of
Just chart -> pure chart
Nothing -> do
updateChart' cId maybeListId tabType Nothing
updateChart' cId listId tabType Nothing
pure $ constructHashedResponse chart
......@@ -192,23 +192,23 @@ updateChart :: HasNodeError err =>
-> Maybe Limit
-> DBCmd err ()
updateChart cId maybeListId tabType maybeLimit = do
listId <- case maybeListId of
Just lid -> pure lid
Nothing -> defaultList cId
printDebug "[updateChart] cId" cId
printDebug "[updateChart] maybeListId" maybeListId
printDebug "[updateChart] listId" listId
printDebug "[updateChart] tabType" tabType
printDebug "[updateChart] maybeLimit" maybeLimit
_ <- updateChart' cId maybeListId tabType maybeLimit
_ <- updateChart' cId listId tabType maybeLimit
pure ()
updateChart' :: HasNodeError err =>
CorpusId
-> Maybe ListId
-> ListId
-> TabType
-> Maybe Limit
-> DBCmd err (ChartMetrics Histo)
updateChart' cId maybeListId tabType _maybeLimit = do
listId <- case maybeListId of
Just lid -> pure lid
Nothing -> defaultList cId
updateChart' cId listId tabType _maybeLimit = do
node <- getNodeWith listId (Proxy :: Proxy HyperdataList)
let hl = node ^. node_hyperdata
chartMap = hl ^. hl_chart
......@@ -218,11 +218,11 @@ updateChart' cId maybeListId tabType _maybeLimit = do
pure $ ChartMetrics h
getChartHash :: FlowCmdM env err m =>
CorpusId
-> Maybe ListId
-> TabType
-> m Text
getChartHash :: HasNodeStory env err m
=> CorpusId
-> Maybe ListId
-> TabType
-> m Text
getChartHash cId maybeListId tabType = do
hash <$> getChart cId Nothing Nothing maybeListId tabType
......@@ -249,7 +249,7 @@ pieApi id' = getPie id'
:<|> updatePie id'
:<|> getPieHash id'
getPie :: FlowCmdM env err m
getPie :: HasNodeStory env err m
=> CorpusId
-> Maybe UTCTime
-> Maybe UTCTime
......@@ -271,12 +271,12 @@ getPie cId _start _end maybeListId tabType = do
pure $ constructHashedResponse chart
updatePie :: FlowCmdM env err m =>
CorpusId
-> Maybe ListId
-> TabType
-> Maybe Limit
-> m ()
updatePie :: HasNodeStory env err m
=> CorpusId
-> Maybe ListId
-> TabType
-> Maybe Limit
-> m ()
updatePie cId maybeListId tabType maybeLimit = do
printDebug "[updatePie] cId" cId
printDebug "[updatePie] maybeListId" maybeListId
......@@ -285,12 +285,12 @@ updatePie cId maybeListId tabType maybeLimit = do
_ <- updatePie' cId maybeListId tabType maybeLimit
pure ()
updatePie' :: FlowCmdM env err m =>
CorpusId
-> Maybe ListId
-> TabType
-> Maybe Limit
-> m (ChartMetrics Histo)
updatePie' :: (HasNodeStory env err m, HasNodeError err)
=> CorpusId
-> Maybe ListId
-> TabType
-> Maybe Limit
-> m (ChartMetrics Histo)
updatePie' cId maybeListId tabType _maybeLimit = do
listId <- case maybeListId of
Just lid -> pure lid
......@@ -304,11 +304,11 @@ updatePie' cId maybeListId tabType _maybeLimit = do
pure $ ChartMetrics p
getPieHash :: FlowCmdM env err m =>
CorpusId
-> Maybe ListId
-> TabType
-> m Text
getPieHash :: HasNodeStory env err m
=> CorpusId
-> Maybe ListId
-> TabType
-> m Text
getPieHash cId maybeListId tabType = do
hash <$> getPie cId Nothing Nothing maybeListId tabType
......@@ -338,7 +338,7 @@ treeApi id' = getTree id'
:<|> updateTree id'
:<|> getTreeHash id'
getTree :: FlowCmdM env err m
getTree :: HasNodeStory env err m
=> CorpusId
-> Maybe UTCTime
-> Maybe UTCTime
......@@ -362,12 +362,12 @@ getTree cId _start _end maybeListId tabType listType = do
pure $ constructHashedResponse chart
updateTree :: FlowCmdM env err m =>
CorpusId
-> Maybe ListId
-> TabType
-> ListType
-> m ()
updateTree :: HasNodeStory env err m
=> CorpusId
-> Maybe ListId
-> TabType
-> ListType
-> m ()
updateTree cId maybeListId tabType listType = do
printDebug "[updateTree] cId" cId
printDebug "[updateTree] maybeListId" maybeListId
......@@ -376,12 +376,12 @@ updateTree cId maybeListId tabType listType = do
_ <- updateTree' cId maybeListId tabType listType
pure ()
updateTree' :: FlowCmdM env err m =>
CorpusId
-> Maybe ListId
-> TabType
-> ListType
-> m (ChartMetrics (Vector NgramsTree))
updateTree' :: HasNodeStory env err m
=> CorpusId
-> Maybe ListId
-> TabType
-> ListType
-> m (ChartMetrics (Vector NgramsTree))
updateTree' cId maybeListId tabType listType = do
listId <- case maybeListId of
Just lid -> pure lid
......@@ -395,11 +395,11 @@ updateTree' cId maybeListId tabType listType = do
pure $ ChartMetrics t
getTreeHash :: FlowCmdM env err m =>
CorpusId
-> Maybe ListId
-> TabType
-> ListType
-> m Text
getTreeHash :: HasNodeStory env err m
=> CorpusId
-> Maybe ListId
-> TabType
-> ListType
-> m Text
getTreeHash cId maybeListId tabType listType = do
hash <$> getTree cId Nothing Nothing maybeListId tabType listType
......@@ -108,7 +108,6 @@ import Gargantext.Core.NodeStory
import Gargantext.Core.Types (ListType(..), NodeId, ListId, DocId, TODO, assertValid, HasInvalidError, ContextId)
import Gargantext.Core.Types.Query (Limit(..), Offset(..), MinSize(..), MaxSize(..))
import Gargantext.API.Ngrams.Tools
import Gargantext.Database.Action.Flow.Types
import Gargantext.Database.Action.Metrics.NgramsByContext (getOccByNgramsOnlyFast)
import Gargantext.Database.Admin.Config (userMaster)
import Gargantext.Database.Admin.Types.Node (NodeType(..))
......@@ -418,8 +417,6 @@ tableNgramsPut tabType listId (Versioned p_version p_table)
tableNgramsPostChartsAsync :: ( HasNodeStory env err m
, FlowCmdM env err m
, HasNodeError err
, HasSettings env
, MonadJobStatus m
)
......@@ -471,7 +468,7 @@ tableNgramsPostChartsAsync utn jobHandle = do
-- printDebug "[tableNgramsPostChartsAsync] Terms, updating Metrics (Histo), cId" cId
markStarted 6 jobHandle
{-
_ <- Metrics.updateChart cId (Just listId) tabType Nothing
_ <- Metrics.updateChart cId listId tabType Nothing
logRefSuccess
_ <- Metrics.updatePie cId (Just listId) tabType Nothing
logRefSuccess
......
......@@ -16,16 +16,17 @@ Portability : POSIX
module Gargantext.API.Node.Update
where
--import Gargantext.Core.Types.Individu (User(..))
import Control.Lens (view)
import Data.Aeson
import Data.Maybe (Maybe(..), fromMaybe)
import Data.Set qualified as Set
import Data.Swagger
import GHC.Generics (Generic)
import Gargantext.API.Admin.EnvTypes (GargJob(..), Env)
import Gargantext.API.Admin.Orchestrator.Types (JobLog(..), AsyncJobs)
import Gargantext.API.Admin.Types (HasSettings)
--import Gargantext.API.Ngrams.Types (TabType(..))
import Gargantext.API.Metrics qualified as Metrics
import Gargantext.API.Ngrams.Types qualified as NgramsTypes
import Gargantext.API.Prelude (GargM, GargError, simuLogs)
import Gargantext.Core.Methods.Similarities (GraphMetric(..))
import Gargantext.Core.NodeStory (HasNodeStory)
......@@ -35,10 +36,8 @@ import Gargantext.Core.Viz.Graph.Tools (PartitionMethod(..), BridgenessMethod(..
import Gargantext.Core.Viz.Graph.Types (Strength)
import Gargantext.Core.Viz.Phylo (PhyloSubConfigAPI(..), subConfigAPI2config)
import Gargantext.Core.Viz.Phylo.API.Tools (flowPhyloAPI)
-- import Gargantext.Database.Action.Mail (sendMail)
import Gargantext.Database.Action.Flow (reIndexWith)
import Gargantext.Database.Action.Flow.Pairing (pairing)
import Gargantext.Database.Action.Flow.Types (FlowCmdM)
import Gargantext.Database.Action.Metrics (updateNgramsOccurrences, updateContextScore)
import Gargantext.Database.Admin.Types.Hyperdata
import Gargantext.Database.Admin.Types.Node
......@@ -47,15 +46,12 @@ import Gargantext.Database.Query.Table.Node.UpdateOpaleye (updateHyperdata)
import Gargantext.Database.Schema.Ngrams (NgramsType(NgramsTerms))
import Gargantext.Database.Schema.Node (node_parent_id)
import Gargantext.Prelude (Bool(..), Ord, Eq, (<$>), ($), {-printDebug,-} pure, show, cs, (<>), panic, (<*>))
import Gargantext.Utils.Aeson qualified as GUA
import Gargantext.Utils.Jobs (serveJobsAPI, MonadJobStatus(..))
import Prelude (Enum, Bounded, minBound, maxBound)
import Servant
import Test.QuickCheck (elements)
import Test.QuickCheck.Arbitrary
import qualified Data.Set as Set
import qualified Gargantext.API.Metrics as Metrics
import qualified Gargantext.API.Ngrams.Types as NgramsTypes
import qualified Gargantext.Utils.Aeson as GUA
------------------------------------------------------------------------
type API = Summary " Update node according to NodeType params"
......@@ -100,12 +96,12 @@ api uId nId =
serveJobsAPI UpdateNodeJob $ \jHandle p ->
updateNode uId nId p jHandle
updateNode :: (HasSettings env, FlowCmdM env err m, MonadJobStatus m)
=> UserId
-> NodeId
-> UpdateNodeParams
-> JobHandle m
-> m ()
updateNode :: (HasNodeStory env err m, HasSettings env, MonadJobStatus m)
=> UserId
-> NodeId
-> UpdateNodeParams
-> JobHandle m
-> m ()
updateNode uId nId (UpdateNodeParamsGraph metric partitionMethod bridgeMethod strength nt1 nt2) jobHandle = do
markStarted 2 jobHandle
......@@ -150,7 +146,7 @@ updateNode _uId lId (UpdateNodeParamsList _mode) jobHandle = do
_ <- case corpusId of
Just cId -> do
_ <- reIndexWith cId lId NgramsTerms (Set.singleton MapTerm)
_ <- updateNgramsOccurrences cId (Just lId)
_ <- updateNgramsOccurrences cId lId
pure ()
Nothing -> pure ()
......@@ -202,9 +198,9 @@ updateDocs :: (HasNodeStory env err m)
updateDocs cId = do
lId <- defaultList cId
_ <- reIndexWith cId lId NgramsTerms (Set.singleton MapTerm)
_ <- updateNgramsOccurrences cId (Just lId)
_ <- updateNgramsOccurrences cId lId
_ <- updateContextScore cId lId
_ <- Metrics.updateChart cId (Just lId) NgramsTypes.Docs Nothing
_ <- Metrics.updateChart' cId lId NgramsTypes.Docs Nothing
-- printDebug "updateContextsScore" (cId, lId, u)
pure ()
......
......@@ -34,11 +34,10 @@ import Gargantext.Core.Viz.Graph.GEXF ()
import Gargantext.Core.Viz.Graph.Tools -- (cooc2graph)
import Gargantext.Core.Viz.Graph.Types
import Gargantext.Database.Action.Metrics.NgramsByContext (getContextsByNgramsOnlyUser)
import Gargantext.Database.Action.Flow.Types (FlowCmdM)
import Gargantext.Database.Action.Node (mkNodeWithParent)
import Gargantext.Database.Admin.Config
import Gargantext.Database.Admin.Types.Node
import Gargantext.Database.Prelude (Cmd)
import Gargantext.Database.Prelude (DBCmd)
import Gargantext.Database.Query.Table.Node
import Gargantext.Database.Query.Table.Node.Error (HasNodeError)
import Gargantext.Database.Query.Table.Node.Select
......@@ -83,8 +82,8 @@ graphAPI u n = getGraph u n
------------------------------------------------------------------------
--getGraph :: UserId -> NodeId -> GargServer HyperdataGraphAPI
getGraph :: FlowCmdM env err m
=> UserId
getGraph :: HasNodeStory env err m
=> UserId
-> NodeId
-> m HyperdataGraphAPI
getGraph _uId nId = do
......@@ -122,7 +121,7 @@ getGraph _uId nId = do
--recomputeGraph :: UserId -> NodeId -> Maybe GraphMetric -> GargNoServer Graph
recomputeGraph :: FlowCmdM env err m
recomputeGraph :: HasNodeStory env err m
=> UserId
-> NodeId
-> PartitionMethod
......@@ -179,7 +178,7 @@ recomputeGraph _uId nId partitionMethod bridgeMethod maybeSimilarity maybeStreng
-- TODO remove repo
computeGraph :: FlowCmdM env err m
computeGraph :: HasNodeError err
=> CorpusId
-> PartitionMethod
-> BridgenessMethod
......@@ -187,7 +186,7 @@ computeGraph :: FlowCmdM env err m
-> Strength
-> (NgramsType, NgramsType)
-> NodeListStory
-> m Graph
-> DBCmd err Graph
computeGraph corpusId partitionMethod bridgeMethod similarity strength (nt1,nt2) repo = do
-- Getting the Node parameters
lId <- defaultList corpusId
......@@ -230,7 +229,7 @@ defaultGraphMetadata :: HasNodeError err
-> NodeListStory
-> GraphMetric
-> Strength
-> Cmd err GraphMetadata
-> DBCmd err GraphMetadata
defaultGraphMetadata cId t repo gm str = do
lId <- defaultList cId
......@@ -265,7 +264,7 @@ graphAsync u n =
-- -> (JobLog -> GargNoServer ())
-- -> GargNoServer JobLog
-- TODO get Graph Metadata to recompute
graphRecompute :: (FlowCmdM env err m, MonadJobStatus m)
graphRecompute :: (HasNodeStory env err m, MonadJobStatus m)
=> UserId
-> NodeId
-> JobHandle m
......@@ -319,7 +318,7 @@ graphVersions n nId = do
, gv_repo = v }
--recomputeVersions :: UserId -> NodeId -> GargNoServer Graph
recomputeVersions :: FlowCmdM env err m
recomputeVersions :: HasNodeStory env err m
=> UserId
-> NodeId
-> m Graph
......@@ -351,8 +350,8 @@ graphClone uId pId (HyperdataGraphAPI { _hyperdataAPIGraph = graph
--getGraphGexf :: UserId
-- -> NodeId
-- -> GargNoServer (Headers '[Servant.Header "Content-Disposition" Text] Graph)
getGraphGexf :: FlowCmdM env err m
=> UserId
getGraphGexf :: HasNodeStory env err m
=> UserId
-> NodeId
-> m (Headers '[Servant.Header "Content-Disposition" Text] Graph)
getGraphGexf uId nId = do
......
......@@ -16,35 +16,33 @@ module Gargantext.Core.Viz.Phylo.API.Tools
import Control.Lens hiding (Context)
import Data.Aeson (Value, decodeFileStrict, eitherDecode, encode)
import Data.ByteString.Lazy qualified as Lazy
import Data.Map.Strict (Map)
import Data.Proxy
import Data.Map.Strict qualified as Map
import Data.Maybe (fromMaybe)
import Data.Proxy
import Data.Set (Set)
import Data.Set qualified as Set
import Data.Text (Text, pack)
import Data.Time.Calendar (fromGregorian, diffGregorianDurationClip, cdMonths, diffDays, showGregorian)
import Data.Time.Clock.POSIX(posixSecondsToUTCTime)
import Gargantext.API.Ngrams.Prelude (getTermList)
import Gargantext.API.Ngrams.Types (NgramsTerm(..))
import Gargantext.API.Prelude (GargNoServer)
import Gargantext.Core.Text.Terms.WithList (Patterns, buildPatterns, termsInText)
import Gargantext.Core (withDefaultLanguage, Lang)
import Gargantext.Core.NodeStory (HasNodeStory)
import Gargantext.Core.Text.Terms.WithList (Patterns, buildPatterns, termsInText)
import Gargantext.Core.Types (Context)
-- import Gargantext.Core.Types.Individu (User(..))
import Gargantext.Core.Types.Main (ListType(MapTerm))
import Gargantext.Core.Viz.Phylo (TimeUnit(..), Date, Document(..), PhyloConfig(..), Phylo)
import Gargantext.Core.Viz.Phylo.PhyloExport (toPhyloExport, dotToFile)
import Gargantext.Core.Viz.Phylo.PhyloMaker (toPhylo, toPhyloWithoutLink)
import Gargantext.Core.Viz.Phylo.PhyloTools ({-printIOMsg, printIOComment,-} setConfig)
-- import Gargantext.Database.Action.Flow (getOrMk_RootWithCorpus)
-- import Gargantext.Database.Admin.Config (userMaster)
-- import Gargantext.Database.Admin.Types.Hyperdata (HyperdataCorpus)
-- import Gargantext.Database.Action.Flow (getOrMk_RootWithCorpus)
-- import Gargantext.Database.Admin.Config (userMaster)
-- import Gargantext.Database.Admin.Types.Hyperdata (HyperdataCorpus)
import Gargantext.Database.Admin.Types.Hyperdata (HyperdataPhylo(..), HyperdataCorpus(..))
import Gargantext.Database.Admin.Types.Hyperdata.Document (HyperdataDocument(..))
import Gargantext.Database.Admin.Types.Node (CorpusId, ContextId, PhyloId)
import Gargantext.Database.Prelude (DBCmd)
import Gargantext.Database.Query.Table.Node (defaultList, getNodeWith)
import Gargantext.Database.Query.Table.Node.Error (HasNodeError)
import Gargantext.Database.Query.Table.NodeContext (selectDocNodes)
import Gargantext.Database.Schema.Context
import Gargantext.Database.Schema.Ngrams (NgramsType(..))
......@@ -53,21 +51,19 @@ import Gargantext.Prelude
import Prelude hiding (map)
import System.FilePath ((</>))
import System.IO.Temp (withTempDirectory)
import System.Process as Shell
import qualified Data.ByteString.Lazy as Lazy
import qualified Data.Map.Strict as Map
import qualified Data.Set as Set
import System.Process qualified as Shell
--------------------------------------------------------------------
getPhyloData :: PhyloId -> GargNoServer (Maybe Phylo)
getPhyloData :: HasNodeError err
=> PhyloId -> DBCmd err (Maybe Phylo)
getPhyloData phyloId = do
nodePhylo <- getNodeWith phyloId (Proxy :: Proxy HyperdataPhylo)
pure $ _hp_data $ _node_hyperdata nodePhylo
putPhylo :: PhyloId -> GargNoServer Phylo
putPhylo :: PhyloId -> DBCmd err Phylo
putPhylo = undefined
savePhylo :: PhyloId -> GargNoServer ()
savePhylo :: PhyloId -> DBCmd err ()
savePhylo = undefined
--------------------------------------------------------------------
......@@ -93,7 +89,8 @@ phylo2dot2json phylo = do
Just v -> pure v
flowPhyloAPI :: PhyloConfig -> CorpusId -> GargNoServer Phylo
flowPhyloAPI :: (HasNodeStory env err m, HasNodeError err)
=> PhyloConfig -> CorpusId -> m Phylo
flowPhyloAPI config cId = do
corpus <- corpusIdtoDocuments (timeUnit config) cId
let phyloWithCliques = toPhyloWithoutLink corpus config
......@@ -103,7 +100,8 @@ flowPhyloAPI config cId = do
pure $ toPhylo $ setConfig config phyloWithCliques
--------------------------------------------------------------------
corpusIdtoDocuments :: TimeUnit -> CorpusId -> GargNoServer [Document]
corpusIdtoDocuments :: (HasNodeStory env err m, HasNodeError err)
=> TimeUnit -> CorpusId -> m [Document]
corpusIdtoDocuments timeUnit corpusId = do
docs <- selectDocNodes corpusId
lId <- defaultList corpusId
......
......@@ -385,7 +385,7 @@ flowCorpusUser l user userCorpusId listId ctype mfslw = do
-- _ <- mkAnnuaire rootUserId userId
_ <- reIndexWith userCorpusId listId NgramsTerms (Set.singleton MapTerm)
_ <- updateContextScore userCorpusId listId
_ <- updateNgramsOccurrences userCorpusId (Just listId)
_ <- updateNgramsOccurrences userCorpusId listId
pure userCorpusId
......
......@@ -25,8 +25,8 @@ import Data.Set (Set)
import Data.Text (Text)
import Gargantext.API.Ngrams.Tools
import Gargantext.API.Ngrams.Types (NgramsTerm(..))
import Gargantext.API.Prelude (GargNoServer)
import Gargantext.Core
import Gargantext.Core.NodeStory (HasNodeStory)
import Gargantext.Core.Text.Metrics.CharByChar (levenshtein)
import Gargantext.Core.Types (TableResult(..))
import Gargantext.Core.Types.Main
......@@ -38,6 +38,7 @@ import Gargantext.Database.Admin.Types.Node -- (AnnuaireId, CorpusId, ListId, Do
import Gargantext.Database.Query.Prelude (returnA, queryNodeNodeTable)
import Gargantext.Database.Query.Table.Node (defaultList)
import Gargantext.Database.Query.Table.Node.Children (getAllContacts)
import Gargantext.Database.Query.Table.Node.Error (HasNodeError)
import Gargantext.Database.Query.Table.Node.Select (selectNodesWithUsername)
import Gargantext.Database.Query.Table.NodeContext_NodeContext (insertNodeContext_NodeContext)
import Gargantext.Database.Query.Table.NodeNode (insertNodeNode)
......@@ -68,7 +69,8 @@ isPairedWith nId nt = runOpaQuery (selectQuery nt nId)
returnA -< node^.node_id
-----------------------------------------------------------------------
pairing :: AnnuaireId -> CorpusId -> Maybe ListId -> GargNoServer [Int]
pairing :: (HasNodeStory env err m, HasNodeError err)
=> AnnuaireId -> CorpusId -> Maybe ListId -> m [Int]
pairing a c l' = do
l <- case l' of
Nothing -> defaultList c
......@@ -78,9 +80,10 @@ pairing a c l' = do
insertNodeContext_NodeContext $ prepareInsert c a dataPaired
dataPairing :: AnnuaireId
dataPairing :: HasNodeStory env err m
=> AnnuaireId
-> (CorpusId, ListId, NgramsType)
-> GargNoServer (HashMap ContactId (Set DocId))
-> m (HashMap ContactId (Set DocId))
dataPairing aId (cId, lId, ngt) = do
-- mc :: HM.HashMap ContactName (Set ContactId)
mc <- getNgramsContactId aId
......@@ -164,7 +167,7 @@ getClosest f (NgramsTerm from) candidates = fst <$> head scored
------------------------------------------------------------------------
getNgramsContactId :: AnnuaireId
-> Cmd err (HashMap ContactName (Set NodeId))
-> DBCmd err (HashMap ContactName (Set NodeId))
getNgramsContactId aId = do
contacts <- getAllContacts aId
-- printDebug "getAllContexts" (tr_count contacts)
......@@ -181,10 +184,11 @@ toName contact = NgramsTerm $ (Text.toTitle firstName) <> " " <> (Text.toTitle l
firstName = fromMaybe "" $ contact^.(node_hyperdata . hc_who . _Just . cw_firstName)
lastName = fromMaybe "" $ contact^.(node_hyperdata . hc_who . _Just . cw_lastName)
getNgramsDocId :: CorpusId
getNgramsDocId :: HasNodeStory env err m
=> CorpusId
-> ListId
-> NgramsType
-> GargNoServer (HashMap DocAuthor (Set NodeId))
-> m (HashMap DocAuthor (Set NodeId))
getNgramsDocId cId lId nt = do
lIds <- selectNodesWithUsername NodeList userMaster
repo <- getRepo (lId:lIds)
......
......@@ -36,36 +36,29 @@ import Gargantext.Core.NodeStory hiding (runPGSQuery)
import Gargantext.Core.Text.Metrics (scored, Scored(..), {-localMetrics, toScored-})
import Gargantext.Core.Types (ListType(..), NodeType(..), ContextId)
import Gargantext.Core.Types.Query (Limit(..))
import Gargantext.Database.Action.Flow.Types (FlowCmdM)
import Gargantext.Database.Action.Metrics.NgramsByContext (getContextsByNgramsOnlyUser{-, getTficfWith-})
import Gargantext.Database.Admin.Config (userMaster)
import Gargantext.Database.Admin.Types.Node (ListId, CorpusId)
import Gargantext.Database.Prelude (runPGSQuery{-, formatPGSQuery-})
import Gargantext.Database.Query.Table.Node (defaultList)
import Gargantext.Database.Query.Table.Node.Select
import Gargantext.Prelude
getMetrics :: FlowCmdM env err m
=> CorpusId -> Maybe ListId -> TabType -> Maybe Limit
-> m (HashMap NgramsTerm (ListType, Maybe NgramsTerm), Vector (Scored NgramsTerm))
getMetrics cId maybeListId tabType maybeLimit = do
(ngs, _, myCooc) <- getNgramsCooc cId maybeListId tabType maybeLimit
getMetrics :: (HasNodeStory env err m)
=> CorpusId -> ListId -> TabType -> Maybe Limit
-> m (HashMap NgramsTerm (ListType, Maybe NgramsTerm), Vector (Scored NgramsTerm))
getMetrics cId listId tabType maybeLimit = do
(ngs, _, myCooc) <- getNgramsCooc cId listId tabType maybeLimit
-- TODO HashMap
pure (ngs, scored myCooc)
getNgramsCooc :: (FlowCmdM env err m)
=> CorpusId -> Maybe ListId -> TabType -> Maybe Limit
-> m ( HashMap NgramsTerm (ListType, Maybe NgramsTerm)
, HashMap NgramsTerm (Maybe RootTerm)
, HashMap (NgramsTerm, NgramsTerm) Int
)
getNgramsCooc cId maybeListId tabType maybeLimit = do
lId <- case maybeListId of
Nothing -> defaultList cId
Just lId' -> pure lId'
getNgramsCooc :: (HasNodeStory env err m)
=> CorpusId -> ListId -> TabType -> Maybe Limit
-> m ( HashMap NgramsTerm (ListType, Maybe NgramsTerm)
, HashMap NgramsTerm (Maybe RootTerm)
, HashMap (NgramsTerm, NgramsTerm) Int
)
getNgramsCooc cId lId tabType maybeLimit = do
(ngs', ngs) <- getNgrams lId tabType
lIds <- selectNodesWithUsername NodeList userMaster
......@@ -81,21 +74,17 @@ getNgramsCooc cId maybeListId tabType maybeLimit = do
------------------------------------------------------------------------
------------------------------------------------------------------------
updateNgramsOccurrences :: (HasNodeStory env err m)
=> CorpusId -> Maybe ListId
=> CorpusId -> ListId
-> m ()
updateNgramsOccurrences cId mlId = do
_ <- mapM (updateNgramsOccurrences' cId mlId Nothing) [Terms, Sources, Authors, Institutes]
updateNgramsOccurrences cId lId = do
_ <- mapM (updateNgramsOccurrences' cId lId Nothing) [Terms, Sources, Authors, Institutes]
pure ()
updateNgramsOccurrences' :: (HasNodeStory env err m)
=> CorpusId -> Maybe ListId -> Maybe Limit -> TabType
=> CorpusId -> ListId -> Maybe Limit -> TabType
-> m [Int]
updateNgramsOccurrences' cId maybeListId maybeLimit tabType = do
lId <- case maybeListId of
Nothing -> defaultList cId
Just lId' -> pure lId'
updateNgramsOccurrences' cId lId maybeLimit tabType = do
result <- getNgramsOccurrences cId lId tabType maybeLimit
......
......@@ -19,17 +19,17 @@ Portability : POSIX
module Gargantext.Database.Action.Metrics.Lists
where
import Gargantext.API.Ngrams.Types (TabType(..))
import Gargantext.Core.Text.Metrics (Scored(..))
import Gargantext.Core.Types -- (NodePoly(..), NodeCorpus, ListId)
import Gargantext.Core.Types.Query (Limit)
import Gargantext.Database.Action.Flow.Types (FlowCmdM)
import Gargantext.Prelude hiding (sum, head)
import Prelude hiding (null, id, map, sum)
import qualified Data.HashMap.Strict as HashMap
import qualified Data.Map.Strict as Map
import qualified Data.Vector as Vec
import qualified Gargantext.Database.Action.Metrics as Metrics
-- import Gargantext.API.Ngrams.Types (TabType(..))
-- import Gargantext.Core.Text.Metrics (Scored(..))
-- import Gargantext.Core.Types -- (NodePoly(..), NodeCorpus, ListId)
-- import Gargantext.Core.Types.Query (Limit)
-- import Gargantext.Database.Action.Flow.Types (FlowCmdM)
-- import Gargantext.Prelude hiding (sum, head)
-- import Prelude hiding (null, id, map, sum)
-- import qualified Data.HashMap.Strict as HashMap
-- import qualified Data.Map.Strict as Map
-- import qualified Data.Vector as Vec
-- import qualified Gargantext.Database.Action.Metrics as Metrics
{-
trainModel :: FlowCmdM env ServantErr m
=> Username -> m Score
......@@ -42,18 +42,18 @@ trainModel u = do
--}
getMetrics' :: FlowCmdM env err m
=> CorpusId -> Maybe ListId -> TabType -> Maybe Limit
-> m (Map.Map ListType [Vec.Vector Double])
getMetrics' cId maybeListId tabType maybeLimit = do
(ngs', scores) <- Metrics.getMetrics cId maybeListId tabType maybeLimit
-- getMetrics' :: FlowCmdM env err m
-- => CorpusId -> Maybe ListId -> TabType -> Maybe Limit
-- -> m (Map.Map ListType [Vec.Vector Double])
-- getMetrics' cId maybeListId tabType maybeLimit = do
-- (ngs', scores) <- Metrics.getMetrics cId maybeListId tabType maybeLimit
let
metrics = map (\(Scored t s1 s2) -> (listType t ngs', [Vec.fromList [s1,s2]])) scores
listType t m = maybe (panic errorMsg) fst $ HashMap.lookup t m
errorMsg = "API.Node.metrics: key absent"
-- let
-- metrics = map (\(Scored t s1 s2) -> (listType t ngs', [Vec.fromList [s1,s2]])) scores
-- listType t m = maybe (panic errorMsg) fst $ HashMap.lookup t m
-- errorMsg = "API.Node.metrics: key absent"
{-
_ <- Learn.grid 100 110 metrics' metrics'
--}
pure $ Map.fromListWith (<>) $ Vec.toList metrics
-- {-
-- _ <- Learn.grid 100 110 metrics' metrics'
-- --}
-- pure $ Map.fromListWith (<>) $ Vec.toList metrics
{-|
import Gargantext.Database.Prelude (Cmd, runPGSQuery)
Module : Gargantext.Database.Query.Table.Node
Description : Main Tools of Node to the database
Copyright : (c) CNRS, 2017-Present
......@@ -53,7 +52,7 @@ selectNode id' = proc () -> do
restrict -< _node_id row .== id'
returnA -< row
runGetNodes :: Select NodeRead -> Cmd err [Node HyperdataAny]
runGetNodes :: Select NodeRead -> DBCmd err [Node HyperdataAny]
runGetNodes = runOpaQuery
------------------------------------------------------------------------
......@@ -84,7 +83,7 @@ selectNodesWith' parentId maybeNodeType = proc () -> do
returnA -< row ) -< ()
returnA -< node'
deleteNode :: NodeId -> Cmd err Int
deleteNode :: NodeId -> DBCmd err Int
deleteNode n = mkCmd $ \conn ->
fromIntegral <$> runDelete_ conn
(Delete nodeTable
......@@ -92,7 +91,7 @@ deleteNode n = mkCmd $ \conn ->
rCount
)
deleteNodes :: [NodeId] -> Cmd err Int
deleteNodes :: [NodeId] -> DBCmd err Int
deleteNodes ns = mkCmd $ \conn ->
fromIntegral <$> runDelete_ conn
(Delete nodeTable
......@@ -102,7 +101,7 @@ deleteNodes ns = mkCmd $ \conn ->
-- TODO: NodeType should match with `a'
getNodesWith :: (JSONB a, HasDBid NodeType) => NodeId -> proxy a -> Maybe NodeType
-> Maybe Offset -> Maybe Limit -> Cmd err [Node a]
-> Maybe Offset -> Maybe Limit -> DBCmd err [Node a]
getNodesWith parentId _ nodeType maybeOffset maybeLimit =
runOpaQuery $ selectNodesWith parentId nodeType maybeOffset maybeLimit
......@@ -110,7 +109,7 @@ getNodesWith parentId _ nodeType maybeOffset maybeLimit =
-- TODO: Why not use getNodesWith?
getNodesWithParentId :: (Hyperdata a, JSONB a)
=> Maybe NodeId
-> Cmd err [Node a]
-> DBCmd err [Node a]
getNodesWithParentId n = runOpaQuery $ selectNodesWithParentID n'
where
n' = case n of
......@@ -124,7 +123,7 @@ getNodesWithParentId n = runOpaQuery $ selectNodesWithParentID n'
getClosestParentIdByType :: HasDBid NodeType
=> NodeId
-> NodeType
-> Cmd err (Maybe NodeId)
-> DBCmd err (Maybe NodeId)
getClosestParentIdByType nId nType = do
result <- runPGSQuery query (PGS.Only nId)
case result of
......@@ -148,7 +147,7 @@ getClosestParentIdByType nId nType = do
getClosestParentIdByType' :: HasDBid NodeType
=> NodeId
-> NodeType
-> Cmd err (Maybe NodeId)
-> DBCmd err (Maybe NodeId)
getClosestParentIdByType' nId nType = do
result <- runPGSQuery query (PGS.Only nId)
case result of
......@@ -185,14 +184,14 @@ getChildrenByType nId nType = do
|]
------------------------------------------------------------------------
getDocumentsV3WithParentId :: HasDBid NodeType => NodeId -> Cmd err [Node HyperdataDocumentV3]
getDocumentsV3WithParentId :: HasDBid NodeType => NodeId -> DBCmd err [Node HyperdataDocumentV3]
getDocumentsV3WithParentId n = runOpaQuery $ selectNodesWith' n (Just NodeDocument)
-- TODO: merge with getDocumentsWithParentId by having a class IsHyperdataDocument
getDocumentsWithParentId :: HasDBid NodeType => NodeId -> Cmd err [Node HyperdataDocument]
getDocumentsWithParentId :: HasDBid NodeType => NodeId -> DBCmd err [Node HyperdataDocument]
getDocumentsWithParentId n = runOpaQuery $ selectNodesWith' n (Just NodeDocument)
getListsModelWithParentId :: HasDBid NodeType => NodeId -> Cmd err [Node HyperdataModel]
getListsModelWithParentId :: HasDBid NodeType => NodeId -> DBCmd err [Node HyperdataModel]
getListsModelWithParentId n = runOpaQuery $ selectNodesWith' n (Just NodeModel)
getCorporaWithParentId :: HasDBid NodeType => NodeId -> DBCmd err [Node HyperdataCorpus]
......@@ -209,7 +208,7 @@ selectNodesWithParentID n = proc () -> do
------------------------------------------------------------------------
-- | Example of use:
-- runCmdReplEasy (getNodesWithType NodeList (Proxy :: Proxy HyperdataList))
getNodesWithType :: (HasNodeError err, JSONB a, HasDBid NodeType) => NodeType -> proxy a -> Cmd err [Node a]
getNodesWithType :: (HasNodeError err, JSONB a, HasDBid NodeType) => NodeType -> proxy a -> DBCmd err [Node a]
getNodesWithType nt _ = runOpaQuery $ selectNodesWithType nt
where
selectNodesWithType :: HasDBid NodeType
......@@ -223,7 +222,7 @@ getNodeWithType :: (HasNodeError err, JSONB a, HasDBid NodeType)
=> NodeId
-> NodeType
-> proxy a
-> Cmd err [Node a]
-> DBCmd err [Node a]
getNodeWithType nId nt _ = runOpaQuery $ selectNodeWithType nId nt
where
selectNodeWithType :: HasDBid NodeType
......@@ -234,7 +233,7 @@ getNodeWithType nId nt _ = runOpaQuery $ selectNodeWithType nId nt
restrict -< tn .== sqlInt4 (toDBid nt')
returnA -< row
getNodesIdWithType :: (HasNodeError err, HasDBid NodeType) => NodeType -> Cmd err [NodeId]
getNodesIdWithType :: (HasNodeError err, HasDBid NodeType) => NodeType -> DBCmd err [NodeId]
getNodesIdWithType nt = do
ns <- runOpaQuery $ selectNodesIdWithType nt
pure (map NodeId ns)
......@@ -248,7 +247,7 @@ selectNodesIdWithType nt = proc () -> do
------------------------------------------------------------------------
nodeExists :: (HasNodeError err) => NodeId -> Cmd err Bool
nodeExists :: (HasNodeError err) => NodeId -> DBCmd err Bool
nodeExists nId = (== [PGS.Only True])
<$> runPGSQuery [sql|SELECT true FROM nodes WHERE id = ? |] (PGS.Only nId)
......@@ -317,7 +316,7 @@ insertNodes :: [NodeWrite] -> DBCmd err Int64
insertNodes ns = mkCmd $ \conn -> runInsert_ conn $ Insert nodeTable ns rCount Nothing
{-
insertNodes' :: [Node a] -> Cmd err Int64
insertNodes' :: [Node a] -> DBCmd err Int64
insertNodes' ns = mkCmd $ \conn -> runInsert_ conn
$ Insert nodeTable ns' rCount Nothing
where
......@@ -359,11 +358,11 @@ data Node' = Node' { _n_type :: NodeType
, _n_children :: [Node']
} deriving (Show)
mkNodes :: [NodeWrite] -> Cmd err Int64
mkNodes :: [NodeWrite] -> DBCmd err Int64
mkNodes ns = mkCmd $ \conn -> runInsert_ conn
$ Insert nodeTable ns rCount Nothing
mkNodeR :: [NodeWrite] -> Cmd err [NodeId]
mkNodeR :: [NodeWrite] -> DBCmd err [NodeId]
mkNodeR ns = mkCmd $ \conn -> runInsert_ conn $ Insert nodeTable ns (rReturning _node_id) Nothing
------------------------------------------------------------------------
......@@ -410,7 +409,7 @@ defaultList :: (HasNodeError err, HasDBid NodeType) => CorpusId -> DBCmd err Lis
defaultList cId =
maybe (nodeError (NoListFound cId)) (pure . view node_id) . headMay =<< getListsWithParentId cId
defaultListMaybe :: (HasNodeError err, HasDBid NodeType) => CorpusId -> Cmd err (Maybe NodeId)
defaultListMaybe :: (HasNodeError err, HasDBid NodeType) => CorpusId -> DBCmd err (Maybe NodeId)
defaultListMaybe cId = headMay <$> map (view node_id ) <$> getListsWithParentId cId
getListsWithParentId :: HasDBid NodeType => NodeId -> DBCmd err [Node HyperdataList]
......
......@@ -36,12 +36,12 @@ import Opaleye
-- TODO getAllTableDocuments
getAllDocuments :: HasDBid NodeType => ParentId -> Cmd err (TableResult (Node HyperdataDocument))
getAllDocuments :: HasDBid NodeType => ParentId -> DBCmd err (TableResult (Node HyperdataDocument))
getAllDocuments pId = getAllChildren pId (Proxy :: Proxy HyperdataDocument)
(Just NodeDocument)
-- TODO getAllTableContacts
getAllContacts :: HasDBid NodeType => ParentId -> Cmd err (TableResult (Node HyperdataContact))
getAllContacts :: HasDBid NodeType => ParentId -> DBCmd err (TableResult (Node HyperdataContact))
getAllContacts pId = getAllChildren pId (Proxy :: Proxy HyperdataContact)
(Just NodeContact)
......@@ -49,7 +49,7 @@ getAllChildren :: (JSONB a, HasDBid NodeType)
=> ParentId
-> proxy a
-> Maybe NodeType
-> Cmd err (NodeTableResult a)
-> DBCmd err (NodeTableResult a)
getAllChildren pId p maybeNodeType = getChildren pId p maybeNodeType Nothing Nothing
......@@ -59,7 +59,7 @@ getChildren :: (JSONB a, HasDBid NodeType)
-> Maybe NodeType
-> Maybe Offset
-> Maybe Limit
-> Cmd err (NodeTableResult a)
-> DBCmd err (NodeTableResult a)
getChildren pId p t@(Just NodeDocument) maybeOffset maybeLimit = getChildrenContext pId p t maybeOffset maybeLimit
getChildren pId p t@(Just NodeContact ) maybeOffset maybeLimit = getChildrenContext pId p t maybeOffset maybeLimit
getChildren a b c d e = getChildrenNode a b c d e
......@@ -71,7 +71,7 @@ getChildrenNode :: (JSONB a, HasDBid NodeType)
-> Maybe NodeType
-> Maybe Offset
-> Maybe Limit
-> Cmd err (NodeTableResult a)
-> DBCmd err (NodeTableResult a)
getChildrenNode pId _ maybeNodeType maybeOffset maybeLimit = do
-- printDebug "getChildrenNode" (pId, maybeNodeType)
let query = selectChildrenNode pId maybeNodeType
......@@ -97,12 +97,12 @@ selectChildrenNode parentId maybeNodeType = proc () -> do
getChildrenContext :: (JSONB a, HasDBid NodeType)
=> ParentId
-> proxy a
-> Maybe NodeType
-> Maybe Offset
-> Maybe Limit
-> Cmd err (NodeTableResult a)
=> ParentId
-> proxy a
-> Maybe NodeType
-> Maybe Offset
-> Maybe Limit
-> DBCmd err (NodeTableResult a)
getChildrenContext pId _ maybeNodeType maybeOffset maybeLimit = do
-- printDebug "getChildrenContext" (pId, maybeNodeType)
let query = selectChildren' pId maybeNodeType
......
......@@ -32,7 +32,7 @@ queryNodeContext_NodeContextTable :: Select NodeContext_NodeContextRead
queryNodeContext_NodeContextTable = selectTable nodeContext_NodeContextTable
-}
insertNodeContext_NodeContext :: [(CorpusId, DocId, AnnuaireId, ContactId)] -> Cmd err [Int]
insertNodeContext_NodeContext :: [(CorpusId, DocId, AnnuaireId, ContactId)] -> DBCmd err [Int]
insertNodeContext_NodeContext contexts = do
let
fields = map (\t -> QualifiedIdentifier Nothing t) $ snd fields_name
......
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