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, (^?))
  20 import Data.Aeson
  21 import Data.Swagger
  22 import Data.Text
  23 import Debug.Trace (trace)
  24 import GHC.Generics (Generic)
  25 import Gargantext.API.Admin.Orchestrator.Types
  26 import Gargantext.API.Ngrams.Tools
  27 import Gargantext.API.Ngrams.Types (NgramsRepo, r_version)
  28 import Gargantext.API.Prelude
  29 import Gargantext.Core.Methods.Distances (Distance(..), GraphMetric(..))
  30 import Gargantext.Core.Types.Main
  31 import Gargantext.Core.Viz.Graph
  32 import Gargantext.Core.Viz.Graph.GEXF ()
  33 import Gargantext.Core.Viz.Graph.Tools -- (cooc2graph)
  34 import Gargantext.Database.Action.Metrics.NgramsByNode (getNodesByNgramsOnlyUser)
  35 import Gargantext.Database.Action.Node (mkNodeWithParent)
  36 import Gargantext.Database.Admin.Config
  37 import Gargantext.Database.Admin.Types.Node
  38 import Gargantext.Database.Prelude (Cmd)
  39 import Gargantext.Database.Query.Table.Node
  40 import Gargantext.Database.Query.Table.Node.Error (HasNodeError)
  41 import Gargantext.Database.Query.Table.Node.Select
  42 import Gargantext.Database.Query.Table.Node.UpdateOpaleye (updateHyperdata)
  43 import Gargantext.Database.Query.Table.Node.User (getNodeUser)
  44 import Gargantext.Database.Schema.Ngrams
  45 import Gargantext.Database.Schema.Node (node_parentId, node_hyperdata, node_name, node_userId)
  46 import Gargantext.Prelude
  47 import Servant
  48 import Servant.Job.Async
  49 import Servant.XML
  50 import qualified Data.HashMap.Strict as HashMap
  51 ------------------------------------------------------------------------
  52 -- | There is no Delete specific API for Graph since it can be deleted
  53 -- as simple Node.
  54 type GraphAPI   =  Get  '[JSON] HyperdataGraphAPI
  55               :<|> "async" :> GraphAsyncAPI
  56               :<|> "clone"
  57                    :> ReqBody '[JSON] HyperdataGraphAPI
  58                    :> Post '[JSON] NodeId
  59               :<|> "gexf" :> Get '[XML] (Headers '[Servant.Header "Content-Disposition" Text] Graph)
  60               :<|> "versions" :> GraphVersionsAPI
  61
  62 data GraphVersions =
  63   GraphVersions { gv_graph :: Maybe Int
  64                 , gv_repo :: Int
  65                 }
  66    deriving (Show, Generic)
  67
  68 instance ToJSON GraphVersions
  69 instance ToSchema GraphVersions
  70
  71 graphAPI :: UserId -> NodeId -> GargServer GraphAPI
  72 graphAPI u n = getGraph         u n
  73           :<|> graphAsync       u n
  74           :<|> graphClone       u n
  75           :<|> getGraphGexf     u n
  76           :<|> graphVersionsAPI u n
  77
  78 ------------------------------------------------------------------------
  79 getGraph :: UserId -> NodeId -> GargNoServer HyperdataGraphAPI
  80 getGraph _uId nId = do
  81   nodeGraph <- getNodeWith nId (Proxy :: Proxy HyperdataGraph)
  82   repo <- getRepo
  83
  84   let
  85     graph  = nodeGraph ^. node_hyperdata . hyperdataGraph
  86     camera = nodeGraph ^. node_hyperdata . hyperdataCamera
  87     cId = maybe (panic "[G.V.G.API] Node has no parent")
  88                   identity
  89                   $ nodeGraph ^. node_parentId
  90
  91   -- TODO Distance in Graph params
  92   case graph of
  93     Nothing     -> do
  94         -- graph' <- computeGraph cId Distributional NgramsTerms repo
  95         graph' <- computeGraph cId Conditional NgramsTerms repo
  96         mt     <- defaultGraphMetadata cId "Title" repo
  97         let
  98           graph'' = set graph_metadata (Just mt) graph'
  99           hg = HyperdataGraphAPI graph'' camera
 100        -- _      <- updateHyperdata nId hg
 101         _ <- updateHyperdata nId (HyperdataGraph (Just graph'') camera)
 102         pure $ trace "[G.V.G.API] Graph empty, computing" hg
 103
 104     Just graph' -> pure $ trace "[G.V.G.API] Graph exists, returning" $
 105         HyperdataGraphAPI graph' camera
 106
 107
 108 recomputeGraph :: UserId -> NodeId -> Distance -> GargNoServer Graph
 109 recomputeGraph _uId nId d = do
 110   nodeGraph <- getNodeWith nId (Proxy :: Proxy HyperdataGraph)
 111   let
 112     graph  = nodeGraph ^. node_hyperdata . hyperdataGraph
 113     camera = nodeGraph ^. node_hyperdata . hyperdataCamera
 114     graphMetadata = graph ^? _Just . graph_metadata . _Just
 115     listVersion   = graph ^? _Just . graph_metadata . _Just . gm_list . lfg_version
 116
 117   repo <- getRepo
 118   let
 119     v   = repo ^. r_version
 120     cId = maybe (panic "[G.V.G.API.recomputeGraph] Node has no parent")
 121                   identity
 122                   $ nodeGraph ^. node_parentId
 123
 124   case graph of
 125     Nothing     -> do
 126       graph' <- computeGraph cId d NgramsTerms repo
 127       mt     <- defaultGraphMetadata cId "Title" repo
 128       let graph'' = set graph_metadata (Just mt) graph'
 129       _ <- updateHyperdata nId (HyperdataGraph (Just graph'') camera)
 130       pure $ trace "[G.V.G.API.recomputeGraph] Graph empty, computed" graph''
 131
 132     Just graph' -> if listVersion == Just v
 133                      then pure graph'
 134                      else do
 135                        graph'' <- computeGraph cId d NgramsTerms repo
 136                        let graph''' = set graph_metadata graphMetadata graph''
 137                        _ <- updateHyperdata nId (HyperdataGraph (Just graph''') camera)
 138                        pure $ trace "[G.V.G.API] Graph exists, recomputing" graph'''
 139
 140
 141 -- TODO use Database Monad only here ?
 142 computeGraph :: HasNodeError err
 143              => CorpusId
 144              -> Distance
 145              -> NgramsType
 146              -> NgramsRepo
 147              -> Cmd err Graph
 148 computeGraph cId d nt repo = do
 149   lId  <- defaultList cId
 150   lIds <- selectNodesWithUsername NodeList userMaster
 151
 152   let ngs = filterListWithRoot MapTerm
 153           $ mapTermListRoot [lId] nt repo
 154
 155   myCooc <- HashMap.filter (>1) -- Removing the hapax (ngrams with 1 cooc)
 156          <$> getCoocByNgrams (Diagonal True)
 157          <$> groupNodesByNgrams ngs
 158          <$> getNodesByNgramsOnlyUser cId (lIds <> [lId]) nt (HashMap.keys ngs)
 159
 160   printDebug "myCooc" myCooc
 161
 162   graph <- liftBase $ cooc2graphWith Spinglass d 0 myCooc
 163   pure graph
 164
 165
 166 defaultGraphMetadata :: HasNodeError err
 167                      => CorpusId
 168                      -> Text
 169                      -> NgramsRepo
 170                      -> Cmd err GraphMetadata
 171 defaultGraphMetadata cId t repo = do
 172   lId  <- defaultList cId
 173
 174   pure $ GraphMetadata {
 175       _gm_title = t
 176     , _gm_metric = Order1
 177     , _gm_corpusId = [cId]
 178     , _gm_legend = [
 179           LegendField 1 "#FFF" "Cluster1"
 180         , LegendField 2 "#FFF" "Cluster2"
 181         , LegendField 3 "#FFF" "Cluster3"
 182         , LegendField 4 "#FFF" "Cluster4"
 183         ]
 184       , _gm_list = (ListForGraph lId (repo ^. r_version))
 185       , _gm_startForceAtlas = True
 186     }
 187                          -- (map (\n -> LegendField n "#FFFFFF" (pack $ show n)) [1..10])
 188
 189
 190 ------------------------------------------------------------
 191 type GraphAsyncAPI = Summary "Recompute graph"
 192                      :> "recompute"
 193                      :> AsyncJobsAPI JobLog () JobLog
 194
 195
 196 graphAsync :: UserId -> NodeId -> GargServer GraphAsyncAPI
 197 graphAsync u n =
 198   serveJobsAPI $
 199     JobFunction (\_ log' -> graphRecompute u n (liftBase . log'))
 200
 201
 202 graphRecompute :: UserId
 203                -> NodeId
 204                -> (JobLog -> GargNoServer ())
 205                -> GargNoServer JobLog
 206 graphRecompute u n logStatus = do
 207   logStatus JobLog { _scst_succeeded = Just 0
 208                    , _scst_failed    = Just 0
 209                    , _scst_remaining = Just 1
 210                    , _scst_events    = Just []
 211                    }
 212   _g <- trace (show u) $ recomputeGraph u n Distributional
 213   pure  JobLog { _scst_succeeded = Just 1
 214                , _scst_failed    = Just 0
 215                , _scst_remaining = Just 0
 216                , _scst_events    = Just []
 217                }
 218
 219 ------------------------------------------------------------
 220 type GraphVersionsAPI = Summary "Graph versions"
 221                         :> Get '[JSON] GraphVersions
 222                    :<|> Summary "Recompute graph version"
 223                         :> Post '[JSON] Graph
 224
 225 graphVersionsAPI :: UserId -> NodeId -> GargServer GraphVersionsAPI
 226 graphVersionsAPI u n =
 227            graphVersions n
 228       :<|> recomputeVersions u n
 229
 230 graphVersions :: NodeId -> GargNoServer GraphVersions
 231 graphVersions nId = do
 232   nodeGraph <- getNodeWith nId (Proxy :: Proxy HyperdataGraph)
 233   let
 234     graph =  nodeGraph
 235           ^. node_hyperdata
 236            . hyperdataGraph
 237
 238     listVersion =  graph
 239                 ^? _Just
 240                 . graph_metadata
 241                 . _Just
 242                 . gm_list
 243                 . lfg_version
 244
 245   repo <- getRepo
 246   let v = repo ^. r_version
 247
 248   pure $ GraphVersions { gv_graph = listVersion
 249                        , gv_repo = v }
 250
 251 recomputeVersions :: UserId -> NodeId -> GargNoServer Graph
 252 recomputeVersions uId nId = recomputeGraph uId nId Distributional
 253
 254 ------------------------------------------------------------
 255 graphClone :: UserId
 256            -> NodeId
 257            -> HyperdataGraphAPI
 258            -> GargNoServer NodeId
 259 graphClone uId pId (HyperdataGraphAPI { _hyperdataAPIGraph = graph
 260                                       , _hyperdataAPICamera = camera }) = do
 261   let nodeType = NodeGraph
 262   nodeUser <- getNodeUser (NodeId uId)
 263   nodeParent <- getNodeWith pId (Proxy :: Proxy HyperdataGraph)
 264   let uId' = nodeUser ^. node_userId
 265   nIds <- mkNodeWithParent nodeType (Just pId) uId' $ nodeParent ^. node_name
 266   case nIds of
 267     [] -> pure pId
 268     (nId:_) -> do
 269       let graphP = graph
 270       let graphP' = set (graph_metadata . _Just . gm_startForceAtlas) False graphP
 271
 272       _ <- updateHyperdata nId (HyperdataGraph (Just graphP') camera)
 273
 274       pure nId
 275
 276 ------------------------------------------------------------
 277 getGraphGexf :: UserId
 278              -> NodeId
 279              -> GargNoServer (Headers '[Servant.Header "Content-Disposition" Text] Graph)
 280 getGraphGexf uId nId = do
 281   HyperdataGraphAPI { _hyperdataAPIGraph = graph } <- getGraph uId nId
 282   pure $ addHeader "attachment; filename=graph.gexf" graph