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 BangPatterns      #-}
  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.EnvTypes (GargJob(..), Env)
  27 import Gargantext.API.Admin.Orchestrator.Types
  28 import Gargantext.API.Ngrams.Tools
  29 import Gargantext.API.Prelude
  30 import Gargantext.Core.Methods.Similarities (Similarity(..), GraphMetric(..), withMetric)
  31 import Gargantext.Core.NodeStory
  32 import Gargantext.Core.Types.Main
  33 import Gargantext.Core.Viz.Graph.GEXF ()
  34 import Gargantext.Core.Viz.Graph.Tools -- (cooc2graph)
  35 import Gargantext.Core.Viz.Graph.Types
  36 import Gargantext.Database.Action.Metrics.NgramsByContext (getContextsByNgramsOnlyUser)
  37 import Gargantext.Database.Action.Flow.Types (FlowCmdM)
  38 import Gargantext.Database.Action.Node (mkNodeWithParent)
  39 import Gargantext.Database.Admin.Config
  40 import Gargantext.Database.Admin.Types.Node
  41 import Gargantext.Database.Prelude (Cmd)
  42 import Gargantext.Database.Query.Table.Node
  43 import Gargantext.Database.Query.Table.Node.Error (HasNodeError)
  44 import Gargantext.Database.Query.Table.Node.Select
  45 import Gargantext.Database.Query.Table.Node.UpdateOpaleye (updateHyperdata)
  46 import Gargantext.Database.Query.Table.Node.User (getNodeUser)
  47 import Gargantext.Database.Schema.Node
  48 import Gargantext.Database.Schema.Ngrams
  49 import Gargantext.Prelude
  50 import Gargantext.Utils.Jobs (serveJobsAPI)
  51 import Servant
  52 import Servant.Job.Async (AsyncJobsAPI)
  53 import Servant.XML
  54 import qualified Data.HashMap.Strict as HashMap
  55
  56 ------------------------------------------------------------------------
  57 -- | There is no Delete specific API for Graph since it can be deleted
  58 -- as simple Node.
  59 type GraphAPI   =  Get  '[JSON] HyperdataGraphAPI
  60               :<|> "async" :> GraphAsyncAPI
  61               :<|> "clone"
  62                    :> ReqBody '[JSON] HyperdataGraphAPI
  63                    :> Post '[JSON] NodeId
  64               :<|> "gexf" :> Get '[XML] (Headers '[Servant.Header "Content-Disposition" Text] Graph)
  65               :<|> "versions" :> GraphVersionsAPI
  66
  67 data GraphVersions =
  68   GraphVersions { gv_graph :: Maybe Int
  69                 , gv_repo :: Int
  70                 }
  71    deriving (Show, Generic)
  72
  73 instance FromJSON GraphVersions
  74 instance ToJSON GraphVersions
  75 instance ToSchema GraphVersions
  76
  77 graphAPI :: UserId -> NodeId -> ServerT GraphAPI (GargM Env GargError)
  78 graphAPI u n = getGraph         u n
  79           :<|> graphAsync       u n
  80           :<|> graphClone       u n
  81           :<|> getGraphGexf     u n
  82           :<|> graphVersionsAPI u n
  83
  84 ------------------------------------------------------------------------
  85 --getGraph :: UserId -> NodeId -> GargServer HyperdataGraphAPI
  86 getGraph :: FlowCmdM env err m
  87          => UserId
  88          -> NodeId
  89          -> m HyperdataGraphAPI
  90 getGraph _uId nId = do
  91   nodeGraph <- getNodeWith nId (Proxy :: Proxy HyperdataGraph)
  92
  93   let
  94     graph  = nodeGraph ^. node_hyperdata . hyperdataGraph
  95     camera = nodeGraph ^. node_hyperdata . hyperdataCamera
  96
  97   mcId <- getClosestParentIdByType nId NodeCorpus
  98   let cId = maybe (panic "[G.V.G.API] Node has no parent") identity mcId
  99
 100   -- printDebug "[getGraph] getting list for cId" cId
 101   listId <- defaultList cId
 102   repo <- getRepo [listId]
 103
 104   -- TODO Similarity in Graph params
 105   case graph of
 106     Nothing     -> do
 107         let defaultMetric          = Order1
 108         let defaultPartitionMethod = Spinglass
 109         let defaultEdgesStrength   = Strong
 110         let defaultBridgenessMethod = BridgenessMethod_Basic
 111         graph' <- computeGraph cId defaultPartitionMethod defaultBridgenessMethod (withMetric defaultMetric) defaultEdgesStrength (NgramsTerms, NgramsTerms) repo
 112         mt     <- defaultGraphMetadata cId "Title" repo defaultMetric defaultEdgesStrength
 113         let
 114           graph'' = set graph_metadata (Just mt) graph'
 115           hg = HyperdataGraphAPI graph'' camera
 116        -- _      <- updateHyperdata nId hg
 117         _ <- updateHyperdata nId (HyperdataGraph (Just graph'') camera)
 118         pure $ trace "[G.V.G.API] Graph empty, computing" hg
 119
 120     Just graph' -> pure $ trace "[G.V.G.API] Graph exists, returning" $
 121         HyperdataGraphAPI graph' camera
 122
 123
 124 --recomputeGraph :: UserId -> NodeId -> Maybe GraphMetric -> GargNoServer Graph
 125 recomputeGraph :: FlowCmdM env err m
 126                => UserId
 127                -> NodeId
 128                -> PartitionMethod
 129                -> BridgenessMethod
 130                -> Maybe GraphMetric
 131                -> Maybe Strength
 132                -> NgramsType
 133                -> NgramsType
 134                -> Bool
 135                -> m Graph
 136 recomputeGraph _uId nId partitionMethod bridgeMethod maybeSimilarity maybeStrength nt1 nt2 force = do
 137   nodeGraph <- getNodeWith nId (Proxy :: Proxy HyperdataGraph)
 138   let
 139     graph  = nodeGraph ^. node_hyperdata . hyperdataGraph
 140     camera = nodeGraph ^. node_hyperdata . hyperdataCamera
 141     graphMetadata = graph ^? _Just . graph_metadata . _Just
 142     listVersion   = graph ^? _Just . graph_metadata . _Just . gm_list . lfg_version
 143     graphMetric   = case maybeSimilarity of
 144                       Nothing -> graph ^? _Just . graph_metadata . _Just . gm_metric
 145                       Just _  -> maybeSimilarity
 146     similarity = case graphMetric of
 147                    Nothing -> withMetric Order1
 148                    Just m  -> withMetric m
 149
 150     strength = case maybeStrength of
 151                    Nothing -> case graph ^? _Just . graph_metadata . _Just . gm_edgesStrength of
 152                         Nothing  -> Strong
 153                         Just  mr -> fromMaybe Strong mr
 154                    Just r  -> r
 155
 156   mcId <- getClosestParentIdByType nId NodeCorpus
 157   let cId = maybe (panic "[G.V.G.API] Node has no parent") identity mcId
 158
 159   listId  <- defaultList cId
 160   repo <- getRepo [listId]
 161   let v   = repo ^. unNodeStory . at listId . _Just . a_version
 162
 163   let computeG mt = do
 164         !g <- computeGraph cId partitionMethod bridgeMethod similarity strength (nt1,nt2) repo
 165         let g' = set graph_metadata mt g
 166         _nentries <- updateHyperdata nId (HyperdataGraph (Just g') camera)
 167         pure g'
 168
 169   case graph of
 170     Nothing     -> do
 171       mt     <- defaultGraphMetadata cId "Title" repo (fromMaybe Order1 maybeSimilarity) strength
 172       g <- computeG $ Just mt
 173       pure $ trace "[G.V.G.API.recomputeGraph] Graph empty, computed" g
 174     Just graph' -> if (listVersion == Just v) && (not force)
 175                      then pure graph'
 176                      else do
 177                        g <- computeG graphMetadata
 178                        pure $ trace "[G.V.G.API] Graph exists, recomputing" g
 179
 180
 181 -- TODO remove repo
 182 computeGraph :: FlowCmdM env err m
 183              => CorpusId
 184              -> PartitionMethod
 185              -> BridgenessMethod
 186              -> Similarity
 187              -> Strength
 188              -> (NgramsType, NgramsType)
 189              -> NodeListStory
 190              -> m Graph
 191 computeGraph corpusId partitionMethod bridgeMethod similarity strength (nt1,nt2) repo = do
 192   -- Getting the Node parameters
 193   lId  <- defaultList corpusId
 194   lIds <- selectNodesWithUsername NodeList userMaster
 195
 196   -- Getting the Ngrams to compute with and grouping it according to the lists
 197   let
 198     groupedContextsByNgrams nt corpusId' (lists_master, lists_user) = do
 199       let
 200         ngs = filterListWithRoot [MapTerm] $ mapTermListRoot lists_user nt repo
 201       groupNodesByNgrams ngs <$> getContextsByNgramsOnlyUser corpusId'
 202                                      (lists_user <> lists_master) nt (HashMap.keys ngs)
 203
 204   -- Optim if nt1 == nt2 : do not compute twice
 205   (m1,m2) <- do
 206     m1 <- groupedContextsByNgrams nt1 corpusId (lIds, [lId])
 207     if nt1 == nt2
 208       then
 209         pure (m1,m1)
 210       else do
 211         m2 <- groupedContextsByNgrams nt2 corpusId (lIds, [lId])
 212         pure (m1,m2)
 213
 214             -- Removing the hapax (ngrams with 1 cooc)
 215   let !myCooc = {- HashMap.filter (>0)
 216               $ -} getCoocByNgrams'' (Diagonal True) (identity, identity) (m1,m2)
 217
 218   -- TODO MultiPartite Here
 219   liftBase
 220         $ cooc2graphWith partitionMethod bridgeMethod (MultiPartite (Partite (HashMap.keysSet m1) nt1)
 221                                               (Partite (HashMap.keysSet m2) nt2)
 222                                               )
 223                                 similarity 0 strength myCooc
 224
 225
 226
 227 defaultGraphMetadata :: HasNodeError err
 228                      => CorpusId
 229                      -> Text
 230                      -> NodeListStory
 231                      -> GraphMetric
 232                      -> Strength
 233                      -> Cmd err GraphMetadata
 234 defaultGraphMetadata cId t repo gm str = do
 235   lId  <- defaultList cId
 236
 237   pure $ GraphMetadata { _gm_title         = t
 238                        , _gm_metric        = gm
 239                        , _gm_edgesStrength = Just str
 240                        , _gm_corpusId      = [cId]
 241                        , _gm_legend = [
 242                              LegendField 1 "#FFF" "Cluster1"
 243                            , LegendField 2 "#FFF" "Cluster2"
 244                            , LegendField 3 "#FFF" "Cluster3"
 245                            , LegendField 4 "#FFF" "Cluster4"
 246                            ]
 247                        , _gm_list  = ListForGraph lId (repo ^. unNodeStory . at lId . _Just . a_version)
 248                        , _gm_startForceAtlas = True
 249                        }
 250                          -- (map (\n -> LegendField n "#FFFFFF" (pack $ show n)) [1..10])
 251
 252 ------------------------------------------------------------
 253 type GraphAsyncAPI = Summary "Recompute graph"
 254                      :> "recompute"
 255                      :> AsyncJobsAPI JobLog () JobLog
 256
 257
 258 graphAsync :: UserId -> NodeId -> ServerT GraphAsyncAPI (GargM Env GargError)
 259 graphAsync u n =
 260   serveJobsAPI RecomputeGraphJob $ \_ log' ->
 261     graphRecompute u n (liftBase . log')
 262
 263
 264 --graphRecompute :: UserId
 265 --               -> NodeId
 266 --               -> (JobLog -> GargNoServer ())
 267 --               -> GargNoServer JobLog
 268 -- TODO get Graph Metadata to recompute
 269 graphRecompute :: FlowCmdM env err m
 270                => UserId
 271                -> NodeId
 272                -> (JobLog -> m ())
 273                -> m JobLog
 274 graphRecompute u n logStatus = do
 275   logStatus JobLog { _scst_succeeded = Just 0
 276                    , _scst_failed    = Just 0
 277                    , _scst_remaining = Just 1
 278                    , _scst_events    = Just []
 279                    }
 280   _g <- recomputeGraph u n Spinglass BridgenessMethod_Basic Nothing Nothing NgramsTerms NgramsTerms False
 281   pure  JobLog { _scst_succeeded = Just 1
 282                , _scst_failed    = Just 0
 283                , _scst_remaining = Just 0
 284                , _scst_events    = Just []
 285                }
 286
 287 ------------------------------------------------------------
 288 type GraphVersionsAPI = Summary "Graph versions"
 289                         :> Get '[JSON] GraphVersions
 290                    :<|> Summary "Recompute graph version"
 291                         :> Post '[JSON] Graph
 292
 293 graphVersionsAPI :: UserId -> NodeId -> GargServer GraphVersionsAPI
 294 graphVersionsAPI u n =
 295            graphVersions 0 n
 296       :<|> recomputeVersions u n
 297
 298 graphVersions :: Int -> NodeId -> GargNoServer GraphVersions
 299 graphVersions n nId = do
 300   nodeGraph <- getNodeWith nId (Proxy :: Proxy HyperdataGraph)
 301   let
 302     graph =  nodeGraph
 303           ^. node_hyperdata
 304            . hyperdataGraph
 305
 306     listVersion =  graph
 307                 ^? _Just
 308                 . graph_metadata
 309                 . _Just
 310                 . gm_list
 311                 . lfg_version
 312
 313   mcId <- getClosestParentIdByType nId NodeCorpus
 314   let cId = maybe (panic "[G.V.G.API] Node has no parent") identity mcId
 315
 316   maybeListId <- defaultListMaybe cId
 317   case maybeListId of
 318     Nothing     -> if n <= 2
 319                       then graphVersions (n+1) cId
 320                       else panic "[G.V.G.API] list not found after iterations"
 321
 322     Just listId -> do
 323       repo <- getRepo [listId]
 324       let v = repo ^. unNodeStory . at listId . _Just . a_version
 325       -- printDebug "graphVersions" v
 326
 327       pure $ GraphVersions { gv_graph = listVersion
 328                            , gv_repo = v }
 329
 330 --recomputeVersions :: UserId -> NodeId -> GargNoServer Graph
 331 recomputeVersions :: FlowCmdM env err m
 332                   => UserId
 333                   -> NodeId
 334                   -> m Graph
 335 recomputeVersions uId nId = recomputeGraph uId nId Spinglass BridgenessMethod_Basic Nothing Nothing NgramsTerms NgramsTerms False
 336
 337 ------------------------------------------------------------
 338 graphClone :: UserId
 339            -> NodeId
 340            -> HyperdataGraphAPI
 341            -> GargNoServer NodeId
 342 graphClone uId pId (HyperdataGraphAPI { _hyperdataAPIGraph = graph
 343                                       , _hyperdataAPICamera = camera }) = do
 344   let nodeType = NodeGraph
 345   nodeUser <- getNodeUser (NodeId uId)
 346   nodeParent <- getNodeWith pId (Proxy :: Proxy HyperdataGraph)
 347   let uId' = nodeUser ^. node_user_id
 348   nIds <- mkNodeWithParent nodeType (Just pId) uId' $ nodeParent ^. node_name
 349   case nIds of
 350     [] -> pure pId
 351     (nId:_) -> do
 352       let graphP = graph
 353       let graphP' = set (graph_metadata . _Just . gm_startForceAtlas) False graphP
 354
 355       _ <- updateHyperdata nId (HyperdataGraph (Just graphP') camera)
 356
 357       pure nId
 358
 359 ------------------------------------------------------------
 360 --getGraphGexf :: UserId
 361 --             -> NodeId
 362 --             -> GargNoServer (Headers '[Servant.Header "Content-Disposition" Text] Graph)
 363 getGraphGexf :: FlowCmdM env err m
 364              => UserId
 365              -> NodeId
 366              -> m (Headers '[Servant.Header "Content-Disposition" Text] Graph)
 367 getGraphGexf uId nId = do
 368   HyperdataGraphAPI { _hyperdataAPIGraph = graph } <- getGraph uId nId
 369   pure $ addHeader "attachment; filename=graph.gexf" graph