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