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 n
 243       :<|> recomputeVersions u n
 244
 245 graphVersions :: NodeId -> GargNoServer GraphVersions
 246 graphVersions 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     cId = maybe (panic "[G.V.G.API] Node has no parent")
 261                   identity
 262                   $ nodeGraph ^. node_parent_id
 263
 264   listId <- defaultList cId
 265   repo <- getRepo' [listId]
 266   let v = repo ^. unNodeStory . at listId . _Just . a_version
 267
 268   pure $ GraphVersions { gv_graph = listVersion
 269                        , gv_repo = v }
 270
 271 recomputeVersions :: UserId -> NodeId -> GargNoServer Graph
 272 recomputeVersions uId nId = recomputeGraph uId nId Nothing
 273
 274 ------------------------------------------------------------
 275 graphClone :: UserId
 276            -> NodeId
 277            -> HyperdataGraphAPI
 278            -> GargNoServer NodeId
 279 graphClone uId pId (HyperdataGraphAPI { _hyperdataAPIGraph = graph
 280                                       , _hyperdataAPICamera = camera }) = do
 281   let nodeType = NodeGraph
 282   nodeUser <- getNodeUser (NodeId uId)
 283   nodeParent <- getNodeWith pId (Proxy :: Proxy HyperdataGraph)
 284   let uId' = nodeUser ^. node_user_id
 285   nIds <- mkNodeWithParent nodeType (Just pId) uId' $ nodeParent ^. node_name
 286   case nIds of
 287     [] -> pure pId
 288     (nId:_) -> do
 289       let graphP = graph
 290       let graphP' = set (graph_metadata . _Just . gm_startForceAtlas) False graphP
 291
 292       _ <- updateHyperdata nId (HyperdataGraph (Just graphP') camera)
 293
 294       pure nId
 295
 296 ------------------------------------------------------------
 297 getGraphGexf :: UserId
 298              -> NodeId
 299              -> GargNoServer (Headers '[Servant.Header "Content-Disposition" Text] Graph)
 300 getGraphGexf uId nId = do
 301   HyperdataGraphAPI { _hyperdataAPIGraph = graph } <- getGraph uId nId
 302   pure $ addHeader "attachment; filename=graph.gexf" graph
 303
 304
 305
 306
 307
 308