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 OverloadedLists   #-}   -- allows to write Map and HashMap as lists
  13 {-# LANGUAGE TypeOperators     #-}
  14
  15 module Gargantext.Core.Viz.Graph.API
  16   where
  17
  18 import Control.Lens (set, (^.), _Just, (^?), at)
  19 import Data.Aeson
  20 import Data.Maybe (fromMaybe)
  21 import Data.Swagger
  22 import Data.Text hiding (head)
  23 import Debug.Trace (trace)
  24 import GHC.Generics (Generic)
  25 import Gargantext.API.Admin.Orchestrator.Types
  26 import Gargantext.API.Ngrams.Tools
  27 import Gargantext.API.Prelude
  28 import Gargantext.Core.Methods.Distances (Distance(..), GraphMetric(..), withMetric)
  29 import Gargantext.Core.NodeStory
  30 import Gargantext.Core.Types.Main
  31 import Gargantext.Core.Viz.Graph
  32 import Gargantext.Core.Viz.Graph.GEXF ()
  33 import Gargantext.Core.Viz.Graph.Tools -- (cooc2graph)
  34 import Gargantext.Database.Action.Metrics.NgramsByContext (getContextsByNgramsOnlyUser)
  35 import Gargantext.Database.Action.Flow.Types (FlowCmdM)
  36 import Gargantext.Database.Action.Node (mkNodeWithParent)
  37 import Gargantext.Database.Admin.Config
  38 import Gargantext.Database.Admin.Types.Node
  39 import Gargantext.Database.Prelude (Cmd)
  40 import Gargantext.Database.Query.Table.Node
  41 import Gargantext.Database.Query.Table.Node.Error (HasNodeError)
  42 import Gargantext.Database.Query.Table.Node.Select
  43 import Gargantext.Database.Query.Table.Node.UpdateOpaleye (updateHyperdata)
  44 import Gargantext.Database.Query.Table.Node.User (getNodeUser)
  45 import Gargantext.Database.Schema.Node
  46 import Gargantext.Database.Schema.Ngrams
  47 import Gargantext.Prelude
  48 import Servant
  49 import Servant.Job.Async
  50 import Servant.XML
  51 import qualified Data.HashMap.Strict as HashMap
  52
  53 ------------------------------------------------------------------------
  54 -- | There is no Delete specific API for Graph since it can be deleted
  55 -- as simple Node.
  56 type GraphAPI   =  Get  '[JSON] HyperdataGraphAPI
  57               :<|> "async" :> GraphAsyncAPI
  58               :<|> "clone"
  59                    :> ReqBody '[JSON] HyperdataGraphAPI
  60                    :> Post '[JSON] NodeId
  61               :<|> "gexf" :> Get '[XML] (Headers '[Servant.Header "Content-Disposition" Text] Graph)
  62               :<|> "versions" :> GraphVersionsAPI
  63
  64 data GraphVersions =
  65   GraphVersions { gv_graph :: Maybe Int
  66                 , gv_repo :: Int
  67                 }
  68    deriving (Show, Generic)
  69
  70 instance FromJSON GraphVersions
  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         let defaultPartitionMethod = Spinglass
 106         graph' <- computeGraph cId defaultPartitionMethod (withMetric defaultMetric) NgramsTerms repo
 107         mt     <- defaultGraphMetadata cId "Title" repo defaultMetric
 108         let
 109           graph'' = set graph_metadata (Just mt) graph'
 110           hg = HyperdataGraphAPI graph'' camera
 111        -- _      <- updateHyperdata nId hg
 112         _ <- updateHyperdata nId (HyperdataGraph (Just graph'') camera)
 113         pure $ trace "[G.V.G.API] Graph empty, computing" hg
 114
 115     Just graph' -> pure $ trace "[G.V.G.API] Graph exists, returning" $
 116         HyperdataGraphAPI graph' camera
 117
 118
 119 --recomputeGraph :: UserId -> NodeId -> Maybe GraphMetric -> GargNoServer Graph
 120 recomputeGraph :: FlowCmdM env err m
 121                => UserId
 122                -> NodeId
 123                -> PartitionMethod
 124                -> Maybe GraphMetric
 125                -> Bool
 126                -> m Graph
 127 recomputeGraph _uId nId method maybeDistance force = do
 128   nodeGraph <- getNodeWith nId (Proxy :: Proxy HyperdataGraph)
 129   let
 130     graph  = nodeGraph ^. node_hyperdata . hyperdataGraph
 131     camera = nodeGraph ^. node_hyperdata . hyperdataCamera
 132     graphMetadata = graph ^? _Just . graph_metadata . _Just
 133     listVersion   = graph ^? _Just . graph_metadata . _Just . gm_list . lfg_version
 134     graphMetric   = case maybeDistance of
 135                       Nothing -> graph ^? _Just . graph_metadata . _Just . gm_metric
 136                       _       -> maybeDistance
 137     similarity = case graphMetric of
 138                    Nothing -> withMetric Order1
 139                    Just m  -> withMetric m
 140
 141   mcId <- getClosestParentIdByType nId NodeCorpus
 142   let cId = maybe (panic "[G.V.G.API] Node has no parent") identity mcId
 143
 144   listId  <- defaultList cId
 145   repo <- getRepo [listId]
 146   let v   = repo ^. unNodeStory . at listId . _Just . a_version
 147
 148   let computeG mt = do
 149         g <- computeGraph cId method similarity NgramsTerms repo
 150         let g' = set graph_metadata mt g
 151         _ <- updateHyperdata nId (HyperdataGraph (Just g') camera)
 152         pure g'
 153
 154   case graph of
 155     Nothing     -> do
 156       mt     <- defaultGraphMetadata cId "Title" repo (fromMaybe Order1 maybeDistance)
 157       g <- computeG $ Just mt
 158       pure $ trace "[G.V.G.API.recomputeGraph] Graph empty, computed" g
 159     Just graph' -> if (listVersion == Just v) && (not force)
 160                      then pure graph'
 161                      else do
 162                        g <- computeG graphMetadata
 163                        pure $ trace "[G.V.G.API] Graph exists, recomputing" g
 164
 165
 166 computeGraph :: FlowCmdM env err m
 167              => CorpusId
 168              -> PartitionMethod
 169              -> Distance
 170              -> NgramsType
 171              -> NodeListStory
 172              -> m Graph
 173 computeGraph cId method d nt repo = do
 174   lId  <- defaultList cId
 175   lIds <- selectNodesWithUsername NodeList userMaster
 176
 177   let ngs = filterListWithRoot [MapTerm]
 178           $ mapTermListRoot [lId] nt repo
 179
 180   myCooc <- HashMap.filter (>1) -- Removing the hapax (ngrams with 1 cooc)
 181          <$> getCoocByNgrams (Diagonal True)
 182          <$> groupNodesByNgrams ngs
 183          <$> getContextsByNgramsOnlyUser cId (lIds <> [lId]) nt (HashMap.keys ngs)
 184
 185   graph <- liftBase $ cooc2graphWith method d 0 myCooc
 186
 187   listNgrams <- getListNgrams [lId] nt
 188   let graph' = mergeGraphNgrams graph (Just listNgrams)
 189   -- saveAsFileDebug "/tmp/graphWithNodes" graph'
 190
 191   pure graph'
 192
 193
 194 defaultGraphMetadata :: HasNodeError err
 195                      => CorpusId
 196                      -> Text
 197                      -> NodeListStory
 198                      -> GraphMetric
 199                      -> Cmd err GraphMetadata
 200 defaultGraphMetadata cId t repo gm = do
 201   lId  <- defaultList cId
 202
 203   pure $ GraphMetadata {
 204       _gm_title = t
 205     , _gm_metric = gm
 206     , _gm_corpusId = [cId]
 207     , _gm_legend = [
 208           LegendField 1 "#FFF" "Cluster1"
 209         , LegendField 2 "#FFF" "Cluster2"
 210         , LegendField 3 "#FFF" "Cluster3"
 211         , LegendField 4 "#FFF" "Cluster4"
 212         ]
 213       , _gm_list = (ListForGraph lId (repo ^. unNodeStory . at lId . _Just . a_version))
 214       , _gm_startForceAtlas = True
 215     }
 216                          -- (map (\n -> LegendField n "#FFFFFF" (pack $ show n)) [1..10])
 217
 218 ------------------------------------------------------------
 219 type GraphAsyncAPI = Summary "Recompute graph"
 220                      :> "recompute"
 221                      :> AsyncJobsAPI JobLog () JobLog
 222
 223
 224 graphAsync :: UserId -> NodeId -> GargServer GraphAsyncAPI
 225 graphAsync u n =
 226   serveJobsAPI $
 227     JobFunction (\_ log' -> graphRecompute u n (liftBase . log'))
 228
 229
 230 --graphRecompute :: UserId
 231 --               -> NodeId
 232 --               -> (JobLog -> GargNoServer ())
 233 --               -> GargNoServer JobLog
 234 graphRecompute :: FlowCmdM env err m
 235                => UserId
 236                -> NodeId
 237                -> (JobLog -> m ())
 238                -> m JobLog
 239 graphRecompute u n logStatus = do
 240   logStatus JobLog { _scst_succeeded = Just 0
 241                    , _scst_failed    = Just 0
 242                    , _scst_remaining = Just 1
 243                    , _scst_events    = Just []
 244                    }
 245   _g <- trace (show u) $ recomputeGraph u n Spinglass Nothing False
 246   pure  JobLog { _scst_succeeded = Just 1
 247                , _scst_failed    = Just 0
 248                , _scst_remaining = Just 0
 249                , _scst_events    = Just []
 250                }
 251
 252 ------------------------------------------------------------
 253 type GraphVersionsAPI = Summary "Graph versions"
 254                         :> Get '[JSON] GraphVersions
 255                    :<|> Summary "Recompute graph version"
 256                         :> Post '[JSON] Graph
 257
 258 graphVersionsAPI :: UserId -> NodeId -> GargServer GraphVersionsAPI
 259 graphVersionsAPI u n =
 260            graphVersions 0 n
 261       :<|> recomputeVersions u n
 262
 263 graphVersions :: Int -> NodeId -> GargNoServer GraphVersions
 264 graphVersions n nId = do
 265   nodeGraph <- getNodeWith nId (Proxy :: Proxy HyperdataGraph)
 266   let
 267     graph =  nodeGraph
 268           ^. node_hyperdata
 269            . hyperdataGraph
 270
 271     listVersion =  graph
 272                 ^? _Just
 273                 . graph_metadata
 274                 . _Just
 275                 . gm_list
 276                 . lfg_version
 277
 278   mcId <- getClosestParentIdByType nId NodeCorpus
 279   let cId = maybe (panic "[G.V.G.API] Node has no parent") identity mcId
 280
 281   maybeListId <- defaultListMaybe cId
 282   case maybeListId of
 283     Nothing     -> if n <= 2
 284                       then graphVersions (n+1) cId
 285                       else panic "[G.V.G.API] list not found after iterations"
 286
 287     Just listId -> do
 288       repo <- getRepo [listId]
 289       let v = repo ^. unNodeStory . at listId . _Just . a_version
 290       -- printDebug "graphVersions" v
 291
 292       pure $ GraphVersions { gv_graph = listVersion
 293                            , gv_repo = v }
 294
 295 --recomputeVersions :: UserId -> NodeId -> GargNoServer Graph
 296 recomputeVersions :: FlowCmdM env err m
 297                   => UserId
 298                   -> NodeId
 299                   -> m Graph
 300 recomputeVersions uId nId = recomputeGraph uId nId Spinglass Nothing False
 301
 302 ------------------------------------------------------------
 303 graphClone :: UserId
 304            -> NodeId
 305            -> HyperdataGraphAPI
 306            -> GargNoServer NodeId
 307 graphClone uId pId (HyperdataGraphAPI { _hyperdataAPIGraph = graph
 308                                       , _hyperdataAPICamera = camera }) = do
 309   let nodeType = NodeGraph
 310   nodeUser <- getNodeUser (NodeId uId)
 311   nodeParent <- getNodeWith pId (Proxy :: Proxy HyperdataGraph)
 312   let uId' = nodeUser ^. node_user_id
 313   nIds <- mkNodeWithParent nodeType (Just pId) uId' $ nodeParent ^. node_name
 314   case nIds of
 315     [] -> pure pId
 316     (nId:_) -> do
 317       let graphP = graph
 318       let graphP' = set (graph_metadata . _Just . gm_startForceAtlas) False graphP
 319
 320       _ <- updateHyperdata nId (HyperdataGraph (Just graphP') camera)
 321
 322       pure nId
 323
 324 ------------------------------------------------------------
 325 --getGraphGexf :: UserId
 326 --             -> NodeId
 327 --             -> GargNoServer (Headers '[Servant.Header "Content-Disposition" Text] Graph)
 328 getGraphGexf :: FlowCmdM env err m
 329              => UserId
 330              -> NodeId
 331              -> m (Headers '[Servant.Header "Content-Disposition" Text] Graph)
 332 getGraphGexf uId nId = do
 333   HyperdataGraphAPI { _hyperdataAPIGraph = graph } <- getGraph uId nId
 334   pure $ addHeader "attachment; filename=graph.gexf" graph
 335