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