-}
-
{-# LANGUAGE OverloadedLists #-} -- allows to write Map and HashMap as lists
{-# LANGUAGE TypeOperators #-}
import Gargantext.Core.Viz.Graph
import Gargantext.Core.Viz.Graph.GEXF ()
import Gargantext.Core.Viz.Graph.Tools -- (cooc2graph)
-import Gargantext.Database.Action.Metrics.NgramsByNode (getNodesByNgramsOnlyUser)
+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
}
deriving (Show, Generic)
+instance FromJSON GraphVersions
instance ToJSON GraphVersions
instance ToSchema GraphVersions
let
graph = nodeGraph ^. node_hyperdata . hyperdataGraph
camera = nodeGraph ^. node_hyperdata . hyperdataCamera
- cId = maybe (panic "[G.V.G.API] Node has no parent")
- identity
- $ nodeGraph ^. node_parent_id
+ mcId <- getClosestParentIdByType nId NodeCorpus
+ let cId = maybe (panic "[G.V.G.API] Node has no parent") identity mcId
+
+ -- printDebug "[getGraph] getting list for cId" cId
listId <- defaultList cId
repo <- getRepo' [listId]
-- TODO Distance in Graph params
case graph of
Nothing -> do
- let defaultMetric = Order1
- graph' <- computeGraph cId (withMetric defaultMetric) NgramsTerms repo
+ let defaultMetric = Order1
+ let defaultPartitionMethod = Spinglass
+ graph' <- computeGraph cId defaultPartitionMethod (withMetric defaultMetric) NgramsTerms repo
mt <- defaultGraphMetadata cId "Title" repo defaultMetric
let
graph'' = set graph_metadata (Just mt) graph'
recomputeGraph :: FlowCmdM env err m
=> UserId
-> NodeId
+ -> PartitionMethod
-> Maybe GraphMetric
+ -> Bool
-> m Graph
-recomputeGraph _uId nId maybeDistance = do
+recomputeGraph _uId nId method maybeDistance force = do
nodeGraph <- getNodeWith nId (Proxy :: Proxy HyperdataGraph)
let
graph = nodeGraph ^. node_hyperdata . hyperdataGraph
graphMetric = case maybeDistance of
Nothing -> graph ^? _Just . graph_metadata . _Just . gm_metric
_ -> maybeDistance
-
- let
- cId = maybe (panic "[G.C.V.G.API.recomputeGraph] Node has no parent")
- identity
- $ nodeGraph ^. node_parent_id
similarity = case graphMetric of
Nothing -> withMetric Order1
Just m -> withMetric m
+ mcId <- getClosestParentIdByType nId NodeCorpus
+ let cId = maybe (panic "[G.V.G.API] Node has no parent") identity mcId
+
listId <- defaultList cId
repo <- getRepo' [listId]
let v = repo ^. unNodeStory . at listId . _Just . a_version
+ let computeG mt = do
+ g <- computeGraph cId method similarity NgramsTerms repo
+ let g' = set graph_metadata mt g
+ _ <- updateHyperdata nId (HyperdataGraph (Just g') camera)
+ pure g'
+
case graph of
Nothing -> do
- graph' <- computeGraph cId similarity NgramsTerms repo
mt <- defaultGraphMetadata cId "Title" repo (fromMaybe Order1 maybeDistance)
- let graph'' = set graph_metadata (Just mt) graph'
- _ <- updateHyperdata nId (HyperdataGraph (Just graph'') camera)
- pure $ trace "[G.V.G.API.recomputeGraph] Graph empty, computed" graph''
-
- Just graph' -> if listVersion == Just v
+ g <- computeG $ Just mt
+ pure $ trace "[G.V.G.API.recomputeGraph] Graph empty, computed" g
+ Just graph' -> if (listVersion == Just v) && (not force)
then pure graph'
else do
- graph'' <- computeGraph cId similarity NgramsTerms repo
- let graph''' = set graph_metadata graphMetadata graph''
- _ <- updateHyperdata nId (HyperdataGraph (Just graph''') camera)
- pure $ trace "[G.V.G.API] Graph exists, recomputing" graph'''
-
-
--- TODO use Database Monad only here ?
---computeGraph :: HasNodeError err
--- => CorpusId
--- -> Distance
--- -> NgramsType
--- -> NodeListStory
--- -> Cmd err Graph
+ g <- computeG graphMetadata
+ pure $ trace "[G.V.G.API] Graph exists, recomputing" g
+
+
computeGraph :: FlowCmdM env err m
=> CorpusId
+ -> PartitionMethod
-> Distance
-> NgramsType
-> NodeListStory
-> m Graph
-computeGraph cId d nt repo = do
+computeGraph cId method d nt repo = do
lId <- defaultList cId
lIds <- selectNodesWithUsername NodeList userMaster
- let ngs = filterListWithRoot MapTerm
+ let ngs = filterListWithRoot [MapTerm]
$ mapTermListRoot [lId] nt repo
myCooc <- HashMap.filter (>1) -- Removing the hapax (ngrams with 1 cooc)
- <$> getCoocByNgrams (if d == Conditional then Diagonal True else Diagonal False)
+ <$> getCoocByNgrams (Diagonal True)
<$> groupNodesByNgrams ngs
- <$> getNodesByNgramsOnlyUser cId (lIds <> [lId]) nt (HashMap.keys ngs)
-
- -- printDebug "myCooc" myCooc
- -- saveAsFileDebug "debug/my-cooc" myCooc
+ <$> getContextsByNgramsOnlyUser cId (lIds <> [lId]) nt (HashMap.keys ngs)
listNgrams <- getListNgrams [lId] nt
- graph <- liftBase $ cooc2graphWith Spinglass d 0 myCooc
- -- saveAsFileDebug "debug/graph" graph
- pure $ mergeGraphNgrams graph (Just listNgrams)
+ graph <- liftBase $ cooc2graphWith method d 0 myCooc
+
+ let graph' = mergeGraphNgrams graph (Just listNgrams)
+ -- saveAsFileDebug "/tmp/graphWithNodes" graph'
+
+ pure graph'
defaultGraphMetadata :: HasNodeError err
}
-- (map (\n -> LegendField n "#FFFFFF" (pack $ show n)) [1..10])
-
------------------------------------------------------------
type GraphAsyncAPI = Summary "Recompute graph"
:> "recompute"
, _scst_remaining = Just 1
, _scst_events = Just []
}
- _g <- trace (show u) $ recomputeGraph u n Nothing
+ _g <- trace (show u) $ recomputeGraph u n Spinglass Nothing False
pure JobLog { _scst_succeeded = Just 1
, _scst_failed = Just 0
, _scst_remaining = Just 0
Just listId -> do
repo <- getRepo' [listId]
let v = repo ^. unNodeStory . at listId . _Just . a_version
- printDebug "graphVersions" v
+ -- printDebug "graphVersions" v
pure $ GraphVersions { gv_graph = listVersion
, gv_repo = v }
=> UserId
-> NodeId
-> m Graph
-recomputeVersions uId nId = recomputeGraph uId nId Nothing
+recomputeVersions uId nId = recomputeGraph uId nId Spinglass Nothing False
------------------------------------------------------------
graphClone :: UserId
HyperdataGraphAPI { _hyperdataAPIGraph = graph } <- getGraph uId nId
pure $ addHeader "attachment; filename=graph.gexf" graph
-
-
-
-
-