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 {-# LANGUAGE OverloadedLists   #-}   -- allows to write Map and HashMap as lists
  13 {-# LANGUAGE TypeOperators     #-}
  14
  15 module Gargantext.Core.Viz.Graph.API
  16   where
  17
  18 import Control.Lens (set, (^.), _Just, (^?), at)
  19 import Data.Aeson
  20 import Data.Maybe (fromMaybe)
  21 import Data.Swagger
  22 import Data.Text hiding (head)
  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.Prelude
  28 import Gargantext.Core.Methods.Distances (Distance(..), GraphMetric(..), withMetric)
  29 import Gargantext.Core.NodeStory
  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.Flow.Types (FlowCmdM)
  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 FromJSON GraphVersions
  71 instance ToJSON GraphVersions
  72 instance ToSchema GraphVersions
  73
  74 graphAPI :: UserId -> NodeId -> GargServer GraphAPI
  75 graphAPI u n = getGraph         u n
  76           :<|> graphAsync       u n
  77           :<|> graphClone       u n
  78           :<|> getGraphGexf     u n
  79           :<|> graphVersionsAPI u n
  80
  81 ------------------------------------------------------------------------
  82 --getGraph :: UserId -> NodeId -> GargServer HyperdataGraphAPI
  83 getGraph :: FlowCmdM env err m
  84          => UserId
  85          -> NodeId
  86          -> m HyperdataGraphAPI
  87 getGraph _uId nId = do
  88   nodeGraph <- getNodeWith nId (Proxy :: Proxy HyperdataGraph)
  89
  90   let
  91     graph  = nodeGraph ^. node_hyperdata . hyperdataGraph
  92     camera = nodeGraph ^. node_hyperdata . hyperdataCamera
  93
  94   mcId <- getClosestParentIdByType nId NodeCorpus
  95   let cId = maybe (panic "[G.V.G.API] Node has no parent") identity mcId
  96
  97   printDebug "[getGraph] getting list for cId" cId
  98   listId <- defaultList cId
  99   repo <- getRepo' [listId]
 100
 101   -- TODO Distance in Graph params
 102   case graph of
 103     Nothing     -> do
 104         let defaultMetric = Order1
 105         graph' <- computeGraph cId (withMetric defaultMetric) NgramsTerms repo
 106         mt     <- defaultGraphMetadata cId "Title" repo defaultMetric
 107         let
 108           graph'' = set graph_metadata (Just mt) graph'
 109           hg = HyperdataGraphAPI graph'' camera
 110        -- _      <- updateHyperdata nId hg
 111         _ <- updateHyperdata nId (HyperdataGraph (Just graph'') camera)
 112         pure $ trace "[G.V.G.API] Graph empty, computing" hg
 113
 114     Just graph' -> pure $ trace "[G.V.G.API] Graph exists, returning" $
 115         HyperdataGraphAPI graph' camera
 116
 117
 118 --recomputeGraph :: UserId -> NodeId -> Maybe GraphMetric -> GargNoServer Graph
 119 recomputeGraph :: FlowCmdM env err m
 120                => UserId
 121                -> NodeId
 122                -> Maybe GraphMetric
 123                -> m Graph
 124 recomputeGraph _uId nId maybeDistance = do
 125   nodeGraph <- getNodeWith nId (Proxy :: Proxy HyperdataGraph)
 126   let
 127     graph  = nodeGraph ^. node_hyperdata . hyperdataGraph
 128     camera = nodeGraph ^. node_hyperdata . hyperdataCamera
 129     graphMetadata = graph ^? _Just . graph_metadata . _Just
 130     listVersion   = graph ^? _Just . graph_metadata . _Just . gm_list . lfg_version
 131     graphMetric   = case maybeDistance of
 132                       Nothing -> graph ^? _Just . graph_metadata . _Just . gm_metric
 133                       _       -> maybeDistance
 134     similarity = case graphMetric of
 135                    Nothing -> withMetric Order1
 136                    Just m  -> withMetric m
 137
 138   mcId <- getClosestParentIdByType nId NodeCorpus
 139   let cId = maybe (panic "[G.V.G.API] Node has no parent") identity mcId
 140
 141   listId  <- defaultList cId
 142   repo <- getRepo' [listId]
 143   let v   = repo ^. unNodeStory . at listId . _Just . a_version
 144
 145   case graph of
 146     Nothing     -> do
 147       graph' <- computeGraph cId similarity NgramsTerms repo
 148       mt     <- defaultGraphMetadata cId "Title" repo (fromMaybe Order1 maybeDistance)
 149       let graph'' = set graph_metadata (Just mt) graph'
 150       _ <- updateHyperdata nId (HyperdataGraph (Just graph'') camera)
 151       pure $ trace "[G.V.G.API.recomputeGraph] Graph empty, computed" graph''
 152
 153     Just graph' -> if listVersion == Just v
 154                      then pure graph'
 155                      else do
 156                        graph'' <- computeGraph cId similarity NgramsTerms repo
 157                        let graph''' = set graph_metadata graphMetadata graph''
 158                        _ <- updateHyperdata nId (HyperdataGraph (Just graph''') camera)
 159                        pure $ trace "[G.V.G.API] Graph exists, recomputing" graph'''
 160
 161
 162 computeGraph :: FlowCmdM env err m
 163              => CorpusId
 164              -> Distance
 165              -> NgramsType
 166              -> NodeListStory
 167              -> m Graph
 168 computeGraph cId d nt repo = do
 169   lId  <- defaultList cId
 170   lIds <- selectNodesWithUsername NodeList userMaster
 171
 172   let ngs = filterListWithRoot MapTerm
 173           $ mapTermListRoot [lId] nt repo
 174
 175   myCooc <- HashMap.filter (>1) -- Removing the hapax (ngrams with 1 cooc)
 176          -- <$> HashMap.filterWithKey (\(x,y) _ -> x /= y)
 177          -- <$> getCoocByNgrams (if d == Conditional then Diagonal True else Diagonal False)
 178          <$> getCoocByNgrams (Diagonal True)
 179          <$> groupNodesByNgrams ngs
 180          <$> getNodesByNgramsOnlyUser cId (lIds <> [lId]) nt (HashMap.keys ngs)
 181
 182   -- printDebug "myCooc" myCooc
 183   -- saveAsFileDebug "debug/my-cooc" myCooc
 184
 185   listNgrams <- getListNgrams [lId] nt
 186
 187   -- graph <- liftBase $ cooc2graphWith Bac d 0 myCooc
 188   graph <- liftBase $ cooc2graphWith Spinglass d 0 myCooc
 189   -- saveAsFileDebug "debug/graph" graph
 190
 191   pure $ mergeGraphNgrams graph (Just listNgrams)
 192
 193
 194 defaultGraphMetadata :: HasNodeError err
 195                      => CorpusId
 196                      -> Text
 197                      -> NodeListStory
 198                      -> GraphMetric
 199                      -> Cmd err GraphMetadata
 200 defaultGraphMetadata cId t repo gm = do
 201   lId  <- defaultList cId
 202
 203   pure $ GraphMetadata {
 204       _gm_title = t
 205     , _gm_metric = gm
 206     , _gm_corpusId = [cId]
 207     , _gm_legend = [
 208           LegendField 1 "#FFF" "Cluster1"
 209         , LegendField 2 "#FFF" "Cluster2"
 210         , LegendField 3 "#FFF" "Cluster3"
 211         , LegendField 4 "#FFF" "Cluster4"
 212         ]
 213       , _gm_list = (ListForGraph lId (repo ^. unNodeStory . at lId . _Just . a_version))
 214       , _gm_startForceAtlas = True
 215     }
 216                          -- (map (\n -> LegendField n "#FFFFFF" (pack $ show n)) [1..10])
 217
 218 ------------------------------------------------------------
 219 type GraphAsyncAPI = Summary "Recompute graph"
 220                      :> "recompute"
 221                      :> AsyncJobsAPI JobLog () JobLog
 222
 223
 224 graphAsync :: UserId -> NodeId -> GargServer GraphAsyncAPI
 225 graphAsync u n =
 226   serveJobsAPI $
 227     JobFunction (\_ log' -> graphRecompute u n (liftBase . log'))
 228
 229
 230 --graphRecompute :: UserId
 231 --               -> NodeId
 232 --               -> (JobLog -> GargNoServer ())
 233 --               -> GargNoServer JobLog
 234 graphRecompute :: FlowCmdM env err m
 235                => UserId
 236                -> NodeId
 237                -> (JobLog -> m ())
 238                -> m JobLog
 239 graphRecompute u n logStatus = do
 240   logStatus JobLog { _scst_succeeded = Just 0
 241                    , _scst_failed    = Just 0
 242                    , _scst_remaining = Just 1
 243                    , _scst_events    = Just []
 244                    }
 245   _g <- trace (show u) $ recomputeGraph u n Nothing
 246   pure  JobLog { _scst_succeeded = Just 1
 247                , _scst_failed    = Just 0
 248                , _scst_remaining = Just 0
 249                , _scst_events    = Just []
 250                }
 251
 252 ------------------------------------------------------------
 253 type GraphVersionsAPI = Summary "Graph versions"
 254                         :> Get '[JSON] GraphVersions
 255                    :<|> Summary "Recompute graph version"
 256                         :> Post '[JSON] Graph
 257
 258 graphVersionsAPI :: UserId -> NodeId -> GargServer GraphVersionsAPI
 259 graphVersionsAPI u n =
 260            graphVersions 0 n
 261       :<|> recomputeVersions u n
 262
 263 graphVersions :: Int -> NodeId -> GargNoServer GraphVersions
 264 graphVersions n nId = do
 265   nodeGraph <- getNodeWith nId (Proxy :: Proxy HyperdataGraph)
 266   let
 267     graph =  nodeGraph
 268           ^. node_hyperdata
 269            . hyperdataGraph
 270
 271     listVersion =  graph
 272                 ^? _Just
 273                 . graph_metadata
 274                 . _Just
 275                 . gm_list
 276                 . lfg_version
 277
 278   mcId <- getClosestParentIdByType nId NodeCorpus
 279   let cId = maybe (panic "[G.V.G.API] Node has no parent") identity mcId
 280
 281   maybeListId <- defaultListMaybe cId
 282   case maybeListId of
 283     Nothing     -> if n <= 2
 284                       then graphVersions (n+1) cId
 285                       else panic "[G.V.G.API] list not found after iterations"
 286
 287     Just listId -> do
 288       repo <- getRepo' [listId]
 289       let v = repo ^. unNodeStory . at listId . _Just . a_version
 290       printDebug "graphVersions" v
 291
 292       pure $ GraphVersions { gv_graph = listVersion
 293                            , gv_repo = v }
 294
 295 --recomputeVersions :: UserId -> NodeId -> GargNoServer Graph
 296 recomputeVersions :: FlowCmdM env err m
 297                   => UserId
 298                   -> NodeId
 299                   -> m Graph
 300 recomputeVersions uId nId = recomputeGraph uId nId Nothing
 301
 302 ------------------------------------------------------------
 303 graphClone :: UserId
 304            -> NodeId
 305            -> HyperdataGraphAPI
 306            -> GargNoServer NodeId
 307 graphClone uId pId (HyperdataGraphAPI { _hyperdataAPIGraph = graph
 308                                       , _hyperdataAPICamera = camera }) = do
 309   let nodeType = NodeGraph
 310   nodeUser <- getNodeUser (NodeId uId)
 311   nodeParent <- getNodeWith pId (Proxy :: Proxy HyperdataGraph)
 312   let uId' = nodeUser ^. node_user_id
 313   nIds <- mkNodeWithParent nodeType (Just pId) uId' $ nodeParent ^. node_name
 314   case nIds of
 315     [] -> pure pId
 316     (nId:_) -> do
 317       let graphP = graph
 318       let graphP' = set (graph_metadata . _Just . gm_startForceAtlas) False graphP
 319
 320       _ <- updateHyperdata nId (HyperdataGraph (Just graphP') camera)
 321
 322       pure nId
 323
 324 ------------------------------------------------------------
 325 --getGraphGexf :: UserId
 326 --             -> NodeId
 327 --             -> GargNoServer (Headers '[Servant.Header "Content-Disposition" Text] Graph)
 328 getGraphGexf :: FlowCmdM env err m
 329              => UserId
 330              -> NodeId
 331              -> m (Headers '[Servant.Header "Content-Disposition" Text] Graph)
 332 getGraphGexf uId nId = do
 333   HyperdataGraphAPI { _hyperdataAPIGraph = graph } <- getGraph uId nId
 334   pure $ addHeader "attachment; filename=graph.gexf" graph
 335