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         let defaultEdgesStrength   = Strong
 108         graph' <- computeGraph cId defaultPartitionMethod (withMetric defaultMetric) defaultEdgesStrength NgramsTerms repo
 109         mt     <- defaultGraphMetadata cId "Title" repo defaultMetric defaultEdgesStrength
 110         let
 111           graph'' = set graph_metadata (Just mt) graph'
 112           hg = HyperdataGraphAPI graph'' camera
 113        -- _      <- updateHyperdata nId hg
 114         _ <- updateHyperdata nId (HyperdataGraph (Just graph'') camera)
 115         pure $ trace "[G.V.G.API] Graph empty, computing" hg
 116
 117     Just graph' -> pure $ trace "[G.V.G.API] Graph exists, returning" $
 118         HyperdataGraphAPI graph' camera
 119
 120
 121 --recomputeGraph :: UserId -> NodeId -> Maybe GraphMetric -> GargNoServer Graph
 122 recomputeGraph :: FlowCmdM env err m
 123                => UserId
 124                -> NodeId
 125                -> PartitionMethod
 126                -> Maybe GraphMetric
 127                -> Maybe Strength
 128                -> Bool
 129                -> m Graph
 130 recomputeGraph _uId nId method maybeDistance maybeStrength force = do
 131   nodeGraph <- getNodeWith nId (Proxy :: Proxy HyperdataGraph)
 132   let
 133     graph  = nodeGraph ^. node_hyperdata . hyperdataGraph
 134     camera = nodeGraph ^. node_hyperdata . hyperdataCamera
 135     graphMetadata = graph ^? _Just . graph_metadata . _Just
 136     listVersion   = graph ^? _Just . graph_metadata . _Just . gm_list . lfg_version
 137     graphMetric   = case maybeDistance of
 138                       Nothing -> graph ^? _Just . graph_metadata . _Just . gm_metric
 139                       _       -> maybeDistance
 140     similarity = case graphMetric of
 141                    Nothing -> withMetric Order1
 142                    Just m  -> withMetric m
 143
 144     strength = case maybeStrength of
 145                    Nothing -> case graph ^? _Just . graph_metadata . _Just . gm_edgesStrength of
 146                         Nothing  -> Strong
 147                         Just  mr -> fromMaybe Strong mr
 148                    Just r  -> r
 149
 150   mcId <- getClosestParentIdByType nId NodeCorpus
 151   let cId = maybe (panic "[G.V.G.API] Node has no parent") identity mcId
 152
 153   listId  <- defaultList cId
 154   repo <- getRepo [listId]
 155   let v   = repo ^. unNodeStory . at listId . _Just . a_version
 156
 157   let computeG mt = do
 158         !g <- computeGraph cId method similarity strength NgramsTerms repo
 159         let g' = set graph_metadata mt g
 160         _nentries <- updateHyperdata nId (HyperdataGraph (Just g') camera)
 161         pure g'
 162
 163   case graph of
 164     Nothing     -> do
 165       mt     <- defaultGraphMetadata cId "Title" repo (fromMaybe Order1 maybeDistance) strength
 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              -> Strength
 180              -> NgramsType
 181              -> NodeListStory
 182              -> m Graph
 183 computeGraph cId method d strength nt repo = do
 184   lId  <- defaultList cId
 185   lIds <- selectNodesWithUsername NodeList userMaster
 186   let ngs = filterListWithRoot [MapTerm]
 187           $ mapTermListRoot [lId] nt repo
 188
 189   !myCooc <- HashMap.filter (>1) -- Removing the hapax (ngrams with 1 cooc)
 190          <$> getCoocByNgrams (Diagonal True)
 191          <$> groupNodesByNgrams ngs
 192          <$> getContextsByNgramsOnlyUser cId (lIds <> [lId]) nt (HashMap.keys ngs)
 193
 194   graph <- liftBase $ cooc2graphWith method d 0 strength myCooc
 195
 196   --listNgrams <- getListNgrams [lId] nt
 197   --let graph' = mergeGraphNgrams graph (Just listNgrams)
 198   -- saveAsFileDebug "/tmp/graphWithNodes" graph'
 199
 200   pure graph
 201
 202
 203 defaultGraphMetadata :: HasNodeError err
 204                      => CorpusId
 205                      -> Text
 206                      -> NodeListStory
 207                      -> GraphMetric
 208                      -> Strength
 209                      -> Cmd err GraphMetadata
 210 defaultGraphMetadata cId t repo gm str = do
 211   lId  <- defaultList cId
 212
 213   pure $ GraphMetadata { _gm_title         = t
 214                        , _gm_metric        = gm
 215                        , _gm_edgesStrength = Just str
 216                        , _gm_corpusId      = [cId]
 217                        , _gm_legend = [
 218                              LegendField 1 "#FFF" "Cluster1"
 219                            , LegendField 2 "#FFF" "Cluster2"
 220                            , LegendField 3 "#FFF" "Cluster3"
 221                            , LegendField 4 "#FFF" "Cluster4"
 222                            ]
 223                        , _gm_list  = (ListForGraph lId (repo ^. unNodeStory . at lId . _Just . a_version))
 224                        , _gm_startForceAtlas = True
 225                        }
 226                          -- (map (\n -> LegendField n "#FFFFFF" (pack $ show n)) [1..10])
 227
 228 ------------------------------------------------------------
 229 type GraphAsyncAPI = Summary "Recompute graph"
 230                      :> "recompute"
 231                      :> AsyncJobsAPI JobLog () JobLog
 232
 233
 234 graphAsync :: UserId -> NodeId -> GargServer GraphAsyncAPI
 235 graphAsync u n =
 236   serveJobsAPI $
 237     JobFunction (\_ log' -> graphRecompute u n (liftBase . log'))
 238
 239
 240 --graphRecompute :: UserId
 241 --               -> NodeId
 242 --               -> (JobLog -> GargNoServer ())
 243 --               -> GargNoServer JobLog
 244 graphRecompute :: FlowCmdM env err m
 245                => UserId
 246                -> NodeId
 247                -> (JobLog -> m ())
 248                -> m JobLog
 249 graphRecompute u n logStatus = do
 250   logStatus JobLog { _scst_succeeded = Just 0
 251                    , _scst_failed    = Just 0
 252                    , _scst_remaining = Just 1
 253                    , _scst_events    = Just []
 254                    }
 255   _g <- recomputeGraph u n Spinglass Nothing Nothing False
 256   pure  JobLog { _scst_succeeded = Just 1
 257                , _scst_failed    = Just 0
 258                , _scst_remaining = Just 0
 259                , _scst_events    = Just []
 260                }
 261
 262 ------------------------------------------------------------
 263 type GraphVersionsAPI = Summary "Graph versions"
 264                         :> Get '[JSON] GraphVersions
 265                    :<|> Summary "Recompute graph version"
 266                         :> Post '[JSON] Graph
 267
 268 graphVersionsAPI :: UserId -> NodeId -> GargServer GraphVersionsAPI
 269 graphVersionsAPI u n =
 270            graphVersions 0 n
 271       :<|> recomputeVersions u n
 272
 273 graphVersions :: Int -> NodeId -> GargNoServer GraphVersions
 274 graphVersions n nId = do
 275   nodeGraph <- getNodeWith nId (Proxy :: Proxy HyperdataGraph)
 276   let
 277     graph =  nodeGraph
 278           ^. node_hyperdata
 279            . hyperdataGraph
 280
 281     listVersion =  graph
 282                 ^? _Just
 283                 . graph_metadata
 284                 . _Just
 285                 . gm_list
 286                 . lfg_version
 287
 288   mcId <- getClosestParentIdByType nId NodeCorpus
 289   let cId = maybe (panic "[G.V.G.API] Node has no parent") identity mcId
 290
 291   maybeListId <- defaultListMaybe cId
 292   case maybeListId of
 293     Nothing     -> if n <= 2
 294                       then graphVersions (n+1) cId
 295                       else panic "[G.V.G.API] list not found after iterations"
 296
 297     Just listId -> do
 298       repo <- getRepo [listId]
 299       let v = repo ^. unNodeStory . at listId . _Just . a_version
 300       -- printDebug "graphVersions" v
 301
 302       pure $ GraphVersions { gv_graph = listVersion
 303                            , gv_repo = v }
 304
 305 --recomputeVersions :: UserId -> NodeId -> GargNoServer Graph
 306 recomputeVersions :: FlowCmdM env err m
 307                   => UserId
 308                   -> NodeId
 309                   -> m Graph
 310 recomputeVersions uId nId = recomputeGraph uId nId Spinglass Nothing Nothing False
 311
 312 ------------------------------------------------------------
 313 graphClone :: UserId
 314            -> NodeId
 315            -> HyperdataGraphAPI
 316            -> GargNoServer NodeId
 317 graphClone uId pId (HyperdataGraphAPI { _hyperdataAPIGraph = graph
 318                                       , _hyperdataAPICamera = camera }) = do
 319   let nodeType = NodeGraph
 320   nodeUser <- getNodeUser (NodeId uId)
 321   nodeParent <- getNodeWith pId (Proxy :: Proxy HyperdataGraph)
 322   let uId' = nodeUser ^. node_user_id
 323   nIds <- mkNodeWithParent nodeType (Just pId) uId' $ nodeParent ^. node_name
 324   case nIds of
 325     [] -> pure pId
 326     (nId:_) -> do
 327       let graphP = graph
 328       let graphP' = set (graph_metadata . _Just . gm_startForceAtlas) False graphP
 329
 330       _ <- updateHyperdata nId (HyperdataGraph (Just graphP') camera)
 331
 332       pure nId
 333
 334 ------------------------------------------------------------
 335 --getGraphGexf :: UserId
 336 --             -> NodeId
 337 --             -> GargNoServer (Headers '[Servant.Header "Content-Disposition" Text] Graph)
 338 getGraphGexf :: FlowCmdM env err m
 339              => UserId
 340              -> NodeId
 341              -> m (Headers '[Servant.Header "Content-Disposition" Text] Graph)
 342 getGraphGexf uId nId = do
 343   HyperdataGraphAPI { _hyperdataAPIGraph = graph } <- getGraph uId nId
 344   pure $ addHeader "attachment; filename=graph.gexf" graph
 345