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 Bac d 0 myCooc
 193   graph <- liftBase $ cooc2graphWith Spinglass d 0 myCooc
 194   -- saveAsFileDebug "debug/graph" graph
 195
 196   pure $ mergeGraphNgrams graph (Just listNgrams)
 197
 198
 199 defaultGraphMetadata :: HasNodeError err
 200                      => CorpusId
 201                      -> Text
 202                      -> NodeListStory
 203                      -> GraphMetric
 204                      -> Cmd err GraphMetadata
 205 defaultGraphMetadata cId t repo gm = do
 206   lId  <- defaultList cId
 207
 208   pure $ GraphMetadata {
 209       _gm_title = t
 210     , _gm_metric = gm
 211     , _gm_corpusId = [cId]
 212     , _gm_legend = [
 213           LegendField 1 "#FFF" "Cluster1"
 214         , LegendField 2 "#FFF" "Cluster2"
 215         , LegendField 3 "#FFF" "Cluster3"
 216         , LegendField 4 "#FFF" "Cluster4"
 217         ]
 218       , _gm_list = (ListForGraph lId (repo ^. unNodeStory . at lId . _Just . a_version))
 219       , _gm_startForceAtlas = True
 220     }
 221                          -- (map (\n -> LegendField n "#FFFFFF" (pack $ show n)) [1..10])
 222
 223
 224 ------------------------------------------------------------
 225 type GraphAsyncAPI = Summary "Recompute graph"
 226                      :> "recompute"
 227                      :> AsyncJobsAPI JobLog () JobLog
 228
 229
 230 graphAsync :: UserId -> NodeId -> GargServer GraphAsyncAPI
 231 graphAsync u n =
 232   serveJobsAPI $
 233     JobFunction (\_ log' -> graphRecompute u n (liftBase . log'))
 234
 235
 236 --graphRecompute :: UserId
 237 --               -> NodeId
 238 --               -> (JobLog -> GargNoServer ())
 239 --               -> GargNoServer JobLog
 240 graphRecompute :: FlowCmdM env err m
 241                => UserId
 242                -> NodeId
 243                -> (JobLog -> m ())
 244                -> m JobLog
 245 graphRecompute u n logStatus = do
 246   logStatus JobLog { _scst_succeeded = Just 0
 247                    , _scst_failed    = Just 0
 248                    , _scst_remaining = Just 1
 249                    , _scst_events    = Just []
 250                    }
 251   _g <- trace (show u) $ recomputeGraph u n Nothing
 252   pure  JobLog { _scst_succeeded = Just 1
 253                , _scst_failed    = Just 0
 254                , _scst_remaining = Just 0
 255                , _scst_events    = Just []
 256                }
 257
 258 ------------------------------------------------------------
 259 type GraphVersionsAPI = Summary "Graph versions"
 260                         :> Get '[JSON] GraphVersions
 261                    :<|> Summary "Recompute graph version"
 262                         :> Post '[JSON] Graph
 263
 264 graphVersionsAPI :: UserId -> NodeId -> GargServer GraphVersionsAPI
 265 graphVersionsAPI u n =
 266            graphVersions 0 n
 267       :<|> recomputeVersions u n
 268
 269 graphVersions :: Int -> NodeId -> GargNoServer GraphVersions
 270 graphVersions n nId = do
 271   nodeGraph <- getNodeWith nId (Proxy :: Proxy HyperdataGraph)
 272   let
 273     graph =  nodeGraph
 274           ^. node_hyperdata
 275            . hyperdataGraph
 276
 277     listVersion =  graph
 278                 ^? _Just
 279                 . graph_metadata
 280                 . _Just
 281                 . gm_list
 282                 . lfg_version
 283
 284   mcId <- getClosestParentIdByType nId NodeCorpus
 285   let cId = maybe (panic "[G.V.G.API] Node has no parent") identity mcId
 286
 287   maybeListId <- defaultListMaybe cId
 288   case maybeListId of
 289     Nothing     -> if n <= 2
 290                       then graphVersions (n+1) cId
 291                       else panic "[G.V.G.API] list not found after iterations"
 292
 293     Just listId -> do
 294       repo <- getRepo' [listId]
 295       let v = repo ^. unNodeStory . at listId . _Just . a_version
 296       printDebug "graphVersions" v
 297
 298       pure $ GraphVersions { gv_graph = listVersion
 299                            , gv_repo = v }
 300
 301 --recomputeVersions :: UserId -> NodeId -> GargNoServer Graph
 302 recomputeVersions :: FlowCmdM env err m
 303                   => UserId
 304                   -> NodeId
 305                   -> m Graph
 306 recomputeVersions uId nId = recomputeGraph uId nId Nothing
 307
 308 ------------------------------------------------------------
 309 graphClone :: UserId
 310            -> NodeId
 311            -> HyperdataGraphAPI
 312            -> GargNoServer NodeId
 313 graphClone uId pId (HyperdataGraphAPI { _hyperdataAPIGraph = graph
 314                                       , _hyperdataAPICamera = camera }) = do
 315   let nodeType = NodeGraph
 316   nodeUser <- getNodeUser (NodeId uId)
 317   nodeParent <- getNodeWith pId (Proxy :: Proxy HyperdataGraph)
 318   let uId' = nodeUser ^. node_user_id
 319   nIds <- mkNodeWithParent nodeType (Just pId) uId' $ nodeParent ^. node_name
 320   case nIds of
 321     [] -> pure pId
 322     (nId:_) -> do
 323       let graphP = graph
 324       let graphP' = set (graph_metadata . _Just . gm_startForceAtlas) False graphP
 325
 326       _ <- updateHyperdata nId (HyperdataGraph (Just graphP') camera)
 327
 328       pure nId
 329
 330 ------------------------------------------------------------
 331 --getGraphGexf :: UserId
 332 --             -> NodeId
 333 --             -> GargNoServer (Headers '[Servant.Header "Content-Disposition" Text] Graph)
 334 getGraphGexf :: FlowCmdM env err m
 335              => UserId
 336              -> NodeId
 337              -> m (Headers '[Servant.Header "Content-Disposition" Text] Graph)
 338 getGraphGexf uId nId = do
 339   HyperdataGraphAPI { _hyperdataAPIGraph = graph } <- getGraph uId nId
 340   pure $ addHeader "attachment; filename=graph.gexf" graph
 341
 342
 343
 344
 345
 346