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 FromJSON GraphVersions
  72 instance ToJSON GraphVersions
  73 instance ToSchema GraphVersions
  74
  75 graphAPI :: UserId -> NodeId -> GargServer GraphAPI
  76 graphAPI u n = getGraph         u n
  77           :<|> graphAsync       u n
  78           :<|> graphClone       u n
  79           :<|> getGraphGexf     u n
  80           :<|> graphVersionsAPI u n
  81
  82 ------------------------------------------------------------------------
  83 --getGraph :: UserId -> NodeId -> GargServer HyperdataGraphAPI
  84 getGraph :: FlowCmdM env err m
  85          => UserId
  86          -> NodeId
  87          -> m HyperdataGraphAPI
  88 getGraph _uId nId = do
  89   nodeGraph <- getNodeWith nId (Proxy :: Proxy HyperdataGraph)
  90
  91   let
  92     graph  = nodeGraph ^. node_hyperdata . hyperdataGraph
  93     camera = nodeGraph ^. node_hyperdata . hyperdataCamera
  94     cId = maybe (panic "[G.V.G.API] Node has no parent")
  95                   identity
  96                   $ nodeGraph ^. node_parent_id
  97
  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
 135   let
 136     cId = maybe (panic "[G.C.V.G.API.recomputeGraph] Node has no parent")
 137                   identity
 138                   $ nodeGraph ^. node_parent_id
 139     similarity = case graphMetric of
 140                    Nothing -> withMetric Order1
 141                    Just m  -> withMetric m
 142
 143   listId  <- defaultList cId
 144   repo <- getRepo' [listId]
 145   let v   = repo ^. unNodeStory . at listId . _Just . a_version
 146
 147   case graph of
 148     Nothing     -> do
 149       graph' <- computeGraph cId similarity NgramsTerms repo
 150       mt     <- defaultGraphMetadata cId "Title" repo (fromMaybe Order1 maybeDistance)
 151       let graph'' = set graph_metadata (Just mt) graph'
 152       _ <- updateHyperdata nId (HyperdataGraph (Just graph'') camera)
 153       pure $ trace "[G.V.G.API.recomputeGraph] Graph empty, computed" graph''
 154
 155     Just graph' -> if listVersion == Just v
 156                      then pure graph'
 157                      else do
 158                        graph'' <- computeGraph cId similarity NgramsTerms repo
 159                        let graph''' = set graph_metadata graphMetadata graph''
 160                        _ <- updateHyperdata nId (HyperdataGraph (Just graph''') camera)
 161                        pure $ trace "[G.V.G.API] Graph exists, recomputing" graph'''
 162
 163
 164 -- TODO use Database Monad only here ?
 165 --computeGraph :: HasNodeError err
 166 --             => CorpusId
 167 --             -> Distance
 168 --             -> NgramsType
 169 --             -> NodeListStory
 170 --             -> Cmd err Graph
 171 computeGraph :: FlowCmdM env err m
 172              => CorpusId
 173              -> Distance
 174              -> NgramsType
 175              -> NodeListStory
 176              -> m Graph
 177 computeGraph cId d nt repo = do
 178   lId  <- defaultList cId
 179   lIds <- selectNodesWithUsername NodeList userMaster
 180
 181   let ngs = filterListWithRoot MapTerm
 182           $ mapTermListRoot [lId] nt repo
 183
 184   myCooc <- HashMap.filter (>2) -- Removing the hapax (ngrams with 1 cooc)
 185          <$> getCoocByNgrams (Diagonal True)
 186          <$> groupNodesByNgrams ngs
 187          <$> getNodesByNgramsOnlyUser cId (lIds <> [lId]) nt (HashMap.keys ngs)
 188
 189   -- printDebug "myCooc" myCooc
 190   -- saveAsFileDebug "debug/my-cooc" myCooc
 191
 192   listNgrams <- getListNgrams [lId] nt
 193
 194   graph <- liftBase $ cooc2graphWith Spinglass d 0 myCooc
 195   -- saveAsFileDebug "debug/graph" graph
 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