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   let graph  = nodeGraph ^. node_hyperdata . hyperdataGraph
  83   let camera = nodeGraph ^. node_hyperdata . hyperdataCamera
  84
  85   repo <- getRepo
  86
  87   let 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 graph'' = set graph_metadata (Just mt) graph'
  98         let hg = HyperdataGraphAPI graph'' camera
  99        -- _      <- updateHyperdata nId hg
 100         _ <- updateHyperdata nId (HyperdataGraph (Just graph'') camera)
 101         pure $ trace "[G.V.G.API] Graph empty, computing" hg
 102
 103     Just graph' -> pure $ trace "[G.V.G.API] Graph exists, returning" $
 104         HyperdataGraphAPI graph' camera
 105
 106
 107 recomputeGraph :: UserId -> NodeId -> Distance -> GargNoServer Graph
 108 recomputeGraph _uId nId d = do
 109   nodeGraph <- getNodeWith nId (Proxy :: Proxy HyperdataGraph)
 110   let graph  = nodeGraph ^. node_hyperdata . hyperdataGraph
 111   let camera = nodeGraph ^. node_hyperdata . hyperdataCamera
 112   let graphMetadata = graph ^? _Just . graph_metadata . _Just
 113   let listVersion   = graph ^? _Just . graph_metadata . _Just . gm_list . lfg_version
 114
 115   repo <- getRepo
 116   let v   = repo ^. r_version
 117   let cId = maybe (panic "[G.V.G.API.recomputeGraph] Node has no parent")
 118                   identity
 119                   $ nodeGraph ^. node_parentId
 120
 121   case graph of
 122     Nothing     -> do
 123       graph' <- computeGraph cId d NgramsTerms repo
 124       mt     <- defaultGraphMetadata cId "Title" repo
 125       let graph'' = set graph_metadata (Just mt) graph'
 126       _ <- updateHyperdata nId (HyperdataGraph (Just graph'') camera)
 127       pure $ trace "[G.V.G.API.recomputeGraph] Graph empty, computed" graph''
 128
 129     Just graph' -> if listVersion == Just v
 130                      then pure graph'
 131                      else do
 132                        graph'' <- computeGraph cId d NgramsTerms repo
 133                        let graph''' = set graph_metadata graphMetadata graph''
 134                        _ <- updateHyperdata nId (HyperdataGraph (Just graph''') camera)
 135                        pure $ trace "[G.V.G.API] Graph exists, recomputing" graph'''
 136
 137
 138 -- TODO use Database Monad only here ?
 139 computeGraph :: HasNodeError err
 140              => CorpusId
 141              -> Distance
 142              -> NgramsType
 143              -> NgramsRepo
 144              -> Cmd err Graph
 145 computeGraph cId d nt repo = do
 146   lId  <- defaultList cId
 147
 148   lIds <- selectNodesWithUsername NodeList userMaster
 149   let ngs = filterListWithRoot MapTerm $ mapTermListRoot [lId] nt repo
 150
 151   -- TODO split diagonal
 152   myCooc <- HashMap.filter (>1)
 153          <$> getCoocByNgrams (Diagonal True)
 154          <$> groupNodesByNgrams ngs
 155          <$> getNodesByNgramsOnlyUser cId (lIds <> [lId]) nt (HashMap.keys ngs)
 156
 157   graph <- liftBase $ cooc2graph d 0 myCooc
 158
 159   pure graph
 160
 161
 162 defaultGraphMetadata :: HasNodeError err
 163                      => CorpusId
 164                      -> Text
 165                      -> NgramsRepo
 166                      -> Cmd err GraphMetadata
 167 defaultGraphMetadata cId t repo = do
 168   lId  <- defaultList cId
 169
 170   pure $ GraphMetadata {
 171       _gm_title = t
 172     , _gm_metric = Order1
 173     , _gm_corpusId = [cId]
 174     , _gm_legend = [
 175           LegendField 1 "#FFF" "Cluster1"
 176         , LegendField 2 "#FFF" "Cluster2"
 177         , LegendField 3 "#FFF" "Cluster3"
 178         , LegendField 4 "#FFF" "Cluster4"
 179         ]
 180       , _gm_list = (ListForGraph lId (repo ^. r_version))
 181       , _gm_startForceAtlas = True
 182     }
 183                          -- (map (\n -> LegendField n "#FFFFFF" (pack $ show n)) [1..10])
 184
 185
 186 ------------------------------------------------------------
 187 type GraphAsyncAPI = Summary "Recompute graph"
 188                      :> "recompute"
 189                      :> AsyncJobsAPI JobLog () JobLog
 190
 191
 192 graphAsync :: UserId -> NodeId -> GargServer GraphAsyncAPI
 193 graphAsync u n =
 194   serveJobsAPI $
 195     JobFunction (\_ log' -> graphRecompute u n (liftBase . log'))
 196
 197
 198 graphRecompute :: UserId
 199                -> NodeId
 200                -> (JobLog -> GargNoServer ())
 201                -> GargNoServer JobLog
 202 graphRecompute u n logStatus = do
 203   logStatus JobLog { _scst_succeeded = Just 0
 204                    , _scst_failed    = Just 0
 205                    , _scst_remaining = Just 1
 206                    , _scst_events    = Just []
 207                    }
 208   _g <- trace (show u) $ recomputeGraph u n Conditional -- Distributional
 209   pure  JobLog { _scst_succeeded = Just 1
 210                , _scst_failed    = Just 0
 211                , _scst_remaining = Just 0
 212                , _scst_events    = Just []
 213                }
 214
 215 ------------------------------------------------------------
 216 type GraphVersionsAPI = Summary "Graph versions"
 217                         :> Get '[JSON] GraphVersions
 218                    :<|> Summary "Recompute graph version"
 219                         :> Post '[JSON] Graph
 220
 221 graphVersionsAPI :: UserId -> NodeId -> GargServer GraphVersionsAPI
 222 graphVersionsAPI u n =
 223            graphVersions n
 224       :<|> recomputeVersions u n
 225
 226 graphVersions :: NodeId -> GargNoServer GraphVersions
 227 graphVersions nId = do
 228   nodeGraph <- getNodeWith nId (Proxy :: Proxy HyperdataGraph)
 229   let graph = nodeGraph ^. node_hyperdata . hyperdataGraph
 230   let listVersion = graph ^? _Just
 231                             . graph_metadata
 232                             . _Just
 233                             . gm_list
 234                             . lfg_version
 235
 236   repo <- getRepo
 237   let v = repo ^. r_version
 238
 239   pure $ GraphVersions { gv_graph = listVersion
 240                        , gv_repo = v }
 241
 242 recomputeVersions :: UserId -> NodeId -> GargNoServer Graph
 243 recomputeVersions uId nId = recomputeGraph uId nId Conditional -- Distributional
 244
 245 ------------------------------------------------------------
 246 graphClone :: UserId
 247            -> NodeId
 248            -> HyperdataGraphAPI
 249            -> GargNoServer NodeId
 250 graphClone uId pId (HyperdataGraphAPI { _hyperdataAPIGraph = graph
 251                                       , _hyperdataAPICamera = camera }) = do
 252   let nodeType = NodeGraph
 253   nodeUser <- getNodeUser (NodeId uId)
 254   nodeParent <- getNodeWith pId (Proxy :: Proxy HyperdataGraph)
 255   let uId' = nodeUser ^. node_userId
 256   nIds <- mkNodeWithParent nodeType (Just pId) uId' $ nodeParent ^. node_name
 257   case nIds of
 258     [] -> pure pId
 259     (nId:_) -> do
 260       let graphP = graph
 261       let graphP' = set (graph_metadata . _Just . gm_startForceAtlas) False graphP
 262
 263       _ <- updateHyperdata nId (HyperdataGraph (Just graphP') camera)
 264
 265       pure nId
 266
 267 ------------------------------------------------------------
 268 getGraphGexf :: UserId
 269              -> NodeId
 270              -> GargNoServer (Headers '[Servant.Header "Content-Disposition" Text] Graph)
 271 getGraphGexf uId nId = do
 272   HyperdataGraphAPI { _hyperdataAPIGraph = graph } <- getGraph uId nId
 273   pure $ addHeader "attachment; filename=graph.gexf" graph