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, MonadJobStatus(..))
  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 $ \jHandle _ -> graphRecompute u n jHandle
 261
 262
 263 --graphRecompute :: UserId
 264 --               -> NodeId
 265 --               -> (JobLog -> GargNoServer ())
 266 --               -> GargNoServer JobLog
 267 -- TODO get Graph Metadata to recompute
 268 graphRecompute :: (FlowCmdM env err m, MonadJobStatus m)
 269                => UserId
 270                -> NodeId
 271                -> JobHandle m
 272                -> m ()
 273 graphRecompute u n jobHandle = do
 274   markStarted 1 jobHandle
 275   _g <- recomputeGraph u n Spinglass BridgenessMethod_Basic Nothing Nothing NgramsTerms NgramsTerms False
 276   markComplete jobHandle
 277
 278 ------------------------------------------------------------
 279 type GraphVersionsAPI = Summary "Graph versions"
 280                         :> Get '[JSON] GraphVersions
 281                    :<|> Summary "Recompute graph version"
 282                         :> Post '[JSON] Graph
 283
 284 graphVersionsAPI :: UserId -> NodeId -> GargServer GraphVersionsAPI
 285 graphVersionsAPI u n =
 286            graphVersions 0 n
 287       :<|> recomputeVersions u n
 288
 289 graphVersions :: Int -> NodeId -> GargNoServer GraphVersions
 290 graphVersions n nId = do
 291   nodeGraph <- getNodeWith nId (Proxy :: Proxy HyperdataGraph)
 292   let
 293     graph =  nodeGraph
 294           ^. node_hyperdata
 295            . hyperdataGraph
 296
 297     listVersion =  graph
 298                 ^? _Just
 299                 . graph_metadata
 300                 . _Just
 301                 . gm_list
 302                 . lfg_version
 303
 304   mcId <- getClosestParentIdByType nId NodeCorpus
 305   let cId = maybe (panic "[G.V.G.API] Node has no parent") identity mcId
 306
 307   maybeListId <- defaultListMaybe cId
 308   case maybeListId of
 309     Nothing     -> if n <= 2
 310                       then graphVersions (n+1) cId
 311                       else panic "[G.V.G.API] list not found after iterations"
 312
 313     Just listId -> do
 314       repo <- getRepo [listId]
 315       let v = repo ^. unNodeStory . at listId . _Just . a_version
 316       -- printDebug "graphVersions" v
 317
 318       pure $ GraphVersions { gv_graph = listVersion
 319                            , gv_repo = v }
 320
 321 --recomputeVersions :: UserId -> NodeId -> GargNoServer Graph
 322 recomputeVersions :: FlowCmdM env err m
 323                   => UserId
 324                   -> NodeId
 325                   -> m Graph
 326 recomputeVersions uId nId = recomputeGraph uId nId Spinglass BridgenessMethod_Basic Nothing Nothing NgramsTerms NgramsTerms False
 327
 328 ------------------------------------------------------------
 329 graphClone :: UserId
 330            -> NodeId
 331            -> HyperdataGraphAPI
 332            -> GargNoServer NodeId
 333 graphClone uId pId (HyperdataGraphAPI { _hyperdataAPIGraph = graph
 334                                       , _hyperdataAPICamera = camera }) = do
 335   let nodeType = NodeGraph
 336   nodeUser <- getNodeUser (NodeId uId)
 337   nodeParent <- getNodeWith pId (Proxy :: Proxy HyperdataGraph)
 338   let uId' = nodeUser ^. node_user_id
 339   nIds <- mkNodeWithParent nodeType (Just pId) uId' $ nodeParent ^. node_name
 340   case nIds of
 341     [] -> pure pId
 342     (nId:_) -> do
 343       let graphP = graph
 344       let graphP' = set (graph_metadata . _Just . gm_startForceAtlas) False graphP
 345
 346       _ <- updateHyperdata nId (HyperdataGraph (Just graphP') camera)
 347
 348       pure nId
 349
 350 ------------------------------------------------------------
 351 --getGraphGexf :: UserId
 352 --             -> NodeId
 353 --             -> GargNoServer (Headers '[Servant.Header "Content-Disposition" Text] Graph)
 354 getGraphGexf :: FlowCmdM env err m
 355              => UserId
 356              -> NodeId
 357              -> m (Headers '[Servant.Header "Content-Disposition" Text] Graph)
 358 getGraphGexf uId nId = do
 359   HyperdataGraphAPI { _hyperdataAPIGraph = graph } <- getGraph uId nId
 360   pure $ addHeader "attachment; filename=graph.gexf" graph