2 Module : Gargantext.Core.Viz.Graph
4 Copyright : (c) CNRS, 2017-Present
5 License : AGPL + CECILL v3
6 Maintainer : team@gargantext.org
7 Stability : experimental
13 {-# LANGUAGE OverloadedLists #-} -- allows to write Map and HashMap as lists
14 {-# LANGUAGE TypeOperators #-}
16 module Gargantext.Core.Viz.Graph.API
19 import Control.Lens (set, (^.), _Just, (^?))
21 import Data.Maybe (fromMaybe)
24 import Debug.Trace (trace)
25 import GHC.Generics (Generic)
26 import Gargantext.API.Admin.Orchestrator.Types
27 import Gargantext.API.Ngrams.Tools
28 import Gargantext.API.Ngrams.Types (NgramsRepo, r_version)
29 import Gargantext.API.Prelude
30 import Gargantext.Core.Methods.Distances (Distance(..), GraphMetric(..), withMetric)
31 import Gargantext.Core.Types.Main
32 import Gargantext.Core.Viz.Graph
33 import Gargantext.Core.Viz.Graph.GEXF ()
34 import Gargantext.Core.Viz.Graph.Tools -- (cooc2graph)
35 import Gargantext.Database.Action.Metrics.NgramsByNode (getNodesByNgramsOnlyUser)
36 import Gargantext.Database.Action.Node (mkNodeWithParent)
37 import Gargantext.Database.Admin.Config
38 import Gargantext.Database.Admin.Types.Node
39 import Gargantext.Database.Prelude (Cmd)
40 import Gargantext.Database.Query.Table.Node
41 import Gargantext.Database.Query.Table.Node.Error (HasNodeError)
42 import Gargantext.Database.Query.Table.Node.Select
43 import Gargantext.Database.Query.Table.Node.UpdateOpaleye (updateHyperdata)
44 import Gargantext.Database.Query.Table.Node.User (getNodeUser)
45 import Gargantext.Database.Schema.Ngrams
46 import Gargantext.Database.Schema.Node (node_parent_id, node_hyperdata, node_name, node_user_id)
47 import Gargantext.Prelude
49 import Servant.Job.Async
51 import qualified Data.HashMap.Strict as HashMap
52 ------------------------------------------------------------------------
53 -- | There is no Delete specific API for Graph since it can be deleted
55 type GraphAPI = Get '[JSON] HyperdataGraphAPI
56 :<|> "async" :> GraphAsyncAPI
58 :> ReqBody '[JSON] HyperdataGraphAPI
59 :> Post '[JSON] NodeId
60 :<|> "gexf" :> Get '[XML] (Headers '[Servant.Header "Content-Disposition" Text] Graph)
61 :<|> "versions" :> GraphVersionsAPI
64 GraphVersions { gv_graph :: Maybe Int
67 deriving (Show, Generic)
69 instance ToJSON GraphVersions
70 instance ToSchema GraphVersions
72 graphAPI :: UserId -> NodeId -> GargServer GraphAPI
73 graphAPI u n = getGraph u n
77 :<|> graphVersionsAPI u n
79 ------------------------------------------------------------------------
80 getGraph :: UserId -> NodeId -> GargNoServer HyperdataGraphAPI
81 getGraph _uId nId = do
82 nodeGraph <- getNodeWith nId (Proxy :: Proxy HyperdataGraph)
86 graph = nodeGraph ^. node_hyperdata . hyperdataGraph
87 camera = nodeGraph ^. node_hyperdata . hyperdataCamera
88 cId = maybe (panic "[G.V.G.API] Node has no parent")
90 $ nodeGraph ^. node_parent_id
92 -- TODO Distance in Graph params
95 let defaultMetric = Order1
96 graph' <- computeGraph cId (withMetric defaultMetric) NgramsTerms repo
97 mt <- defaultGraphMetadata cId "Title" repo defaultMetric
99 graph'' = set graph_metadata (Just mt) graph'
100 hg = HyperdataGraphAPI graph'' camera
101 -- _ <- updateHyperdata nId hg
102 _ <- updateHyperdata nId (HyperdataGraph (Just graph'') camera)
103 pure $ trace "[G.V.G.API] Graph empty, computing" hg
105 Just graph' -> pure $ trace "[G.V.G.API] Graph exists, returning" $
106 HyperdataGraphAPI graph' camera
109 recomputeGraph :: UserId -> NodeId -> Maybe GraphMetric -> GargNoServer Graph
110 recomputeGraph _uId nId maybeDistance = do
111 nodeGraph <- getNodeWith nId (Proxy :: Proxy HyperdataGraph)
113 graph = nodeGraph ^. node_hyperdata . hyperdataGraph
114 camera = nodeGraph ^. node_hyperdata . hyperdataCamera
115 graphMetadata = graph ^? _Just . graph_metadata . _Just
116 listVersion = graph ^? _Just . graph_metadata . _Just . gm_list . lfg_version
117 graphMetric = case maybeDistance of
118 Nothing -> graph ^? _Just . graph_metadata . _Just . gm_metric
123 v = repo ^. r_version
124 cId = maybe (panic "[G.V.G.API.recomputeGraph] Node has no parent")
126 $ nodeGraph ^. node_parent_id
127 similarity = case graphMetric of
128 Nothing -> withMetric Order1
129 Just m -> withMetric m
133 graph' <- computeGraph cId similarity NgramsTerms repo
134 mt <- defaultGraphMetadata cId "Title" repo (fromMaybe Order1 maybeDistance)
135 let graph'' = set graph_metadata (Just mt) graph'
136 _ <- updateHyperdata nId (HyperdataGraph (Just graph'') camera)
137 pure $ trace "[G.V.G.API.recomputeGraph] Graph empty, computed" graph''
139 Just graph' -> if listVersion == Just v
142 graph'' <- computeGraph cId similarity NgramsTerms repo
143 let graph''' = set graph_metadata graphMetadata graph''
144 _ <- updateHyperdata nId (HyperdataGraph (Just graph''') camera)
145 pure $ trace "[G.V.G.API] Graph exists, recomputing" graph'''
148 -- TODO use Database Monad only here ?
149 computeGraph :: HasNodeError err
155 computeGraph cId d nt repo = do
156 lId <- defaultList cId
157 lIds <- selectNodesWithUsername NodeList userMaster
159 let ngs = filterListWithRoot MapTerm
160 $ mapTermListRoot [lId] nt repo
162 myCooc <- HashMap.filter (>2) -- Removing the hapax (ngrams with 1 cooc)
163 <$> getCoocByNgrams (Diagonal True)
164 <$> groupNodesByNgrams ngs
165 <$> getNodesByNgramsOnlyUser cId (lIds <> [lId]) nt (HashMap.keys ngs)
167 -- printDebug "myCooc" myCooc
168 -- saveAsFileDebug "debug/my-cooc" myCooc
170 graph <- liftBase $ cooc2graphWith Spinglass d 0 myCooc
171 -- saveAsFileDebug "debug/graph" graph
175 defaultGraphMetadata :: HasNodeError err
180 -> Cmd err GraphMetadata
181 defaultGraphMetadata cId t repo gm = do
182 lId <- defaultList cId
184 pure $ GraphMetadata {
187 , _gm_corpusId = [cId]
189 LegendField 1 "#FFF" "Cluster1"
190 , LegendField 2 "#FFF" "Cluster2"
191 , LegendField 3 "#FFF" "Cluster3"
192 , LegendField 4 "#FFF" "Cluster4"
194 , _gm_list = (ListForGraph lId (repo ^. r_version))
195 , _gm_startForceAtlas = True
197 -- (map (\n -> LegendField n "#FFFFFF" (pack $ show n)) [1..10])
200 ------------------------------------------------------------
201 type GraphAsyncAPI = Summary "Recompute graph"
203 :> AsyncJobsAPI JobLog () JobLog
206 graphAsync :: UserId -> NodeId -> GargServer GraphAsyncAPI
209 JobFunction (\_ log' -> graphRecompute u n (liftBase . log'))
212 graphRecompute :: UserId
214 -> (JobLog -> GargNoServer ())
215 -> GargNoServer JobLog
216 graphRecompute u n logStatus = do
217 logStatus JobLog { _scst_succeeded = Just 0
218 , _scst_failed = Just 0
219 , _scst_remaining = Just 1
220 , _scst_events = Just []
222 _g <- trace (show u) $ recomputeGraph u n Nothing
223 pure JobLog { _scst_succeeded = Just 1
224 , _scst_failed = Just 0
225 , _scst_remaining = Just 0
226 , _scst_events = Just []
229 ------------------------------------------------------------
230 type GraphVersionsAPI = Summary "Graph versions"
231 :> Get '[JSON] GraphVersions
232 :<|> Summary "Recompute graph version"
233 :> Post '[JSON] Graph
235 graphVersionsAPI :: UserId -> NodeId -> GargServer GraphVersionsAPI
236 graphVersionsAPI u n =
238 :<|> recomputeVersions u n
240 graphVersions :: NodeId -> GargNoServer GraphVersions
241 graphVersions nId = do
242 nodeGraph <- getNodeWith nId (Proxy :: Proxy HyperdataGraph)
256 let v = repo ^. r_version
258 pure $ GraphVersions { gv_graph = listVersion
261 recomputeVersions :: UserId -> NodeId -> GargNoServer Graph
262 recomputeVersions uId nId = recomputeGraph uId nId Nothing
264 ------------------------------------------------------------
268 -> GargNoServer NodeId
269 graphClone uId pId (HyperdataGraphAPI { _hyperdataAPIGraph = graph
270 , _hyperdataAPICamera = camera }) = do
271 let nodeType = NodeGraph
272 nodeUser <- getNodeUser (NodeId uId)
273 nodeParent <- getNodeWith pId (Proxy :: Proxy HyperdataGraph)
274 let uId' = nodeUser ^. node_user_id
275 nIds <- mkNodeWithParent nodeType (Just pId) uId' $ nodeParent ^. node_name
280 let graphP' = set (graph_metadata . _Just . gm_startForceAtlas) False graphP
282 _ <- updateHyperdata nId (HyperdataGraph (Just graphP') camera)
286 ------------------------------------------------------------
287 getGraphGexf :: UserId
289 -> GargNoServer (Headers '[Servant.Header "Content-Disposition" Text] Graph)
290 getGraphGexf uId nId = do
291 HyperdataGraphAPI { _hyperdataAPIGraph = graph } <- getGraph uId nId
292 pure $ addHeader "attachment; filename=graph.gexf" graph