2 Module : Gargantext.Viz.Graph
4 Copyright : (c) CNRS, 2017-Present
5 License : AGPL + CECILL v3
6 Maintainer : team@gargantext.org
7 Stability : experimental
13 {-# OPTIONS_GHC -fno-warn-orphans #-}
15 {-# LANGUAGE OverloadedLists #-} -- allows to write Map and HashMap as lists
16 {-# LANGUAGE TypeOperators #-}
18 module Gargantext.Viz.Graph.API
21 import Control.Lens (set, (^.), _Just, (^?))
23 import qualified Data.Map as Map
24 import Data.Maybe (Maybe(..))
27 import Debug.Trace (trace)
28 import GHC.Generics (Generic)
30 import Servant.Job.Async
33 import Gargantext.API.Admin.Orchestrator.Types
34 import Gargantext.API.Ngrams (NgramsRepo, r_version)
35 import Gargantext.API.Ngrams.Tools
36 import Gargantext.API.Prelude
37 import Gargantext.Core.Types.Main
38 import Gargantext.Database.Action.Metrics.NgramsByNode (getNodesByNgramsOnlyUser)
39 import Gargantext.Database.Admin.Config
40 import Gargantext.Database.Admin.Types.Node
41 import Gargantext.Database.Prelude (Cmd)
42 import Gargantext.Database.Query.Table.Node
43 import Gargantext.Database.Query.Table.Node.Error (HasNodeError)
44 import Gargantext.Database.Query.Table.Node.Select
45 import Gargantext.Database.Query.Table.Node.UpdateOpaleye (updateHyperdata)
46 import Gargantext.Database.Schema.Ngrams
47 import Gargantext.Database.Schema.Node (node_parentId, node_hyperdata)
48 import Gargantext.Prelude
49 import Gargantext.Viz.Graph
50 import Gargantext.Viz.Graph.GEXF ()
51 import Gargantext.Viz.Graph.Tools -- (cooc2graph)
52 import Gargantext.Viz.Graph.Distances (Distance(..), GraphMetric(..))
54 ------------------------------------------------------------------------
55 -- | There is no Delete specific API for Graph since it can be deleted
57 type GraphAPI = Get '[JSON] Graph
58 :<|> "async" :> GraphAsyncAPI
59 :<|> "gexf" :> Get '[XML] (Headers '[Servant.Header "Content-Disposition" Text] Graph)
60 :<|> "versions" :> GraphVersionsAPI
63 GraphVersions { gv_graph :: Maybe Int
66 deriving (Show, Generic)
68 instance ToJSON GraphVersions
69 instance ToSchema GraphVersions
71 graphAPI :: UserId -> NodeId -> GargServer GraphAPI
72 graphAPI u n = getGraph u n
75 :<|> graphVersionsAPI u n
77 ------------------------------------------------------------------------
78 getGraph :: UserId -> NodeId -> GargNoServer Graph
79 getGraph _uId nId = do
80 nodeGraph <- getNodeWith nId HyperdataGraph
81 let graph = nodeGraph ^. node_hyperdata . hyperdataGraph
85 let cId = maybe (panic "[G.V.G.API] Node has no parent")
87 $ nodeGraph ^. node_parentId
89 -- TODO Distance in Graph params
92 graph' <- computeGraph cId Conditional NgramsTerms repo
93 mt <- defaultGraphMetadata cId "Title" repo
94 let graph'' = set graph_metadata (Just mt) graph'
95 _ <- updateHyperdata nId (HyperdataGraph $ Just graph'')
96 pure $ trace "[G.V.G.API] Graph empty, computing" graph''
98 Just graph' -> pure $ trace "[G.V.G.API] Graph exists, returning" graph'
101 recomputeGraph :: UserId -> NodeId -> Distance -> GargNoServer Graph
102 recomputeGraph _uId nId d = do
103 nodeGraph <- getNodeWith nId HyperdataGraph
104 let graph = nodeGraph ^. node_hyperdata . hyperdataGraph
105 let graphMetadata = graph ^? _Just . graph_metadata . _Just
106 let listVersion = graph ^? _Just . graph_metadata . _Just . gm_list . lfg_version
109 let v = repo ^. r_version
110 let cId = maybe (panic "[G.V.G.API.recomputeGraph] Node has no parent")
112 $ nodeGraph ^. node_parentId
116 graph' <- computeGraph cId d NgramsTerms repo
117 mt <- defaultGraphMetadata cId "Title" repo
118 let graph'' = set graph_metadata (Just mt) graph'
119 _ <- updateHyperdata nId (HyperdataGraph $ Just graph'')
120 pure $ trace "[G.V.G.API.recomputeGraph] Graph empty, computed" graph''
122 Just graph' -> if listVersion == Just v
125 graph'' <- computeGraph cId d NgramsTerms repo
126 let graph''' = set graph_metadata graphMetadata graph''
127 _ <- updateHyperdata nId (HyperdataGraph $ Just graph''')
128 pure $ trace "[G.V.G.API] Graph exists, recomputing" graph'''
131 -- TODO use Database Monad only here ?
132 computeGraph :: HasNodeError err
138 computeGraph cId d nt repo = do
139 lId <- defaultList cId
141 lIds <- selectNodesWithUsername NodeList userMaster
142 let ngs = filterListWithRoot MapTerm $ mapTermListRoot [lId] nt repo
144 -- TODO split diagonal
145 myCooc <- Map.filter (>1)
146 <$> getCoocByNgrams (Diagonal True)
147 <$> groupNodesByNgrams ngs
148 <$> getNodesByNgramsOnlyUser cId (lIds <> [lId]) nt (Map.keys ngs)
150 graph <- liftBase $ cooc2graph d 0 myCooc
155 defaultGraphMetadata :: HasNodeError err
159 -> Cmd err GraphMetadata
160 defaultGraphMetadata cId t repo = do
161 lId <- defaultList cId
163 pure $ GraphMetadata {
165 , _gm_metric = Order1
166 , _gm_corpusId = [cId]
168 LegendField 1 "#FFF" "Cluster1"
169 , LegendField 2 "#FFF" "Cluster2"
170 , LegendField 3 "#FFF" "Cluster3"
171 , LegendField 4 "#FFF" "Cluster4"
173 , _gm_list = (ListForGraph lId (repo ^. r_version))
174 , _gm_startForceAtlas = True
176 -- (map (\n -> LegendField n "#FFFFFF" (pack $ show n)) [1..10])
179 ------------------------------------------------------------
180 type GraphAsyncAPI = Summary "Recompute graph"
182 :> AsyncJobsAPI JobLog () JobLog
185 graphAsync :: UserId -> NodeId -> GargServer GraphAsyncAPI
188 JobFunction (\_ log' -> graphRecompute u n (liftBase . log'))
191 graphRecompute :: UserId
193 -> (JobLog -> GargNoServer ())
194 -> GargNoServer JobLog
195 graphRecompute u n logStatus = do
196 logStatus JobLog { _scst_succeeded = Just 0
197 , _scst_failed = Just 0
198 , _scst_remaining = Just 1
199 , _scst_events = Just []
201 _g <- trace (show u) $ recomputeGraph u n Conditional
202 pure JobLog { _scst_succeeded = Just 1
203 , _scst_failed = Just 0
204 , _scst_remaining = Just 0
205 , _scst_events = Just []
208 ------------------------------------------------------------
209 type GraphVersionsAPI = Summary "Graph versions"
210 :> Get '[JSON] GraphVersions
211 :<|> Summary "Recompute graph version"
212 :> Post '[JSON] Graph
214 graphVersionsAPI :: UserId -> NodeId -> GargServer GraphVersionsAPI
215 graphVersionsAPI u n =
217 :<|> recomputeVersions u n
219 graphVersions :: UserId -> NodeId -> GargNoServer GraphVersions
220 graphVersions _uId nId = do
221 nodeGraph <- getNodeWith nId HyperdataGraph
222 let graph = nodeGraph ^. node_hyperdata . hyperdataGraph
223 let listVersion = graph ^? _Just
230 let v = repo ^. r_version
232 pure $ GraphVersions { gv_graph = listVersion
235 recomputeVersions :: UserId -> NodeId -> GargNoServer Graph
236 recomputeVersions uId nId = recomputeGraph uId nId Conditional
238 ------------------------------------------------------------
239 getGraphGexf :: UserId
241 -> GargNoServer (Headers '[Servant.Header "Content-Disposition" Text] Graph)
242 getGraphGexf uId nId = do
243 graph <- getGraph uId nId
244 pure $ addHeader "attachment; filename=graph.gexf" graph