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   listNgrams <- getListNgrams [lId] nt
 186
 187   graph <- liftBase $ cooc2graphWith method d 0 myCooc
 188
 189   let graph' = mergeGraphNgrams graph (Just listNgrams)
 190   -- saveAsFileDebug "/tmp/graphWithNodes" graph'
 191
 192   pure graph'
 193
 194
 195 defaultGraphMetadata :: HasNodeError err
 196                      => CorpusId
 197                      -> Text
 198                      -> NodeListStory
 199                      -> GraphMetric
 200                      -> Cmd err GraphMetadata
 201 defaultGraphMetadata cId t repo gm = do
 202   lId  <- defaultList cId
 203
 204   pure $ GraphMetadata {
 205       _gm_title = t
 206     , _gm_metric = gm
 207     , _gm_corpusId = [cId]
 208     , _gm_legend = [
 209           LegendField 1 "#FFF" "Cluster1"
 210         , LegendField 2 "#FFF" "Cluster2"
 211         , LegendField 3 "#FFF" "Cluster3"
 212         , LegendField 4 "#FFF" "Cluster4"
 213         ]
 214       , _gm_list = (ListForGraph lId (repo ^. unNodeStory . at lId . _Just . a_version))
 215       , _gm_startForceAtlas = True
 216     }
 217                          -- (map (\n -> LegendField n "#FFFFFF" (pack $ show n)) [1..10])
 218
 219 ------------------------------------------------------------
 220 type GraphAsyncAPI = Summary "Recompute graph"
 221                      :> "recompute"
 222                      :> AsyncJobsAPI JobLog () JobLog
 223
 224
 225 graphAsync :: UserId -> NodeId -> GargServer GraphAsyncAPI
 226 graphAsync u n =
 227   serveJobsAPI $
 228     JobFunction (\_ log' -> graphRecompute u n (liftBase . log'))
 229
 230
 231 --graphRecompute :: UserId
 232 --               -> NodeId
 233 --               -> (JobLog -> GargNoServer ())
 234 --               -> GargNoServer JobLog
 235 graphRecompute :: FlowCmdM env err m
 236                => UserId
 237                -> NodeId
 238                -> (JobLog -> m ())
 239                -> m JobLog
 240 graphRecompute u n logStatus = do
 241   logStatus JobLog { _scst_succeeded = Just 0
 242                    , _scst_failed    = Just 0
 243                    , _scst_remaining = Just 1
 244                    , _scst_events    = Just []
 245                    }
 246   _g <- trace (show u) $ recomputeGraph u n Spinglass Nothing False
 247   pure  JobLog { _scst_succeeded = Just 1
 248                , _scst_failed    = Just 0
 249                , _scst_remaining = Just 0
 250                , _scst_events    = Just []
 251                }
 252
 253 ------------------------------------------------------------
 254 type GraphVersionsAPI = Summary "Graph versions"
 255                         :> Get '[JSON] GraphVersions
 256                    :<|> Summary "Recompute graph version"
 257                         :> Post '[JSON] Graph
 258
 259 graphVersionsAPI :: UserId -> NodeId -> GargServer GraphVersionsAPI
 260 graphVersionsAPI u n =
 261            graphVersions 0 n
 262       :<|> recomputeVersions u n
 263
 264 graphVersions :: Int -> NodeId -> GargNoServer GraphVersions
 265 graphVersions n nId = do
 266   nodeGraph <- getNodeWith nId (Proxy :: Proxy HyperdataGraph)
 267   let
 268     graph =  nodeGraph
 269           ^. node_hyperdata
 270            . hyperdataGraph
 271
 272     listVersion =  graph
 273                 ^? _Just
 274                 . graph_metadata
 275                 . _Just
 276                 . gm_list
 277                 . lfg_version
 278
 279   mcId <- getClosestParentIdByType nId NodeCorpus
 280   let cId = maybe (panic "[G.V.G.API] Node has no parent") identity mcId
 281
 282   maybeListId <- defaultListMaybe cId
 283   case maybeListId of
 284     Nothing     -> if n <= 2
 285                       then graphVersions (n+1) cId
 286                       else panic "[G.V.G.API] list not found after iterations"
 287
 288     Just listId -> do
 289       repo <- getRepo' [listId]
 290       let v = repo ^. unNodeStory . at listId . _Just . a_version
 291       -- printDebug "graphVersions" v
 292
 293       pure $ GraphVersions { gv_graph = listVersion
 294                            , gv_repo = v }
 295
 296 --recomputeVersions :: UserId -> NodeId -> GargNoServer Graph
 297 recomputeVersions :: FlowCmdM env err m
 298                   => UserId
 299                   -> NodeId
 300                   -> m Graph
 301 recomputeVersions uId nId = recomputeGraph uId nId Spinglass Nothing False
 302
 303 ------------------------------------------------------------
 304 graphClone :: UserId
 305            -> NodeId
 306            -> HyperdataGraphAPI
 307            -> GargNoServer NodeId
 308 graphClone uId pId (HyperdataGraphAPI { _hyperdataAPIGraph = graph
 309                                       , _hyperdataAPICamera = camera }) = do
 310   let nodeType = NodeGraph
 311   nodeUser <- getNodeUser (NodeId uId)
 312   nodeParent <- getNodeWith pId (Proxy :: Proxy HyperdataGraph)
 313   let uId' = nodeUser ^. node_user_id
 314   nIds <- mkNodeWithParent nodeType (Just pId) uId' $ nodeParent ^. node_name
 315   case nIds of
 316     [] -> pure pId
 317     (nId:_) -> do
 318       let graphP = graph
 319       let graphP' = set (graph_metadata . _Just . gm_startForceAtlas) False graphP
 320
 321       _ <- updateHyperdata nId (HyperdataGraph (Just graphP') camera)
 322
 323       pure nId
 324
 325 ------------------------------------------------------------
 326 --getGraphGexf :: UserId
 327 --             -> NodeId
 328 --             -> GargNoServer (Headers '[Servant.Header "Content-Disposition" Text] Graph)
 329 getGraphGexf :: FlowCmdM env err m
 330              => UserId
 331              -> NodeId
 332              -> m (Headers '[Servant.Header "Content-Disposition" Text] Graph)
 333 getGraphGexf uId nId = do
 334   HyperdataGraphAPI { _hyperdataAPIGraph = graph } <- getGraph uId nId
 335   pure $ addHeader "attachment; filename=graph.gexf" graph
 336