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.Flow.Types (FlowCmdM)
  37 import Gargantext.Database.Action.Node (mkNodeWithParent)
  38 import Gargantext.Database.Admin.Config
  39 import Gargantext.Database.Admin.Types.Node
  40 import Gargantext.Database.Prelude (Cmd)
  41 import Gargantext.Database.Query.Table.Node
  42 import Gargantext.Database.Query.Table.Node.Error (HasNodeError)
  43 import Gargantext.Database.Query.Table.Node.Select
  44 import Gargantext.Database.Query.Table.Node.UpdateOpaleye (updateHyperdata)
  45 import Gargantext.Database.Query.Table.Node.User (getNodeUser)
  46 import Gargantext.Database.Schema.Node
  47 import Gargantext.Database.Schema.Ngrams
  48 import Gargantext.Prelude
  49 import Servant
  50 import Servant.Job.Async
  51 import Servant.XML
  52 import qualified Data.HashMap.Strict as HashMap
  53
  54 ------------------------------------------------------------------------
  55 -- | There is no Delete specific API for Graph since it can be deleted
  56 -- as simple Node.
  57 type GraphAPI   =  Get  '[JSON] HyperdataGraphAPI
  58               :<|> "async" :> GraphAsyncAPI
  59               :<|> "clone"
  60                    :> ReqBody '[JSON] HyperdataGraphAPI
  61                    :> Post '[JSON] NodeId
  62               :<|> "gexf" :> Get '[XML] (Headers '[Servant.Header "Content-Disposition" Text] Graph)
  63               :<|> "versions" :> GraphVersionsAPI
  64
  65 data GraphVersions =
  66   GraphVersions { gv_graph :: Maybe Int
  67                 , gv_repo :: Int
  68                 }
  69    deriving (Show, Generic)
  70
  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 -- TODO use Database Monad only here ?
 163 --computeGraph :: HasNodeError err
 164 --             => CorpusId
 165 --             -> Distance
 166 --             -> NgramsType
 167 --             -> NodeListStory
 168 --             -> Cmd err Graph
 169 computeGraph :: FlowCmdM env err m
 170              => CorpusId
 171              -> Distance
 172              -> NgramsType
 173              -> NodeListStory
 174              -> m Graph
 175 computeGraph cId d nt repo = do
 176   lId  <- defaultList cId
 177   lIds <- selectNodesWithUsername NodeList userMaster
 178
 179   let ngs = filterListWithRoot MapTerm
 180           $ mapTermListRoot [lId] nt repo
 181
 182   myCooc <- HashMap.filter (>1) -- Removing the hapax (ngrams with 1 cooc)
 183          <$> getCoocByNgrams (if d == Conditional then Diagonal True else Diagonal False)
 184          <$> groupNodesByNgrams ngs
 185          <$> getNodesByNgramsOnlyUser cId (lIds <> [lId]) nt (HashMap.keys ngs)
 186
 187   -- printDebug "myCooc" myCooc
 188   -- saveAsFileDebug "debug/my-cooc" myCooc
 189
 190   listNgrams <- getListNgrams [lId] nt
 191
 192   graph <- liftBase $ cooc2graphWith Spinglass d 0 myCooc
 193   -- saveAsFileDebug "debug/graph" graph
 194   pure $ mergeGraphNgrams graph (Just listNgrams)
 195
 196
 197 defaultGraphMetadata :: HasNodeError err
 198                      => CorpusId
 199                      -> Text
 200                      -> NodeListStory
 201                      -> GraphMetric
 202                      -> Cmd err GraphMetadata
 203 defaultGraphMetadata cId t repo gm = do
 204   lId  <- defaultList cId
 205
 206   pure $ GraphMetadata {
 207       _gm_title = t
 208     , _gm_metric = gm
 209     , _gm_corpusId = [cId]
 210     , _gm_legend = [
 211           LegendField 1 "#FFF" "Cluster1"
 212         , LegendField 2 "#FFF" "Cluster2"
 213         , LegendField 3 "#FFF" "Cluster3"
 214         , LegendField 4 "#FFF" "Cluster4"
 215         ]
 216       , _gm_list = (ListForGraph lId (repo ^. unNodeStory . at lId . _Just . a_version))
 217       , _gm_startForceAtlas = True
 218     }
 219                          -- (map (\n -> LegendField n "#FFFFFF" (pack $ show n)) [1..10])
 220
 221
 222 ------------------------------------------------------------
 223 type GraphAsyncAPI = Summary "Recompute graph"
 224                      :> "recompute"
 225                      :> AsyncJobsAPI JobLog () JobLog
 226
 227
 228 graphAsync :: UserId -> NodeId -> GargServer GraphAsyncAPI
 229 graphAsync u n =
 230   serveJobsAPI $
 231     JobFunction (\_ log' -> graphRecompute u n (liftBase . log'))
 232
 233
 234 --graphRecompute :: UserId
 235 --               -> NodeId
 236 --               -> (JobLog -> GargNoServer ())
 237 --               -> GargNoServer JobLog
 238 graphRecompute :: FlowCmdM env err m
 239                => UserId
 240                -> NodeId
 241                -> (JobLog -> m ())
 242                -> m JobLog
 243 graphRecompute u n logStatus = do
 244   logStatus JobLog { _scst_succeeded = Just 0
 245                    , _scst_failed    = Just 0
 246                    , _scst_remaining = Just 1
 247                    , _scst_events    = Just []
 248                    }
 249   _g <- trace (show u) $ recomputeGraph u n Nothing
 250   pure  JobLog { _scst_succeeded = Just 1
 251                , _scst_failed    = Just 0
 252                , _scst_remaining = Just 0
 253                , _scst_events    = Just []
 254                }
 255
 256 ------------------------------------------------------------
 257 type GraphVersionsAPI = Summary "Graph versions"
 258                         :> Get '[JSON] GraphVersions
 259                    :<|> Summary "Recompute graph version"
 260                         :> Post '[JSON] Graph
 261
 262 graphVersionsAPI :: UserId -> NodeId -> GargServer GraphVersionsAPI
 263 graphVersionsAPI u n =
 264            graphVersions 0 n
 265       :<|> recomputeVersions u n
 266
 267 graphVersions :: Int -> NodeId -> GargNoServer GraphVersions
 268 graphVersions n nId = do
 269   nodeGraph <- getNodeWith nId (Proxy :: Proxy HyperdataGraph)
 270   let
 271     graph =  nodeGraph
 272           ^. node_hyperdata
 273            . hyperdataGraph
 274
 275     listVersion =  graph
 276                 ^? _Just
 277                 . graph_metadata
 278                 . _Just
 279                 . gm_list
 280                 . lfg_version
 281
 282   mcId <- getClosestParentIdByType nId NodeCorpus
 283   let cId = maybe (panic "[G.V.G.API] Node has no parent") identity mcId
 284
 285   maybeListId <- defaultListMaybe cId
 286   case maybeListId of
 287     Nothing     -> if n <= 2
 288                       then graphVersions (n+1) cId
 289                       else panic "[G.V.G.API] list not found after iterations"
 290
 291     Just listId -> do
 292       repo <- getRepo' [listId]
 293       let v = repo ^. unNodeStory . at listId . _Just . a_version
 294       printDebug "graphVersions" v
 295
 296       pure $ GraphVersions { gv_graph = listVersion
 297                            , gv_repo = v }
 298
 299 --recomputeVersions :: UserId -> NodeId -> GargNoServer Graph
 300 recomputeVersions :: FlowCmdM env err m
 301                   => UserId
 302                   -> NodeId
 303                   -> m Graph
 304 recomputeVersions uId nId = recomputeGraph uId nId Nothing
 305
 306 ------------------------------------------------------------
 307 graphClone :: UserId
 308            -> NodeId
 309            -> HyperdataGraphAPI
 310            -> GargNoServer NodeId
 311 graphClone uId pId (HyperdataGraphAPI { _hyperdataAPIGraph = graph
 312                                       , _hyperdataAPICamera = camera }) = do
 313   let nodeType = NodeGraph
 314   nodeUser <- getNodeUser (NodeId uId)
 315   nodeParent <- getNodeWith pId (Proxy :: Proxy HyperdataGraph)
 316   let uId' = nodeUser ^. node_user_id
 317   nIds <- mkNodeWithParent nodeType (Just pId) uId' $ nodeParent ^. node_name
 318   case nIds of
 319     [] -> pure pId
 320     (nId:_) -> do
 321       let graphP = graph
 322       let graphP' = set (graph_metadata . _Just . gm_startForceAtlas) False graphP
 323
 324       _ <- updateHyperdata nId (HyperdataGraph (Just graphP') camera)
 325
 326       pure nId
 327
 328 ------------------------------------------------------------
 329 --getGraphGexf :: UserId
 330 --             -> NodeId
 331 --             -> GargNoServer (Headers '[Servant.Header "Content-Disposition" Text] Graph)
 332 getGraphGexf :: FlowCmdM env err m
 333              => UserId
 334              -> NodeId
 335              -> m (Headers '[Servant.Header "Content-Disposition" Text] Graph)
 336 getGraphGexf uId nId = do
 337   HyperdataGraphAPI { _hyperdataAPIGraph = graph } <- getGraph uId nId
 338   pure $ addHeader "attachment; filename=graph.gexf" graph
 339
 340
 341
 342
 343
 344