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