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
  34 import Gargantext.Core.Viz.Graph.GEXF ()
  35 import Gargantext.Core.Viz.Graph.Tools -- (cooc2graph)
  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                       _       -> 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   graph <- 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   pure graph
 226
 227
 228
 229 defaultGraphMetadata :: HasNodeError err
 230                      => CorpusId
 231                      -> Text
 232                      -> NodeListStory
 233                      -> GraphMetric
 234                      -> Strength
 235                      -> Cmd err GraphMetadata
 236 defaultGraphMetadata cId t repo gm str = do
 237   lId  <- defaultList cId
 238
 239   pure $ GraphMetadata { _gm_title         = t
 240                        , _gm_metric        = gm
 241                        , _gm_edgesStrength = Just str
 242                        , _gm_corpusId      = [cId]
 243                        , _gm_legend = [
 244                              LegendField 1 "#FFF" "Cluster1"
 245                            , LegendField 2 "#FFF" "Cluster2"
 246                            , LegendField 3 "#FFF" "Cluster3"
 247                            , LegendField 4 "#FFF" "Cluster4"
 248                            ]
 249                        , _gm_list  = (ListForGraph lId (repo ^. unNodeStory . at lId . _Just . a_version))
 250                        , _gm_startForceAtlas = True
 251                        }
 252                          -- (map (\n -> LegendField n "#FFFFFF" (pack $ show n)) [1..10])
 253
 254 ------------------------------------------------------------
 255 type GraphAsyncAPI = Summary "Recompute graph"
 256                      :> "recompute"
 257                      :> AsyncJobsAPI JobLog () JobLog
 258
 259
 260 graphAsync :: UserId -> NodeId -> ServerT GraphAsyncAPI (GargM Env GargError)
 261 graphAsync u n =
 262   serveJobsAPI RecomputeGraphJob $ \_ log' ->
 263     graphRecompute u n (liftBase . log')
 264
 265
 266 --graphRecompute :: UserId
 267 --               -> NodeId
 268 --               -> (JobLog -> GargNoServer ())
 269 --               -> GargNoServer JobLog
 270 -- TODO get Graph Metadata to recompute
 271 graphRecompute :: FlowCmdM env err m
 272                => UserId
 273                -> NodeId
 274                -> (JobLog -> m ())
 275                -> m JobLog
 276 graphRecompute u n logStatus = do
 277   logStatus JobLog { _scst_succeeded = Just 0
 278                    , _scst_failed    = Just 0
 279                    , _scst_remaining = Just 1
 280                    , _scst_events    = Just []
 281                    }
 282   _g <- recomputeGraph u n Spinglass BridgenessMethod_Basic Nothing Nothing NgramsTerms NgramsTerms False
 283   pure  JobLog { _scst_succeeded = Just 1
 284                , _scst_failed    = Just 0
 285                , _scst_remaining = Just 0
 286                , _scst_events    = Just []
 287                }
 288
 289 ------------------------------------------------------------
 290 type GraphVersionsAPI = Summary "Graph versions"
 291                         :> Get '[JSON] GraphVersions
 292                    :<|> Summary "Recompute graph version"
 293                         :> Post '[JSON] Graph
 294
 295 graphVersionsAPI :: UserId -> NodeId -> GargServer GraphVersionsAPI
 296 graphVersionsAPI u n =
 297            graphVersions 0 n
 298       :<|> recomputeVersions u n
 299
 300 graphVersions :: Int -> NodeId -> GargNoServer GraphVersions
 301 graphVersions n nId = do
 302   nodeGraph <- getNodeWith nId (Proxy :: Proxy HyperdataGraph)
 303   let
 304     graph =  nodeGraph
 305           ^. node_hyperdata
 306            . hyperdataGraph
 307
 308     listVersion =  graph
 309                 ^? _Just
 310                 . graph_metadata
 311                 . _Just
 312                 . gm_list
 313                 . lfg_version
 314
 315   mcId <- getClosestParentIdByType nId NodeCorpus
 316   let cId = maybe (panic "[G.V.G.API] Node has no parent") identity mcId
 317
 318   maybeListId <- defaultListMaybe cId
 319   case maybeListId of
 320     Nothing     -> if n <= 2
 321                       then graphVersions (n+1) cId
 322                       else panic "[G.V.G.API] list not found after iterations"
 323
 324     Just listId -> do
 325       repo <- getRepo [listId]
 326       let v = repo ^. unNodeStory . at listId . _Just . a_version
 327       -- printDebug "graphVersions" v
 328
 329       pure $ GraphVersions { gv_graph = listVersion
 330                            , gv_repo = v }
 331
 332 --recomputeVersions :: UserId -> NodeId -> GargNoServer Graph
 333 recomputeVersions :: FlowCmdM env err m
 334                   => UserId
 335                   -> NodeId
 336                   -> m Graph
 337 recomputeVersions uId nId = recomputeGraph uId nId Spinglass BridgenessMethod_Basic Nothing Nothing NgramsTerms NgramsTerms False
 338
 339 ------------------------------------------------------------
 340 graphClone :: UserId
 341            -> NodeId
 342            -> HyperdataGraphAPI
 343            -> GargNoServer NodeId
 344 graphClone uId pId (HyperdataGraphAPI { _hyperdataAPIGraph = graph
 345                                       , _hyperdataAPICamera = camera }) = do
 346   let nodeType = NodeGraph
 347   nodeUser <- getNodeUser (NodeId uId)
 348   nodeParent <- getNodeWith pId (Proxy :: Proxy HyperdataGraph)
 349   let uId' = nodeUser ^. node_user_id
 350   nIds <- mkNodeWithParent nodeType (Just pId) uId' $ nodeParent ^. node_name
 351   case nIds of
 352     [] -> pure pId
 353     (nId:_) -> do
 354       let graphP = graph
 355       let graphP' = set (graph_metadata . _Just . gm_startForceAtlas) False graphP
 356
 357       _ <- updateHyperdata nId (HyperdataGraph (Just graphP') camera)
 358
 359       pure nId
 360
 361 ------------------------------------------------------------
 362 --getGraphGexf :: UserId
 363 --             -> NodeId
 364 --             -> GargNoServer (Headers '[Servant.Header "Content-Disposition" Text] Graph)
 365 getGraphGexf :: FlowCmdM env err m
 366              => UserId
 367              -> NodeId
 368              -> m (Headers '[Servant.Header "Content-Disposition" Text] Graph)
 369 getGraphGexf uId nId = do
 370   HyperdataGraphAPI { _hyperdataAPIGraph = graph } <- getGraph uId nId
 371   pure $ addHeader "attachment; filename=graph.gexf" graph