API.hs 11.9 KB
Newer Older
Alexandre Delanoë's avatar
Alexandre Delanoë committed
1
{-|
2
Module      : Gargantext.Core.Viz.Graph
3
Description :
Alexandre Delanoë's avatar
Alexandre Delanoë committed
4 5 6 7 8 9 10 11 12 13
Copyright   : (c) CNRS, 2017-Present
License     : AGPL + CECILL v3
Maintainer  : team@gargantext.org
Stability   : experimental
Portability : POSIX

-}


{-# LANGUAGE OverloadedLists   #-}   -- allows to write Map and HashMap as lists
14
{-# LANGUAGE TypeOperators     #-}
Alexandre Delanoë's avatar
Alexandre Delanoë committed
15

16
module Gargantext.Core.Viz.Graph.API
Alexandre Delanoë's avatar
Alexandre Delanoë committed
17 18
  where

19
import Control.Lens (set, (^.), _Just, (^?), at)
20
import Data.Aeson
21
import Data.Maybe (fromMaybe)
22
import Data.Swagger
23
import Data.Text hiding (head)
24
import Debug.Trace (trace)
25
import GHC.Generics (Generic)
26
import Gargantext.API.Admin.Orchestrator.Types
Alexandre Delanoë's avatar
Alexandre Delanoë committed
27
import Gargantext.API.Ngrams.Tools
28
import Gargantext.API.Prelude
29
import Gargantext.Core.Methods.Distances (Distance(..), GraphMetric(..), withMetric)
30
import Gargantext.Core.NodeStory
Alexandre Delanoë's avatar
Alexandre Delanoë committed
31
import Gargantext.Core.Types.Main
32 33 34
import Gargantext.Core.Viz.Graph
import Gargantext.Core.Viz.Graph.GEXF ()
import Gargantext.Core.Viz.Graph.Tools -- (cooc2graph)
35
import Gargantext.Database.Action.Metrics.NgramsByNode (getNodesByNgramsOnlyUser)
36
import Gargantext.Database.Action.Flow.Types (FlowCmdM)
37
import Gargantext.Database.Action.Node (mkNodeWithParent)
38 39 40
import Gargantext.Database.Admin.Config
import Gargantext.Database.Admin.Types.Node
import Gargantext.Database.Prelude (Cmd)
41
import Gargantext.Database.Query.Table.Node
42
import Gargantext.Database.Query.Table.Node.Error (HasNodeError)
43
import Gargantext.Database.Query.Table.Node.Select
44
import Gargantext.Database.Query.Table.Node.UpdateOpaleye (updateHyperdata)
45
import Gargantext.Database.Query.Table.Node.User (getNodeUser)
46
import Gargantext.Database.Schema.Node
47
import Gargantext.Database.Schema.Ngrams
Alexandre Delanoë's avatar
Alexandre Delanoë committed
48
import Gargantext.Prelude
49 50 51 52
import Servant
import Servant.Job.Async
import Servant.XML
import qualified Data.HashMap.Strict as HashMap
53

Alexandre Delanoë's avatar
Alexandre Delanoë committed
54 55 56
------------------------------------------------------------------------
-- | There is no Delete specific API for Graph since it can be deleted
-- as simple Node.
57
type GraphAPI   =  Get  '[JSON] HyperdataGraphAPI
58
              :<|> "async" :> GraphAsyncAPI
59
              :<|> "clone"
60
                   :> ReqBody '[JSON] HyperdataGraphAPI
61
                   :> Post '[JSON] NodeId
62
              :<|> "gexf" :> Get '[XML] (Headers '[Servant.Header "Content-Disposition" Text] Graph)
63
              :<|> "versions" :> GraphVersionsAPI
Alexandre Delanoë's avatar
Alexandre Delanoë committed
64

65 66
data GraphVersions =
  GraphVersions { gv_graph :: Maybe Int
67 68
                , gv_repo :: Int
                }
69
   deriving (Show, Generic)
70 71 72

instance ToJSON GraphVersions
instance ToSchema GraphVersions
Alexandre Delanoë's avatar
Alexandre Delanoë committed
73

74
graphAPI :: UserId -> NodeId -> GargServer GraphAPI
75 76
graphAPI u n = getGraph         u n
          :<|> graphAsync       u n
77
          :<|> graphClone       u n
78 79
          :<|> getGraphGexf     u n
          :<|> graphVersionsAPI u n
Alexandre Delanoë's avatar
Alexandre Delanoë committed
80 81

------------------------------------------------------------------------
82 83 84 85 86
--getGraph :: UserId -> NodeId -> GargServer HyperdataGraphAPI
getGraph :: FlowCmdM env err m
         => UserId
         -> NodeId
         -> m HyperdataGraphAPI
87
getGraph _uId nId = do
88
  nodeGraph <- getNodeWith nId (Proxy :: Proxy HyperdataGraph)
89

90 91 92 93
  let
    graph  = nodeGraph ^. node_hyperdata . hyperdataGraph
    camera = nodeGraph ^. node_hyperdata . hyperdataCamera
    cId = maybe (panic "[G.V.G.API] Node has no parent")
94
                  identity
95
                  $ nodeGraph ^. node_parent_id
96

97 98 99
  listId <- defaultList cId
  repo <- getRepo' [listId]

100
  -- TODO Distance in Graph params
101
  case graph of
102
    Nothing     -> do
103 104 105
        let defaultMetric = Order1
        graph' <- computeGraph cId (withMetric defaultMetric) NgramsTerms repo
        mt     <- defaultGraphMetadata cId "Title" repo defaultMetric
106 107 108
        let
          graph'' = set graph_metadata (Just mt) graph'
          hg = HyperdataGraphAPI graph'' camera
109 110
       -- _      <- updateHyperdata nId hg
        _ <- updateHyperdata nId (HyperdataGraph (Just graph'') camera)
111
        pure $ trace "[G.V.G.API] Graph empty, computing" hg
112

113 114
    Just graph' -> pure $ trace "[G.V.G.API] Graph exists, returning" $
        HyperdataGraphAPI graph' camera
115 116


117 118 119 120 121 122
--recomputeGraph :: UserId -> NodeId -> Maybe GraphMetric -> GargNoServer Graph
recomputeGraph :: FlowCmdM env err m
               => UserId
               -> NodeId
               -> Maybe GraphMetric
               -> m Graph
123
recomputeGraph _uId nId maybeDistance = do
124
  nodeGraph <- getNodeWith nId (Proxy :: Proxy HyperdataGraph)
125 126 127 128 129
  let
    graph  = nodeGraph ^. node_hyperdata . hyperdataGraph
    camera = nodeGraph ^. node_hyperdata . hyperdataCamera
    graphMetadata = graph ^? _Just . graph_metadata . _Just
    listVersion   = graph ^? _Just . graph_metadata . _Just . gm_list . lfg_version
130 131 132
    graphMetric   = case maybeDistance of
                      Nothing -> graph ^? _Just . graph_metadata . _Just . gm_metric
                      _       -> maybeDistance
Alexandre Delanoë's avatar
Alexandre Delanoë committed
133

134
  let
135
    cId = maybe (panic "[G.C.V.G.API.recomputeGraph] Node has no parent")
136
                  identity
137
                  $ nodeGraph ^. node_parent_id
138
    similarity = case graphMetric of
139
                   Nothing -> withMetric Order1
140
                   Just m  -> withMetric m
141

142 143 144 145
  listId  <- defaultList cId
  repo <- getRepo' [listId]
  let v   = repo ^. unNodeStory . at listId . _Just . a_version

146
  case graph of
147
    Nothing     -> do
148 149
      graph' <- computeGraph cId similarity NgramsTerms repo
      mt     <- defaultGraphMetadata cId "Title" repo (fromMaybe Order1 maybeDistance)
150
      let graph'' = set graph_metadata (Just mt) graph'
151
      _ <- updateHyperdata nId (HyperdataGraph (Just graph'') camera)
152
      pure $ trace "[G.V.G.API.recomputeGraph] Graph empty, computed" graph''
153

154
    Just graph' -> if listVersion == Just v
155
                     then pure graph'
156
                     else do
157
                       graph'' <- computeGraph cId similarity NgramsTerms repo
158
                       let graph''' = set graph_metadata graphMetadata graph''
159
                       _ <- updateHyperdata nId (HyperdataGraph (Just graph''') camera)
160
                       pure $ trace "[G.V.G.API] Graph exists, recomputing" graph'''
161

162 163

-- TODO use Database Monad only here ?
164 165 166 167 168 169 170
--computeGraph :: HasNodeError err
--             => CorpusId
--             -> Distance
--             -> NgramsType
--             -> NodeListStory
--             -> Cmd err Graph
computeGraph :: FlowCmdM env err m
171
             => CorpusId
172
             -> Distance
173
             -> NgramsType
174
             -> NodeListStory
175
             -> m Graph
176
computeGraph cId d nt repo = do
177
  lId  <- defaultList cId
178
  lIds <- selectNodesWithUsername NodeList userMaster
Alexandre Delanoë's avatar
Alexandre Delanoë committed
179

180 181 182
  let ngs = filterListWithRoot MapTerm
          $ mapTermListRoot [lId] nt repo

183 184
  myCooc <- HashMap.filter (>1) -- Removing the hapax (ngrams with 1 cooc)
         <$> getCoocByNgrams (if d == Conditional then Diagonal True else Diagonal False)
185
         <$> groupNodesByNgrams ngs
186
         <$> getNodesByNgramsOnlyUser cId (lIds <> [lId]) nt (HashMap.keys ngs)
Alexandre Delanoë's avatar
Alexandre Delanoë committed
187

188
  -- printDebug "myCooc" myCooc
189
  -- saveAsFileDebug "debug/my-cooc" myCooc
190

191
  listNgrams <- getListNgrams [lId] nt
192

193
  graph <- liftBase $ cooc2graphWith Spinglass d 0 myCooc
194
  -- saveAsFileDebug "debug/graph" graph
195
  pure $ mergeGraphNgrams graph (Just listNgrams)
196 197


198 199 200
defaultGraphMetadata :: HasNodeError err
                     => CorpusId
                     -> Text
201
                     -> NodeListStory
202
                     -> GraphMetric
203
                     -> Cmd err GraphMetadata
204
defaultGraphMetadata cId t repo gm = do
205 206 207 208
  lId  <- defaultList cId

  pure $ GraphMetadata {
      _gm_title = t
209
    , _gm_metric = gm
210 211 212 213 214 215 216
    , _gm_corpusId = [cId]
    , _gm_legend = [
          LegendField 1 "#FFF" "Cluster1"
        , LegendField 2 "#FFF" "Cluster2"
        , LegendField 3 "#FFF" "Cluster3"
        , LegendField 4 "#FFF" "Cluster4"
        ]
217
      , _gm_list = (ListForGraph lId (repo ^. unNodeStory . at lId . _Just . a_version))
218 219 220
      , _gm_startForceAtlas = True
    }
                         -- (map (\n -> LegendField n "#FFFFFF" (pack $ show n)) [1..10])
221

Alexandre Delanoë's avatar
Alexandre Delanoë committed
222

223
------------------------------------------------------------
224 225 226
type GraphAsyncAPI = Summary "Recompute graph"
                     :> "recompute"
                     :> AsyncJobsAPI JobLog () JobLog
227

Alexandre Delanoë's avatar
Alexandre Delanoë committed
228

229
graphAsync :: UserId -> NodeId -> GargServer GraphAsyncAPI
230 231
graphAsync u n =
  serveJobsAPI $
232
    JobFunction (\_ log' -> graphRecompute u n (liftBase . log'))
233 234


235 236 237 238 239 240
--graphRecompute :: UserId
--               -> NodeId
--               -> (JobLog -> GargNoServer ())
--               -> GargNoServer JobLog
graphRecompute :: FlowCmdM env err m
               => UserId
241
               -> NodeId
242 243
               -> (JobLog -> m ())
               -> m JobLog
244
graphRecompute u n logStatus = do
245
  logStatus JobLog { _scst_succeeded = Just 0
246 247 248 249
                   , _scst_failed    = Just 0
                   , _scst_remaining = Just 1
                   , _scst_events    = Just []
                   }
250
  _g <- trace (show u) $ recomputeGraph u n Nothing
251
  pure  JobLog { _scst_succeeded = Just 1
252 253 254 255
               , _scst_failed    = Just 0
               , _scst_remaining = Just 0
               , _scst_events    = Just []
               }
256 257 258 259 260 261 262 263 264

------------------------------------------------------------
type GraphVersionsAPI = Summary "Graph versions"
                        :> Get '[JSON] GraphVersions
                   :<|> Summary "Recompute graph version"
                        :> Post '[JSON] Graph

graphVersionsAPI :: UserId -> NodeId -> GargServer GraphVersionsAPI
graphVersionsAPI u n =
265
           graphVersions 0 n
266 267
      :<|> recomputeVersions u n

268 269
graphVersions :: Int -> NodeId -> GargNoServer GraphVersions
graphVersions n nId = do
270
  nodeGraph <- getNodeWith nId (Proxy :: Proxy HyperdataGraph)
271 272 273 274 275 276 277 278 279 280 281
  let
    graph =  nodeGraph
          ^. node_hyperdata
           . hyperdataGraph

    listVersion =  graph
                ^? _Just
                . graph_metadata
                . _Just
                . gm_list
                . lfg_version
282

283 284
  mcId <- getClosestParentIdByType nId NodeCorpus
  let cId = maybe (panic "[G.V.G.API] Node has no parent") identity mcId
285

286 287 288 289 290 291 292 293 294 295
  maybeListId <- defaultListMaybe cId
  case maybeListId of
    Nothing     -> if n <= 2
                      then graphVersions (n+1) cId
                      else panic "[G.V.G.API] list not found after iterations"

    Just listId -> do
      repo <- getRepo' [listId]
      let v = repo ^. unNodeStory . at listId . _Just . a_version
      printDebug "graphVersions" v
296

297 298
      pure $ GraphVersions { gv_graph = listVersion
                           , gv_repo = v }
299

300 301 302 303 304
--recomputeVersions :: UserId -> NodeId -> GargNoServer Graph
recomputeVersions :: FlowCmdM env err m
                  => UserId
                  -> NodeId
                  -> m Graph
305
recomputeVersions uId nId = recomputeGraph uId nId Nothing
Alexandre Delanoë's avatar
Alexandre Delanoë committed
306

307 308 309
------------------------------------------------------------
graphClone :: UserId
           -> NodeId
310
           -> HyperdataGraphAPI
311
           -> GargNoServer NodeId
312 313
graphClone uId pId (HyperdataGraphAPI { _hyperdataAPIGraph = graph
                                      , _hyperdataAPICamera = camera }) = do
314 315
  let nodeType = NodeGraph
  nodeUser <- getNodeUser (NodeId uId)
316
  nodeParent <- getNodeWith pId (Proxy :: Proxy HyperdataGraph)
317
  let uId' = nodeUser ^. node_user_id
318 319 320 321 322 323 324
  nIds <- mkNodeWithParent nodeType (Just pId) uId' $ nodeParent ^. node_name
  case nIds of
    [] -> pure pId
    (nId:_) -> do
      let graphP = graph
      let graphP' = set (graph_metadata . _Just . gm_startForceAtlas) False graphP

325
      _ <- updateHyperdata nId (HyperdataGraph (Just graphP') camera)
326 327 328

      pure nId

Alexandre Delanoë's avatar
Alexandre Delanoë committed
329
------------------------------------------------------------
330 331 332 333 334
--getGraphGexf :: UserId
--             -> NodeId
--             -> GargNoServer (Headers '[Servant.Header "Content-Disposition" Text] Graph)
getGraphGexf :: FlowCmdM env err m
             => UserId
Alexandre Delanoë's avatar
Alexandre Delanoë committed
335
             -> NodeId
336
             -> m (Headers '[Servant.Header "Content-Disposition" Text] Graph)
Alexandre Delanoë's avatar
Alexandre Delanoë committed
337
getGraphGexf uId nId = do
338
  HyperdataGraphAPI { _hyperdataAPIGraph = graph } <- getGraph uId nId
339
  pure $ addHeader "attachment; filename=graph.gexf" graph
340 341 342 343 344 345