src/Gargantext/Core/Viz/Graph/API.hs

   1 {-|
   2 Module      : Gargantext.Core.Viz.Graph
   3 Description :
   4 Copyright   : (c) CNRS, 2017-Present
   5 License     : AGPL + CECILL v3
   6 Maintainer  : team@gargantext.org
   7 Stability   : experimental
   8 Portability : POSIX
   9
  10 -}
  11
  12
  13 {-# LANGUAGE OverloadedLists   #-}   -- allows to write Map and HashMap as lists
  14 {-# LANGUAGE TypeOperators     #-}
  15
  16 module Gargantext.Core.Viz.Graph.API
  17   where
  18
  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
  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
  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.Node
  46 import Gargantext.Database.Schema.Ngrams
  47 import Gargantext.Prelude
  48 import Servant
  49 import Servant.Job.Async
  50 import Servant.XML
  51 import qualified Data.HashMap.Strict as HashMap
  52
  53 ------------------------------------------------------------------------
  54 -- | There is no Delete specific API for Graph since it can be deleted
  55 -- as simple Node.
  56 type GraphAPI   =  Get  '[JSON] HyperdataGraphAPI
  57               :<|> "async" :> GraphAsyncAPI
  58               :<|> "clone"
  59                    :> ReqBody '[JSON] HyperdataGraphAPI
  60                    :> Post '[JSON] NodeId
  61               :<|> "gexf" :> Get '[XML] (Headers '[Servant.Header "Content-Disposition" Text] Graph)
  62               :<|> "versions" :> GraphVersionsAPI
  63
  64 data GraphVersions =
  65   GraphVersions { gv_graph :: Maybe Int
  66                 , gv_repo :: Int
  67                 }
  68    deriving (Show, Generic)
  69
  70 instance ToJSON GraphVersions
  71 instance ToSchema GraphVersions
  72
  73 graphAPI :: UserId -> NodeId -> GargServer GraphAPI
  74 graphAPI u n = getGraph         u n
  75           :<|> graphAsync       u n
  76           :<|> graphClone       u n
  77           :<|> getGraphGexf     u n
  78           :<|> graphVersionsAPI u n
  79
  80 ------------------------------------------------------------------------
  81 getGraph :: UserId -> NodeId -> GargNoServer HyperdataGraphAPI
  82 getGraph _uId nId = do
  83   nodeGraph <- getNodeWith nId (Proxy :: Proxy HyperdataGraph)
  84
  85   let
  86     graph  = nodeGraph ^. node_hyperdata . hyperdataGraph
  87     camera = nodeGraph ^. node_hyperdata . hyperdataCamera
  88     cId = maybe (panic "[G.V.G.API] Node has no parent")
  89                   identity
  90                   $ nodeGraph ^. node_parent_id
  91
  92   listId <- defaultList cId
  93   repo <- getRepo' [listId]
  94
  95   -- TODO Distance in Graph params
  96   case graph of
  97     Nothing     -> do
  98         let defaultMetric = Order1
  99         graph' <- computeGraph cId (withMetric defaultMetric) NgramsTerms repo
 100         mt     <- defaultGraphMetadata cId "Title" repo defaultMetric
 101         let
 102           graph'' = set graph_metadata (Just mt) graph'
 103           hg = HyperdataGraphAPI graph'' camera
 104        -- _      <- updateHyperdata nId hg
 105         _ <- updateHyperdata nId (HyperdataGraph (Just graph'') camera)
 106         pure $ trace "[G.V.G.API] Graph empty, computing" hg
 107
 108     Just graph' -> pure $ trace "[G.V.G.API] Graph exists, returning" $
 109         HyperdataGraphAPI graph' camera
 110
 111
 112 recomputeGraph :: UserId -> NodeId -> Maybe GraphMetric -> GargNoServer Graph
 113 recomputeGraph _uId nId maybeDistance = do
 114   nodeGraph <- getNodeWith nId (Proxy :: Proxy HyperdataGraph)
 115   let
 116     graph  = nodeGraph ^. node_hyperdata . hyperdataGraph
 117     camera = nodeGraph ^. node_hyperdata . hyperdataCamera
 118     graphMetadata = graph ^? _Just . graph_metadata . _Just
 119     listVersion   = graph ^? _Just . graph_metadata . _Just . gm_list . lfg_version
 120     graphMetric   = case maybeDistance of
 121                       Nothing -> graph ^? _Just . graph_metadata . _Just . gm_metric
 122                       _       -> maybeDistance
 123
 124   let
 125     cId = maybe (panic "[G.V.G.API.recomputeGraph] Node has no parent")
 126                   identity
 127                   $ nodeGraph ^. node_parent_id
 128     similarity = case graphMetric of
 129                    Nothing -> withMetric Order1
 130                    Just m  -> withMetric m
 131
 132   listId  <- defaultList cId
 133   repo <- getRepo' [listId]
 134   let v   = repo ^. unNodeStory . at listId . _Just . a_version
 135
 136   case graph of
 137     Nothing     -> do
 138       graph' <- computeGraph cId similarity NgramsTerms repo
 139       mt     <- defaultGraphMetadata cId "Title" repo (fromMaybe Order1 maybeDistance)
 140       let graph'' = set graph_metadata (Just mt) graph'
 141       _ <- updateHyperdata nId (HyperdataGraph (Just graph'') camera)
 142       pure $ trace "[G.V.G.API.recomputeGraph] Graph empty, computed" graph''
 143
 144     Just graph' -> if listVersion == Just v
 145                      then pure graph'
 146                      else do
 147                        graph'' <- computeGraph cId similarity NgramsTerms repo
 148                        let graph''' = set graph_metadata graphMetadata graph''
 149                        _ <- updateHyperdata nId (HyperdataGraph (Just graph''') camera)
 150                        pure $ trace "[G.V.G.API] Graph exists, recomputing" graph'''
 151
 152
 153 -- TODO use Database Monad only here ?
 154 computeGraph :: HasNodeError err
 155              => CorpusId
 156              -> Distance
 157              -> NgramsType
 158              -> NodeListStory
 159              -> Cmd err Graph
 160 computeGraph cId d nt repo = do
 161   lId  <- defaultList cId
 162   lIds <- selectNodesWithUsername NodeList userMaster
 163
 164   let ngs = filterListWithRoot MapTerm
 165           $ mapTermListRoot [lId] nt repo
 166
 167   myCooc <- HashMap.filter (>2) -- Removing the hapax (ngrams with 1 cooc)
 168          <$> getCoocByNgrams (Diagonal True)
 169          <$> groupNodesByNgrams ngs
 170          <$> getNodesByNgramsOnlyUser cId (lIds <> [lId]) nt (HashMap.keys ngs)
 171
 172   -- printDebug "myCooc" myCooc
 173   -- saveAsFileDebug "debug/my-cooc" myCooc
 174
 175   graph <- liftBase $ cooc2graphWith Spinglass d 0 myCooc
 176   -- saveAsFileDebug "debug/graph" graph
 177   pure graph
 178
 179
 180 defaultGraphMetadata :: HasNodeError err
 181                      => CorpusId
 182                      -> Text
 183                      -> NodeListStory
 184                      -> GraphMetric
 185                      -> Cmd err GraphMetadata
 186 defaultGraphMetadata cId t repo gm = do
 187   lId  <- defaultList cId
 188
 189   pure $ GraphMetadata {
 190       _gm_title = t
 191     , _gm_metric = gm
 192     , _gm_corpusId = [cId]
 193     , _gm_legend = [
 194           LegendField 1 "#FFF" "Cluster1"
 195         , LegendField 2 "#FFF" "Cluster2"
 196         , LegendField 3 "#FFF" "Cluster3"
 197         , LegendField 4 "#FFF" "Cluster4"
 198         ]
 199       , _gm_list = (ListForGraph lId (repo ^. unNodeStory . at lId . _Just . a_version))
 200       , _gm_startForceAtlas = True
 201     }
 202                          -- (map (\n -> LegendField n "#FFFFFF" (pack $ show n)) [1..10])
 203
 204
 205 ------------------------------------------------------------
 206 type GraphAsyncAPI = Summary "Recompute graph"
 207                      :> "recompute"
 208                      :> AsyncJobsAPI JobLog () JobLog
 209
 210
 211 graphAsync :: UserId -> NodeId -> GargServer GraphAsyncAPI
 212 graphAsync u n =
 213   serveJobsAPI $
 214     JobFunction (\_ log' -> graphRecompute u n (liftBase . log'))
 215
 216
 217 graphRecompute :: UserId
 218                -> NodeId
 219                -> (JobLog -> GargNoServer ())
 220                -> GargNoServer JobLog
 221 graphRecompute u n logStatus = do
 222   logStatus JobLog { _scst_succeeded = Just 0
 223                    , _scst_failed    = Just 0
 224                    , _scst_remaining = Just 1
 225                    , _scst_events    = Just []
 226                    }
 227   _g <- trace (show u) $ recomputeGraph u n Nothing
 228   pure  JobLog { _scst_succeeded = Just 1
 229                , _scst_failed    = Just 0
 230                , _scst_remaining = Just 0
 231                , _scst_events    = Just []
 232                }
 233
 234 ------------------------------------------------------------
 235 type GraphVersionsAPI = Summary "Graph versions"
 236                         :> Get '[JSON] GraphVersions
 237                    :<|> Summary "Recompute graph version"
 238                         :> Post '[JSON] Graph
 239
 240 graphVersionsAPI :: UserId -> NodeId -> GargServer GraphVersionsAPI
 241 graphVersionsAPI u n =
 242            graphVersions 0 n
 243       :<|> recomputeVersions u n
 244
 245 graphVersions :: Int -> NodeId -> GargNoServer GraphVersions
 246 graphVersions n nId = do
 247   nodeGraph <- getNodeWith nId (Proxy :: Proxy HyperdataGraph)
 248   let
 249     graph =  nodeGraph
 250           ^. node_hyperdata
 251            . hyperdataGraph
 252
 253     listVersion =  graph
 254                 ^? _Just
 255                 . graph_metadata
 256                 . _Just
 257                 . gm_list
 258                 . lfg_version
 259
 260   mcId <- getClosestParentIdByType nId NodeCorpus
 261   let cId = maybe (panic "[G.V.G.API] Node has no parent") identity mcId
 262
 263   maybeListId <- defaultListMaybe cId
 264   case maybeListId of
 265     Nothing     -> if n <= 2
 266                       then graphVersions (n+1) cId
 267                       else panic "[G.V.G.API] list not found after iterations"
 268
 269     Just listId -> do
 270       repo <- getRepo' [listId]
 271       let v = repo ^. unNodeStory . at listId . _Just . a_version
 272       printDebug "graphVersions" v
 273
 274       pure $ GraphVersions { gv_graph = listVersion
 275                            , gv_repo = v }
 276
 277 recomputeVersions :: UserId -> NodeId -> GargNoServer Graph
 278 recomputeVersions uId nId = recomputeGraph uId nId Nothing
 279
 280 ------------------------------------------------------------
 281 graphClone :: UserId
 282            -> NodeId
 283            -> HyperdataGraphAPI
 284            -> GargNoServer NodeId
 285 graphClone uId pId (HyperdataGraphAPI { _hyperdataAPIGraph = graph
 286                                       , _hyperdataAPICamera = camera }) = do
 287   let nodeType = NodeGraph
 288   nodeUser <- getNodeUser (NodeId uId)
 289   nodeParent <- getNodeWith pId (Proxy :: Proxy HyperdataGraph)
 290   let uId' = nodeUser ^. node_user_id
 291   nIds <- mkNodeWithParent nodeType (Just pId) uId' $ nodeParent ^. node_name
 292   case nIds of
 293     [] -> pure pId
 294     (nId:_) -> do
 295       let graphP = graph
 296       let graphP' = set (graph_metadata . _Just . gm_startForceAtlas) False graphP
 297
 298       _ <- updateHyperdata nId (HyperdataGraph (Just graphP') camera)
 299
 300       pure nId
 301
 302 ------------------------------------------------------------
 303 getGraphGexf :: UserId
 304              -> NodeId
 305              -> GargNoServer (Headers '[Servant.Header "Content-Disposition" Text] Graph)
 306 getGraphGexf uId nId = do
 307   HyperdataGraphAPI { _hyperdataAPIGraph = graph } <- getGraph uId nId
 308   pure $ addHeader "attachment; filename=graph.gexf" graph
 309
 310
 311
 312
 313
 314