-}
-{-# OPTIONS_GHC -fno-warn-orphans #-}
-
{-# LANGUAGE OverloadedLists #-} -- allows to write Map and HashMap as lists
{-# LANGUAGE TypeOperators #-}
import Control.Lens (set, (^.), _Just, (^?))
import Data.Aeson
-import qualified Data.Map as Map
-import Data.Maybe (Maybe(..))
import Data.Swagger
import Data.Text
import Debug.Trace (trace)
import GHC.Generics (Generic)
-import Servant
-import Servant.Job.Async
-import Servant.XML
-
import Gargantext.API.Admin.Orchestrator.Types
-import Gargantext.API.Ngrams (NgramsRepo, r_version)
import Gargantext.API.Ngrams.Tools
+import Gargantext.API.Ngrams.Types (NgramsRepo, r_version)
import Gargantext.API.Prelude
+import Gargantext.Core.Methods.Distances (Distance(..), GraphMetric(..))
import Gargantext.Core.Types.Main
+import Gargantext.Core.Viz.Graph
+import Gargantext.Core.Viz.Graph.GEXF ()
+import Gargantext.Core.Viz.Graph.Tools -- (cooc2graph)
import Gargantext.Database.Action.Metrics.NgramsByNode (getNodesByNgramsOnlyUser)
+import Gargantext.Database.Action.Node (mkNodeWithParent)
import Gargantext.Database.Admin.Config
import Gargantext.Database.Admin.Types.Node
import Gargantext.Database.Prelude (Cmd)
import Gargantext.Database.Query.Table.Node.Error (HasNodeError)
import Gargantext.Database.Query.Table.Node.Select
import Gargantext.Database.Query.Table.Node.UpdateOpaleye (updateHyperdata)
+import Gargantext.Database.Query.Table.Node.User (getNodeUser)
import Gargantext.Database.Schema.Ngrams
-import Gargantext.Database.Schema.Node (node_parentId, node_hyperdata)
+import Gargantext.Database.Schema.Node (node_parentId, node_hyperdata, node_name, node_userId)
import Gargantext.Prelude
-import Gargantext.Core.Viz.Graph
-import Gargantext.Core.Viz.Graph.GEXF ()
-import Gargantext.Core.Viz.Graph.Tools -- (cooc2graph)
-import Gargantext.Core.Viz.Graph.Distances (Distance(..), GraphMetric(..))
-
+import Servant
+import Servant.Job.Async
+import Servant.XML
+import qualified Data.HashMap.Strict as HashMap
------------------------------------------------------------------------
-- | There is no Delete specific API for Graph since it can be deleted
-- as simple Node.
-type GraphAPI = Get '[JSON] Graph
+type GraphAPI = Get '[JSON] HyperdataGraphAPI
+ :<|> "async" :> GraphAsyncAPI
+ :<|> "clone"
+ :> ReqBody '[JSON] HyperdataGraphAPI
+ :> Post '[JSON] NodeId
:<|> "gexf" :> Get '[XML] (Headers '[Servant.Header "Content-Disposition" Text] Graph)
- :<|> GraphAsyncAPI
:<|> "versions" :> GraphVersionsAPI
data GraphVersions =
instance ToSchema GraphVersions
graphAPI :: UserId -> NodeId -> GargServer GraphAPI
-graphAPI u n = getGraph u n
- :<|> getGraphGexf u n
- :<|> graphAsync u n
- :<|> graphVersionsAPI u n
+graphAPI u n = getGraph u n
+ :<|> graphAsync u n
+ :<|> graphClone u n
+ :<|> getGraphGexf u n
+ :<|> graphVersionsAPI u n
------------------------------------------------------------------------
-getGraph :: UserId -> NodeId -> GargNoServer Graph
+getGraph :: UserId -> NodeId -> GargNoServer HyperdataGraphAPI
getGraph _uId nId = do
- nodeGraph <- getNodeWith nId HyperdataGraph
- let graph = nodeGraph ^. node_hyperdata . hyperdataGraph
+ nodeGraph <- getNodeWith nId (Proxy :: Proxy HyperdataGraph)
+ let graph = nodeGraph ^. node_hyperdata . hyperdataGraph
+ let camera = nodeGraph ^. node_hyperdata . hyperdataCamera
repo <- getRepo
case graph of
Nothing -> do
graph' <- computeGraph cId Conditional NgramsTerms repo
- _ <- updateHyperdata nId (HyperdataGraph $ Just graph')
- pure $ trace "[G.V.G.API] Graph empty, computing" graph'
+ mt <- defaultGraphMetadata cId "Title" repo
+ let graph'' = set graph_metadata (Just mt) graph'
+ let hg = HyperdataGraphAPI graph'' camera
+ -- _ <- updateHyperdata nId hg
+ _ <- updateHyperdata nId (HyperdataGraph (Just graph'') camera)
+ pure $ trace "[G.V.G.API] Graph empty, computing" hg
- Just graph' -> pure $ trace "[G.V.G.API] Graph exists, returning" graph'
+ Just graph' -> pure $ trace "[G.V.G.API] Graph exists, returning" $
+ HyperdataGraphAPI graph' camera
recomputeGraph :: UserId -> NodeId -> Distance -> GargNoServer Graph
recomputeGraph _uId nId d = do
- nodeGraph <- getNodeWith nId HyperdataGraph
- let graph = nodeGraph ^. node_hyperdata . hyperdataGraph
- let listVersion = graph ^? _Just
- . graph_metadata
- . _Just
- . gm_list
- . lfg_version
+ nodeGraph <- getNodeWith nId (Proxy :: Proxy HyperdataGraph)
+ let graph = nodeGraph ^. node_hyperdata . hyperdataGraph
+ let camera = nodeGraph ^. node_hyperdata . hyperdataCamera
+ let graphMetadata = graph ^? _Just . graph_metadata . _Just
+ let listVersion = graph ^? _Just . graph_metadata . _Just . gm_list . lfg_version
repo <- getRepo
let v = repo ^. r_version
case graph of
Nothing -> do
graph' <- computeGraph cId d NgramsTerms repo
- _ <- updateHyperdata nId (HyperdataGraph $ Just graph')
- pure $ trace "[G.V.G.API.recomputeGraph] Graph empty, computed" graph'
+ mt <- defaultGraphMetadata cId "Title" repo
+ let graph'' = set graph_metadata (Just mt) graph'
+ _ <- updateHyperdata nId (HyperdataGraph (Just graph'') camera)
+ pure $ trace "[G.V.G.API.recomputeGraph] Graph empty, computed" graph''
Just graph' -> if listVersion == Just v
then pure graph'
else do
graph'' <- computeGraph cId d NgramsTerms repo
- _ <- updateHyperdata nId (HyperdataGraph $ Just graph'')
- pure $ trace "[G.V.G.API] Graph exists, recomputing" graph''
+ let graph''' = set graph_metadata graphMetadata graph''
+ _ <- updateHyperdata nId (HyperdataGraph (Just graph''') camera)
+ pure $ trace "[G.V.G.API] Graph exists, recomputing" graph'''
-- TODO use Database Monad only here ?
let ngs = filterListWithRoot MapTerm $ mapTermListRoot [lId] nt repo
-- TODO split diagonal
- myCooc <- Map.filter (>1)
+ myCooc <- HashMap.filter (>1)
<$> getCoocByNgrams (Diagonal True)
<$> groupNodesByNgrams ngs
- <$> getNodesByNgramsOnlyUser cId (lIds <> [lId]) nt (Map.keys ngs)
+ <$> getNodesByNgramsOnlyUser cId (lIds <> [lId]) nt (HashMap.keys ngs)
graph <- liftBase $ cooc2graph d 0 myCooc
+ pure graph
- let metadata = GraphMetadata "Title"
- Order1
- [cId]
- [ LegendField 1 "#FFF" "Cluster1"
- , LegendField 2 "#FFF" "Cluster2"
- , LegendField 3 "#FFF" "Cluster3"
- , LegendField 4 "#FFF" "Cluster4"
- ]
- (ListForGraph lId (repo ^. r_version))
- -- (map (\n -> LegendField n "#FFFFFF" (pack $ show n)) [1..10])
- pure $ set graph_metadata (Just metadata) graph
+defaultGraphMetadata :: HasNodeError err
+ => CorpusId
+ -> Text
+ -> NgramsRepo
+ -> Cmd err GraphMetadata
+defaultGraphMetadata cId t repo = do
+ lId <- defaultList cId
+
+ pure $ GraphMetadata {
+ _gm_title = t
+ , _gm_metric = Order1
+ , _gm_corpusId = [cId]
+ , _gm_legend = [
+ LegendField 1 "#FFF" "Cluster1"
+ , LegendField 2 "#FFF" "Cluster2"
+ , LegendField 3 "#FFF" "Cluster3"
+ , LegendField 4 "#FFF" "Cluster4"
+ ]
+ , _gm_list = (ListForGraph lId (repo ^. r_version))
+ , _gm_startForceAtlas = True
+ }
+ -- (map (\n -> LegendField n "#FFFFFF" (pack $ show n)) [1..10])
------------------------------------------------------------
-type GraphAsyncAPI = Summary "Update graph"
- :> "async"
- :> AsyncJobsAPI JobLog () JobLog
+type GraphAsyncAPI = Summary "Recompute graph"
+ :> "recompute"
+ :> AsyncJobsAPI JobLog () JobLog
graphAsync :: UserId -> NodeId -> GargServer GraphAsyncAPI
graphAsync u n =
serveJobsAPI $
- JobFunction (\_ log' -> graphAsync' u n (liftBase . log'))
+ JobFunction (\_ log' -> graphRecompute u n (liftBase . log'))
-graphAsync' :: UserId
- -> NodeId
- -> (JobLog -> GargNoServer ())
- -> GargNoServer JobLog
-graphAsync' u n logStatus = do
+graphRecompute :: UserId
+ -> NodeId
+ -> (JobLog -> GargNoServer ())
+ -> GargNoServer JobLog
+graphRecompute u n logStatus = do
logStatus JobLog { _scst_succeeded = Just 0
- , _scst_failed = Just 0
- , _scst_remaining = Just 1
- , _scst_events = Just []
- }
+ , _scst_failed = Just 0
+ , _scst_remaining = Just 1
+ , _scst_events = Just []
+ }
_g <- trace (show u) $ recomputeGraph u n Conditional
pure JobLog { _scst_succeeded = Just 1
- , _scst_failed = Just 0
- , _scst_remaining = Just 0
- , _scst_events = Just []
- }
+ , _scst_failed = Just 0
+ , _scst_remaining = Just 0
+ , _scst_events = Just []
+ }
------------------------------------------------------------
type GraphVersionsAPI = Summary "Graph versions"
graphVersionsAPI :: UserId -> NodeId -> GargServer GraphVersionsAPI
graphVersionsAPI u n =
- graphVersions u n
+ graphVersions n
:<|> recomputeVersions u n
-graphVersions :: UserId -> NodeId -> GargNoServer GraphVersions
-graphVersions _uId nId = do
- nodeGraph <- getNodeWith nId HyperdataGraph
+graphVersions :: NodeId -> GargNoServer GraphVersions
+graphVersions nId = do
+ nodeGraph <- getNodeWith nId (Proxy :: Proxy HyperdataGraph)
let graph = nodeGraph ^. node_hyperdata . hyperdataGraph
let listVersion = graph ^? _Just
. graph_metadata
recomputeVersions :: UserId -> NodeId -> GargNoServer Graph
recomputeVersions uId nId = recomputeGraph uId nId Conditional
+------------------------------------------------------------
+graphClone :: UserId
+ -> NodeId
+ -> HyperdataGraphAPI
+ -> GargNoServer NodeId
+graphClone uId pId (HyperdataGraphAPI { _hyperdataAPIGraph = graph
+ , _hyperdataAPICamera = camera }) = do
+ let nodeType = NodeGraph
+ nodeUser <- getNodeUser (NodeId uId)
+ nodeParent <- getNodeWith pId (Proxy :: Proxy HyperdataGraph)
+ let uId' = nodeUser ^. node_userId
+ nIds <- mkNodeWithParent nodeType (Just pId) uId' $ nodeParent ^. node_name
+ case nIds of
+ [] -> pure pId
+ (nId:_) -> do
+ let graphP = graph
+ let graphP' = set (graph_metadata . _Just . gm_startForceAtlas) False graphP
+
+ _ <- updateHyperdata nId (HyperdataGraph (Just graphP') camera)
+
+ pure nId
+
------------------------------------------------------------
getGraphGexf :: UserId
-> NodeId
-> GargNoServer (Headers '[Servant.Header "Content-Disposition" Text] Graph)
getGraphGexf uId nId = do
- graph <- getGraph uId nId
+ HyperdataGraphAPI { _hyperdataAPIGraph = graph } <- getGraph uId nId
pure $ addHeader "attachment; filename=graph.gexf" graph
-
-
-