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 Order2
 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 (>1) -- 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
 169   graph <- liftBase $ cooc2graphWith Spinglass d 0 myCooc
 170   pure graph
 171
 172
 173 defaultGraphMetadata :: HasNodeError err
 174                      => CorpusId
 175                      -> Text
 176                      -> NgramsRepo
 177                      -> GraphMetric
 178                      -> Cmd err GraphMetadata
 179 defaultGraphMetadata cId t repo gm = do
 180   lId  <- defaultList cId
 181
 182   pure $ GraphMetadata {
 183       _gm_title = t
 184     , _gm_metric = gm
 185     , _gm_corpusId = [cId]
 186     , _gm_legend = [
 187           LegendField 1 "#FFF" "Cluster1"
 188         , LegendField 2 "#FFF" "Cluster2"
 189         , LegendField 3 "#FFF" "Cluster3"
 190         , LegendField 4 "#FFF" "Cluster4"
 191         ]
 192       , _gm_list = (ListForGraph lId (repo ^. r_version))
 193       , _gm_startForceAtlas = True
 194     }
 195                          -- (map (\n -> LegendField n "#FFFFFF" (pack $ show n)) [1..10])
 196
 197
 198 ------------------------------------------------------------
 199 type GraphAsyncAPI = Summary "Recompute graph"
 200                      :> "recompute"
 201                      :> AsyncJobsAPI JobLog () JobLog
 202
 203
 204 graphAsync :: UserId -> NodeId -> GargServer GraphAsyncAPI
 205 graphAsync u n =
 206   serveJobsAPI $
 207     JobFunction (\_ log' -> graphRecompute u n (liftBase . log'))
 208
 209
 210 graphRecompute :: UserId
 211                -> NodeId
 212                -> (JobLog -> GargNoServer ())
 213                -> GargNoServer JobLog
 214 graphRecompute u n logStatus = do
 215   logStatus JobLog { _scst_succeeded = Just 0
 216                    , _scst_failed    = Just 0
 217                    , _scst_remaining = Just 1
 218                    , _scst_events    = Just []
 219                    }
 220   _g <- trace (show u) $ recomputeGraph u n Nothing
 221   pure  JobLog { _scst_succeeded = Just 1
 222                , _scst_failed    = Just 0
 223                , _scst_remaining = Just 0
 224                , _scst_events    = Just []
 225                }
 226
 227 ------------------------------------------------------------
 228 type GraphVersionsAPI = Summary "Graph versions"
 229                         :> Get '[JSON] GraphVersions
 230                    :<|> Summary "Recompute graph version"
 231                         :> Post '[JSON] Graph
 232
 233 graphVersionsAPI :: UserId -> NodeId -> GargServer GraphVersionsAPI
 234 graphVersionsAPI u n =
 235            graphVersions n
 236       :<|> recomputeVersions u n
 237
 238 graphVersions :: NodeId -> GargNoServer GraphVersions
 239 graphVersions nId = do
 240   nodeGraph <- getNodeWith nId (Proxy :: Proxy HyperdataGraph)
 241   let
 242     graph =  nodeGraph
 243           ^. node_hyperdata
 244            . hyperdataGraph
 245
 246     listVersion =  graph
 247                 ^? _Just
 248                 . graph_metadata
 249                 . _Just
 250                 . gm_list
 251                 . lfg_version
 252
 253   repo <- getRepo
 254   let v = repo ^. r_version
 255
 256   pure $ GraphVersions { gv_graph = listVersion
 257                        , gv_repo = v }
 258
 259 recomputeVersions :: UserId -> NodeId -> GargNoServer Graph
 260 recomputeVersions uId nId = recomputeGraph uId nId Nothing
 261
 262 ------------------------------------------------------------
 263 graphClone :: UserId
 264            -> NodeId
 265            -> HyperdataGraphAPI
 266            -> GargNoServer NodeId
 267 graphClone uId pId (HyperdataGraphAPI { _hyperdataAPIGraph = graph
 268                                       , _hyperdataAPICamera = camera }) = do
 269   let nodeType = NodeGraph
 270   nodeUser <- getNodeUser (NodeId uId)
 271   nodeParent <- getNodeWith pId (Proxy :: Proxy HyperdataGraph)
 272   let uId' = nodeUser ^. node_user_id
 273   nIds <- mkNodeWithParent nodeType (Just pId) uId' $ nodeParent ^. node_name
 274   case nIds of
 275     [] -> pure pId
 276     (nId:_) -> do
 277       let graphP = graph
 278       let graphP' = set (graph_metadata . _Just . gm_startForceAtlas) False graphP
 279
 280       _ <- updateHyperdata nId (HyperdataGraph (Just graphP') camera)
 281
 282       pure nId
 283
 284 ------------------------------------------------------------
 285 getGraphGexf :: UserId
 286              -> NodeId
 287              -> GargNoServer (Headers '[Servant.Header "Content-Disposition" Text] Graph)
 288 getGraphGexf uId nId = do
 289   HyperdataGraphAPI { _hyperdataAPIGraph = graph } <- getGraph uId nId
 290   pure $ addHeader "attachment; filename=graph.gexf" graph